/[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 - (show annotations)
Tue Apr 20 17:57:43 2010 UTC (4 years 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 ;;; -*- 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/amd64-vm.lisp,v 1.7 2010/04/20 17:57:43 rtoy Rel $")
11 ;;;
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 (intl:textdomain "cmucl")
28
29 (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 #+freebsd
61 (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 (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
172
173 ;;;; MACHINE-TYPE and MACHINE-VERSION
174
175 #-cross-compiler
176 (defun machine-type ()
177 "Returns a string describing the type of the local machine."
178 "AMD x86-64")
179
180
181 #-cross-compiler
182 (defun machine-version ()
183 "Returns a string describing the version of the local machine."
184 "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 (error (intl:gettext "Unknown code-object-fixup kind ~s.") kind))
234 (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 ;;; The loader uses this to convert alien names to the form they occur in
449 ;;; 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 (error (intl:gettext "Unknown foreign symbol: ~S") name))
474 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 ;;; This is used in error.lisp to ensure floating-point exceptions
490 ;;; 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 ;;; cases. Note these are initialised by genesis as they are needed
500 ;;; 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 ;;; Enable/disable scavenging of the read-only space.
516 (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 "Atomically compare object's slot value to test-value and if EQ store
543 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 "Atomically compare symbol's value to test-value and if EQ store
549 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 "Atomically compare the car of CONS to test-value and if EQ store
555 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 "Atomically compare the cdr of CONS to test-value and if EQ store
561 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 "Atomically compare an element of vector to test-value and if EQ store
567 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 "Thread safe push of val onto the list in the symbol global value."
572 (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 "Thread safe pop from the list in the symbol global value."
586 (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 "Thread safe push of val onto the list in the car of cons."
598 (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 "Thread safe push of val onto the list in the cdr of cons."
612 (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 "Thread safe push of val onto the list in the vector element."
626 (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