/[cmucl]/src/code/x86-vm.lisp
ViewVC logotype

Diff of /src/code/x86-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.29.8.2 by rtoy, Tue Sep 30 14:40:08 2008 UTC revision 1.39 by rtoy, Mon Aug 30 20:01:15 2010 UTC
# Line 24  Line 24 
24  (use-package "UNIX")  (use-package "UNIX")
25  (use-package "KERNEL")  (use-package "KERNEL")
26    
27    (intl:textdomain "cmucl-x86-vm")
28    
29  (export '(fixup-code-object internal-error-arguments  (export '(fixup-code-object internal-error-arguments
30            sigcontext-program-counter sigcontext-register            sigcontext-program-counter sigcontext-register
31            sigcontext-float-register sigcontext-floating-point-modes            sigcontext-float-register sigcontext-floating-point-modes
32            extern-alien-name sanctify-for-execution))            extern-alien-name sanctify-for-execution))
33    
34  #+sse2  #+complex-fp-vops
35  (sys:register-lisp-runtime-feature :sse2)  (sys:register-lisp-feature :complex-fp-vops)
36    
37  #+(or x87 (not :sse2))  #+(or x87 (not :sse2))
38  (sys:register-lisp-feature :x87)  (sys:register-lisp-feature :x87)
39    #+sse2
40    (progn
41      (setf *features* (delete :x87 *features*))
42      (sys:register-lisp-feature :sse2))
43    
44    
45  ;;;; The sigcontext structure.  ;;;; The sigcontext structure.
# Line 49  Line 55 
55    
56  #-cross-compiler  #-cross-compiler
57  (defun machine-type ()  (defun machine-type ()
58    "Returns a string describing the type of the local machine."    _N"Returns a string describing the type of the local machine."
59    "X86")    "X86")
60    
61    
62  #-cross-compiler  #-cross-compiler
63  (defun machine-version ()  (defun machine-version ()
64    "Returns a string describing the version of the local machine."    _N"Returns a string describing the version of the local machine."
65    "X86")    "X86")
66    
67    
# Line 105  Line 111 
111              (ncode-words (kernel:code-header-ref code 1))              (ncode-words (kernel:code-header-ref code 1))
112              (code-end-addr (+ code-start-addr (* ncode-words 4))))              (code-end-addr (+ code-start-addr (* ncode-words 4))))
113         (unless (member kind '(:absolute :relative))         (unless (member kind '(:absolute :relative))
114           (error "Unknown code-object-fixup kind ~s." kind))           (error (intl:gettext "Unknown code-object-fixup kind ~s.") kind))
115         (ecase kind         (ecase kind
116           (:absolute           (:absolute
117            ;; Word at sap + offset contains a value to be replaced by            ;; Word at sap + offset contains a value to be replaced by
# Line 241  Line 247 
247    
248  ;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface  ;;; SIGCONTEXT-FLOAT-REGISTER  --  Interface
249  ;;;  ;;;
250  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float
251  ;;; Format is the type of float to return.  ;;; 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  ;;;  ;;;
255  (defun sigcontext-float-register (scp index format)  (defun sigcontext-float-register (scp index format)
256    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
# Line 250  Line 258 
258                            (function system-area-pointer                            (function system-area-pointer
259                                      (* sigcontext)                                      (* sigcontext)
260                                      (integer 32)))))                                      (integer 32)))))
261      (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)))      #+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    
281  ;;;  ;;;
282  (defun %set-sigcontext-float-register (scp index format new)  (defun %set-sigcontext-float-register (scp index format new)
283    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
# Line 258  Line 285 
285                            (function system-area-pointer                            (function system-area-pointer
286                                      (* sigcontext)                                      (* sigcontext)
287                                      (integer 32)))))                                      (integer 32)))))
288      (let* ((sap (alien-funcall fn scp index))      (let* ((sap (alien-funcall fn scp index)))
289             (result (setf (sap-ref-long sap 0) (coerce new 'long-float))))        (if (< index 8)
290        (coerce result format))))            (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  ;;;  ;;;
305  (defsetf sigcontext-float-register %set-sigcontext-float-register)  (defsetf sigcontext-float-register %set-sigcontext-float-register)
306    
# Line 312  Line 352 
352                value                value
353                (let ((value (system:alternate-get-global-address name)))                (let ((value (system:alternate-get-global-address name)))
354                  (when (zerop value)                  (when (zerop value)
355                    (error "Unknown foreign symbol: ~S" name))                    (error (intl:gettext "Unknown foreign symbol: ~S") name))
356                  value))))))                  value))))))
357    
358    
# Line 494  Line 534 
534        (when (< entry (lisp::foreign-linkage-symbols))        (when (< entry (lisp::foreign-linkage-symbols))
535          (lisp::foreign-linkage-entry entry)))))          (lisp::foreign-linkage-entry entry)))))
536  )  )
537    
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      ;;
656      ;; FIXME: How do we distinguish between an exception caused by SSE2
657      ;; and one caused by x87?
658      (multiple-value-bind (fop dst src)
659          (get-fp-operation scp)
660        (values fop (list dst src))))

Legend:
Removed from v.1.29.8.2  
changed lines
  Added in v.1.39

  ViewVC Help
Powered by ViewVC 1.1.5