/[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.17 - (hide annotations)
Thu Dec 6 19:15:41 2001 UTC (12 years, 4 months ago) by pmai
Branch: MAIN
Changes since 1.16: +35 -9 lines
Added specialised port to OpenBSD (2.9).  Many parts of the original
code which were previously conditionalized on :FreeBSD, are now
conditionalized on :BSD instead, with the :BSD feature now implying a
4.4BSD(lite2) derived OS.  This should make future BSD-ports easier.
FreeBSD and OpenBSD are differentiated by having either :FreeBSD or
:OpenBSD on the features list.

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

  ViewVC Help
Powered by ViewVC 1.1.5