/[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.39 - (hide annotations)
Mon Aug 30 20:01:15 2010 UTC (3 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, cross-sol-x86-branch
Changes since 1.38: +4 -1 lines
Just add comment that we don't distinguish between SIGFPE between x87
and sse.
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.39 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.39 2010/08/30 20:01:15 rtoy Rel $")
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 rtoy 1.38 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float
251     ;;; register. Format is the type of float to return. For SSE2, also
252     ;;; support complex numbers. The format in this case is
253     ;;; complex-single-float and complex-double-float.
254 dtc 1.13 ;;;
255 ram 1.1 (defun sigcontext-float-register (scp index format)
256     (declare (type (alien (* sigcontext)) scp))
257 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_reg"
258     (function system-area-pointer
259     (* sigcontext)
260     (integer 32)))))
261 rtoy 1.38 #+x87
262     (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)
263     #+sse2
264     (if (< index 8)
265     (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)
266     (ecase format
267     (single-float
268     (sap-ref-single (alien-funcall fn scp index) 0))
269     (double-float
270     (sap-ref-double (alien-funcall fn scp index) 0))
271     (complex-single-float
272     ;; Need to extract the parts out out of the XMM register
273     (let ((addr (alien-funcall fn scp index)))
274     (complex (sap-ref-single addr 0)
275     (sap-ref-single addr 4))))
276     (complex-double-float
277     (let ((addr (alien-funcall fn scp index)))
278     (complex (sap-ref-double addr 0)
279     (sap-ref-double addr 8))))))))
280 rtoy 1.36
281 cshapiro 1.29 ;;;
282     (defun %set-sigcontext-float-register (scp index format new)
283 ram 1.1 (declare (type (alien (* sigcontext)) scp))
284 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_reg"
285     (function system-area-pointer
286     (* sigcontext)
287     (integer 32)))))
288 rtoy 1.38 (let* ((sap (alien-funcall fn scp index)))
289     (if (< index 8)
290     (let ((result (setf (sap-ref-long sap 0) (coerce new 'long-float))))
291     (coerce result format))
292     (ecase format
293     (single-float
294     (setf (sap-ref-single sap 0) new))
295     (double-float
296     (setf (sap-ref-double sap 0) new))
297     (complex-single-float
298     (setf (sap-ref-single sap 0) (realpart new))
299     (setf (sap-ref-single sap 4) (imagpart new)))
300     (complex-double-float
301     (setf (sap-ref-double sap 0) (realpart new))
302     (setf (sap-ref-double sap 8) (imagpart new))))))))
303    
304 ram 1.1 ;;;
305     (defsetf sigcontext-float-register %set-sigcontext-float-register)
306    
307     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
308     ;;;
309     ;;; Given a sigcontext pointer, return the floating point modes word in the
310     ;;; same format as returned by FLOATING-POINT-MODES.
311     ;;;
312     (defun sigcontext-floating-point-modes (scp)
313     (declare (type (alien (* sigcontext)) scp))
314 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_modes"
315     (function (integer 32)
316     (* sigcontext)))))
317     (alien-funcall fn scp)))
318 ram 1.1
319 rtoy 1.30 (defun %set-sigcontext-floating-point-modes (scp new-mode)
320     (declare (type (alien (* sigcontext)) scp))
321     (let ((fn (extern-alien "os_set_sigcontext_fpu_modes"
322     (function (integer 32)
323     (* sigcontext)
324     c-call:unsigned-int))))
325     (alien-funcall fn scp new-mode)
326     new-mode))
327    
328     (defsetf sigcontext-floating-point-modes %set-sigcontext-floating-point-modes)
329    
330 ram 1.1
331     ;;; EXTERN-ALIEN-NAME -- interface.
332     ;;;
333     ;;; The loader uses this to convert alien names to the form they occure in
334     ;;; the symbol table (for example, prepending an underscore).
335     ;;;
336     (defun extern-alien-name (name)
337     (declare (type simple-string name))
338 cshapiro 1.25 name)
339 ram 1.1
340 moore 1.21 #+(and (or linux (and freebsd elf)) (not linkage-table))
341     (defun lisp::foreign-symbol-address-aux (name flavor)
342     (declare (ignore flavor))
343 dtc 1.8 (multiple-value-bind (value found)
344     (gethash name lisp::*foreign-symbols* 0)
345     (if found
346     value
347     (multiple-value-bind (value found)
348     (gethash
349 pmai 1.20 (concatenate 'string "PVE_stub_" name)
350 dtc 1.8 lisp::*foreign-symbols* 0)
351     (if found
352     value
353     (let ((value (system:alternate-get-global-address name)))
354     (when (zerop value)
355 rtoy 1.35 (error (intl:gettext "Unknown foreign symbol: ~S") name))
356 dtc 1.8 value))))))
357 ram 1.1
358 moore 1.21
359 ram 1.1
360     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
361     ;;;
362 dtc 1.14 ;;; Do whatever is necessary to make the given code component
363     ;;; executable - nothing on the x86.
364 ram 1.1 ;;;
365     (defun sanctify-for-execution (component)
366     (declare (ignore component))
367     nil)
368    
369     ;;; FLOAT-WAIT
370     ;;;
371     ;;; This is used in error.lisp to insure floating-point exceptions
372     ;;; are properly trapped. The compiler translates this to a VOP.
373 dtc 1.14 ;;;
374 ram 1.1 (defun float-wait()
375     (float-wait))
376    
377     ;;; FLOAT CONSTANTS
378     ;;;
379 dtc 1.14 ;;; These are used by the FP move-from-{single|double} VOPs rather
380     ;;; than the i387 load constant instructions to avoid consing in some
381     ;;; cases. Note these are initialise by genesis as they are needed
382     ;;; early.
383     ;;;
384     (defvar *fp-constant-0s0*)
385     (defvar *fp-constant-1s0*)
386     (defvar *fp-constant-0d0*)
387     (defvar *fp-constant-1d0*)
388     ;;; The long-float constants.
389     (defvar *fp-constant-0l0*)
390     (defvar *fp-constant-1l0*)
391     (defvar *fp-constant-pi*)
392     (defvar *fp-constant-l2t*)
393     (defvar *fp-constant-l2e*)
394     (defvar *fp-constant-lg2*)
395     (defvar *fp-constant-ln2*)
396 dtc 1.3
397 dtc 1.7 ;;; Enable/Disable scavenging of the read-only space.
398 dtc 1.12 (defvar *scavenge-read-only-space* nil)
399 dtc 1.7
400 dtc 1.3 ;;; The current alien stack pointer; saved/restored for non-local
401     ;;; exits.
402     (defvar *alien-stack*)
403 dtc 1.4
404 dtc 1.12 ;;; Support for the MT19937 random number generator. The update
405     ;;; function is implemented as an assembly routine. This definition is
406     ;;; transformed to a call to this routine allowing its use in byte
407     ;;; compiled code.
408     ;;;
409     (defun random-mt19937 (state)
410     (declare (type (simple-array (unsigned-byte 32) (627)) state))
411     (random-mt19937 state))
412 dtc 1.15
413    
414     ;;;; Useful definitions for writing thread safe code.
415    
416     (in-package "KERNEL")
417    
418     (export '(atomic-push-symbol-value atomic-pop-symbol-value
419     atomic-pusha atomic-pushd atomic-push-vector))
420    
421     (defun %instance-set-conditional (object slot test-value new-value)
422     (declare (type instance object)
423     (type index slot))
424 rtoy 1.34 "Atomically compare object's slot value to test-value and if EQ store
425 dtc 1.15 new-value in the slot. The original value of the slot is returned."
426     (%instance-set-conditional object slot test-value new-value))
427    
428     (defun set-symbol-value-conditional (symbol test-value new-value)
429     (declare (type symbol symbol))
430 rtoy 1.34 "Atomically compare symbol's value to test-value and if EQ store
431 dtc 1.15 new-value in symbol's value slot and return the original value."
432     (set-symbol-value-conditional symbol test-value new-value))
433    
434     (defun rplaca-conditional (cons test-value new-value)
435     (declare (type cons cons))
436 rtoy 1.34 "Atomically compare the car of CONS to test-value and if EQ store
437 dtc 1.15 new-value its car and return the original value."
438     (rplaca-conditional cons test-value new-value))
439    
440     (defun rplacd-conditional (cons test-value new-value)
441     (declare (type cons cons))
442 rtoy 1.34 "Atomically compare the cdr of CONS to test-value and if EQ store
443 dtc 1.15 new-value its cdr and return the original value."
444     (rplacd-conditional cons test-value new-value))
445    
446     (defun data-vector-set-conditional (vector index test-value new-value)
447     (declare (type simple-vector vector))
448 rtoy 1.34 "Atomically compare an element of vector to test-value and if EQ store
449 dtc 1.15 new-value the element and return the original value."
450     (data-vector-set-conditional vector index test-value new-value))
451    
452     (defmacro atomic-push-symbol-value (val symbol)
453 rtoy 1.34 "Thread safe push of val onto the list in the symbol global value."
454 dtc 1.15 (ext:once-only ((n-val val))
455     (let ((new-list (gensym))
456     (old-list (gensym)))
457     `(let ((,new-list (cons ,n-val nil)))
458     (loop
459     (let ((,old-list ,symbol))
460     (setf (cdr ,new-list) ,old-list)
461     (when (eq (set-symbol-value-conditional
462     ',symbol ,old-list ,new-list)
463     ,old-list)
464     (return ,new-list))))))))
465    
466     (defmacro atomic-pop-symbol-value (symbol)
467 rtoy 1.34 "Thread safe pop from the list in the symbol global value."
468 dtc 1.15 (let ((new-list (gensym))
469     (old-list (gensym)))
470     `(loop
471     (let* ((,old-list ,symbol)
472     (,new-list (cdr ,old-list)))
473     (when (eq (set-symbol-value-conditional
474     ',symbol ,old-list ,new-list)
475     ,old-list)
476     (return (car ,old-list)))))))
477    
478     (defmacro atomic-pusha (val cons)
479 rtoy 1.34 "Thread safe push of val onto the list in the car of cons."
480 dtc 1.15 (once-only ((n-val val)
481     (n-cons cons))
482     (let ((new-list (gensym))
483     (old-list (gensym)))
484     `(let ((,new-list (cons ,n-val nil)))
485     (loop
486     (let ((,old-list (car ,n-cons)))
487     (setf (cdr ,new-list) ,old-list)
488     (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
489     ,old-list)
490     (return ,new-list))))))))
491    
492     (defmacro atomic-pushd (val cons)
493 rtoy 1.34 "Thread safe push of val onto the list in the cdr of cons."
494 dtc 1.15 (once-only ((n-val val)
495     (n-cons cons))
496     (let ((new-list (gensym))
497     (old-list (gensym)))
498     `(let ((,new-list (cons ,n-val nil)))
499     (loop
500     (let ((,old-list (cdr ,n-cons)))
501     (setf (cdr ,new-list) ,old-list)
502     (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
503     ,old-list)
504     (return ,new-list))))))))
505    
506     (defmacro atomic-push-vector (val vect index)
507 rtoy 1.34 "Thread safe push of val onto the list in the vector element."
508 dtc 1.15 (once-only ((n-val val)
509     (n-vect vect)
510     (n-index index))
511     (let ((new-list (gensym))
512     (old-list (gensym)))
513     `(let ((,new-list (cons ,n-val nil)))
514     (loop
515     (let ((,old-list (svref ,n-vect ,n-index)))
516     (setf (cdr ,new-list) ,old-list)
517     (when (eq (data-vector-set-conditional
518     ,n-vect ,n-index ,old-list ,new-list)
519     ,old-list)
520     (return ,new-list))))))))
521 moore 1.21
522     #+linkage-table
523     (progn
524     (defun lisp::foreign-symbol-address-aux (name flavor)
525     (let ((entry-num (lisp::register-foreign-linkage name flavor)))
526     (+ #.vm:target-foreign-linkage-space-start
527     (* entry-num vm:target-foreign-linkage-entry-size))))
528    
529     (defun lisp::find-foreign-symbol (addr)
530     (declare (type (unsigned-byte 32) addr))
531     (when (>= addr vm:target-foreign-linkage-space-start)
532     (let ((entry (/ (- addr vm:target-foreign-linkage-space-start)
533     vm:target-foreign-linkage-entry-size)))
534     (when (< entry (lisp::foreign-linkage-symbols))
535     (lisp::foreign-linkage-entry entry)))))
536     )
537 rtoy 1.38
538     (in-package "X86")
539    
540     (defun get-fp-operation (scp)
541     (declare (type (alien (* sigcontext)) scp))
542     ;; Get the offending FP instruction from the context. We return the
543     ;; operation associated with the FP instruction, the precision of
544     ;; the operation, and the operands of the instruction.
545    
546     ;; For SSE2, the PC should be at the offending SSE2 instruction
547     (let ((pc (sigcontext-program-counter scp)))
548     #+(or)
549     (progn
550     (format *debug-io* "~&PC = ~S~%" pc)
551     (format *debug-io* " ~2,'0X~%" (sys:sap-ref-8 pc 0))
552     (format *debug-io* " ~2,'0X~%" (sys:sap-ref-8 pc 1))
553     (format *debug-io* " ~2,'0X~%" (sys:sap-ref-8 pc 2))
554     (format *debug-io* " ~2,'0X~%" (sys:sap-ref-8 pc 3))
555     (format *debug-io* " ~2,'0X~%" (sys:sap-ref-8 pc 4))
556     (finish-output *debug-io*))
557    
558     (labels
559     ((fop (x)
560     ;; Look at the byte and see what kind of operation is
561     ;; encoded.
562     (cdr (assoc x '((#x58 . +) (#x59 . *) (#x5c . -) (#x5e . /)))))
563     (decode-mod-r/m (byte)
564     ;; Return the mod bits, the r/m bits, and the value, in
565     ;; that order. See, for example, Table 2-1 in the Intel 64
566     ;; and IA-32 Architectures Software Developer's Manual,
567     ;; Volume 2A.
568     (values (ldb (byte 2 6) byte)
569     (ldb (byte 3 0) byte)
570     (ldb (byte 3 3) byte)))
571     (decode-operands (offset format)
572     (multiple-value-bind (mod r/m v)
573     (decode-mod-r/m (sys:sap-ref-8 pc offset))
574     #+(or)
575     (format *debug-io* "~&mod = #b~2,'0b~%r/m = #b~3,'0b~%v = #b~3,'0b~%" mod r/m v)
576     ;; I'm lazy right now and don't want to try to fetch the
577     ;; operand from memory if the source is in memory. Just
578     ;; return NIL for that.
579     (values (sigcontext-float-register scp (+ 8 v) format)
580     (when (= mod #b11)
581     (sigcontext-float-register scp (+ 8 r/m) format))))))
582     ;; Look at the instruction and see if it's one of the arithmetic
583     ;; SSE2 instructions. If so, figure out the operation and try
584     ;; to get the operands. Currently, if an operand is in memory,
585     ;; we don't try to fetch it.
586     ;;
587     ;; Also, for the packed operations that hold complex numbers,
588     ;; it's not exactly clear what to do. The main issue is that
589     ;; when multiplying or dividing complex numbers, there is no
590     ;; single instruction. The operation is decomposed into several
591     ;; operations and the contents of the packed register may not
592     ;; have any simple relationship to the Lisp complex number. For
593     ;; now, instead of returning the complex number, we return a
594     ;; list of the components. Perhaps this is better than nothing,
595     ;; but might be confusing.
596     (cond ((and (= (sys:sap-ref-8 pc 0) #xf2)
597     (= (sys:sap-ref-8 pc 1) #x0f)
598     (fop (sys:sap-ref-8 pc 2)))
599     ;; ADDSD: F2 0F 58
600     ;; MULSD: F2 0F 59
601     ;; SUBSD: F2 0F 5C
602     ;; DIVSD: F2 0F 5E
603     ;; SQRTSD: F2 0F 51
604     (multiple-value-bind (dst src)
605     (decode-operands 3 'double-float)
606     (values (fop (sys:sap-ref-8 pc 2)) dst src)))
607     ((and (= (sys:sap-ref-8 pc 0) #xf3)
608     (= (sys:sap-ref-8 pc 1) #x0f)
609     (fop (sys:sap-ref-8 pc 2)))
610     ;; ADDSS: F3 0F 58
611     ;; MULSS: F3 0F 59
612     ;; SUBSS: F3 0F 5C
613     ;; DIVSS: F3 0F 5E
614     ;; SQRTSS: F3 0F 51
615     (multiple-value-bind (dst src)
616     (decode-operands 3 'single-float)
617     (values (fop (sys:sap-ref-8 pc 2)) dst src)))
618     ((and (= (sys:sap-ref-8 pc 0) #x66)
619     (= (sys:sap-ref-8 pc 1) #x0f)
620     (fop (sys:sap-ref-8 pc 2)))
621     ;; ADDPD: 66 0F 58
622     ;; MULPD: 66 0F 59
623     ;; SUBPD: 66 0F 5C
624     ;; DIVPD: 66 0F 5E
625     (multiple-value-bind (dst src)
626     (decode-operands 3 'complex-double-float)
627     (values (fop (sys:sap-ref-8 pc 2))
628     (list (realpart dst)
629     (imagpart dst))
630     (when src
631     (list (realpart src)
632     (imagpart src))))))
633     ((and (= (sys:sap-ref-8 pc 0) #x0f)
634     (fop (sys:sap-ref-8 pc 1)))
635     ;; ADDPS: 0F 58
636     ;; MULPS: 0F 59
637     ;; SUBPS: 0F 5C
638     ;; DIVPS: 0F 5E
639     (multiple-value-bind (dst src)
640     (decode-operands 2 'complex-single-float)
641     (values (fop (sys:sap-ref-8 pc 1))
642     (list (realpart dst)
643     (imagpart dst))
644     (when src
645     (list (realpart src)
646     (imagpart src))))))
647     (t
648     (values nil nil nil nil))))))
649    
650     (defun get-fp-operands (scp modes)
651     (declare (type (alien (* sigcontext)) scp)
652     (ignore modes))
653     ;; From the offending FP instruction, get the operation and
654     ;; operands, if we can.
655 rtoy 1.39 ;;
656     ;; FIXME: How do we distinguish between an exception caused by SSE2
657     ;; and one caused by x87?
658 rtoy 1.38 (multiple-value-bind (fop dst src)
659     (get-fp-operation scp)
660     (values fop (list dst src))))

  ViewVC Help
Powered by ViewVC 1.1.5