Commit 97bd0eaa authored by Raymond Toy's avatar Raymond Toy

Add WITH-FLOAT-TRAPS-ENABLED to enable specific traps.

This works like WITH-FLOAT-TRAPS-MASKED, except that the specified
traps are enabled.

Use this in fdlibm to enable the inexact trap.
parent b9e3a511
......@@ -1583,7 +1583,8 @@
"FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P"
"FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
"FLOAT-SIGNALING-NAN-P"
"WITH-FLOAT-TRAPS-MASKED")
"WITH-FLOAT-TRAPS-MASKED"
"WITH-FLOAT-TRAPS-ENABLED")
;; More float extensions
#+double-double
(:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"
......
......@@ -23,7 +23,8 @@
)
(in-package "EXTENSIONS")
(export '(set-floating-point-modes get-floating-point-modes
with-float-traps-masked))
with-float-traps-masked
with-float-traps-enabled))
(in-package "VM")
(eval-when (compile load eval)
......@@ -406,3 +407,44 @@
#+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
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)))
,@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))))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment