/[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.28 - (hide annotations)
Wed Nov 14 17:44:07 2007 UTC (6 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-12
Changes since 1.27: +8 -8 lines
Fix some mistakes accidentally introduced in the sigcontext
rearrangement.  Changes not tested, but there are no compiler warnings
anymore.

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

  ViewVC Help
Powered by ViewVC 1.1.5