/[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.16 - (hide annotations)
Wed Apr 12 17:41:15 2000 UTC (14 years ago) by pw
Branch: MAIN
Changes since 1.15: +28 -2 lines
Support for FreeBSd 4.x version of struct sigcontext conditionalized
by :freebsd4. From Tim Moore.
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 pw 1.16 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.16 2000/04/12 17:41:15 pw 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     ;; For Linux...
107     #+linux
108     (def-alien-type sigcontext
109     (struct nil
110     (gs unsigned-short)
111     (__gsh unsigned-short)
112     (fs unsigned-short)
113     (__fsh unsigned-short)
114     (sc-es unsigned-short)
115     (__esh unsigned-short)
116     (sc-ds unsigned-short)
117     (__dsh unsigned-short)
118     (sc-edi unsigned-long)
119     (sc-esi unsigned-long)
120     (ebp unsigned-long)
121     (sc-sp unsigned-long)
122     (sc-ebx unsigned-long)
123     (sc-edx unsigned-long)
124     (sc-ecx unsigned-long)
125     (sc-eax unsigned-long)
126     (trapno unsigned-long)
127     (err unsigned-long)
128     (sc-pc unsigned-long)
129     (sc-cs unsigned-short)
130     (__csh unsigned-short)
131     (sc-efl unsigned-long)
132     (esp_at_signal unsigned-long)
133     (sc-ss unsigned-short)
134     (__ssh unsigned-short)
135     ; (fpstate unsigned-long) ;; fpstate struct pointer
136     (fpstate (* (struct fpstate)))
137     (sc-mask unsigned-long)
138     (cr2 unsigned-long)))
139    
140    
141    
142     ;;;; MACHINE-TYPE and MACHINE-VERSION
143    
144     #-cross-compiler
145     (defun machine-type ()
146     "Returns a string describing the type of the local machine."
147     "X86")
148    
149    
150     #-cross-compiler
151     (defun machine-version ()
152     "Returns a string describing the version of the local machine."
153     "X86")
154    
155    
156    
157 dtc 1.12 ;;; Fixup-Code-Object -- Interface
158     ;;;
159 ram 1.1 ;;; This gets called by LOAD to resolve newly positioned objects
160     ;;; with things (like code instructions) that have to refer to them.
161 dtc 1.12 ;;;
162 dtc 1.7 ;;; Add a fixup offset to the vector of fixup offsets for the given
163     ;;; code object.
164     ;;;
165     ;;; Counter to measure the storage overhead.
166     (defvar *num-fixups* 0)
167     ;;;
168 ram 1.1 (defun fixup-code-object (code offset fixup kind)
169     (declare (type index offset))
170 dtc 1.12 (flet ((add-fixup (code offset)
171     ;; Although this could check for and ignore fixups for code
172     ;; objects in the read-only and static spaces, this should
173     ;; only be the case when *enable-dynamic-space-code* is
174     ;; True.
175     (when lisp::*enable-dynamic-space-code*
176     (incf *num-fixups*)
177     (let ((fixups (code-header-ref code code-constants-offset)))
178     (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
179     (let ((new-fixups
180     (adjust-array fixups (1+ (length fixups))
181     :element-type '(unsigned-byte 32))))
182     (setf (aref new-fixups (length fixups)) offset)
183     (setf (code-header-ref code code-constants-offset)
184     new-fixups)))
185     (t
186     (unless (or (eq (get-type fixups) vm:unbound-marker-type)
187     (zerop fixups))
188     (format t "** Init. code FU = ~s~%" fixups))
189     (setf (code-header-ref code code-constants-offset)
190     (make-array 1 :element-type '(unsigned-byte 32)
191     :initial-element offset))))))))
192     (system:without-gcing
193     (let* ((sap (truly-the system-area-pointer
194     (kernel:code-instructions code)))
195     (obj-start-addr (logand (kernel:get-lisp-obj-address code)
196     #xfffffff8))
197     #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
198     (code-start-addr (sys:sap-int (kernel:code-instructions code)))
199     (ncode-words (kernel:code-header-ref code 1))
200     (code-end-addr (+ code-start-addr (* ncode-words 4))))
201     (unless (member kind '(:absolute :relative))
202     (error "Unknown code-object-fixup kind ~s." kind))
203     (ecase kind
204     (:absolute
205     ;; Word at sap + offset contains a value to be replaced by
206     ;; adding that value to fixup.
207     (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
208     ;; Record absolute fixups that point within the code object.
209     (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
210     (add-fixup code offset)))
211     (:relative
212     ;; Fixup is the actual address wanted.
213     ;;
214     ;; Record relative fixups that point outside the code
215     ;; object.
216     (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
217     (add-fixup code offset))
218     ;; Replace word with value to add to that loc to get there.
219     (let* ((loc-sap (+ (sap-int sap) offset))
220     (rel-val (- fixup loc-sap 4)))
221     (declare (type (unsigned-byte 32) loc-sap)
222     (type (signed-byte 32) rel-val))
223     (setf (signed-sap-ref-32 sap offset) rel-val))))))
224     nil))
225    
226     ;;; Do-Load-Time-Code-Fixups
227     ;;;
228     ;;; Add a code fixup to a code object generated by new-genesis. The
229     ;;; fixup has already been applied, it's just a matter of placing the
230     ;;; fixup in the code's fixup vector if necessary.
231     ;;;
232     #+gencgc
233     (defun do-load-time-code-fixup (code offset fixup kind)
234     (flet ((add-load-time-code-fixup (code offset)
235     (let ((fixups (code-header-ref code vm:code-constants-offset)))
236     (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
237     (let ((new-fixups
238     (adjust-array fixups (1+ (length fixups))
239     :element-type '(unsigned-byte 32))))
240     (setf (aref new-fixups (length fixups)) offset)
241     (setf (code-header-ref code vm:code-constants-offset)
242     new-fixups)))
243     (t
244     (unless (or (eq (get-type fixups) vm:unbound-marker-type)
245     (zerop fixups))
246     (%primitive print "** Init. code FU"))
247     (setf (code-header-ref code vm:code-constants-offset)
248     (make-array 1 :element-type '(unsigned-byte 32)
249     :initial-element offset)))))))
250     (let* ((sap (truly-the system-area-pointer
251     (kernel:code-instructions code)))
252     (obj-start-addr
253     (logand (kernel:get-lisp-obj-address code) #xfffffff8))
254     (code-start-addr (sys:sap-int (kernel:code-instructions code)))
255     (ncode-words (kernel:code-header-ref code 1))
256     (code-end-addr (+ code-start-addr (* ncode-words 4))))
257     (ecase kind
258     (:absolute
259     ;; Record absolute fixups that point within the
260     ;; code object.
261     (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
262     (add-load-time-code-fixup code offset)))
263     (:relative
264     ;; Record relative fixups that point outside the
265     ;; code object.
266     (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
267     (add-load-time-code-fixup code offset)))))))
268 ram 1.1
269    
270     ;;;; Internal-error-arguments.
271    
272     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
273     ;;;
274     ;;; Given the sigcontext, extract the internal error arguments from the
275     ;;; instruction stream.
276     ;;;
277     (defun internal-error-arguments (scp)
278     (declare (type (alien (* sigcontext)) scp))
279     (with-alien ((scp (* sigcontext) scp))
280     (let ((pc (int-sap (slot scp 'sc-pc))))
281     (declare (type system-area-pointer pc))
282     ;; using INT3 the pc is .. INT3 <here> code length bytes...
283     (let* ((length (sap-ref-8 pc 1))
284     (vector (make-array length :element-type '(unsigned-byte 8))))
285     (declare (type (unsigned-byte 8) length)
286     (type (simple-array (unsigned-byte 8) (*)) vector))
287     (copy-from-system-area pc (* vm:byte-bits 2)
288     vector (* vm:word-bits
289     vm:vector-data-offset)
290     (* length vm:byte-bits))
291     (let* ((index 0)
292     (error-number (c::read-var-integer vector index)))
293     (collect ((sc-offsets))
294     (loop
295     (when (>= index length)
296     (return))
297     (sc-offsets (c::read-var-integer vector index)))
298     (values error-number (sc-offsets))))))))
299    
300    
301     ;;;; Sigcontext access functions.
302    
303     ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
304     ;;;
305     (defun sigcontext-program-counter (scp)
306     (declare (type (alien (* sigcontext)) scp))
307     (with-alien ((scp (* sigcontext) scp))
308     (int-sap (slot scp 'sc-pc))))
309    
310     ;;; SIGCONTEXT-REGISTER -- Interface.
311     ;;;
312     ;;; An escape register saves the value of a register for a frame that someone
313     ;;; interrupts.
314     ;;;
315    
316     (defun sigcontext-register (scp index)
317     (declare (type (alien (* sigcontext)) scp))
318     (with-alien ((scp (* sigcontext) scp))
319     (case index ; ugly -- I know.
320     (#.eax-offset (slot scp 'sc-eax))
321     (#.ecx-offset (slot scp 'sc-ecx))
322     (#.edx-offset (slot scp 'sc-edx))
323     (#.ebx-offset (slot scp 'sc-ebx))
324     (#.esp-offset (slot scp 'sc-sp))
325 dtc 1.13 (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
326 ram 1.1 (#.esi-offset (slot scp 'sc-esi))
327     (#.edi-offset (slot scp 'sc-edi)))))
328    
329    
330     (defun %set-sigcontext-register (scp index new)
331     (declare (type (alien (* sigcontext)) scp))
332     (with-alien ((scp (* sigcontext) scp))
333     (case index
334     (#.eax-offset (setf (slot scp 'sc-eax) new))
335     (#.ecx-offset (setf (slot scp 'sc-ecx) new))
336     (#.edx-offset (setf (slot scp 'sc-edx) new))
337     (#.ebx-offset (setf (slot scp 'sc-ebx) new))
338     (#.esp-offset (setf (slot scp 'sc-sp) new))
339 dtc 1.13 (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
340 ram 1.1 (#.esi-offset (setf (slot scp 'sc-esi) new))
341     (#.edi-offset (setf (slot scp 'sc-edi) new))))
342     new)
343    
344     (defsetf sigcontext-register %set-sigcontext-register)
345    
346    
347     ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
348     ;;;
349     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
350     ;;; Format is the type of float to return.
351 dtc 1.13 ;;;
352 ram 1.1 #+linux
353     (defun sigcontext-float-register (scp index format)
354     (declare (type (alien (* sigcontext)) scp))
355     (with-alien ((scp (* sigcontext) scp))
356     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
357 dtc 1.13 'fpreg)
358 ram 1.1 index))))
359 dtc 1.13 (coerce (sys:sap-ref-long reg-sap 0) format))))
360    
361     ;;; Not supported on FreeBSD because the floating point state is not
362     ;;; saved.
363     #+FreeBSD
364     (defun sigcontext-float-register (scp index format)
365     (declare (ignore scp index))
366     (coerce 0l0 format))
367 ram 1.1
368     #+linux
369     (defun %set-sigcontext-float-register (scp index format new-value)
370     (declare (type (alien (* sigcontext)) scp))
371     (with-alien ((scp (* sigcontext) scp))
372     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
373     'fpreg)
374     index))))
375 dtc 1.14 (declare (ignorable reg-sap))
376 dtc 1.13 #+not-yet
377     (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
378     (coerce new-value format))))
379    
380     ;;; Not supported on FreeBSD.
381     #+FreeBSD
382     (defun %set-sigcontext-float-register (scp index format new-value)
383     (declare (ignore scp index))
384     (coerce new-value format))
385 ram 1.1
386     ;;;
387     (defsetf sigcontext-float-register %set-sigcontext-float-register)
388    
389     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
390     ;;;
391     ;;; Given a sigcontext pointer, return the floating point modes word in the
392     ;;; same format as returned by FLOATING-POINT-MODES.
393     ;;;
394    
395     #+FreeBSD
396     (defun sigcontext-floating-point-modes (scp)
397     (declare (type (alien (* sigcontext)) scp)
398     (ignore scp))
399     ;; This is broken until some future release of FreeBSD!!!
400     (floating-point-modes))
401    
402     #+linux
403     (defun sigcontext-floating-point-modes (scp)
404     (declare (type (alien (* sigcontext)) scp))
405     (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
406     (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
407     ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
408     ;; NOT TESTED -- clear sticky bits to clear interrupt condition
409     (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
410     ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
411     ;; simulate floating-point-modes VOP
412     (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
413    
414    
415     ;;; EXTERN-ALIEN-NAME -- interface.
416     ;;;
417     ;;; The loader uses this to convert alien names to the form they occure in
418     ;;; the symbol table (for example, prepending an underscore).
419     ;;;
420     (defun extern-alien-name (name)
421     (declare (type simple-string name))
422 dtc 1.8 name)
423 ram 1.1
424 dtc 1.8 (defun lisp::foreign-symbol-address-aux (name)
425     (multiple-value-bind (value found)
426     (gethash name lisp::*foreign-symbols* 0)
427     (if found
428     value
429     (multiple-value-bind (value found)
430     (gethash
431     (concatenate 'string #+linux "PVE_stub_" #+freebsd "_" name)
432     lisp::*foreign-symbols* 0)
433     (if found
434     value
435     (let ((value (system:alternate-get-global-address name)))
436     (when (zerop value)
437     (error "Unknown foreign symbol: ~S" name))
438     value))))))
439 ram 1.1
440    
441     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
442     ;;;
443 dtc 1.14 ;;; Do whatever is necessary to make the given code component
444     ;;; executable - nothing on the x86.
445 ram 1.1 ;;;
446     (defun sanctify-for-execution (component)
447     (declare (ignore component))
448     nil)
449    
450     ;;; FLOAT-WAIT
451     ;;;
452     ;;; This is used in error.lisp to insure floating-point exceptions
453     ;;; are properly trapped. The compiler translates this to a VOP.
454 dtc 1.14 ;;;
455 ram 1.1 (defun float-wait()
456     (float-wait))
457    
458     ;;; FLOAT CONSTANTS
459     ;;;
460 dtc 1.14 ;;; These are used by the FP move-from-{single|double} VOPs rather
461     ;;; than the i387 load constant instructions to avoid consing in some
462     ;;; cases. Note these are initialise by genesis as they are needed
463     ;;; early.
464     ;;;
465     (defvar *fp-constant-0s0*)
466     (defvar *fp-constant-1s0*)
467     (defvar *fp-constant-0d0*)
468     (defvar *fp-constant-1d0*)
469     ;;; The long-float constants.
470     (defvar *fp-constant-0l0*)
471     (defvar *fp-constant-1l0*)
472     (defvar *fp-constant-pi*)
473     (defvar *fp-constant-l2t*)
474     (defvar *fp-constant-l2e*)
475     (defvar *fp-constant-lg2*)
476     (defvar *fp-constant-ln2*)
477 dtc 1.3
478 dtc 1.7 ;;; Enable/Disable scavenging of the read-only space.
479 dtc 1.12 (defvar *scavenge-read-only-space* nil)
480 dtc 1.7
481 dtc 1.3 ;;; The current alien stack pointer; saved/restored for non-local
482     ;;; exits.
483     (defvar *alien-stack*)
484 dtc 1.4
485 dtc 1.12 ;;; Support for the MT19937 random number generator. The update
486     ;;; function is implemented as an assembly routine. This definition is
487     ;;; transformed to a call to this routine allowing its use in byte
488     ;;; compiled code.
489     ;;;
490     (defun random-mt19937 (state)
491     (declare (type (simple-array (unsigned-byte 32) (627)) state))
492     (random-mt19937 state))
493 dtc 1.15
494    
495     ;;;; Useful definitions for writing thread safe code.
496    
497     (in-package "KERNEL")
498    
499     (export '(atomic-push-symbol-value atomic-pop-symbol-value
500     atomic-pusha atomic-pushd atomic-push-vector))
501    
502     (defun %instance-set-conditional (object slot test-value new-value)
503     (declare (type instance object)
504     (type index slot))
505     "Atomically compare object's slot value to test-value and if EQ store
506     new-value in the slot. The original value of the slot is returned."
507     (%instance-set-conditional object slot test-value new-value))
508    
509     (defun set-symbol-value-conditional (symbol test-value new-value)
510     (declare (type symbol symbol))
511     "Atomically compare symbol's value to test-value and if EQ store
512     new-value in symbol's value slot and return the original value."
513     (set-symbol-value-conditional symbol test-value new-value))
514    
515     (defun rplaca-conditional (cons test-value new-value)
516     (declare (type cons cons))
517     "Atomically compare the car of CONS to test-value and if EQ store
518     new-value its car and return the original value."
519     (rplaca-conditional cons test-value new-value))
520    
521     (defun rplacd-conditional (cons test-value new-value)
522     (declare (type cons cons))
523     "Atomically compare the cdr of CONS to test-value and if EQ store
524     new-value its cdr and return the original value."
525     (rplacd-conditional cons test-value new-value))
526    
527     (defun data-vector-set-conditional (vector index test-value new-value)
528     (declare (type simple-vector vector))
529     "Atomically compare an element of vector to test-value and if EQ store
530     new-value the element and return the original value."
531     (data-vector-set-conditional vector index test-value new-value))
532    
533     (defmacro atomic-push-symbol-value (val symbol)
534     "Thread safe push of val onto the list in the symbol global value."
535     (ext:once-only ((n-val val))
536     (let ((new-list (gensym))
537     (old-list (gensym)))
538     `(let ((,new-list (cons ,n-val nil)))
539     (loop
540     (let ((,old-list ,symbol))
541     (setf (cdr ,new-list) ,old-list)
542     (when (eq (set-symbol-value-conditional
543     ',symbol ,old-list ,new-list)
544     ,old-list)
545     (return ,new-list))))))))
546    
547     (defmacro atomic-pop-symbol-value (symbol)
548     "Thread safe pop from the list in the symbol global value."
549     (let ((new-list (gensym))
550     (old-list (gensym)))
551     `(loop
552     (let* ((,old-list ,symbol)
553     (,new-list (cdr ,old-list)))
554     (when (eq (set-symbol-value-conditional
555     ',symbol ,old-list ,new-list)
556     ,old-list)
557     (return (car ,old-list)))))))
558    
559     (defmacro atomic-pusha (val cons)
560     "Thread safe push of val onto the list in the car of cons."
561     (once-only ((n-val val)
562     (n-cons cons))
563     (let ((new-list (gensym))
564     (old-list (gensym)))
565     `(let ((,new-list (cons ,n-val nil)))
566     (loop
567     (let ((,old-list (car ,n-cons)))
568     (setf (cdr ,new-list) ,old-list)
569     (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
570     ,old-list)
571     (return ,new-list))))))))
572    
573     (defmacro atomic-pushd (val cons)
574     "Thread safe push of val onto the list in the cdr of cons."
575     (once-only ((n-val val)
576     (n-cons cons))
577     (let ((new-list (gensym))
578     (old-list (gensym)))
579     `(let ((,new-list (cons ,n-val nil)))
580     (loop
581     (let ((,old-list (cdr ,n-cons)))
582     (setf (cdr ,new-list) ,old-list)
583     (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
584     ,old-list)
585     (return ,new-list))))))))
586    
587     (defmacro atomic-push-vector (val vect index)
588     "Thread safe push of val onto the list in the vector element."
589     (once-only ((n-val val)
590     (n-vect vect)
591     (n-index index))
592     (let ((new-list (gensym))
593     (old-list (gensym)))
594     `(let ((,new-list (cons ,n-val nil)))
595     (loop
596     (let ((,old-list (svref ,n-vect ,n-index)))
597     (setf (cdr ,new-list) ,old-list)
598     (when (eq (data-vector-set-conditional
599     ,n-vect ,n-index ,old-list ,new-list)
600     ,old-list)
601     (return ,new-list))))))))

  ViewVC Help
Powered by ViewVC 1.1.5