/[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.19 - (hide annotations)
Wed Mar 13 08:01:58 2002 UTC (12 years, 1 month ago) by moore
Branch: MAIN
Changes since 1.18: +4 -2 lines
Support for dynamic loading in FreeBSD 4.0 and later.  This involves moving
the static space up, so a cross-compile is required to bootstrap these changes.
1 ram 1.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 dtc 1.7 (ext:file-comment
10 moore 1.19 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.19 2002/03/13 08:01:58 moore Exp $")
11 ram 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the X86 specific runtime stuff.
15     ;;;
16 dtc 1.15 ;;; Code movement fixups by Douglas T. Crosher, 1997.
17     ;;; Thread support by Douglas T. Crosher, 1999.
18     ;;;
19 ram 1.1
20 dtc 1.7 (in-package "X86")
21 ram 1.1 (use-package "SYSTEM")
22     (use-package "ALIEN")
23     (use-package "C-CALL")
24     (use-package "UNIX")
25 dtc 1.7 (use-package "KERNEL")
26 ram 1.1
27     (export '(fixup-code-object internal-error-arguments
28     sigcontext-program-counter sigcontext-register
29     sigcontext-float-register sigcontext-floating-point-modes
30 dtc 1.9 extern-alien-name sanctify-for-execution))
31 ram 1.1
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     ;;; for FreeBSD
59 pw 1.16 #+(and freebsd (not freebsd4))
60 ram 1.1 (def-alien-type sigcontext
61     (struct nil
62     (sc-onstack unsigned-int)
63     (sc-mask unsigned-int)
64     (sc-sp unsigned-int)
65     (sc-fp unsigned-int)
66     (sc-isp unsigned-int)
67     (sc-pc unsigned-int)
68     (sc-efl unsigned-int) ; sc_ps
69     (sc-es unsigned-int)
70     (sc-ds unsigned-int)
71     (sc-cs unsigned-int)
72     (sc-ss unsigned-int)
73     (sc-edi unsigned-int)
74     (sc-esi unsigned-int)
75     (sc-ebx unsigned-int)
76     (sc-edx unsigned-int)
77     (sc-ecx unsigned-int)
78     (sc-eax unsigned-int)))
79 pw 1.16
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 ram 1.1
106 pmai 1.18 ;;; OpenBSD/NetBSD also have sigcontext structs that look more like Linux.
107 pmai 1.17 #+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 pmai 1.18 ))
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 pmai 1.17 ))
159    
160 ram 1.1 ;; For Linux...
161     #+linux
162     (def-alien-type sigcontext
163     (struct nil
164     (gs unsigned-short)
165     (__gsh unsigned-short)
166     (fs unsigned-short)
167     (__fsh unsigned-short)
168     (sc-es unsigned-short)
169     (__esh unsigned-short)
170     (sc-ds unsigned-short)
171     (__dsh unsigned-short)
172     (sc-edi unsigned-long)
173     (sc-esi unsigned-long)
174     (ebp unsigned-long)
175     (sc-sp unsigned-long)
176     (sc-ebx unsigned-long)
177     (sc-edx unsigned-long)
178     (sc-ecx unsigned-long)
179     (sc-eax unsigned-long)
180     (trapno unsigned-long)
181     (err unsigned-long)
182     (sc-pc unsigned-long)
183     (sc-cs unsigned-short)
184     (__csh unsigned-short)
185     (sc-efl unsigned-long)
186     (esp_at_signal unsigned-long)
187     (sc-ss unsigned-short)
188     (__ssh unsigned-short)
189     ; (fpstate unsigned-long) ;; fpstate struct pointer
190     (fpstate (* (struct fpstate)))
191     (sc-mask unsigned-long)
192     (cr2 unsigned-long)))
193    
194    
195    
196     ;;;; MACHINE-TYPE and MACHINE-VERSION
197    
198     #-cross-compiler
199     (defun machine-type ()
200     "Returns a string describing the type of the local machine."
201     "X86")
202    
203    
204     #-cross-compiler
205     (defun machine-version ()
206     "Returns a string describing the version of the local machine."
207     "X86")
208    
209    
210    
211 dtc 1.12 ;;; Fixup-Code-Object -- Interface
212     ;;;
213 ram 1.1 ;;; This gets called by LOAD to resolve newly positioned objects
214     ;;; with things (like code instructions) that have to refer to them.
215 dtc 1.12 ;;;
216 dtc 1.7 ;;; 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 ram 1.1 (defun fixup-code-object (code offset fixup kind)
223     (declare (type index offset))
224 dtc 1.12 (flet ((add-fixup (code offset)
225     ;; Although this could check for and ignore fixups for code
226     ;; objects in the read-only and static spaces, this should
227     ;; only be the case when *enable-dynamic-space-code* is
228     ;; True.
229     (when lisp::*enable-dynamic-space-code*
230     (incf *num-fixups*)
231     (let ((fixups (code-header-ref code code-constants-offset)))
232     (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
233     (let ((new-fixups
234     (adjust-array fixups (1+ (length fixups))
235     :element-type '(unsigned-byte 32))))
236     (setf (aref new-fixups (length fixups)) offset)
237     (setf (code-header-ref code code-constants-offset)
238     new-fixups)))
239     (t
240     (unless (or (eq (get-type fixups) vm:unbound-marker-type)
241     (zerop fixups))
242     (format t "** Init. code FU = ~s~%" fixups))
243     (setf (code-header-ref code code-constants-offset)
244     (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 ram 1.1
323    
324     ;;;; Internal-error-arguments.
325    
326     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
327     ;;;
328     ;;; Given the sigcontext, extract the internal error arguments from the
329     ;;; instruction stream.
330     ;;;
331     (defun internal-error-arguments (scp)
332     (declare (type (alien (* sigcontext)) scp))
333     (with-alien ((scp (* sigcontext) scp))
334     (let ((pc (int-sap (slot scp 'sc-pc))))
335     (declare (type system-area-pointer pc))
336     ;; using INT3 the pc is .. INT3 <here> code length bytes...
337     (let* ((length (sap-ref-8 pc 1))
338     (vector (make-array length :element-type '(unsigned-byte 8))))
339     (declare (type (unsigned-byte 8) length)
340     (type (simple-array (unsigned-byte 8) (*)) vector))
341     (copy-from-system-area pc (* vm:byte-bits 2)
342     vector (* vm:word-bits
343     vm:vector-data-offset)
344     (* length vm:byte-bits))
345     (let* ((index 0)
346     (error-number (c::read-var-integer vector index)))
347     (collect ((sc-offsets))
348     (loop
349     (when (>= index length)
350     (return))
351     (sc-offsets (c::read-var-integer vector index)))
352     (values error-number (sc-offsets))))))))
353    
354    
355     ;;;; Sigcontext access functions.
356    
357     ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
358     ;;;
359     (defun sigcontext-program-counter (scp)
360     (declare (type (alien (* sigcontext)) scp))
361     (with-alien ((scp (* sigcontext) scp))
362     (int-sap (slot scp 'sc-pc))))
363    
364     ;;; SIGCONTEXT-REGISTER -- Interface.
365     ;;;
366     ;;; An escape register saves the value of a register for a frame that someone
367     ;;; interrupts.
368     ;;;
369    
370     (defun sigcontext-register (scp index)
371     (declare (type (alien (* sigcontext)) scp))
372     (with-alien ((scp (* sigcontext) scp))
373     (case index ; ugly -- I know.
374     (#.eax-offset (slot scp 'sc-eax))
375     (#.ecx-offset (slot scp 'sc-ecx))
376     (#.edx-offset (slot scp 'sc-edx))
377     (#.ebx-offset (slot scp 'sc-ebx))
378     (#.esp-offset (slot scp 'sc-sp))
379 dtc 1.13 (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
380 ram 1.1 (#.esi-offset (slot scp 'sc-esi))
381     (#.edi-offset (slot scp 'sc-edi)))))
382    
383    
384     (defun %set-sigcontext-register (scp index new)
385     (declare (type (alien (* sigcontext)) scp))
386     (with-alien ((scp (* sigcontext) scp))
387     (case index
388     (#.eax-offset (setf (slot scp 'sc-eax) new))
389     (#.ecx-offset (setf (slot scp 'sc-ecx) new))
390     (#.edx-offset (setf (slot scp 'sc-edx) new))
391     (#.ebx-offset (setf (slot scp 'sc-ebx) new))
392     (#.esp-offset (setf (slot scp 'sc-sp) new))
393 dtc 1.13 (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
394 ram 1.1 (#.esi-offset (setf (slot scp 'sc-esi) new))
395     (#.edi-offset (setf (slot scp 'sc-edi) new))))
396     new)
397    
398     (defsetf sigcontext-register %set-sigcontext-register)
399    
400    
401     ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
402     ;;;
403     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
404     ;;; Format is the type of float to return.
405 dtc 1.13 ;;;
406 ram 1.1 #+linux
407     (defun sigcontext-float-register (scp index format)
408     (declare (type (alien (* sigcontext)) scp))
409     (with-alien ((scp (* sigcontext) scp))
410     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
411 dtc 1.13 'fpreg)
412 ram 1.1 index))))
413 dtc 1.13 (coerce (sys:sap-ref-long reg-sap 0) format))))
414    
415 pmai 1.17 ;;; Not supported on Free/OpenBSD because the floating point state is not
416     ;;; saved. For now we assume this is true for all modern BSDs
417     #+BSD
418 dtc 1.13 (defun sigcontext-float-register (scp index format)
419     (declare (ignore scp index))
420     (coerce 0l0 format))
421 ram 1.1
422     #+linux
423     (defun %set-sigcontext-float-register (scp index format new-value)
424     (declare (type (alien (* sigcontext)) scp))
425     (with-alien ((scp (* sigcontext) scp))
426     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
427     'fpreg)
428     index))))
429 dtc 1.14 (declare (ignorable reg-sap))
430 dtc 1.13 #+not-yet
431     (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
432     (coerce new-value format))))
433    
434 pmai 1.17 ;;; Not supported on Free/OpenBSD.
435     #+BSD
436 dtc 1.13 (defun %set-sigcontext-float-register (scp index format new-value)
437     (declare (ignore scp index))
438     (coerce new-value format))
439 ram 1.1
440     ;;;
441     (defsetf sigcontext-float-register %set-sigcontext-float-register)
442    
443     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
444     ;;;
445     ;;; Given a sigcontext pointer, return the floating point modes word in the
446     ;;; same format as returned by FLOATING-POINT-MODES.
447     ;;;
448    
449 pmai 1.17 #+BSD
450 ram 1.1 (defun sigcontext-floating-point-modes (scp)
451     (declare (type (alien (* sigcontext)) scp)
452     (ignore scp))
453 pmai 1.17 ;; This is broken until some future release of FreeBSD/OpenBSD!!!
454 ram 1.1 (floating-point-modes))
455    
456     #+linux
457     (defun sigcontext-floating-point-modes (scp)
458     (declare (type (alien (* sigcontext)) scp))
459     (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
460     (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
461     ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
462     ;; NOT TESTED -- clear sticky bits to clear interrupt condition
463     (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
464     ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
465     ;; simulate floating-point-modes VOP
466     (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
467    
468    
469     ;;; EXTERN-ALIEN-NAME -- interface.
470     ;;;
471     ;;; The loader uses this to convert alien names to the form they occure in
472     ;;; the symbol table (for example, prepending an underscore).
473     ;;;
474     (defun extern-alien-name (name)
475     (declare (type simple-string name))
476 dtc 1.8 name)
477 ram 1.1
478 dtc 1.8 (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 moore 1.19 (concatenate 'string #+(or linux (and freebsd elf)) "PVE_stub_"
486     #+(and bsd (not elf)) "_"
487     name)
488 dtc 1.8 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 ram 1.1
496    
497     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
498     ;;;
499 dtc 1.14 ;;; Do whatever is necessary to make the given code component
500     ;;; executable - nothing on the x86.
501 ram 1.1 ;;;
502     (defun sanctify-for-execution (component)
503     (declare (ignore component))
504     nil)
505    
506     ;;; FLOAT-WAIT
507     ;;;
508     ;;; This is used in error.lisp to insure floating-point exceptions
509     ;;; are properly trapped. The compiler translates this to a VOP.
510 dtc 1.14 ;;;
511 ram 1.1 (defun float-wait()
512     (float-wait))
513    
514     ;;; FLOAT CONSTANTS
515     ;;;
516 dtc 1.14 ;;; These are used by the FP move-from-{single|double} VOPs rather
517     ;;; than the i387 load constant instructions to avoid consing in some
518     ;;; cases. Note these are initialise by genesis as they are needed
519     ;;; early.
520     ;;;
521     (defvar *fp-constant-0s0*)
522     (defvar *fp-constant-1s0*)
523     (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 dtc 1.3
534 dtc 1.7 ;;; Enable/Disable scavenging of the read-only space.
535 dtc 1.12 (defvar *scavenge-read-only-space* nil)
536 dtc 1.7
537 dtc 1.3 ;;; The current alien stack pointer; saved/restored for non-local
538     ;;; exits.
539     (defvar *alien-stack*)
540 dtc 1.4
541 dtc 1.12 ;;; 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 dtc 1.15
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))))))))

  ViewVC Help
Powered by ViewVC 1.1.5