/[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.36 - (hide annotations)
Tue Jun 22 03:24:49 2010 UTC (3 years, 9 months ago) by rtoy
Branch: MAIN
Changes since 1.35: +13 -1 lines
Fix issue where the debugger (and TRACE) would get the wrong
floating-point values for arguments because the x87 registers were
used instead of the sse2 registers in the sigcontext.

code/x86-vm.lisp:
o For SSE2 on Mac OS X, call os_sigcontext_fpu_reg_sse2 to get the
  SSE2 register values from the sigcontext.

lisp/Darwin-os.c:
o Add os_sigcontext_fpu_reg_sse2 to get the SSE2 floating point
  values.

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

  ViewVC Help
Powered by ViewVC 1.1.5