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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pw, Sun Apr 13 21:07:29 1997 UTC revision 1.2.2.3 by pw, Sat Mar 23 18:50:15 2002 UTC
# Line 6  Line 6 
6  ;;; If you want to use this code or any part of CMU Common Lisp, please contact  ;;; 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.  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;;  ;;;
9  ;(ext:file-comment  (ext:file-comment
10  ;  "$Header$")    "$Header$")
11  ;;;  ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; This file contains the X86 specific runtime stuff.  ;;; 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 :vm)  (in-package "X86")
21  (use-package "SYSTEM")  (use-package "SYSTEM")
22  (use-package "ALIEN")  (use-package "ALIEN")
23  (use-package "C-CALL")  (use-package "C-CALL")
24  (use-package "UNIX")  (use-package "UNIX")
25  (use-package :kernel)  (use-package "KERNEL")
26    
27  (export '(fixup-code-object internal-error-arguments  (export '(fixup-code-object internal-error-arguments
28            sigcontext-program-counter sigcontext-register            sigcontext-program-counter sigcontext-register
29            sigcontext-float-register sigcontext-floating-point-modes            sigcontext-float-register sigcontext-floating-point-modes
30            extern-alien-name sanctify-for-execution            extern-alien-name sanctify-for-execution))
           alternate-get-global-address))  
