[Openmcl-cvs-notifications] r8014 - in /trunk/ccl/level-1: l1-error-system.lisp x86-trap-support.lisp

[gb at clozure.com]

Author: gb
Date: Tue Jan  8 00:43:40 2008
New Revision: 8014

Log:
Add a STATUS slot to ARITHMETIC-ERROR, with reader
CCL::ARITHMETIC-ERROR-STATUS.

Define xp-mxcsr for all current x86-64 platforms; use it to access
the mxcsr on an exception which generates an ARITHMETIC-ERROR, and
initialize that ARITHMETIC-ERROR's status slot to the mxcsr value.

Modified:
    trunk/ccl/level-1/l1-error-system.lisp
    trunk/ccl/level-1/x86-trap-support.lisp

Modified: trunk/ccl/level-1/l1-error-system.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/ccl/level-1/l1-error-system.lisp (original)
+++ trunk/ccl/level-1/l1-error-system.lisp Tue Jan  8 00:43:40 2008
@@ -438,11 +438,16 @@
 =

 (define-condition arithmetic-error (error) =

   ((operation :initform nil :initarg :operation :reader arithmetic-error-o=
peration)
-   (operands :initform nil :initarg :operands :reader arithmetic-error-ope=
rands))
-  (:report (lambda (c s) (format s "~S detected ~&performing ~S on ~:S"
-                                 (type-of c) =

-                                 (arithmetic-error-operation c) =

-                                 (arithmetic-error-operands c)))))
+   (operands :initform nil :initarg :operands :reader arithmetic-error-ope=
rands)
+   (status :initform nil :initarg :status :reader arithmetic-error-status))
+  (:report (lambda (c s)
+             (format s "~S detected "
+                     (type-of c))
+             (let* ((operands (arithmetic-error-operands c)))
+               (when operands
+                 (format s "~&performing ~S on ~:S"
+                         (arithmetic-error-operation c) =

+                         operands))))))
 =

 (define-condition division-by-zero (arithmetic-error))
   =


Modified: trunk/ccl/level-1/x86-trap-support.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/ccl/level-1/x86-trap-support.lisp (original)
+++ trunk/ccl/level-1/x86-trap-support.lisp Tue Jan  8 00:43:40 2008
@@ -28,6 +28,8 @@
   (defmacro xp-gp-regs (xp) xp)
   (defconstant flags-register-offset #$REG_EFL)
   (defconstant rip-register-offset #$REG_RIP)
+  (defun xp-mxcsr (xp)
+    (pref x :ucontext.uc_mcontext.fpregs.mxcsr))
   (defparameter *encoded-gpr-to-indexed-gpr*
     #(13                                ;rax
       14                                ;rcx
@@ -53,6 +55,9 @@
   (defmacro xp-gp-regs (xp) xp)
   (defconstant flags-register-offset 22)
   (defconstant rip-register-offset 20)
+  (defun xp-mxcsr (xp)
+    (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate)))
+      (pref state :savefpu.sv_env.en_mxcsr)))
   (defparameter *encoded-gpr-to-indexed-gpr*
     #(7					;rax
       4					;rcx
@@ -96,6 +101,9 @@
                  (:link :address)
                  (:uc_mcsize (:unsigned 64))
                  (:uc_mcontext64 (:* (:struct :portable_mcontext64))))))
+  (defun xp-mxcsr (xp)
+    (%get-unsigned-long
+     (pref (pref xp :portable_ucontext64.uc_mcontext64) :portable_mcontext=
64.fs) 32))
   (defconstant gp-regs-offset 0)
   (defmacro xp-gp-regs (xp)
     `(pref (pref ,xp :portable_ucontext64.uc_mcontext64) :portable_mcontex=
t64.ss))
@@ -181,6 +189,7 @@
           ((=3D signal #$SIGFPE)
            (multiple-value-bind (operation operands)
                (decode-arithmetic-error xp xcf)
+             =

              (let* ((condition-name
                      (cond ((or (=3D code #$FPE_INTDIV)
                                 (=3D code #$FPE_FLTDIV))
@@ -195,7 +204,8 @@
                             'floating-point-invalid-operation))))
                (%error (make-condition condition-name
                                        :operation operation
-                                       :operands operands)
+                                       :operands operands
+                                       :status (xp-mxcsr xp))
                        ()
                        frame-ptr))))
           ((=3D signal #$SIGSEGV)