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

  ViewVC Help
Powered by ViewVC 1.1.5