31    
32    
33  ;;;; The sigcontext structure.  ;;;; The sigcontext structure.
# Line 54  Line 56 
56          (status unsigned-long)))          (status unsigned-long)))
57    
58  ;;; for FreeBSD  ;;; for FreeBSD
59  #+freebsd  #+(and freebsd (not freebsd4))
60  (def-alien-type sigcontext  (def-alien-type sigcontext
61      (struct nil      (struct nil
62          (sc-onstack unsigned-int)          (sc-onstack unsigned-int)
# Line 75  Line 77 
77          (sc-ecx     unsigned-int)          (sc-ecx     unsigned-int)
78          (sc-eax     unsigned-int)))          (sc-eax     unsigned-int)))
79    
80    ;;; FreeBSD 4.0 has a sigcontext that looks more like Linux.
81    #+freebsd4
82    (def-alien-type sigcontext
83        (struct nil
84            (sc-mask    (array unsigned-int 4))
85            (sc-onstack unsigned-int)
86            (sc-gs      unsigned-int)
87            (sc-fs      unsigned-int)
88            (sc-es      unsigned-int)
89            (sc-ds      unsigned-int)
90            (sc-edi     unsigned-int)
91            (sc-esi     unsigned-int)
92            (sc-fp      unsigned-int)
93            (sc-isp     unsigned-int)
94            (sc-ebx     unsigned-int)
95            (sc-edx     unsigned-int)
96            (sc-ecx     unsigned-int)
97            (sc-eax     unsigned-int)
98            (trapno     unsigned-int)
99            (err        unsigned-int)
100            (sc-pc      unsigned-int)
101            (sc-cs      unsigned-int)
102            (sc-efl     unsigned-int)               ; sc_ps
103            (sc-sp      unsigned-int)
104            (sc-ss      unsigned-int)))
105    
106    ;;; OpenBSD/NetBSD also have sigcontext structs that look more like Linux.
107    #+openbsd
108    (def-alien-type sigcontext
109        (struct nil
110            (sc-gs      unsigned-int)
111            (sc-fs      unsigned-int)
112            (sc-es      unsigned-int)
113            (sc-ds      unsigned-int)
114            (sc-edi     unsigned-int)
115            (sc-esi     unsigned-int)
116            (sc-fp      unsigned-int) ;; ebp
117            (sc-ebx     unsigned-int)
118            (sc-edx     unsigned-int)
119            (sc-ecx     unsigned-int)
120            (sc-eax     unsigned-int)
121            (sc-pc      unsigned-int)
122            (sc-cs      unsigned-int)
123            (sc-efl     unsigned-int)               ; sc_ps
124            (sc-sp      unsigned-int)
125            (sc-ss      unsigned-int)
126            (sc-onstack unsigned-int)
127            (sc-mask    unsigned-int)
128            (sc-trapno  unsigned-int)
129            (sc-err     unsigned-int)
130            ))
131    
132    #+netbsd
133    (def-alien-type sigcontext
134        (struct nil
135            (sc-gs      unsigned-int)
136            (sc-fs      unsigned-int)
137            (sc-es      unsigned-int)
138            (sc-ds      unsigned-int)
139            (sc-edi     unsigned-int)
140            (sc-esi     unsigned-int)
141            (sc-fp      unsigned-int) ;; ebp
142            (sc-ebx     unsigned-int)
143            (sc-edx     unsigned-int)
144            (sc-ecx     unsigned-int)
145            (sc-eax     unsigned-int)
146            (sc-pc      unsigned-int)
147            (sc-cs      unsigned-int)
148            (sc-efl     unsigned-int)               ; sc_ps
149            (sc-sp      unsigned-int)
150            (sc-ss      unsigned-int)
151            (sc-onstack unsigned-int)
152            ;; Old NetBSD 1.3 signal mask
153            (sc-oldmask unsigned-int)
154            (sc-trapno  unsigned-int)
155            (sc-err     unsigned-int)
156            ;; New signal mask (post NetBSD 1.3)
157            (sc-mask    (array unsigned-int 4))
158            ))
159    
160  ;; For Linux...  ;; For Linux...
161  #+linux  #+linux
162  (def-alien-type sigcontext  (def-alien-type sigcontext
# Line 126  Line 208 
208    
209    
210    
211  ;;; FIXUP-CODE-OBJECT -- Interface  ;;; Fixup-Code-Object -- Interface
212    ;;;
213  ;;; This gets called by LOAD to resolve newly positioned objects  ;;; This gets called by LOAD to resolve newly positioned objects
214  ;;; with things (like code instructions) that have to refer to them.  ;;; with things (like code instructions) that have to refer to them.
215    ;;;
216    ;;; Add a fixup offset to the vector of fixup offsets for the given
217    ;;; code object.
218    ;;;
219    ;;; Counter to measure the storage overhead.
220    (defvar *num-fixups* 0)
221    ;;;
222  (defun fixup-code-object (code offset fixup kind)  (defun fixup-code-object (code offset fixup kind)
223    (declare (type index offset))    (declare (type index offset))
224    (system:without-gcing    (flet ((add-fixup (code offset)
225     (let ((sap (truly-the system-area-pointer (c::code-instructions code))))             ;; Although this could check for and ignore fixups for code
226       (unless (member kind '(:absolute :relative))             ;; objects in the read-only and static spaces, this should
227         (error "Unknown code-object-fixup kind ~s." kind))             ;; only be the case when *enable-dynamic-space-code* is
228       (ecase kind             ;; True.
229         (:absolute             (when lisp::*enable-dynamic-space-code*
230          ;; word at sap + offset contains a value to be replaced by               (incf *num-fixups*)
231          ;; adding that value to fixup.               (let ((fixups (code-header-ref code code-constants-offset)))
232          (setf (sap-ref-32 sap offset)                 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
233                (+ fixup (sap-ref-32 sap offset))))                        (let ((new-fixups
234         (:relative                               (adjust-array fixups (1+ (length fixups))
235          ;; fixup is actual address wanted. replace word with value                                             :element-type '(unsigned-byte 32))))
236          ;; to add to that loc to get there.                          (setf (aref new-fixups (length fixups)) offset)
237          ;; (format t "x86-fixup ~a ~x ~x ~a~&" code offset fixup kind)                          (setf (code-header-ref code code-constants-offset)
238          (let* ((loc-sap (+ (sap-int sap) offset))                                new-fixups)))
239                 (rel-val (- fixup loc-sap 4)))                       (t
240            (declare (type (unsigned-byte 32) loc-sap)                        (unless (or (eq (get-type fixups) vm:unbound-marker-type)
241                     (type (signed-byte 32) rel-val))                                    (zerop fixups))
242            ;;(format t "sap ~x ~x ~x~&" (sap-int sap) loc-sap rel-val)                          (format t "** Init. code FU = ~s~%" fixups))
243            (setf (sap-ref-32 sap offset)  rel-val)) ))))                        (setf (code-header-ref code code-constants-offset)
244    nil)                              (make-array 1 :element-type '(unsigned-byte 32)
245                                            :initial-element offset))))))))
246        (system:without-gcing
247         (let* ((sap (truly-the system-area-pointer
248                                (kernel:code-instructions code)))
249                (obj-start-addr (logand (kernel:get-lisp-obj-address code)
250                                        #xfffffff8))
251                #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
252                (code-start-addr (sys:sap-int (kernel:code-instructions code)))
253                (ncode-words (kernel:code-header-ref code 1))
254                (code-end-addr (+ code-start-addr (* ncode-words 4))))
255           (unless (member kind '(:absolute :relative))
256             (error "Unknown code-object-fixup kind ~s." kind))
257           (ecase kind
258             (:absolute
259              ;; Word at sap + offset contains a value to be replaced by
260              ;; adding that value to fixup.
261              (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
262              ;; Record absolute fixups that point within the code object.
263              (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
264                (add-fixup code offset)))
265             (:relative
266              ;; Fixup is the actual address wanted.
267              ;;
268              ;; Record relative fixups that point outside the code
269              ;; object.
270              (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
271                (add-fixup code offset))
272              ;; Replace word with value to add to that loc to get there.
273              (let* ((loc-sap (+ (sap-int sap) offset))
274                     (rel-val (- fixup loc-sap 4)))
275                (declare (type (unsigned-byte 32) loc-sap)
276                         (type (signed-byte 32) rel-val))
277                (setf (signed-sap-ref-32 sap offset) rel-val))))))
278        nil))
279    
280    ;;; Do-Load-Time-Code-Fixups
281    ;;;
282    ;;; Add a code fixup to a code object generated by new-genesis. The
283    ;;; fixup has already been applied, it's just a matter of placing the
284    ;;; fixup in the code's fixup vector if necessary.
285    ;;;
286    #+gencgc
287    (defun do-load-time-code-fixup (code offset fixup kind)
288      (flet ((add-load-time-code-fixup (code offset)
289               (let ((fixups (code-header-ref code vm:code-constants-offset)))
290                 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
291                        (let ((new-fixups
292                               (adjust-array fixups (1+ (length fixups))
293                                             :element-type '(unsigned-byte 32))))
294                          (setf (aref new-fixups (length fixups)) offset)
295                          (setf (code-header-ref code vm:code-constants-offset)
296                                new-fixups)))
297                       (t
298                        (unless (or (eq (get-type fixups) vm:unbound-marker-type)
299                                    (zerop fixups))
300                          (%primitive print "** Init. code FU"))
301                        (setf (code-header-ref code vm:code-constants-offset)
302                              (make-array 1 :element-type '(unsigned-byte 32)
303                                          :initial-element offset)))))))
304        (let* ((sap (truly-the system-area-pointer
305                               (kernel:code-instructions code)))
306               (obj-start-addr
307                (logand (kernel:get-lisp-obj-address code) #xfffffff8))
308               (code-start-addr (sys:sap-int (kernel:code-instructions code)))
309               (ncode-words (kernel:code-header-ref code 1))
310             (code-end-addr (+ code-start-addr (* ncode-words 4))))
311          (ecase kind
312            (:absolute
313             ;; Record absolute fixups that point within the
314             ;; code object.
315             (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
316               (add-load-time-code-fixup code offset)))
317            (:relative
318             ;; Record relative fixups that point outside the
319             ;; code object.
320             (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
321               (add-load-time-code-fixup code offset)))))))
322    
323    
324  ;;;; Internal-error-arguments.  ;;;; Internal-error-arguments.
# Line 211  Line 376 
376        (#.edx-offset (slot scp 'sc-edx))        (#.edx-offset (slot scp 'sc-edx))
377        (#.ebx-offset (slot scp 'sc-ebx))        (#.ebx-offset (slot scp 'sc-ebx))
378        (#.esp-offset (slot scp 'sc-sp))        (#.esp-offset (slot scp 'sc-sp))
379  #-linux      (#.ebp-offset (slot scp 'sc-fp))        (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
 #+linux      (#.ebp-offset (slot scp 'ebp))  
380        (#.esi-offset (slot scp 'sc-esi))        (#.esi-offset (slot scp 'sc-esi))
381        (#.edi-offset (slot scp 'sc-edi)))))        (#.edi-offset (slot scp 'sc-edi)))))
382    
# Line 226  Line 390 
390        (#.edx-offset (setf (slot scp 'sc-edx) new))        (#.edx-offset (setf (slot scp 'sc-edx) new))
391        (#.ebx-offset (setf (slot scp 'sc-ebx) new))        (#.ebx-offset (setf (slot scp 'sc-ebx) new))
392        (#.esp-offset (setf (slot scp 'sc-sp)  new))        (#.esp-offset (setf (slot scp 'sc-sp)  new))
393  #-linux      (#.ebp-offset (setf (slot scp 'sc-fp)  new))        (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp)  new))
 #+linux      (#.ebp-offset (setf (slot scp 'ebp)  new))  
394        (#.esi-offset (setf (slot scp 'sc-esi) new))        (#.esi-offset (setf (slot scp 'sc-esi) new))
395        (#.edi-offset (setf (slot scp 'sc-edi) new))))        (#.edi-offset (setf (slot scp 'sc-edi) new))))
396    new)    new)
# Line 239  Line 402 
402  ;;;  ;;;
403  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
404  ;;; Format is the type of float to return.  ;;; Format is the type of float to return.
405  ;;; XXX  ;;;
 #-linux  
 (defun sigcontext-float-register (scp index format)  
   (declare (type (alien (* sigcontext)) scp))  
   (with-alien ((scp (* sigcontext) scp))  
     ;; fp regs not in sigcontext -- need new vop or c support  
     (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs))))  
       (declare (ignore sap))  
       index  
       (ecase format  
         (single-float 0s0  
          #+nil (system:sap-ref-single sap (* index vm:word-bytes)))  
         (double-float 0d0  
          #+nil(system:sap-ref-double sap (* index vm:word-bytes)))))))  
   
406  #+linux  #+linux
407  (defun sigcontext-float-register (scp index format)  (defun sigcontext-float-register (scp index format)
408    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
409    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* sigcontext) scp))
     ;; fp regs in sigcontext !!!  
410      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
411                                              'fpreg)                                             'fpreg)
412                                       index))))                                       index))))
413        (ecase format        (coerce (sys:sap-ref-long reg-sap 0) format))))
414          (single-float  
415            (system:sap-ref-single reg-sap 0))  ;;; Not supported on Free/OpenBSD because the floating point state is not
416          (double-float  ;;; saved.  For now we assume this is true for all modern BSDs
417            (system:sap-ref-double reg-sap 0))))))  #+BSD
418    (defun sigcontext-float-register (scp index format)
419      (declare (ignore scp index))
420      (coerce 0l0 format))
421    
 ;;;  
 #-linux  
 (defun %set-sigcontext-float-register (scp index format new-value)  
   (declare (type (alien (* sigcontext)) scp))  
   scp index format new-value  
   #+nil  
   (with-alien ((scp (* sigcontext) scp))  
     (let ((sap (alien-sap (slot scp 'fpregs))))  
       (ecase format  
         (single-float  
          (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))  
         (double-float  
          (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))  
422  #+linux  #+linux
423  (defun %set-sigcontext-float-register (scp index format new-value)  (defun %set-sigcontext-float-register (scp index format new-value)
424    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
# Line 288  Line 426 
426      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
427                                              'fpreg)                                              'fpreg)
428                                       index))))                                       index))))
429        (ecase format        (declare (ignorable reg-sap))
430          (single-float        #+not-yet
431           (setf (system:sap-ref-single reg-sap 0) new-value))        (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
432          (double-float        (coerce new-value format))))
          (setf (system:sap-ref-double reg-sap 0)new-value))))))  
433    
434  ;;;  ;;; Not supported on Free/OpenBSD.
435    #+BSD
436    (defun %set-sigcontext-float-register (scp index format new-value)
437      (declare (ignore scp index))
438      (coerce new-value format))
439    
440    ;;;
441  (defsetf sigcontext-float-register %set-sigcontext-float-register)  (defsetf sigcontext-float-register %set-sigcontext-float-register)
442    
443  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
# Line 304  Line 446 
446  ;;; same format as returned by FLOATING-POINT-MODES.  ;;; same format as returned by FLOATING-POINT-MODES.
447  ;;;  ;;;
448    
449  #+FreeBSD  #+BSD
450  (defun sigcontext-floating-point-modes (scp)  (defun sigcontext-floating-point-modes (scp)
451    (declare (type (alien (* sigcontext)) scp)    (declare (type (alien (* sigcontext)) scp)
452             (ignore scp))             (ignore scp))
453    ;; This is broken until some future release of FreeBSD!!!    ;; This is broken until some future release of FreeBSD/OpenBSD!!!
454    (floating-point-modes))    (floating-point-modes))
455    
456  #+linux  #+linux
# Line 329  Line 471 
471  ;;; The loader uses this to convert alien names to the form they occure in  ;;; The loader uses this to convert alien names to the form they occure in
472  ;;; the symbol table (for example, prepending an underscore).  ;;; the symbol table (for example, prepending an underscore).
473  ;;;  ;;;
 ;;; On the x86 under FreeBSD, we prepend an underscore. If this is not  
 ;;; done under Linux then this is the place to make the change.  
 ;;;  
474  (defun extern-alien-name (name)  (defun extern-alien-name (name)
475    (declare (type simple-string name))    (declare (type simple-string name))
476    (lisp:concatenate 'string #+linux "" #-linux "_" name))    name)
   
 ;;; This used to live in foreign.lisp but it gets loaded too late  
 ;;; to be useful. This gets used by the loader to map lisp foreign  
 ;;; symbol names to the OS's version of it. This was added for the  
 ;;; Linux port -- maybe it makes the above extern-alien-name  
 ;;; obsolete?  
 (defun system:alternate-get-global-address(symbol)  
   (declare (type simple-string symbol))  
   (let ((namex symbol)  
         (table lisp::*foreign-symbols*)) ; defined in load.lisp  
     (cond ((gethash namex table nil))  
 #+linux   ((gethash (concatenate 'string "PVE_stub_" namex) table nil))  
 #+linux   ((gethash (concatenate 'string "" namex) table nil)) ; Linux  
 #+freebsd ((gethash (concatenate 'string "_" namex) table nil)); FreeBSD  
           ((gethash (concatenate 'string "__" namex) table nil))  
           ((gethash (concatenate 'string "__libc_" namex) table nil))  
           (t (progn (format t "Error: can't be in alt-get-gl-addr ~a" namex)  
         ;; returning 0 is VERY dangerous!  
                 0)))))  
477    
478    (defun lisp::foreign-symbol-address-aux (name)
479      (multiple-value-bind (value found)
480          (gethash name lisp::*foreign-symbols* 0)
481        (if found
482            value
483            (multiple-value-bind (value found)
484                (gethash
485                 (concatenate 'string #+(or linux (and freebsd elf)) "PVE_stub_"
486                              #+(and bsd (not elf)) "_"
487                              name)
488                 lisp::*foreign-symbols* 0)
489              (if found
490                  value
491                  (let ((value (system:alternate-get-global-address name)))
492                    (when (zerop value)
493                      (error "Unknown foreign symbol: ~S" name))
494                    value))))))
495    
496    
497  ;;; SANCTIFY-FOR-EXECUTION -- Interface.  ;;; SANCTIFY-FOR-EXECUTION -- Interface.
498  ;;;  ;;;
499  ;;; Do whatever is necessary to make the given code component executable.  ;;; Do whatever is necessary to make the given code component
500  ;;; On the sparc, we don't need to do anything, because the i and d caches  ;;; executable - nothing on the x86.
 ;;; are unified.  
501  ;;;  ;;;
502  (defun sanctify-for-execution (component)  (defun sanctify-for-execution (component)
503    (declare (ignore component))    (declare (ignore component))
# Line 371  Line 507 
507  ;;;  ;;;
508  ;;; This is used in error.lisp to insure floating-point  exceptions  ;;; This is used in error.lisp to insure floating-point  exceptions
509  ;;; are properly trapped. The compiler translates this to a VOP.  ;;; are properly trapped. The compiler translates this to a VOP.
510  ;;; Note: if you are compiling this from an old version you may need  ;;;
 ;;; to disable this until the float-wait VOP is entrenched.  
511  (defun float-wait()  (defun float-wait()
512    (float-wait))    (float-wait))
513    
514  ;;; FLOAT CONSTANTS  ;;; FLOAT CONSTANTS
515  ;;;  ;;;
516  ;;; These are used by the FP move-from-{single|double} VOPs  ;;; These are used by the FP move-from-{single|double} VOPs rather
517  ;;; rather than the i387 load constant instructions to avoid  ;;; than the i387 load constant instructions to avoid consing in some
518  ;;; consing in some cases.  ;;; cases. Note these are initialise by genesis as they are needed
519    ;;; early.
520  (defvar *fp-constant-0s0* 0s0)  ;;;
521  (defvar *fp-constant-0d0* 0d0)  (defvar *fp-constant-0s0*)
522  (defvar *fp-constant-1s0* 1s0)  (defvar *fp-constant-1s0*)
523  (defvar *fp-constant-1d0* 1d0)  (defvar *fp-constant-0d0*)
524    (defvar *fp-constant-1d0*)
525    ;;; The long-float constants.
526    (defvar *fp-constant-0l0*)
527    (defvar *fp-constant-1l0*)
528    (defvar *fp-constant-pi*)
529    (defvar *fp-constant-l2t*)
530    (defvar *fp-constant-l2e*)
531    (defvar *fp-constant-lg2*)
532    (defvar *fp-constant-ln2*)
533    
534    ;;; Enable/Disable scavenging of the read-only space.
535    (defvar *scavenge-read-only-space* nil)
536    
537    ;;; The current alien stack pointer; saved/restored for non-local
538    ;;; exits.
539    (defvar *alien-stack*)
540    
541    ;;; Support for the MT19937 random number generator. The update
542    ;;; function is implemented as an assembly routine. This definition is
543    ;;; transformed to a call to this routine allowing its use in byte
544    ;;; compiled code.
545    ;;;
546    (defun random-mt19937 (state)
547      (declare (type (simple-array (unsigned-byte 32) (627)) state))
548      (random-mt19937 state))
549    
550    
551    ;;;; Useful definitions for writing thread safe code.
552    
553    (in-package "KERNEL")
554    
555    (export '(atomic-push-symbol-value atomic-pop-symbol-value
556              atomic-pusha atomic-pushd atomic-push-vector))
557    
558    (defun %instance-set-conditional (object slot test-value new-value)
559      (declare (type instance object)
560               (type index slot))
561      "Atomically compare object's slot value to test-value and if EQ store
562       new-value in the slot. The original value of the slot is returned."
563      (%instance-set-conditional object slot test-value new-value))
564    
565    (defun set-symbol-value-conditional (symbol test-value new-value)
566      (declare (type symbol symbol))
567      "Atomically compare symbol's value to test-value and if EQ store
568      new-value in symbol's value slot and return the original value."
569      (set-symbol-value-conditional symbol test-value new-value))
570    
571    (defun rplaca-conditional (cons test-value new-value)
572      (declare (type cons cons))
573      "Atomically compare the car of CONS to test-value and if EQ store
574      new-value its car and return the original value."
575      (rplaca-conditional cons test-value new-value))
576    
577    (defun rplacd-conditional (cons test-value new-value)
578      (declare (type cons cons))
579      "Atomically compare the cdr of CONS to test-value and if EQ store
580      new-value its cdr and return the original value."
581      (rplacd-conditional cons test-value new-value))
582    
583    (defun data-vector-set-conditional (vector index test-value new-value)
584      (declare (type simple-vector vector))
585      "Atomically compare an element of vector to test-value and if EQ store
586      new-value the element and return the original value."
587      (data-vector-set-conditional vector index test-value new-value))
588    
589    (defmacro atomic-push-symbol-value (val symbol)
590      "Thread safe push of val onto the list in the symbol global value."
591      (ext:once-only ((n-val val))
592        (let ((new-list (gensym))
593              (old-list (gensym)))
594          `(let ((,new-list (cons ,n-val nil)))
595             (loop
596              (let ((,old-list ,symbol))
597                (setf (cdr ,new-list) ,old-list)
598                (when (eq (set-symbol-value-conditional
599                           ',symbol ,old-list ,new-list)
600                          ,old-list)
601                  (return ,new-list))))))))
602    
603    (defmacro atomic-pop-symbol-value (symbol)
604      "Thread safe pop from the list in the symbol global value."
605      (let ((new-list (gensym))
606            (old-list (gensym)))
607        `(loop
608          (let* ((,old-list ,symbol)
609                 (,new-list (cdr ,old-list)))
610            (when (eq (set-symbol-value-conditional
611                       ',symbol ,old-list ,new-list)
612                      ,old-list)
613              (return (car ,old-list)))))))
614    
615    (defmacro atomic-pusha (val cons)
616      "Thread safe push of val onto the list in the car of cons."
617      (once-only ((n-val val)
618                  (n-cons cons))
619        (let ((new-list (gensym))
620              (old-list (gensym)))
621          `(let ((,new-list (cons ,n-val nil)))
622             (loop
623              (let ((,old-list (car ,n-cons)))
624                (setf (cdr ,new-list) ,old-list)
625                (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
626                          ,old-list)
627                  (return ,new-list))))))))
628    
629    (defmacro atomic-pushd (val cons)
630      "Thread safe push of val onto the list in the cdr of cons."
631      (once-only ((n-val val)
632                  (n-cons cons))
633        (let ((new-list (gensym))
634              (old-list (gensym)))
635          `(let ((,new-list (cons ,n-val nil)))
636             (loop
637              (let ((,old-list (cdr ,n-cons)))
638                (setf (cdr ,new-list) ,old-list)
639                (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
640                          ,old-list)
641                  (return ,new-list))))))))
642    
643    (defmacro atomic-push-vector (val vect index)
644      "Thread safe push of val onto the list in the vector element."
645      (once-only ((n-val val)
646                  (n-vect vect)
647                  (n-index index))
648        (let ((new-list (gensym))
649              (old-list (gensym)))
650          `(let ((,new-list (cons ,n-val nil)))
651             (loop
652              (let ((,old-list (svref ,n-vect ,n-index)))
653                (setf (cdr ,new-list) ,old-list)
654                (when (eq (data-vector-set-conditional
655                           ,n-vect ,n-index ,old-list ,new-list)
656                          ,old-list)
657                  (return ,new-list))))))))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.2.2.3

  ViewVC Help
Powered by ViewVC 1.1.5