/[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.2.2.3 - (show annotations)
Sat Mar 23 18:50:15 2002 UTC (12 years ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18d
Changes since 1.2.2.2: +65 -9 lines
Mega commit to bring RELENG_18 branch in sync with HEAD in preparation
for release tagging 18d.
1 ;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.2.2.3 2002/03/23 18:50:15 pw Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file contains the X86 specific runtime stuff.
15 ;;;
16 ;;; Code movement fixups by Douglas T. Crosher, 1997.
17 ;;; Thread support by Douglas T. Crosher, 1999.
18 ;;;
19
20 (in-package "X86")
21 (use-package "SYSTEM")
22 (use-package "ALIEN")
23 (use-package "C-CALL")
24 (use-package "UNIX")
25 (use-package "KERNEL")
26
27 (export '(fixup-code-object internal-error-arguments
28 sigcontext-program-counter sigcontext-register
29 sigcontext-float-register sigcontext-floating-point-modes
30 extern-alien-name sanctify-for-execution))
31
32
33 ;;;; The sigcontext structure.
34 ;;;; Add machine specific features to *features*
35
36 (pushnew :x86 *features*)
37
38
39
40 #+linux
41 (def-alien-type nil
42 (struct fpreg
43 (significand (array unsigned-short 4))
44 (exponent unsigned-short)))
45 #+linux
46 (def-alien-type nil
47 (struct fpstate
48 (cw unsigned-long)
49 (sw unsigned-long)
50 (tag unsigned-long)
51 (ipoff unsigned-long)
52 (cssel unsigned-long)
53 (dataoff unsigned-long)
54 (datasel unsigned-long)
55 (fpreg (array (struct fpreg) 8))
56 (status unsigned-long)))
57
58 ;;; for FreeBSD
59 #+(and freebsd (not freebsd4))
60 (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
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...
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 ;;; Fixup-Code-Object -- Interface
212 ;;;
213 ;;; This gets called by LOAD to resolve newly positioned objects
214 ;;; 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)
223 (declare (type index offset))
224 (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
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 (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
380 (#.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 (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
394 (#.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 ;;;
406 #+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 'fpreg)
412 index))))
413 (coerce (sys:sap-ref-long reg-sap 0) format))))
414
415 ;;; 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 (defun sigcontext-float-register (scp index format)
419 (declare (ignore scp index))
420 (coerce 0l0 format))
421
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 (declare (ignorable reg-sap))
430 #+not-yet
431 (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
432 (coerce new-value format))))
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)
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 #+BSD
450 (defun sigcontext-floating-point-modes (scp)
451 (declare (type (alien (* sigcontext)) scp)
452 (ignore scp))
453 ;; This is broken until some future release of FreeBSD/OpenBSD!!!
454 (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 name)
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.
498 ;;;
499 ;;; Do whatever is necessary to make the given code component
500 ;;; executable - nothing on the x86.
501 ;;;
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 ;;;
511 (defun float-wait()
512 (float-wait))
513
514 ;;; FLOAT CONSTANTS
515 ;;;
516 ;;; 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
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))))))))

  ViewVC Help
Powered by ViewVC 1.1.5