/[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.29.8.2 - (show annotations)
Tue Sep 30 14:40:08 2008 UTC (5 years, 6 months ago) by rtoy
Branch: sse2-branch
CVS Tags: sse2-packed-base, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-10
Branch point for: sse2-packed-branch
Changes since 1.29.8.1: +12 -1 lines
First cut at getting sigfpe working with sse2.  Previously, the
enabled traps were cleared, but now they retain their original
values.  However, after handling the sigfpe, the current-exceptions
includes the just handled exception.  This causes the exception to be
thrown again at the next FP instruction.

More work needed.

lisp/Linux-os.c:
o Add os_set_sigcontext_fpu_modes function to set the FPU modes in the
  sigcontext.
o Update restore_fpu to restore the SSE2 status like we already do for
  the FPU status.

code/x86-vm.lisp:
o Add interfact to os_set_sigcontext_fpu_modes.

code/float-trap.lisp:
o For now, add special version of SIGFPE-HANDLER for SSE2.  We attempt
  to clear the signaled exception from the modes and set the
  sigcontext with the new modes.  (The sigcontext appears to be set,
  but the curent-exceptions doesn't appear to be correctly cleared.)
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.29.8.2 2008/09/30 14:40:08 rtoy 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 #+sse2
33 (sys:register-lisp-runtime-feature :sse2)
34
35 #+(or x87 (not :sse2))
36 (sys:register-lisp-feature :x87)
37
38
39 ;;;; The sigcontext structure.
40
41 (def-alien-type sigcontext system-area-pointer)
42
43 ;;;; Add machine specific features to *features*
44
45 (pushnew :x86 *features*)
46
47
48 ;;;; MACHINE-TYPE and MACHINE-VERSION
49
50 #-cross-compiler
51 (defun machine-type ()
52 "Returns a string describing the type of the local machine."
53 "X86")
54
55
56 #-cross-compiler
57 (defun machine-version ()
58 "Returns a string describing the version of the local machine."
59 "X86")
60
61
62
63 ;;; Fixup-Code-Object -- Interface
64 ;;;
65 ;;; This gets called by LOAD to resolve newly positioned objects
66 ;;; with things (like code instructions) that have to refer to them.
67 ;;;
68 ;;; Add a fixup offset to the vector of fixup offsets for the given
69 ;;; code object.
70 ;;;
71 ;;; Counter to measure the storage overhead.
72 (defvar *num-fixups* 0)
73 ;;; XXX
74 (defun fixup-code-object (code offset fixup kind)
75 (declare (type index offset))
76 (flet ((add-fixup (code offset)
77 ;; Although this could check for and ignore fixups for code
78 ;; objects in the read-only and static spaces, this should
79 ;; only be the case when *enable-dynamic-space-code* is
80 ;; True.
81 (when lisp::*enable-dynamic-space-code*
82 (incf *num-fixups*)
83 (let ((fixups (code-header-ref code code-constants-offset)))
84 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
85 (let ((new-fixups
86 (adjust-array fixups (1+ (length fixups))
87 :element-type '(unsigned-byte 32))))
88 (setf (aref new-fixups (length fixups)) offset)
89 (setf (code-header-ref code code-constants-offset)
90 new-fixups)))
91 (t
92 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
93 (zerop fixups))
94 (format t "** Init. code FU = ~s~%" fixups))
95 (setf (code-header-ref code code-constants-offset)
96 (make-array 1 :element-type '(unsigned-byte 32)
97 :initial-element offset))))))))
98 (system:without-gcing
99 (let* ((sap (truly-the system-area-pointer
100 (kernel:code-instructions code)))
101 (obj-start-addr (logand (kernel:get-lisp-obj-address code)
102 #xfffffff8))
103 #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
104 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
105 (ncode-words (kernel:code-header-ref code 1))
106 (code-end-addr (+ code-start-addr (* ncode-words 4))))
107 (unless (member kind '(:absolute :relative))
108 (error "Unknown code-object-fixup kind ~s." kind))
109 (ecase kind
110 (:absolute
111 ;; Word at sap + offset contains a value to be replaced by
112 ;; adding that value to fixup.
113 (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
114 ;; Record absolute fixups that point within the code object.
115 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
116 (add-fixup code offset)))
117 (:relative
118 ;; Fixup is the actual address wanted.
119 ;;
120 ;; Record relative fixups that point outside the code
121 ;; object.
122 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
123 (add-fixup code offset))
124 ;; Replace word with value to add to that loc to get there.
125 (let* ((loc-sap (+ (sap-int sap) offset))
126 (rel-val (- fixup loc-sap 4)))
127 (declare (type (unsigned-byte 32) loc-sap)
128 (type (signed-byte 32) rel-val))
129 (setf (signed-sap-ref-32 sap offset) rel-val))))))
130 nil))
131
132 ;;; Do-Load-Time-Code-Fixups
133 ;;;
134 ;;; Add a code fixup to a code object generated by new-genesis. The
135 ;;; fixup has already been applied, it's just a matter of placing the
136 ;;; fixup in the code's fixup vector if necessary.
137 ;;;
138 #+gencgc
139 (defun do-load-time-code-fixup (code offset fixup kind)
140 (flet ((add-load-time-code-fixup (code offset)
141 (let ((fixups (code-header-ref code vm:code-constants-offset)))
142 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
143 (let ((new-fixups
144 (adjust-array fixups (1+ (length fixups))
145 :element-type '(unsigned-byte 32))))
146 (setf (aref new-fixups (length fixups)) offset)
147 (setf (code-header-ref code vm:code-constants-offset)
148 new-fixups)))
149 (t
150 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
151 (zerop fixups))
152 (%primitive print "** Init. code FU"))
153 (setf (code-header-ref code vm:code-constants-offset)
154 (make-array 1 :element-type '(unsigned-byte 32)
155 :initial-element offset)))))))
156 (let* ((sap (truly-the system-area-pointer
157 (kernel:code-instructions code)))
158 (obj-start-addr
159 (logand (kernel:get-lisp-obj-address code) #xfffffff8))
160 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
161 (ncode-words (kernel:code-header-ref code 1))
162 (code-end-addr (+ code-start-addr (* ncode-words 4))))
163 (ecase kind
164 (:absolute
165 ;; Record absolute fixups that point within the
166 ;; code object.
167 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
168 (add-load-time-code-fixup code offset)))
169 (:relative
170 ;; Record relative fixups that point outside the
171 ;; code object.
172 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
173 (add-load-time-code-fixup code offset)))))))
174
175
176 ;;;; Internal-error-arguments.
177
178 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
179 ;;;
180 ;;; Given the sigcontext, extract the internal error arguments from the
181 ;;; instruction stream.
182 ;;;
183 (defun internal-error-arguments (scp)
184 (declare (type (alien (* sigcontext)) scp))
185 (with-alien ((scp (* sigcontext) scp))
186 (let ((pc (sigcontext-program-counter scp)))
187 (declare (type system-area-pointer pc))
188 ;; using INT3 the pc is .. INT3 <here> code length bytes...
189 (let* ((length (sap-ref-8 pc 1))
190 (vector (make-array length :element-type '(unsigned-byte 8))))
191 (declare (type (unsigned-byte 8) length)
192 (type (simple-array (unsigned-byte 8) (*)) vector))
193 (copy-from-system-area pc (* vm:byte-bits 2)
194 vector (* vm:word-bits
195 vm:vector-data-offset)
196 (* length vm:byte-bits))
197 (let* ((index 0)
198 (error-number (c::read-var-integer vector index)))
199 (collect ((sc-offsets))
200 (loop
201 (when (>= index length)
202 (return))
203 (sc-offsets (c::read-var-integer vector index)))
204 (values error-number (sc-offsets))))))))
205
206
207 ;;;; Sigcontext access functions.
208
209 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
210 ;;;
211 (defun sigcontext-program-counter (scp)
212 (declare (type (alien (* sigcontext)) scp))
213 (let ((fn (extern-alien "os_sigcontext_pc"
214 (function system-area-pointer
215 (* sigcontext)))))
216 (sap-ref-sap (alien-funcall fn scp) 0)))
217
218 ;;; SIGCONTEXT-REGISTER -- Interface.
219 ;;;
220 ;;; An escape register saves the value of a register for a frame that someone
221 ;;; interrupts.
222 ;;;
223 (defun sigcontext-register (scp index)
224 (declare (type (alien (* sigcontext)) scp))
225 (let ((fn (extern-alien "os_sigcontext_reg"
226 (function system-area-pointer
227 (* sigcontext)
228 (integer 32)))))
229 (sap-ref-32 (alien-funcall fn scp index) 0)))
230
231 (defun %set-sigcontext-register (scp index new)
232 (declare (type (alien (* sigcontext)) scp))
233 (let ((fn (extern-alien "os_sigcontext_reg"
234 (function system-area-pointer
235 (* sigcontext)
236 (integer 32)))))
237 (setf (sap-ref-32 (alien-funcall fn scp index) 0) new)))
238
239 (defsetf sigcontext-register %set-sigcontext-register)
240
241
242 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
243 ;;;
244 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
245 ;;; Format is the type of float to return.
246 ;;;
247 (defun sigcontext-float-register (scp index format)
248 (declare (type (alien (* sigcontext)) scp))
249 (let ((fn (extern-alien "os_sigcontext_fpu_reg"
250 (function system-area-pointer
251 (* sigcontext)
252 (integer 32)))))
253 (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)))
254 ;;;
255 (defun %set-sigcontext-float-register (scp index format new)
256 (declare (type (alien (* sigcontext)) scp))
257 (let ((fn (extern-alien "os_sigcontext_fpu_reg"
258 (function system-area-pointer
259 (* sigcontext)
260 (integer 32)))))
261 (let* ((sap (alien-funcall fn scp index))
262 (result (setf (sap-ref-long sap 0) (coerce new 'long-float))))
263 (coerce result format))))
264 ;;;
265 (defsetf sigcontext-float-register %set-sigcontext-float-register)
266
267 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
268 ;;;
269 ;;; Given a sigcontext pointer, return the floating point modes word in the
270 ;;; same format as returned by FLOATING-POINT-MODES.
271 ;;;
272 (defun sigcontext-floating-point-modes (scp)
273 (declare (type (alien (* sigcontext)) scp))
274 (let ((fn (extern-alien "os_sigcontext_fpu_modes"
275 (function (integer 32)
276 (* sigcontext)))))
277 (alien-funcall fn scp)))
278
279 (defun %set-sigcontext-floating-point-modes (scp new-mode)
280 (declare (type (alien (* sigcontext)) scp))
281 (let ((fn (extern-alien "os_set_sigcontext_fpu_modes"
282 (function (integer 32)
283 (* sigcontext)
284 c-call:unsigned-int))))
285 (alien-funcall fn scp new-mode)
286 new-mode))
287
288 (defsetf sigcontext-floating-point-modes %set-sigcontext-floating-point-modes)
289
290
291 ;;; EXTERN-ALIEN-NAME -- interface.
292 ;;;
293 ;;; The loader uses this to convert alien names to the form they occure in
294 ;;; the symbol table (for example, prepending an underscore).
295 ;;;
296 (defun extern-alien-name (name)
297 (declare (type simple-string name))
298 name)
299
300 #+(and (or linux (and freebsd elf)) (not linkage-table))
301 (defun lisp::foreign-symbol-address-aux (name flavor)
302 (declare (ignore flavor))
303 (multiple-value-bind (value found)
304 (gethash name lisp::*foreign-symbols* 0)
305 (if found
306 value
307 (multiple-value-bind (value found)
308 (gethash
309 (concatenate 'string "PVE_stub_" name)
310 lisp::*foreign-symbols* 0)
311 (if found
312 value
313 (let ((value (system:alternate-get-global-address name)))
314 (when (zerop value)
315 (error "Unknown foreign symbol: ~S" name))
316 value))))))
317
318
319
320 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
321 ;;;
322 ;;; Do whatever is necessary to make the given code component
323 ;;; executable - nothing on the x86.
324 ;;;
325 (defun sanctify-for-execution (component)
326 (declare (ignore component))
327 nil)
328
329 ;;; FLOAT-WAIT
330 ;;;
331 ;;; This is used in error.lisp to insure floating-point exceptions
332 ;;; are properly trapped. The compiler translates this to a VOP.
333 ;;;
334 (defun float-wait()
335 (float-wait))
336
337 ;;; FLOAT CONSTANTS
338 ;;;
339 ;;; These are used by the FP move-from-{single|double} VOPs rather
340 ;;; than the i387 load constant instructions to avoid consing in some
341 ;;; cases. Note these are initialise by genesis as they are needed
342 ;;; early.
343 ;;;
344 (defvar *fp-constant-0s0*)
345 (defvar *fp-constant-1s0*)
346 (defvar *fp-constant-0d0*)
347 (defvar *fp-constant-1d0*)
348 ;;; The long-float constants.
349 (defvar *fp-constant-0l0*)
350 (defvar *fp-constant-1l0*)
351 (defvar *fp-constant-pi*)
352 (defvar *fp-constant-l2t*)
353 (defvar *fp-constant-l2e*)
354 (defvar *fp-constant-lg2*)
355 (defvar *fp-constant-ln2*)
356
357 ;;; Enable/Disable scavenging of the read-only space.
358 (defvar *scavenge-read-only-space* nil)
359
360 ;;; The current alien stack pointer; saved/restored for non-local
361 ;;; exits.
362 (defvar *alien-stack*)
363
364 ;;; Support for the MT19937 random number generator. The update
365 ;;; function is implemented as an assembly routine. This definition is
366 ;;; transformed to a call to this routine allowing its use in byte
367 ;;; compiled code.
368 ;;;
369 (defun random-mt19937 (state)
370 (declare (type (simple-array (unsigned-byte 32) (627)) state))
371 (random-mt19937 state))
372
373
374 ;;;; Useful definitions for writing thread safe code.
375
376 (in-package "KERNEL")
377
378 (export '(atomic-push-symbol-value atomic-pop-symbol-value
379 atomic-pusha atomic-pushd atomic-push-vector))
380
381 (defun %instance-set-conditional (object slot test-value new-value)
382 (declare (type instance object)
383 (type index slot))
384 "Atomically compare object's slot value to test-value and if EQ store
385 new-value in the slot. The original value of the slot is returned."
386 (%instance-set-conditional object slot test-value new-value))
387
388 (defun set-symbol-value-conditional (symbol test-value new-value)
389 (declare (type symbol symbol))
390 "Atomically compare symbol's value to test-value and if EQ store
391 new-value in symbol's value slot and return the original value."
392 (set-symbol-value-conditional symbol test-value new-value))
393
394 (defun rplaca-conditional (cons test-value new-value)
395 (declare (type cons cons))
396 "Atomically compare the car of CONS to test-value and if EQ store
397 new-value its car and return the original value."
398 (rplaca-conditional cons test-value new-value))
399
400 (defun rplacd-conditional (cons test-value new-value)
401 (declare (type cons cons))
402 "Atomically compare the cdr of CONS to test-value and if EQ store
403 new-value its cdr and return the original value."
404 (rplacd-conditional cons test-value new-value))
405
406 (defun data-vector-set-conditional (vector index test-value new-value)
407 (declare (type simple-vector vector))
408 "Atomically compare an element of vector to test-value and if EQ store
409 new-value the element and return the original value."
410 (data-vector-set-conditional vector index test-value new-value))
411
412 (defmacro atomic-push-symbol-value (val symbol)
413 "Thread safe push of val onto the list in the symbol global value."
414 (ext:once-only ((n-val val))
415 (let ((new-list (gensym))
416 (old-list (gensym)))
417 `(let ((,new-list (cons ,n-val nil)))
418 (loop
419 (let ((,old-list ,symbol))
420 (setf (cdr ,new-list) ,old-list)
421 (when (eq (set-symbol-value-conditional
422 ',symbol ,old-list ,new-list)
423 ,old-list)
424 (return ,new-list))))))))
425
426 (defmacro atomic-pop-symbol-value (symbol)
427 "Thread safe pop from the list in the symbol global value."
428 (let ((new-list (gensym))
429 (old-list (gensym)))
430 `(loop
431 (let* ((,old-list ,symbol)
432 (,new-list (cdr ,old-list)))
433 (when (eq (set-symbol-value-conditional
434 ',symbol ,old-list ,new-list)
435 ,old-list)
436 (return (car ,old-list)))))))
437
438 (defmacro atomic-pusha (val cons)
439 "Thread safe push of val onto the list in the car of cons."
440 (once-only ((n-val val)
441 (n-cons cons))
442 (let ((new-list (gensym))
443 (old-list (gensym)))
444 `(let ((,new-list (cons ,n-val nil)))
445 (loop
446 (let ((,old-list (car ,n-cons)))
447 (setf (cdr ,new-list) ,old-list)
448 (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
449 ,old-list)
450 (return ,new-list))))))))
451
452 (defmacro atomic-pushd (val cons)
453 "Thread safe push of val onto the list in the cdr of cons."
454 (once-only ((n-val val)
455 (n-cons cons))
456 (let ((new-list (gensym))
457 (old-list (gensym)))
458 `(let ((,new-list (cons ,n-val nil)))
459 (loop
460 (let ((,old-list (cdr ,n-cons)))
461 (setf (cdr ,new-list) ,old-list)
462 (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
463 ,old-list)
464 (return ,new-list))))))))
465
466 (defmacro atomic-push-vector (val vect index)
467 "Thread safe push of val onto the list in the vector element."
468 (once-only ((n-val val)
469 (n-vect vect)
470 (n-index index))
471 (let ((new-list (gensym))
472 (old-list (gensym)))
473 `(let ((,new-list (cons ,n-val nil)))
474 (loop
475 (let ((,old-list (svref ,n-vect ,n-index)))
476 (setf (cdr ,new-list) ,old-list)
477 (when (eq (data-vector-set-conditional
478 ,n-vect ,n-index ,old-list ,new-list)
479 ,old-list)
480 (return ,new-list))))))))
481
482 #+linkage-table
483 (progn
484 (defun lisp::foreign-symbol-address-aux (name flavor)
485 (let ((entry-num (lisp::register-foreign-linkage name flavor)))
486 (+ #.vm:target-foreign-linkage-space-start
487 (* entry-num vm:target-foreign-linkage-entry-size))))
488
489 (defun lisp::find-foreign-symbol (addr)
490 (declare (type (unsigned-byte 32) addr))
491 (when (>= addr vm:target-foreign-linkage-space-start)
492 (let ((entry (/ (- addr vm:target-foreign-linkage-space-start)
493 vm:target-foreign-linkage-entry-size)))
494 (when (< entry (lisp::foreign-linkage-symbols))
495 (lisp::foreign-linkage-entry entry)))))
496 )

  ViewVC Help
Powered by ViewVC 1.1.5