[Git][cmucl/cmucl][rtoy-setexception-inexact] Simplify WITH-FLOAT-TRAPS-MASKED and WITH-FLOAT-TRAPS-ENABLED.

[Raymond Toy]

Raymond Toy pushed to branch rtoy-setexception-inexact at cmucl / cmucl


Commits:
5721ddd2 by Raymond Toy at 2015-12-24T11:46:36Z
Simplify WITH-FLOAT-TRAPS-MASKED and WITH-FLOAT-TRAPS-ENABLED.

Merge the body of both macros into one since they only differ in how
the bits are merged with the actual mode bits.

- - - - -


1 changed file:

- src/code/float-trap.lisp


Changes:

=====================================
src/code/float-trap.lisp
=====================================
--- a/src/code/float-trap.lisp
+++ b/src/code/float-trap.lisp
@@ -366,85 +366,52 @@
 			code)))))))
 
 ;;; WITH-FLOAT-TRAPS-MASKED  --  Public
-;;;
-(defmacro with-float-traps-masked (traps &body body)
-  "Execute BODY with the floating point exceptions listed in TRAPS
-  masked (disabled).  TRAPS should be a list of possible exceptions
-  which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
-  :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
-  accrued exceptions are cleared at the start of the body to support
-  their testing within, and restored on exit."
-  (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
-	(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
-	(trap-mask (dpb (lognot (float-trap-mask traps))
-			float-traps-byte #xffffffff))
-	(exception-mask (dpb (lognot (vm::float-trap-mask traps))
-			     float-sticky-bits #xffffffff))
-	;; On ppc if we are masking the invalid trap, we need to make
-	;; sure we wipe out the various individual sticky bits
-	;; representing the invalid operation.  Otherwise, if we
-	;; enable the invalid trap later, these sticky bits will cause
-	;; an exception.
-	#+ppc
-	(invalid-mask (if (member :invalid traps)
-			  (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)))
-      (unwind-protect
-	   (progn
-	     (setf (floating-point-modes)
-		   (logand ,orig-modes ,(logand trap-mask exception-mask)))
-	     , at body)
-	;; Restore the original traps and exceptions.
-	(setf (floating-point-modes)
-	      (logior (logand ,orig-modes ,(logior traps exceptions))
-		      (logand (floating-point-modes)
-			      ,(logand trap-mask exception-mask)
-			      #+ppc
-			      ,invalid-mask
-			      #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
-
-(defmacro with-float-traps-enabled (traps &body body)
-  "Execute BODY with the floating point exceptions listed in TRAPS
+;;; WITH-FLOAT-TRAPS-ENABLED --  Public
+
+
+(macrolet
+    ((with-float-traps (name logical-op)
+       `(defmacro ,(symbolicate "WITH-FLOAT-TRAPS-" name) (traps &body body)
+	  "Execute BODY with the floating point exceptions listed in TRAPS
   enabled.  TRAPS should be a list of possible exceptions which
   includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
   :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
   accrued exceptions are cleared at the start of the body to support
   their testing within, and restored on exit."
-  (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
-	(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
-	(trap-mask (dpb (lognot (float-trap-mask traps))
-			float-traps-byte #xffffffff))
-	(exception-mask (dpb (lognot (vm::float-trap-mask traps))
-			     float-sticky-bits #xffffffff))
-	;; On ppc if we are masking the invalid trap, we need to make
-	;; sure we wipe out the various individual sticky bits
-	;; representing the invalid operation.  Otherwise, if we
-	;; enable the invalid trap later, these sticky bits will cause
-	;; an exception.
-	#+ppc
-	(invalid-mask (if (member :invalid traps)
-			  (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)))
-      (unwind-protect
-	   (progn
-	     (setf (floating-point-modes)
-		   (logorc2 ,orig-modes ,(logand trap-mask exception-mask)))
-	     , at body)
-	;; Restore the original traps and exceptions.
-	(setf (floating-point-modes)
-	      (logior (logand ,orig-modes ,(logior traps exceptions))
-		      (logand (floating-point-modes)
-			      ,(logand trap-mask exception-mask)
-			      #+ppc
-			      ,invalid-mask
-			      #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
+	  (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
+		(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
+		(trap-mask (dpb (lognot (float-trap-mask traps))
+				float-traps-byte #xffffffff))
+		(exception-mask (dpb (lognot (vm::float-trap-mask traps))
+				     float-sticky-bits #xffffffff))
+		;; On ppc if we are masking the invalid trap, we need to make
+		;; sure we wipe out the various individual sticky bits
+		;; representing the invalid operation.  Otherwise, if we
+		;; enable the invalid trap later, these sticky bits will cause
+		;; an exception.
+		#+ppc
+		(invalid-mask (if (member :invalid traps)
+				  (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)))
+	       (unwind-protect
+		    (progn
+		      (setf (floating-point-modes)
+			    (,',logical-op ,orig-modes ,(logand trap-mask exception-mask)))
+		      , at body)
+		 ;; Restore the original traps and exceptions.
+		 (setf (floating-point-modes)
+		       (logior (logand ,orig-modes ,(logior traps exceptions))
+			       (logand (floating-point-modes)
+				       ,(logand trap-mask exception-mask)
+				       #+ppc
+				       ,invalid-mask
+				       #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))))
+  ;; Masked and Enabled only differ whether we AND in the bits or OR
+  ;; them.
+  (with-float-traps masked logand)
+  (with-float-traps enabled logorc2))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5721ddd2c71849c61c25bad61c4d1877be45ccc7
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20151224/d99429ab/attachment-0001.html>