Changeset 14838

Timestamp:

Jun 22, 2011, 7:10:43 PM (13 years ago)

Author:

Gary Byers

Message:

Partial support for determining arithmetic-error operation/operands
on x86.

NOT YET TESTED ON ALL PLATFORMS; MAY NOT EVEN COMPILE WITHOUT ERROR.

Location:

trunk/source

Files:

• compiler/X86/x86-asm.lisp (modified) (1 diff)
• level-1/x86-trap-support.lisp (modified) (11 diffs)

trunk/source/compiler/X86/x86-asm.lisp

@@ -4848 +4848 @@
         (match-template-types template type0 type1 type2))))))
 
+(defun ccl::register-operand-regno (op type)
+  (when (and (typep op 'x86::x86-register-operand)
+             (eql (x86::x86-register-operand-type op)
+                  type))
+    (x86::reg-entry-reg-num
+     (x86::x86-register-operand-entry op))))
+
 
 (provide "X86-ASM")

trunk/source/level-1/x86-trap-support.lisp

@@ -31 +31 @@
   (defun xp-mxcsr (xp)
     (pref xp :ucontext.uc_mcontext.fpregs.mxcsr))
+  (defmacro xp-xmm-regs (xp)
+    `(pref ,xp :ucontext.uc_mcontext.fpregs._xmm))
   (defparameter *encoded-gpr-to-indexed-gpr*
     #(13                                ;rax
@@ -59 +61 @@
     (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate)))
       (pref state :savefpu.sv_env.en_mxcsr)))
+  (defmacro xp-xmm-regs (xp)
+    (let* ((state (gensym)))
+      `(with-macptrs ((,state (pref ,xp :__ucontext.uc_mcontext.mc_fpstate)))
+        (pref ,state :savefpu.sv_xmm))))
+      
   (defparameter *encoded-gpr-to-indexed-gpr*
     #(7                                 ;rax
@@ -85 +92 @@
   (defmacro xp-gp-regs (xp)
     `(pref ,xp :ucontext_t.uc_mcontext.__ss))
+  (defmacro xp-xmm-regs (xp)
+    `(pref ,xp :ucontext_t.uc_mcontext.__fs.__fpu_xmm0))
 
   (defconstant flags-register-offset 17)
@@ -116 +125 @@
   (defun xp-mxcsr (xp)
     (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
+  (defmacro xp-mmx-regs (xp)
+    `(pref ,xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm))
   (defparameter *encoded-gpr-to-indexed-gpr*
     #(14                                ;rax
@@ -142 +153 @@
   (defun xp-mxcsr (xp)
     (pref xp #>CONTEXT.MxCsr))
+  (defmacro xp-xmm-regs (xp)
+    `(pref ,xp #>CONTEXT.nil.FltSave.XmmRegisters))
   (defparameter *encoded-gpr-to-indexed-gpr*
     #(0                                 ;rax
@@ -168 +181 @@
   (defun xp-mxcsr (xp)
     (pref xp :ucontext_t.uc_mcontext.__fs.__fpu_mxcsr))
+  (defmacro xp-xmm-regs (xp)
+    `(pref ,xp :ucontext_t.uc_mcontext.__fs.__fpu_xmm0))
   (defconstant flags-register-offset 9)
   (defconstant eip-register-offset 10)
@@ -189 +204 @@
     (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs)
           :_fpstate.mxcsr))
+  (defmacro xp-xmm-regs (xp)
+    `(pref ,xp :ucontext.uc_mcontext.fpregs._xmm))
   (defconstant flags-register-offset #$REG_EFL)
   (defconstant eip-register-offset #$REG_EIP)
@@ -210 +227 @@
   (defun xp-mxcsr (xp)
     (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24))
+  (defmacro xp-xmm-regs (xp)
+    `(%inc-ptr ,xp #x16c))
   (defconstant flags-register-offset 48)
   (defconstant eip-register-offset 45)
@@ -232 +251 @@
     (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr))
   (defconstant flags-register-offset #$EFL)
+  (defmacro xp-xmm-regs (xp)
+    `(pref ,xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm))
   (defconstant eip-register-offset #$EIP)
   (defparameter *encoded-gpr-to-indexed-gpr*
@@ -308 +329 @@
   #+x8632-target
   (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift)))))
-  
-
+(defmacro xp-xmm-single-float (xp n)
+  `(%get-single-float (xp-xmm-regs ,xp) (ash ,n 4)))
+(defmacro xp-xmm-double-float (xp n)
+  `(%get-double-float (xp-xmm-regs ,xp) (ash ,n 4)))
 
 (defun %get-xcf-byte (xcf-ptr delta)
@@ -337 +360 @@
       -1)
     skip))
-                            
+
+(defun arithmetic-error-operation-from-instruction (instruction)
+  (let* ((name (make-keyword (string-upcase (x86-di-mnemonic instruction)))))
+    (case name
+      ((:divss :divsd :idivl :idivd) '/)
+      ((:mulss :mulsd) '*)
+      ((:addss :addsd) '+)
+      ((:subss :subsd) '-)
+      (t 'coerce))))
+
+(defun arithmetic-error-operands-from-instruction (instruction xp)
+  (let* ((name (make-keyword (string-upcase (x86-di-mnemonic instruction)))))
+    (let* ((op0 (x86-di-op0 instruction))
+           (op1 (x86-di-op1 instruction))
+           (xmmop0 (register-operand-regno op0 #.x86::+operand-type-RegXMM+))
+           (xmmop1 (register-operand-regno op1 #.x86::+operand-type-RegXMM+)))
+      (collect ((opvals))
+        (case name
+          ((:divss :mulss :addss :subss)
+           (when (and xmmop0 xmmop1)
+             (opvals (xp-xmm-single-float xp xmmop1))
+             (opvals (xp-xmm-single-float xp xmmop0))))
+          ((:divsd :mulsd :addsd :subsd)
+           (when (and xmmop0 xmmop1)
+             (opvals (xp-xmm-double-float xp xmmop1))
+             (opvals (xp-xmm-double-float xp xmmop0))))
+            
+          )
+        (opvals)))))
+
+
                                   
 (defun decode-arithmetic-error (xp xcf)
-  (declare (ignore xp xcf))
-  (values 'unknown nil))
+  (declare (ignorable xp xcf))
+  (let* ((code-vector (make-array 15 :element-type '(unsigned-byte 8)))
+         (xfunction (%alloc-misc 1 target::subtag-xfunction)))
+    (dotimes (i 15)                     ;maximum instructon size
+      (setf (aref code-vector i) (%get-xcf-byte xcf i)))
+    (setf (uvref xfunction 0) code-vector)
+    (let* ((ds (make-x86-disassembly-state
+                :mode-64 #+x8664-target t #+x8632-target nil
+                :code-vector code-vector
+                :constants-vector xfunction
+                :entry-point 0
+                :code-pointer 0           ; for next-u32/next-u16 below
+                :symbolic-names nil
+                :pending-labels (list 0)
+                :code-limit 15
+                :code-pointer 0))
+           (instruction (ignore-errors (x86-disassemble-instruction ds nil))))
+      (if instruction
+        (values (arithmetic-error-operation-from-instruction  instruction)
+                (arithmetic-error-operands-from-instruction instruction xp))
+        (values 'unknown nil)))))
 
 (eval-when (:compile-toplevel :execute)