/[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 - (show annotations)
Sun Jul 22 05:39:39 2007 UTC (6 years, 8 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 ;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.26 2007/07/22 05:39:39 cshapiro Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file contains the X86 specific runtime stuff.
15 ;;;
16 ;;; Code movement fixups by Douglas T. Crosher, 1997.
17 ;;; Thread support by Douglas T. Crosher, 1999.
18 ;;;
19
20 (in-package "X86")
21 (use-package "SYSTEM")
22 (use-package "ALIEN")
23 (use-package "C-CALL")
24 (use-package "UNIX")
25 (use-package "KERNEL")
26
27 (export '(fixup-code-object internal-error-arguments
28 sigcontext-program-counter sigcontext-register
29 sigcontext-float-register sigcontext-floating-point-modes
30 extern-alien-name sanctify-for-execution))
31
32
33 ;;;; The sigcontext structure.
34 ;;;; Add machine specific features to *features*
35
36 (pushnew :x86 *features*)
37
38
39
40 #+linux
41 (def-alien-type nil
42 (struct fpreg
43 (significand (array unsigned-short 4))
44 (exponent unsigned-short)))
45 #+linux
46 (def-alien-type nil
47 (struct fpstate
48 (cw unsigned-long)
49 (sw unsigned-long)
50 (tag unsigned-long)
51 (ipoff unsigned-long)
52 (cssel unsigned-long)
53 (dataoff unsigned-long)
54 (datasel unsigned-long)
55 (fpreg (array (struct fpreg) 8))
56 (status unsigned-long)))
57
58 #+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 ;;; for FreeBSD
86 #+freebsd
87 (def-alien-type sigcontext
88 (struct nil
89 (sc-onstack unsigned-int)
90 (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
110 ;;; OpenBSD also have sigcontext structs that look more like Linux.
111 #+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 ))
135
136 ;; NetBSD
137
138 #+netbsd1.6
139 (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 ))
165
166 #+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 (def-alien-type sigcontext
198 (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 ;; 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 ;;; Fixup-Code-Object -- Interface
258 ;;;
259 ;;; This gets called by LOAD to resolve newly positioned objects
260 ;;; with things (like code instructions) that have to refer to them.
261 ;;;
262 ;;; 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 ;;; XXX
268 (defun fixup-code-object (code offset fixup kind)
269 (declare (type index offset))
270 (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
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 #-netbsd
378 (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 #+netbsd
402 (defun internal-error-arguments (ucp)
403 (declare (type (alien (* sigcontext)) ucp))
404 (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
425 ;;;; Sigcontext access functions.
426
427 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
428 ;;;
429 #-netbsd
430 (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 #+netbsd
436 (defun sigcontext-program-counter (ucp)
437 (declare (type (alien (* sigcontext)) ucp))
438 (with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
439 (int-sap (slot mcp 'sc-eip))))
440
441 ;;; SIGCONTEXT-REGISTER -- Interface.
442 ;;;
443 ;;; An escape register saves the value of a register for a frame that someone
444 ;;; interrupts.
445 ;;;
446
447 #-netbsd
448 (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 (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
458 (#.esi-offset (slot scp 'sc-esi))
459 (#.edi-offset (slot scp 'sc-edi)))))
460
461 #-netbsd
462 (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 (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
472 (#.esi-offset (setf (slot scp 'sc-esi) new))
473 (#.edi-offset (setf (slot scp 'sc-edi) new))))
474 new)
475
476 #+netbsd
477 (defun sigcontext-register (ucp index)
478 (declare (type (alien (* sigcontext)) ucp))
479 (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 (declare (type (alien (* sigcontext)) ucp))
493 (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 (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 ;;;
513 #+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 'fpreg)
519 index))))
520 (coerce (sys:sap-ref-long reg-sap 0) format))))
521
522 ;;; 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 (defun sigcontext-float-register (scp index format)
526 (declare (ignore scp index))
527 (coerce 0l0 format))
528
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 (declare (ignorable reg-sap))
537 #+not-yet
538 (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
539 (coerce new-value format))))
540
541 ;;; Not supported on Free/OpenBSD.
542 #+BSD
543 (defun %set-sigcontext-float-register (scp index format new-value)
544 (declare (ignore scp index))
545 (coerce new-value format))
546
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 #+bsd
557 (defun sigcontext-floating-point-modes (scp)
558 (declare (type (alien (* sigcontext)) scp)
559 (ignore scp))
560 ;; This is broken until some future release of FreeBSD/OpenBSD!!!
561 (floating-point-modes))
562
563 #+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 name)
584
585 #+(and (or linux (and freebsd elf)) (not linkage-table))
586 (defun lisp::foreign-symbol-address-aux (name flavor)
587 (declare (ignore flavor))
588 (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 (concatenate 'string "PVE_stub_" name)
595 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
603
604
605 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
606 ;;;
607 ;;; Do whatever is necessary to make the given code component
608 ;;; executable - nothing on the x86.
609 ;;;
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 ;;;
619 (defun float-wait()
620 (float-wait))
621
622 ;;; FLOAT CONSTANTS
623 ;;;
624 ;;; 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
642 ;;; Enable/Disable scavenging of the read-only space.
643 (defvar *scavenge-read-only-space* nil)
644
645 ;;; The current alien stack pointer; saved/restored for non-local
646 ;;; exits.
647 (defvar *alien-stack*)
648
649 ;;; 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
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
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