From 70181ee7553a350eedd7acb2815b98dde6ce846c Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Sat, 29 Nov 2014 21:00:38 -0800
Subject: [PATCH] Partially addresses ticket:91 by allowing the test suite to
 finish. The tests still fail (along with others), but the test suite will
 finish.

 * code/float-trap.lisp:
   * Update SET-FLOATING-POINT-MODES:
     * When we clear out bits in float-invalid-op-1-byte, clear out the
       float-invalid-op-2-byte.  Not necessary for this fix, but those
       bits signal other invalid operations from sqrt and such.
     * When clearing the exceptions, clear the sticky exceptions
       summary bit too.
   * Fix SIGFPE-HANDLER:
     * As above, clear out the bit in float-invalid-op-2-byte and the
       exceptions summary bit.
     * Only clear out the new exception bits, as done for SSE2.
     * Mask out the float-invalid-op-2-byte and the summary bit before
       setting the new modes.

 * compiler/ppc/parms.lisp
   * Define float-exceptions-summary-byte.

 * code/exports.lisp:
   * Export FLOAT-INVALID-OP-2-BYTE
---
 src/code/exports.lisp       |  1 +
 src/code/float-trap.lisp    | 28 +++++++++++++++++++++++-----
 src/compiler/ppc/parms.lisp |  7 ++++++-
 3 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/src/code/exports.lisp b/src/code/exports.lisp
index 99e07627e..a6dcc0b19 100644
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -1164,6 +1164,7 @@
   (:export "SIGCONTEXT-LR"
 	   "COMPATIBLE-FUNCTION-TYPES-P"
 	   "FLOAT-INVALID-OP-1-BYTE"
+	   "FLOAT-INVALID-OP-2-BYTE"
 	   "GET-FP-OPERANDS"
 	   "FUSED-MULTIPLY-ADD"
 	   "FUSED-MULTIPLY-SUBTRACT")
diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp
index a736e0d40..d67a4fffe 100644
--- a/src/code/float-trap.lisp
+++ b/src/code/float-trap.lisp
@@ -193,7 +193,8 @@
       #+(and darwin ppc)
       (when (member :invalid current-exceptions)
  	;; Clear out the bits for the detected invalid operation
- 	(setf (ldb vm:float-invalid-op-1-byte modes) 0)))
+ 	(setf (ldb vm:float-invalid-op-1-byte modes) 0)
+	(setf (ldb vm:float-invalid-op-2-byte modes) 0)))
 
     (when accrued-x-p
       (setf (ldb float-sticky-bits modes)
@@ -201,12 +202,18 @@
       #+(and darwin ppc)
       (when (member :invalid current-exceptions)
  	;; Clear out the bits for the detected invalid operation
- 	(setf (ldb vm:float-invalid-op-1-byte modes) 0)))
+ 	(setf (ldb vm:float-invalid-op-1-byte modes) 0)
+	(setf (ldb vm:float-invalid-op-2-byte modes) 0)))
+
+    #+(and darwin ppc)
+    (when (or accrued-x-p current-x-p)
+      (setf (ldb vm:float-exceptions-summary-byte modes) 0))
 
     (when fast-mode-p
       (if fast-mode
 	  (setq modes (logior float-fast-bit modes))
 	  (setq modes (logand (lognot float-fast-bit) modes))))
+
     (setf (floating-point-modes) modes))
     
   (values))
@@ -261,7 +268,12 @@
 	 (traps (logand (ldb float-exceptions-byte modes)
 			(ldb float-traps-byte modes))))
     #+(and darwin ppc)
-    (let ((new-modes modes))
+    (let* ((new-modes modes)
+	   (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes)
+				     traps)))
+      ;; (format t "sigfpe: modes   = #B~32,'0b~%" modes)
+      ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions)
+      (setf (ldb float-exceptions-byte new-modes) new-exceptions)
       ;; Clear out all exceptions and save them to the context.
       ;;
       ;; XXX: Should we just clear out the bits for the traps that are
@@ -273,6 +285,9 @@
       ;; XXX: Should we only do that if the invalid trap is enabled?
       (setf (ldb float-invalid-op-1-byte new-modes) 0)
       (setf (ldb float-invalid-op-2-byte new-modes) 0)
+      ;; Clear the FP exception summary bit too.
+      (setf (ldb float-exceptions-summary-byte new-modes) 0)
+      ;; (format t "sigfpe: new modes   = #B~32,'0b~%" new-modes)
       (setf (floating-point-modes) new-modes)
       (setf (sigcontext-floating-point-modes
 	     (alien:sap-alien scp (* unix:sigcontext)))
@@ -371,7 +386,10 @@
 	;; an exception.
 	#+ppc
 	(invalid-mask (if (member :invalid traps)
-			  (dpb 0 vm:float-invalid-op-1-byte #xffffffff)
+			  (dpb 0
+			       (byte 1 31)
+			       (dpb 0 vm::float-invalid-op-2-byte
+				    (dpb 0 vm:float-invalid-op-1-byte #xffffffff)))
 			  #xffffffff))
 	(orig-modes (gensym)))
     `(let ((,orig-modes (floating-point-modes)))
@@ -387,4 +405,4 @@
 			      ,(logand trap-mask exception-mask)
 			      #+ppc
 			      ,invalid-mask
-		       #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
+			      #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp
index dab5ce513..cc2c5bac2 100644
--- a/src/compiler/ppc/parms.lisp
+++ b/src/compiler/ppc/parms.lisp
@@ -66,7 +66,8 @@
 	  float-underflow-trap-bit float-overflow-trap-bit
 	  float-imprecise-trap-bit float-invalid-trap-bit
 	  float-divide-by-zero-trap-bit
-	  float-invalid-op-1-byte))
+	  float-invalid-op-1-byte
+	  float-invalid-op-2-byte))
 
 #+double-double
 (export '(double-double-float-digits))
@@ -152,6 +153,10 @@
 ;; operation such as some software request, invalid square root, or
 ;; invalid integer convert.
 (defconstant float-invalid-op-2-byte (byte 3 8))
+;; FP exception summary bit. This is set if an FP instruction causes
+;; any of the FP exception bits to transition from 0 to 1 (meaning
+;; that exception occurred.)
+(defconstant float-exceptions-summary-byte (byte 1 31))
 (defconstant float-fast-bit (ash 1 2))	; Non-IEEE mode
 
 ); eval-when
-- 
GitLab