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

Contents of /src/code/amd64-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Tue Apr 20 17:57:43 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.6: +3 -3 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 cwang 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     (ext:file-comment
10 rtoy 1.7 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/amd64-vm.lisp,v 1.7 2010/04/20 17:57:43 rtoy Rel $")
11 cwang 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the AMD64 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 "AMD64")
21     (use-package "SYSTEM")
22     (use-package "ALIEN")
23     (use-package "C-CALL")
24     (use-package "UNIX")
25     (use-package "KERNEL")
26    
27 rtoy 1.5 (intl:textdomain "cmucl")
28    
29 cwang 1.1 (export '(fixup-code-object internal-error-arguments
30     sigcontext-program-counter sigcontext-register
31     sigcontext-float-register sigcontext-floating-point-modes
32     extern-alien-name sanctify-for-execution))
33    
34    
35     ;;;; The sigcontext structure.
36     ;;;; Add machine specific features to *features*
37    
38     (pushnew :amd64 *features*)
39    
40    
41    
42     #+linux
43     (def-alien-type nil
44     (struct fpreg
45     (significand (array unsigned-short 4))
46     (exponent unsigned-short)))
47     #+linux
48     (def-alien-type nil
49     (struct fpstate
50     (cw unsigned-long)
51     (sw unsigned-long)
52     (tag unsigned-long)
53     (ipoff unsigned-long)
54     (cssel unsigned-long)
55     (dataoff unsigned-long)
56     (datasel unsigned-long)
57     (fpreg (array (struct fpreg) 8))
58     (status unsigned-long)))
59    
60 agoncharov 1.4 #+freebsd
61 cwang 1.1 (def-alien-type sigcontext
62     (struct nil
63     (sc-mask (array unsigned-int 4))
64     (sc-onstack unsigned-int)
65     (sc-gs unsigned-int)
66     (sc-fs unsigned-int)
67     (sc-es unsigned-int)
68     (sc-ds unsigned-int)
69     (sc-edi unsigned-int)
70     (sc-esi unsigned-int)
71     (sc-fp unsigned-int)
72     (sc-isp unsigned-int)
73     (sc-ebx unsigned-int)
74     (sc-edx unsigned-int)
75     (sc-ecx unsigned-int)
76     (sc-eax unsigned-int)
77     (trapno unsigned-int)
78     (err unsigned-int)
79     (sc-pc unsigned-int)
80     (sc-cs unsigned-int)
81     (sc-efl unsigned-int) ; sc_ps
82     (sc-sp unsigned-int)
83     (sc-ss unsigned-int)))
84    
85     ;;; OpenBSD/NetBSD also have sigcontext structs that look more like Linux.
86     #+openbsd
87     (def-alien-type sigcontext
88     (struct nil
89     (sc-gs unsigned-int)
90     (sc-fs unsigned-int)
91     (sc-es unsigned-int)
92     (sc-ds unsigned-int)
93     (sc-edi unsigned-int)
94     (sc-esi unsigned-int)
95     (sc-fp unsigned-int) ;; ebp
96     (sc-ebx unsigned-int)
97     (sc-edx unsigned-int)
98     (sc-ecx unsigned-int)
99     (sc-eax 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     (sc-onstack unsigned-int)
106     (sc-mask unsigned-int)
107     (sc-trapno unsigned-int)
108     (sc-err unsigned-int)
109     ))
110    
111     #+netbsd
112     (def-alien-type sigcontext
113     (struct nil
114     (sc-gs unsigned-int)
115     (sc-fs unsigned-int)
116     (sc-es unsigned-int)
117     (sc-ds unsigned-int)
118     (sc-edi unsigned-int)
119     (sc-esi unsigned-int)
120     (sc-fp unsigned-int) ;; ebp
121     (sc-ebx unsigned-int)
122     (sc-edx unsigned-int)
123     (sc-ecx unsigned-int)
124     (sc-eax unsigned-int)
125     (sc-pc unsigned-int)
126     (sc-cs unsigned-int)
127     (sc-efl unsigned-int) ; sc_ps
128     (sc-sp unsigned-int)
129     (sc-ss unsigned-int)
130     (sc-onstack unsigned-int)
131     ;; Old NetBSD 1.3 signal mask
132     (sc-oldmask unsigned-int)
133     (sc-trapno unsigned-int)
134     (sc-err unsigned-int)
135     ;; New signal mask (post NetBSD 1.3)
136     (sc-mask (array unsigned-int 4))
137     ))
138    
139     ;; For Linux...
140     #+linux
141     (def-alien-type sigcontext
142     (struct nil
143 cwang 1.2 (sc-r8 unsigned-long)
144     (sc-r9 unsigned-long)
145     (sc-r10 unsigned-long)
146     (sc-r11 unsigned-long)
147     (sc-r12 unsigned-long)
148     (sc-r13 unsigned-long)
149     (sc-r14 unsigned-long)
150     (sc-r15 unsigned-long)
151     (sc-rdi unsigned-long)
152     (sc-rsi unsigned-long)
153     (rbp unsigned-long)
154     (sc-rbx unsigned-long)
155     (sc-rdx unsigned-long)
156     (sc-rax unsigned-long)
157     (sc-rcx unsigned-long)
158     (sc-sp unsigned-long)
159     (sc-pc unsigned-long)
160     (sc-efl unsigned-long)
161     (sc-cs unsigned-short)
162     (gs unsigned-short)
163     (fs unsigned-short)
164     (__pad0 unsigned-short)
165     (err unsigned-long)
166     (trapno unsigned-long)
167     (sc-mask unsigned-long)
168     (cr2 unsigned-long)
169     (fpstate (* (struct fpstate)))
170     (__reserved1 (array unsigned-long 8))))
171 cwang 1.1
172    
173     ;;;; MACHINE-TYPE and MACHINE-VERSION
174    
175     #-cross-compiler
176     (defun machine-type ()
177 rtoy 1.6 "Returns a string describing the type of the local machine."
178 cwang 1.1 "AMD x86-64")
179    
180    
181     #-cross-compiler
182     (defun machine-version ()
183 rtoy 1.6 "Returns a string describing the version of the local machine."
184 cwang 1.1 "AMD x86-64")
185    
186    
187    
188     ;;; Fixup-Code-Object -- Interface
189     ;;;
190     ;;; This gets called by LOAD to resolve newly positioned objects
191     ;;; with things (like code instructions) that have to refer to them.
192     ;;;
193     ;;; Add a fixup offset to the vector of fixup offsets for the given
194     ;;; code object.
195     ;;;
196     ;;; Counter to measure the storage overhead.
197     (defvar *num-fixups* 0)
198     ;;; XXX
199     (defun fixup-code-object (code offset fixup kind)
200     (declare (type index offset))
201     (flet ((add-fixup (code offset)
202     ;; Although this could check for and ignore fixups for code
203     ;; objects in the read-only and static spaces, this should
204     ;; only be the case when *enable-dynamic-space-code* is
205     ;; True.
206     (when lisp::*enable-dynamic-space-code*
207     (incf *num-fixups*)
208     (let ((fixups (code-header-ref code code-constants-offset)))
209     (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
210     (let ((new-fixups
211     (adjust-array fixups (1+ (length fixups))
212     :element-type '(unsigned-byte 32))))
213     (setf (aref new-fixups (length fixups)) offset)
214     (setf (code-header-ref code code-constants-offset)
215     new-fixups)))
216     (t
217     (unless (or (eq (get-type fixups) vm:unbound-marker-type)
218     (zerop fixups))
219     (format t "** Init. code FU = ~s~%" fixups))
220     (setf (code-header-ref code code-constants-offset)
221     (make-array 1 :element-type '(unsigned-byte 32)
222     :initial-element offset))))))))
223     (system:without-gcing
224     (let* ((sap (truly-the system-area-pointer
225     (kernel:code-instructions code)))
226     (obj-start-addr (logand (kernel:get-lisp-obj-address code)
227     #xfffffff8))
228     #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
229     (code-start-addr (sys:sap-int (kernel:code-instructions code)))
230     (ncode-words (kernel:code-header-ref code 1))
231     (code-end-addr (+ code-start-addr (* ncode-words 8))))
232     (unless (member kind '(:absolute :relative))
233 rtoy 1.7 (error (intl:gettext "Unknown code-object-fixup kind ~s.") kind))
234 cwang 1.1 (ecase kind
235     (:absolute
236     ;; Word at sap + offset contains a value to be replaced by
237     ;; adding that value to fixup.
238     (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
239     ;; Record absolute fixups that point within the code object.
240     (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
241     (add-fixup code offset)))
242     (:relative
243     ;; Fixup is the actual address wanted.
244     ;;
245     ;; Record relative fixups that point outside the code
246     ;; object.
247     (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
248     (add-fixup code offset))
249     ;; Replace word with value to add to that loc to get there.
250     (let* ((loc-sap (+ (sap-int sap) offset))
251     (rel-val (- fixup loc-sap 4)))
252     (declare (type (unsigned-byte 32) loc-sap)
253     (type (signed-byte 32) rel-val))
254     (setf (signed-sap-ref-32 sap offset) rel-val))))))
255     nil))
256    
257     ;;; Do-Load-Time-Code-Fixups
258     ;;;
259     ;;; Add a code fixup to a code object generated by new-genesis. The
260     ;;; fixup has already been applied, it's just a matter of placing the
261     ;;; fixup in the code's fixup vector if necessary.
262     ;;;
263     #+gencgc
264     (defun do-load-time-code-fixup (code offset fixup kind)
265     (flet ((add-load-time-code-fixup (code offset)
266     (let ((fixups (code-header-ref code vm:code-constants-offset)))
267     (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
268     (let ((new-fixups
269     (adjust-array fixups (1+ (length fixups))
270     :element-type '(unsigned-byte 32))))
271     (setf (aref new-fixups (length fixups)) offset)
272     (setf (code-header-ref code vm:code-constants-offset)
273     new-fixups)))
274     (t
275     (unless (or (eq (get-type fixups) vm:unbound-marker-type)
276     (zerop fixups))
277     (%primitive print "** Init. code FU"))
278     (setf (code-header-ref code vm:code-constants-offset)
279     (make-array 1 :element-type '(unsigned-byte 32)
280     :initial-element offset)))))))
281     (let* ((sap (truly-the system-area-pointer
282     (kernel:code-instructions code)))
283     (obj-start-addr
284     (logand (kernel:get-lisp-obj-address code) #xfffffff8))
285     (code-start-addr (sys:sap-int (kernel:code-instructions code)))
286     (ncode-words (kernel:code-header-ref code 1))
287     (code-end-addr (+ code-start-addr (* ncode-words 8))))
288     (ecase kind
289     (:absolute
290     ;; Record absolute fixups that point within the
291     ;; code object.
292     (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
293     (add-load-time-code-fixup code offset)))
294     (:relative
295     ;; Record relative fixups that point outside the
296     ;; code object.
297     (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
298     (add-load-time-code-fixup code offset)))))))
299    
300    
301     ;;;; Internal-error-arguments.
302    
303     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
304     ;;;
305     ;;; Given the sigcontext, extract the internal error arguments from the
306     ;;; instruction stream.
307     ;;;
308     (defun internal-error-arguments (scp)
309     (declare (type (alien (* sigcontext)) scp))
310     (with-alien ((scp (* sigcontext) scp))
311     (let ((pc (int-sap (slot scp 'sc-pc))))
312     (declare (type system-area-pointer pc))
313     ;; using INT3 the pc is .. INT3 <here> code length bytes...
314     (let* ((length (sap-ref-8 pc 1))
315     (vector (make-array length :element-type '(unsigned-byte 8))))
316     (declare (type (unsigned-byte 8) length)
317     (type (simple-array (unsigned-byte 8) (*)) vector))
318     (copy-from-system-area pc (* vm:byte-bits 2)
319     vector (* vm:word-bits
320     vm:vector-data-offset)
321     (* length vm:byte-bits))
322     (let* ((index 0)
323     (error-number (c::read-var-integer vector index)))
324     (collect ((sc-offsets))
325     (loop
326     (when (>= index length)
327     (return))
328     (sc-offsets (c::read-var-integer vector index)))
329     (values error-number (sc-offsets))))))))
330    
331    
332     ;;;; Sigcontext access functions.
333    
334     ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
335     ;;;
336     (defun sigcontext-program-counter (scp)
337     (declare (type (alien (* sigcontext)) scp))
338     (with-alien ((scp (* sigcontext) scp))
339     (int-sap (slot scp 'sc-pc))))
340    
341     ;;; SIGCONTEXT-REGISTER -- Interface.
342     ;;;
343     ;;; An escape register saves the value of a register for a frame that someone
344     ;;; interrupts.
345     ;;;
346    
347     (defun sigcontext-register (scp index)
348     (declare (type (alien (* sigcontext)) scp))
349     (with-alien ((scp (* sigcontext) scp))
350     (case index ; ugly -- I know.
351     (#.eax-offset (slot scp 'sc-eax))
352     (#.ecx-offset (slot scp 'sc-ecx))
353     (#.edx-offset (slot scp 'sc-edx))
354     (#.ebx-offset (slot scp 'sc-ebx))
355     (#.esp-offset (slot scp 'sc-sp))
356     (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
357     (#.esi-offset (slot scp 'sc-esi))
358     (#.edi-offset (slot scp 'sc-edi)))))
359    
360    
361     (defun %set-sigcontext-register (scp index new)
362     (declare (type (alien (* sigcontext)) scp))
363     (with-alien ((scp (* sigcontext) scp))
364     (case index
365     (#.eax-offset (setf (slot scp 'sc-eax) new))
366     (#.ecx-offset (setf (slot scp 'sc-ecx) new))
367     (#.edx-offset (setf (slot scp 'sc-edx) new))
368     (#.ebx-offset (setf (slot scp 'sc-ebx) new))
369     (#.esp-offset (setf (slot scp 'sc-sp) new))
370     (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
371     (#.esi-offset (setf (slot scp 'sc-esi) new))
372     (#.edi-offset (setf (slot scp 'sc-edi) new))))
373     new)
374    
375     (defsetf sigcontext-register %set-sigcontext-register)
376    
377    
378     ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
379     ;;;
380     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
381     ;;; Format is the type of float to return.
382     ;;;
383     #+linux
384     (defun sigcontext-float-register (scp index format)
385     (declare (type (alien (* sigcontext)) scp))
386     (with-alien ((scp (* sigcontext) scp))
387     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
388     'fpreg)
389     index))))
390     (coerce (sys:sap-ref-long reg-sap 0) format))))
391    
392     ;;; Not supported on Free/OpenBSD because the floating point state is not
393     ;;; saved. For now we assume this is true for all modern BSDs
394     #+BSD
395     (defun sigcontext-float-register (scp index format)
396     (declare (ignore scp index))
397     (coerce 0l0 format))
398    
399     #+linux
400     (defun %set-sigcontext-float-register (scp index format new-value)
401     (declare (type (alien (* sigcontext)) scp))
402     (with-alien ((scp (* sigcontext) scp))
403     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
404     'fpreg)
405     index))))
406     (declare (ignorable reg-sap))
407     #+not-yet
408     (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
409     (coerce new-value format))))
410    
411     ;;; Not supported on Free/OpenBSD.
412     #+BSD
413     (defun %set-sigcontext-float-register (scp index format new-value)
414     (declare (ignore scp index))
415     (coerce new-value format))
416    
417     ;;;
418     (defsetf sigcontext-float-register %set-sigcontext-float-register)
419    
420     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
421     ;;;
422     ;;; Given a sigcontext pointer, return the floating point modes word in the
423     ;;; same format as returned by FLOATING-POINT-MODES.
424     ;;;
425    
426     #+BSD
427     (defun sigcontext-floating-point-modes (scp)
428     (declare (type (alien (* sigcontext)) scp)
429     (ignore scp))
430     ;; This is broken until some future release of FreeBSD/OpenBSD!!!
431     (floating-point-modes))
432    
433     #+linux
434     (defun sigcontext-floating-point-modes (scp)
435     (declare (type (alien (* sigcontext)) scp))
436     (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
437     (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
438     ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
439     ;; NOT TESTED -- clear sticky bits to clear interrupt condition
440     (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
441     ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
442     ;; simulate floating-point-modes VOP
443     (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
444    
445    
446     ;;; EXTERN-ALIEN-NAME -- interface.
447     ;;;
448 rtoy 1.3 ;;; The loader uses this to convert alien names to the form they occur in
449 cwang 1.1 ;;; the symbol table (for example, prepending an underscore).
450     ;;;
451     (defun extern-alien-name (name)
452     (declare (type simple-string name))
453     #+(and bsd (not elf))
454     (concatenate 'string "_" name)
455     #-(and bsd (not elf))
456     name)
457    
458     #+(and (or linux (and freebsd elf)) (not linkage-table))
459     (defun lisp::foreign-symbol-address-aux (name flavor)
460     (declare (ignore flavor))
461     (multiple-value-bind (value found)
462     (gethash name lisp::*foreign-symbols* 0)
463     (if found
464     value
465     (multiple-value-bind (value found)
466     (gethash
467     (concatenate 'string "PVE_stub_" name)
468     lisp::*foreign-symbols* 0)
469     (if found
470     value
471     (let ((value (system:alternate-get-global-address name)))
472     (when (zerop value)
473 rtoy 1.7 (error (intl:gettext "Unknown foreign symbol: ~S") name))
474 cwang 1.1 value))))))
475    
476    
477    
478     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
479     ;;;
480     ;;; Do whatever is necessary to make the given code component
481     ;;; executable - nothing on the x86.
482     ;;;
483     (defun sanctify-for-execution (component)
484     (declare (ignore component))
485     nil)
486    
487     ;;; FLOAT-WAIT
488     ;;;
489 rtoy 1.3 ;;; This is used in error.lisp to ensure floating-point exceptions
490 cwang 1.1 ;;; are properly trapped. The compiler translates this to a VOP.
491     ;;;
492     (defun float-wait()
493     (float-wait))
494    
495     ;;; FLOAT CONSTANTS
496     ;;;
497     ;;; These are used by the FP move-from-{single|double} VOPs rather
498     ;;; than the i387 load constant instructions to avoid consing in some
499 rtoy 1.3 ;;; cases. Note these are initialised by genesis as they are needed
500 cwang 1.1 ;;; early.
501     ;;;
502     (defvar *fp-constant-0s0*)
503     (defvar *fp-constant-1s0*)
504     (defvar *fp-constant-0d0*)
505     (defvar *fp-constant-1d0*)
506     ;;; The long-float constants.
507     (defvar *fp-constant-0l0*)
508     (defvar *fp-constant-1l0*)
509     (defvar *fp-constant-pi*)
510     (defvar *fp-constant-l2t*)
511     (defvar *fp-constant-l2e*)
512     (defvar *fp-constant-lg2*)
513     (defvar *fp-constant-ln2*)
514    
515 rtoy 1.3 ;;; Enable/disable scavenging of the read-only space.
516 cwang 1.1 (defvar *scavenge-read-only-space* nil)
517    
518     ;;; The current alien stack pointer; saved/restored for non-local
519     ;;; exits.
520     (defvar *alien-stack*)
521    
522     ;;; Support for the MT19937 random number generator. The update
523     ;;; function is implemented as an assembly routine. This definition is
524     ;;; transformed to a call to this routine allowing its use in byte
525     ;;; compiled code.
526     ;;;
527     (defun random-mt19937 (state)
528     (declare (type (simple-array (unsigned-byte 32) (627)) state))
529     (random-mt19937 state))
530    
531    
532     ;;;; Useful definitions for writing thread safe code.
533    
534     (in-package "KERNEL")
535    
536     (export '(atomic-push-symbol-value atomic-pop-symbol-value
537     atomic-pusha atomic-pushd atomic-push-vector))
538    
539     (defun %instance-set-conditional (object slot test-value new-value)
540     (declare (type instance object)
541     (type index slot))
542 rtoy 1.6 "Atomically compare object's slot value to test-value and if EQ store
543 cwang 1.1 new-value in the slot. The original value of the slot is returned."
544     (%instance-set-conditional object slot test-value new-value))
545    
546     (defun set-symbol-value-conditional (symbol test-value new-value)
547     (declare (type symbol symbol))
548 rtoy 1.6 "Atomically compare symbol's value to test-value and if EQ store
549 cwang 1.1 new-value in symbol's value slot and return the original value."
550     (set-symbol-value-conditional symbol test-value new-value))
551    
552     (defun rplaca-conditional (cons test-value new-value)
553     (declare (type cons cons))
554 rtoy 1.6 "Atomically compare the car of CONS to test-value and if EQ store
555 cwang 1.1 new-value its car and return the original value."
556     (rplaca-conditional cons test-value new-value))
557    
558     (defun rplacd-conditional (cons test-value new-value)
559     (declare (type cons cons))
560 rtoy 1.6 "Atomically compare the cdr of CONS to test-value and if EQ store
561 cwang 1.1 new-value its cdr and return the original value."
562     (rplacd-conditional cons test-value new-value))
563    
564     (defun data-vector-set-conditional (vector index test-value new-value)
565     (declare (type simple-vector vector))
566 rtoy 1.6 "Atomically compare an element of vector to test-value and if EQ store
567 cwang 1.1 new-value the element and return the original value."
568     (data-vector-set-conditional vector index test-value new-value))
569    
570     (defmacro atomic-push-symbol-value (val symbol)
571 rtoy 1.6 "Thread safe push of val onto the list in the symbol global value."
572 cwang 1.1 (ext:once-only ((n-val val))
573     (let ((new-list (gensym))
574     (old-list (gensym)))
575     `(let ((,new-list (cons ,n-val nil)))
576     (loop
577     (let ((,old-list ,symbol))
578     (setf (cdr ,new-list) ,old-list)
579     (when (eq (set-symbol-value-conditional
580     ',symbol ,old-list ,new-list)
581     ,old-list)
582     (return ,new-list))))))))
583    
584     (defmacro atomic-pop-symbol-value (symbol)
585 rtoy 1.6 "Thread safe pop from the list in the symbol global value."
586 cwang 1.1 (let ((new-list (gensym))
587     (old-list (gensym)))
588     `(loop
589     (let* ((,old-list ,symbol)
590     (,new-list (cdr ,old-list)))
591     (when (eq (set-symbol-value-conditional
592     ',symbol ,old-list ,new-list)
593     ,old-list)
594     (return (car ,old-list)))))))
595    
596     (defmacro atomic-pusha (val cons)
597 rtoy 1.6 "Thread safe push of val onto the list in the car of cons."
598 cwang 1.1 (once-only ((n-val val)
599     (n-cons cons))
600     (let ((new-list (gensym))
601     (old-list (gensym)))
602     `(let ((,new-list (cons ,n-val nil)))
603     (loop
604     (let ((,old-list (car ,n-cons)))
605     (setf (cdr ,new-list) ,old-list)
606     (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
607     ,old-list)
608     (return ,new-list))))))))
609    
610     (defmacro atomic-pushd (val cons)
611 rtoy 1.6 "Thread safe push of val onto the list in the cdr of cons."
612 cwang 1.1 (once-only ((n-val val)
613     (n-cons cons))
614     (let ((new-list (gensym))
615     (old-list (gensym)))
616     `(let ((,new-list (cons ,n-val nil)))
617     (loop
618     (let ((,old-list (cdr ,n-cons)))
619     (setf (cdr ,new-list) ,old-list)
620     (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
621     ,old-list)
622     (return ,new-list))))))))
623    
624     (defmacro atomic-push-vector (val vect index)
625 rtoy 1.6 "Thread safe push of val onto the list in the vector element."
626 cwang 1.1 (once-only ((n-val val)
627     (n-vect vect)
628     (n-index index))
629     (let ((new-list (gensym))
630     (old-list (gensym)))
631     `(let ((,new-list (cons ,n-val nil)))
632     (loop
633     (let ((,old-list (svref ,n-vect ,n-index)))
634     (setf (cdr ,new-list) ,old-list)
635     (when (eq (data-vector-set-conditional
636     ,n-vect ,n-index ,old-list ,new-list)
637     ,old-list)
638     (return ,new-list))))))))
639    
640     #+linkage-table
641     (progn
642     (defun lisp::foreign-symbol-address-aux (name flavor)
643     (let ((entry-num (lisp::register-foreign-linkage name flavor)))
644     (+ #.vm:target-foreign-linkage-space-start
645     (* entry-num vm:target-foreign-linkage-entry-size))))
646    
647     (defun lisp::find-foreign-symbol (addr)
648     (declare (type (unsigned-byte 32) addr))
649     (when (>= addr vm:target-foreign-linkage-space-start)
650     (let ((entry (/ (- addr vm:target-foreign-linkage-space-start)
651     vm:target-foreign-linkage-entry-size)))
652     (when (< entry (lisp::foreign-linkage-symbols))
653     (lisp::foreign-linkage-entry entry)))))
654     )

  ViewVC Help
Powered by ViewVC 1.1.5