/[cmucl]/src/code/x86-vm.lisp
ViewVC logotype

Contents of /src/code/x86-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Wed Nov 14 17:44:07 2007 UTC (6 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-12
Changes since 1.27: +8 -8 lines
Fix some mistakes accidentally introduced in the sigcontext
rearrangement.  Changes not tested, but there are no compiler warnings
anymore.

o Fix typo:  It's fpstate, not ftpstate.
o Fix dereferencing of the fpstate, which is not in the sigcontext
  anymore.  It's in the sc-mcontext slot of the sigcontext now.
1 ;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.28 2007/11/14 17:44:07 rtoy Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file contains the X86 specific runtime stuff.
15 ;;;
16 ;;; Code movement fixups by Douglas T. Crosher, 1997.
17 ;;; Thread support by Douglas T. Crosher, 1999.
18 ;;;
19
20 (in-package "X86")
21 (use-package "SYSTEM")
22 (use-package "ALIEN")
23 (use-package "C-CALL")
24 (use-package "UNIX")
25 (use-package "KERNEL")
26
27 (export '(fixup-code-object internal-error-arguments
28 sigcontext-program-counter sigcontext-register
29 sigcontext-float-register sigcontext-floating-point-modes
30 extern-alien-name sanctify-for-execution))
31
32
33 ;;;; The sigcontext structure.
34 ;;;; Add machine specific features to *features*
35
36 (pushnew :x86 *features*)
37
38
39
40 #+linux
41 (def-alien-type nil
42 (struct fpreg
43 (significand (array unsigned-short 4))
44 (exponent unsigned-short)))
45 #+linux
46 (def-alien-type nil
47 (struct fpstate
48 (cw unsigned-long)
49 (sw unsigned-long)
50 (tag unsigned-long)
51 (ipoff unsigned-long)
52 (cssel unsigned-long)
53 (dataoff unsigned-long)
54 (datasel unsigned-long)
55 (fpreg (array (struct fpreg) 8))
56 (status unsigned-long)))
57
58 #+darwin
59 (def-alien-type sigcontext-regs
60 (struct nil
61 (trapno unsigned-int)
62 (err unsigned-int)
63 (faultvaddr unsigned-int)
64 (eax unsigned-int)
65 (ebx unsigned-int)
66 (ecx unsigned-int)
67 (edx unsigned-int)
68 (edi unsigned-int)
69 (esi unsigned-int)
70 (ebp unsigned-int)
71 (esp unsigned-int)
72 (ss unsigned-int)
73 (eflags unsigned-int)
74 (eip unsigned-int)
75 (cs unsigned-int)
76 (ds unsigned-int)
77 (es unsigned-int)
78 (fs unsigned-int)
79 (gs unsigned-int)
80 (fpstate (array char 512))))
81
82 #+darwin
83 (def-alien-type sigcontext
84 (struct nil
85 (sc-onstack int)
86 (sc-sigmask unsigned-int)
87 (sc-stack (array unsigned-int 3))
88 (sc-link system-area-pointer)
89 (sc-mcsize unsigned-int)
90 (sc-mcontext (* sigcontext-regs))))
91
92 ;;; for FreeBSD
93 #+freebsd
94 (def-alien-type sigcontext-regs
95 (struct nil
96 (onstack unsigned-int)
97 (gs unsigned-int)
98 (fs unsigned-int)
99 (es unsigned-int)
100 (ds unsigned-int)
101 (edi unsigned-int)
102 (esi unsigned-int)
103 (ebp unsigned-int)
104 (isp unsigned-int)
105 (ebx unsigned-int)
106 (edx unsigned-int)
107 (ecx unsigned-int)
108 (eax unsigned-int)
109 (trapno unsigned-int)
110 (err unsigned-int)
111 (eip unsigned-int)
112 (cs unsigned-int)
113 (eflags unsigned-int)
114 (esp unsigned-int)
115 (ss unsigned-int)))
116
117 #+freebsd
118 (def-alien-type sigcontext
119 (struct nil
120 (sc-sigmask (array unsigned-int 4))
121 (sc-mcontext sigcontext-regs)))
122
123 ;;; OpenBSD also have sigcontext structs that look more like Linux.
124 #+openbsd
125 (def-alien-type sigcontext
126 (struct nil
127 (sc-gs unsigned-int)
128 (sc-fs unsigned-int)
129 (sc-es unsigned-int)
130 (sc-ds unsigned-int)
131 (sc-edi unsigned-int)
132 (sc-esi unsigned-int)
133 (sc-fp unsigned-int) ;; ebp
134 (sc-ebx unsigned-int)
135 (sc-edx unsigned-int)
136 (sc-ecx unsigned-int)
137 (sc-eax unsigned-int)
138 (sc-pc unsigned-int)
139 (sc-cs unsigned-int)
140 (sc-efl unsigned-int) ; sc_ps
141 (sc-sp unsigned-int)
142 (sc-ss unsigned-int)
143 (sc-onstack unsigned-int)
144 (sc-mask unsigned-int)
145 (sc-trapno unsigned-int)
146 (sc-err unsigned-int)
147 ))
148
149 ;; NetBSD
150 #+netbsd
151 (def-alien-type sigcontext-regs
152 (struct nil
153 (gs unsigned-long)
154 (fs unsigned-long)
155 (es unsigned-long)
156 (ds unsigned-long)
157 (edi unsigned-long)
158 (esi unsigned-long)
159 (ebp unsigned-long)
160 (esp unsigned-long)
161 (ebx unsigned-long)
162 (edx unsigned-long)
163 (ecx unsigned-long)
164 (eax unsigned-long)
165 (trapno unsigned-long)
166 (err unsigned-long)
167 (eip unsigned-long)
168 (cs unsigned-long)
169 (efl unsigned-long)
170 (uesp unsigned-long)
171 (ss unsigned-long)))
172
173 #+netbsd
174 (def-alien-type sigcontext
175 (struct nil
176 (sc-flags unsigned-long)
177 (sc-link system-area-pointer)
178 (sc-sigmask (array unsigned-long 4))
179 (sc-stack (array unsigned-long 3))
180 (sc-mcontext sigcontext-regs)))
181
182 ;; For Linux...
183 #+linux
184 (def-alien-type sigcontext-regs
185 (struct nil
186 (gs unsigned-long)
187 (fs unsigned-long)
188 (es unsigned-long)
189 (ds unsigned-long)
190 (edi unsigned-long)
191 (esi unsigned-long)
192 (ebp unsigned-long)
193 (esp unsigned-long)
194 (ebx unsigned-long)
195 (edx unsigned-long)
196 (ecx unsigned-long)
197 (eax unsigned-long)
198 (trapno unsigned-long)
199 (err unsigned-long)
200 (eip unsigned-long)
201 (cs unsigned-long)
202 (eflags unsigned-long)
203 (esp_at_signal unsigned-long)
204 (ss unsigned-long)
205 (fpstate (* (struct fpstate)))
206 (oldmask unsigned-long)
207 (cr2 unsigned-long)))
208
209 #+linux
210 (def-alien-type sigcontext
211 (struct nil
212 (sc-flags unsigned-long)
213 (sc-link system-area-pointer)
214 (sc-stack (array unsigned-long 3))
215 (sc-mcontext sigcontext-regs)))
216
217
218 ;;;; MACHINE-TYPE and MACHINE-VERSION
219
220 #-cross-compiler
221 (defun machine-type ()
222 "Returns a string describing the type of the local machine."
223 "X86")
224
225
226 #-cross-compiler
227 (defun machine-version ()
228 "Returns a string describing the version of the local machine."
229 "X86")
230
231
232
233 ;;; Fixup-Code-Object -- Interface
234 ;;;
235 ;;; This gets called by LOAD to resolve newly positioned objects
236 ;;; with things (like code instructions) that have to refer to them.
237 ;;;
238 ;;; Add a fixup offset to the vector of fixup offsets for the given
239 ;;; code object.
240 ;;;
241 ;;; Counter to measure the storage overhead.
242 (defvar *num-fixups* 0)
243 ;;; XXX
244 (defun fixup-code-object (code offset fixup kind)
245 (declare (type index offset))
246 (flet ((add-fixup (code offset)
247 ;; Although this could check for and ignore fixups for code
248 ;; objects in the read-only and static spaces, this should
249 ;; only be the case when *enable-dynamic-space-code* is
250 ;; True.
251 (when lisp::*enable-dynamic-space-code*
252 (incf *num-fixups*)
253 (let ((fixups (code-header-ref code code-constants-offset)))
254 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
255 (let ((new-fixups
256 (adjust-array fixups (1+ (length fixups))
257 :element-type '(unsigned-byte 32))))
258 (setf (aref new-fixups (length fixups)) offset)
259 (setf (code-header-ref code code-constants-offset)
260 new-fixups)))
261 (t
262 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
263 (zerop fixups))
264 (format t "** Init. code FU = ~s~%" fixups))
265 (setf (code-header-ref code code-constants-offset)
266 (make-array 1 :element-type '(unsigned-byte 32)
267 :initial-element offset))))))))
268 (system:without-gcing
269 (let* ((sap (truly-the system-area-pointer
270 (kernel:code-instructions code)))
271 (obj-start-addr (logand (kernel:get-lisp-obj-address code)
272 #xfffffff8))
273 #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
274 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
275 (ncode-words (kernel:code-header-ref code 1))
276 (code-end-addr (+ code-start-addr (* ncode-words 4))))
277 (unless (member kind '(:absolute :relative))
278 (error "Unknown code-object-fixup kind ~s." kind))
279 (ecase kind
280 (:absolute
281 ;; Word at sap + offset contains a value to be replaced by
282 ;; adding that value to fixup.
283 (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
284 ;; Record absolute fixups that point within the code object.
285 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
286 (add-fixup code offset)))
287 (:relative
288 ;; Fixup is the actual address wanted.
289 ;;
290 ;; Record relative fixups that point outside the code
291 ;; object.
292 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
293 (add-fixup code offset))
294 ;; Replace word with value to add to that loc to get there.
295 (let* ((loc-sap (+ (sap-int sap) offset))
296 (rel-val (- fixup loc-sap 4)))
297 (declare (type (unsigned-byte 32) loc-sap)
298 (type (signed-byte 32) rel-val))
299 (setf (signed-sap-ref-32 sap offset) rel-val))))))
300 nil))
301
302 ;;; Do-Load-Time-Code-Fixups
303 ;;;
304 ;;; Add a code fixup to a code object generated by new-genesis. The
305 ;;; fixup has already been applied, it's just a matter of placing the
306 ;;; fixup in the code's fixup vector if necessary.
307 ;;;
308 #+gencgc
309 (defun do-load-time-code-fixup (code offset fixup kind)
310 (flet ((add-load-time-code-fixup (code offset)
311 (let ((fixups (code-header-ref code vm:code-constants-offset)))
312 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
313 (let ((new-fixups
314 (adjust-array fixups (1+ (length fixups))
315 :element-type '(unsigned-byte 32))))
316 (setf (aref new-fixups (length fixups)) offset)
317 (setf (code-header-ref code vm:code-constants-offset)
318 new-fixups)))
319 (t
320 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
321 (zerop fixups))
322 (%primitive print "** Init. code FU"))
323 (setf (code-header-ref code vm:code-constants-offset)
324 (make-array 1 :element-type '(unsigned-byte 32)
325 :initial-element offset)))))))
326 (let* ((sap (truly-the system-area-pointer
327 (kernel:code-instructions code)))
328 (obj-start-addr
329 (logand (kernel:get-lisp-obj-address code) #xfffffff8))
330 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
331 (ncode-words (kernel:code-header-ref code 1))
332 (code-end-addr (+ code-start-addr (* ncode-words 4))))
333 (ecase kind
334 (:absolute
335 ;; Record absolute fixups that point within the
336 ;; code object.
337 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
338 (add-load-time-code-fixup code offset)))
339 (:relative
340 ;; Record relative fixups that point outside the
341 ;; code object.
342 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
343 (add-load-time-code-fixup code offset)))))))
344
345
346 ;;;; Internal-error-arguments.
347
348 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
349 ;;;
350 ;;; Given the sigcontext, extract the internal error arguments from the
351 ;;; instruction stream.
352 ;;;
353 (defun internal-error-arguments (scp)
354 (declare (type (alien (* sigcontext)) scp))
355 (with-alien ((scp (* sigcontext) scp))
356 (let ((pc (sigcontext-program-counter scp)))
357 (declare (type system-area-pointer pc))
358 ;; using INT3 the pc is .. INT3 <here> code length bytes...
359 (let* ((length (sap-ref-8 pc 1))
360 (vector (make-array length :element-type '(unsigned-byte 8))))
361 (declare (type (unsigned-byte 8) length)
362 (type (simple-array (unsigned-byte 8) (*)) vector))
363 (copy-from-system-area pc (* vm:byte-bits 2)
364 vector (* vm:word-bits
365 vm:vector-data-offset)
366 (* length vm:byte-bits))
367 (let* ((index 0)
368 (error-number (c::read-var-integer vector index)))
369 (collect ((sc-offsets))
370 (loop
371 (when (>= index length)
372 (return))
373 (sc-offsets (c::read-var-integer vector index)))
374 (values error-number (sc-offsets))))))))
375
376
377 ;;;; Sigcontext access functions.
378
379 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
380 ;;;
381 (defun sigcontext-program-counter (scp)
382 (declare (type (alien (* sigcontext)) scp))
383 (with-alien ((scp (* sigcontext) scp))
384 (int-sap (slot (slot scp 'sc-mcontext) 'eip))))
385
386 ;;; SIGCONTEXT-REGISTER -- Interface.
387 ;;;
388 ;;; An escape register saves the value of a register for a frame that someone
389 ;;; interrupts.
390 ;;;
391 (defun sigcontext-register (scp index)
392 (declare (type (alien (* sigcontext)) scp))
393 (with-alien ((scp (* sigcontext) scp))
394 (case index
395 (#.eax-offset (slot (slot scp 'sc-mcontext) 'eax))
396 (#.ecx-offset (slot (slot scp 'sc-mcontext) 'ecx))
397 (#.edx-offset (slot (slot scp 'sc-mcontext) 'edx))
398 (#.ebx-offset (slot (slot scp 'sc-mcontext) 'ebx))
399 (#.esp-offset (slot (slot scp 'sc-mcontext) 'esp))
400 (#.ebp-offset (slot (slot scp 'sc-mcontext) 'ebp))
401 (#.esi-offset (slot (slot scp 'sc-mcontext) 'esi))
402 (#.edi-offset (slot (slot scp 'sc-mcontext) 'edi)))))
403
404 (defun %set-sigcontext-register (scp index new)
405 (declare (type (alien (* sigcontext)) scp))
406 (with-alien ((scp (* sigcontext) scp))
407 (case index
408 (#.eax-offset (setf (slot (slot scp 'sc-mcontext) 'eax) new))
409 (#.ecx-offset (setf (slot (slot scp 'sc-mcontext) 'ecx) new))
410 (#.edx-offset (setf (slot (slot scp 'sc-mcontext) 'edx) new))
411 (#.ebx-offset (setf (slot (slot scp 'sc-mcontext) 'ebx) new))
412 (#.esp-offset (setf (slot (slot scp 'sc-mcontext) 'esp) new))
413 (#.ebp-offset (setf (slot (slot scp 'sc-mcontext) 'ebp) new))
414 (#.esi-offset (setf (slot (slot scp 'sc-mcontext) 'esi) new))
415 (#.edi-offset (setf (slot (slot scp 'sc-mcontext) 'edi) new))))
416 new)
417
418 (defsetf sigcontext-register %set-sigcontext-register)
419
420
421 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
422 ;;;
423 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
424 ;;; Format is the type of float to return.
425 ;;;
426 #+linux
427 (defun sigcontext-float-register (scp index format)
428 (declare (type (alien (* sigcontext)) scp))
429 (with-alien ((scp (* sigcontext) scp))
430 (let ((reg-sap (alien-sap (deref (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0)
431 'fpreg)
432 index))))
433 (coerce (sys:sap-ref-long reg-sap 0) format))))
434
435 ;;; Not supported on Free/OpenBSD because the floating point state is not
436 ;;; saved. For now we assume this is true for all modern BSDs
437 #+BSD
438 (defun sigcontext-float-register (scp index format)
439 (declare (ignore scp index))
440 (coerce 0l0 format))
441
442 #+linux
443 (defun %set-sigcontext-float-register (scp index format new-value)
444 (declare (type (alien (* sigcontext)) scp))
445 (with-alien ((scp (* sigcontext) scp))
446 (let ((reg-sap (alien-sap (deref (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0)
447 'fpreg)
448 index))))
449 (declare (ignorable reg-sap))
450 #+not-yet
451 (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
452 (coerce new-value format))))
453
454 ;;; Not supported on Free/OpenBSD.
455 #+BSD
456 (defun %set-sigcontext-float-register (scp index format new-value)
457 (declare (ignore scp index))
458 (coerce new-value format))
459
460 ;;;
461 (defsetf sigcontext-float-register %set-sigcontext-float-register)
462
463 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
464 ;;;
465 ;;; Given a sigcontext pointer, return the floating point modes word in the
466 ;;; same format as returned by FLOATING-POINT-MODES.
467 ;;;
468
469 #+bsd
470 (defun sigcontext-floating-point-modes (scp)
471 (declare (type (alien (* sigcontext)) scp)
472 (ignore scp))
473 ;; This is broken until some future release of FreeBSD/OpenBSD!!!
474 (floating-point-modes))
475
476 #+linux
477 (defun sigcontext-floating-point-modes (scp)
478 (declare (type (alien (* sigcontext)) scp))
479 (let ((cw (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'cw))
480 (sw (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'sw)))
481 ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
482 ;; NOT TESTED -- clear sticky bits to clear interrupt condition
483 (setf (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'sw) (logandc2 sw #x3f))
484 ;;(format t "new sw = ~x~%" (slot (deref (slot (slot scp 'sc-mcontext) 'fpstate) 0) 'sw))
485 ;; simulate floating-point-modes VOP
486 (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
487
488
489 ;;; EXTERN-ALIEN-NAME -- interface.
490 ;;;
491 ;;; The loader uses this to convert alien names to the form they occure in
492 ;;; the symbol table (for example, prepending an underscore).
493 ;;;
494 (defun extern-alien-name (name)
495 (declare (type simple-string name))
496 name)
497
498 #+(and (or linux (and freebsd elf)) (not linkage-table))
499 (defun lisp::foreign-symbol-address-aux (name flavor)
500 (declare (ignore flavor))
501 (multiple-value-bind (value found)
502 (gethash name lisp::*foreign-symbols* 0)
503 (if found
504 value
505 (multiple-value-bind (value found)
506 (gethash
507 (concatenate 'string "PVE_stub_" name)
508 lisp::*foreign-symbols* 0)
509 (if found
510 value
511 (let ((value (system:alternate-get-global-address name)))
512 (when (zerop value)
513 (error "Unknown foreign symbol: ~S" name))
514 value))))))
515
516
517
518 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
519 ;;;
520 ;;; Do whatever is necessary to make the given code component
521 ;;; executable - nothing on the x86.
522 ;;;
523 (defun sanctify-for-execution (component)
524 (declare (ignore component))
525 nil)
526
527 ;;; FLOAT-WAIT
528 ;;;
529 ;;; This is used in error.lisp to insure floating-point exceptions
530 ;;; are properly trapped. The compiler translates this to a VOP.
531 ;;;
532 (defun float-wait()
533 (float-wait))
534
535 ;;; FLOAT CONSTANTS
536 ;;;
537 ;;; These are used by the FP move-from-{single|double} VOPs rather
538 ;;; than the i387 load constant instructions to avoid consing in some
539 ;;; cases. Note these are initialise by genesis as they are needed
540 ;;; early.
541 ;;;
542 (defvar *fp-constant-0s0*)
543 (defvar *fp-constant-1s0*)
544 (defvar *fp-constant-0d0*)
545 (defvar *fp-constant-1d0*)
546 ;;; The long-float constants.
547 (defvar *fp-constant-0l0*)
548 (defvar *fp-constant-1l0*)
549 (defvar *fp-constant-pi*)
550 (defvar *fp-constant-l2t*)
551 (defvar *fp-constant-l2e*)
552 (defvar *fp-constant-lg2*)
553 (defvar *fp-constant-ln2*)
554
555 ;;; Enable/Disable scavenging of the read-only space.
556 (defvar *scavenge-read-only-space* nil)
557
558 ;;; The current alien stack pointer; saved/restored for non-local
559 ;;; exits.
560 (defvar *alien-stack*)
561
562 ;;; Support for the MT19937 random number generator. The update
563 ;;; function is implemented as an assembly routine. This definition is
564 ;;; transformed to a call to this routine allowing its use in byte
565 ;;; compiled code.
566 ;;;
567 (defun random-mt19937 (state)
568 (declare (type (simple-array (unsigned-byte 32) (627)) state))
569 (random-mt19937 state))
570
571
572 ;;;; Useful definitions for writing thread safe code.
573
574 (in-package "KERNEL")
575
576 (export '(atomic-push-symbol-value atomic-pop-symbol-value
577 atomic-pusha atomic-pushd atomic-push-vector))
578
579 (defun %instance-set-conditional (object slot test-value new-value)
580 (declare (type instance object)
581 (type index slot))
582 "Atomically compare object's slot value to test-value and if EQ store
583 new-value in the slot. The original value of the slot is returned."
584 (%instance-set-conditional object slot test-value new-value))
585
586 (defun set-symbol-value-conditional (symbol test-value new-value)
587 (declare (type symbol symbol))
588 "Atomically compare symbol's value to test-value and if EQ store
589 new-value in symbol's value slot and return the original value."
590 (set-symbol-value-conditional symbol test-value new-value))
591
592 (defun rplaca-conditional (cons test-value new-value)
593 (declare (type cons cons))
594 "Atomically compare the car of CONS to test-value and if EQ store
595 new-value its car and return the original value."
596 (rplaca-conditional cons test-value new-value))
597
598 (defun rplacd-conditional (cons test-value new-value)
599 (declare (type cons cons))
600 "Atomically compare the cdr of CONS to test-value and if EQ store
601 new-value its cdr and return the original value."
602 (rplacd-conditional cons test-value new-value))
603
604 (defun data-vector-set-conditional (vector index test-value new-value)
605 (declare (type simple-vector vector))
606 "Atomically compare an element of vector to test-value and if EQ store
607 new-value the element and return the original value."
608 (data-vector-set-conditional vector index test-value new-value))
609
610 (defmacro atomic-push-symbol-value (val symbol)
611 "Thread safe push of val onto the list in the symbol global value."
612 (ext:once-only ((n-val val))
613 (let ((new-list (gensym))
614 (old-list (gensym)))
615 `(let ((,new-list (cons ,n-val nil)))
616 (loop
617 (let ((,old-list ,symbol))
618 (setf (cdr ,new-list) ,old-list)
619 (when (eq (set-symbol-value-conditional
620 ',symbol ,old-list ,new-list)
621 ,old-list)
622 (return ,new-list))))))))
623
624 (defmacro atomic-pop-symbol-value (symbol)
625 "Thread safe pop from the list in the symbol global value."
626 (let ((new-list (gensym))
627 (old-list (gensym)))
628 `(loop
629 (let* ((,old-list ,symbol)
630 (,new-list (cdr ,old-list)))
631 (when (eq (set-symbol-value-conditional
632 ',symbol ,old-list ,new-list)
633 ,old-list)
634 (return (car ,old-list)))))))
635
636 (defmacro atomic-pusha (val cons)
637 "Thread safe push of val onto the list in the car of cons."
638 (once-only ((n-val val)
639 (n-cons cons))
640 (let ((new-list (gensym))
641 (old-list (gensym)))
642 `(let ((,new-list (cons ,n-val nil)))
643 (loop
644 (let ((,old-list (car ,n-cons)))
645 (setf (cdr ,new-list) ,old-list)
646 (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
647 ,old-list)
648 (return ,new-list))))))))
649
650 (defmacro atomic-pushd (val cons)
651 "Thread safe push of val onto the list in the cdr of cons."
652 (once-only ((n-val val)
653 (n-cons cons))
654 (let ((new-list (gensym))
655 (old-list (gensym)))
656 `(let ((,new-list (cons ,n-val nil)))
657 (loop
658 (let ((,old-list (cdr ,n-cons)))
659 (setf (cdr ,new-list) ,old-list)
660 (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
661 ,old-list)
662 (return ,new-list))))))))
663
664 (defmacro atomic-push-vector (val vect index)
665 "Thread safe push of val onto the list in the vector element."
666 (once-only ((n-val val)
667 (n-vect vect)
668 (n-index index))
669 (let ((new-list (gensym))
670 (old-list (gensym)))
671 `(let ((,new-list (cons ,n-val nil)))
672 (loop
673 (let ((,old-list (svref ,n-vect ,n-index)))
674 (setf (cdr ,new-list) ,old-list)
675 (when (eq (data-vector-set-conditional
676 ,n-vect ,n-index ,old-list ,new-list)
677 ,old-list)
678 (return ,new-list))))))))
679
680 #+linkage-table
681 (progn
682 (defun lisp::foreign-symbol-address-aux (name flavor)
683 (let ((entry-num (lisp::register-foreign-linkage name flavor)))
684 (+ #.vm:target-foreign-linkage-space-start
685 (* entry-num vm:target-foreign-linkage-entry-size))))
686
687 (defun lisp::find-foreign-symbol (addr)
688 (declare (type (unsigned-byte 32) addr))
689 (when (>= addr vm:target-foreign-linkage-space-start)
690 (let ((entry (/ (- addr vm:target-foreign-linkage-space-start)
691 vm:target-foreign-linkage-entry-size)))
692 (when (< entry (lisp::foreign-linkage-symbols))
693 (lisp::foreign-linkage-entry entry)))))
694 )

  ViewVC Help
Powered by ViewVC 1.1.5