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

Commits: 97bd0eaa by Raymond Toy at 2015-12-24T10:37:57Z 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.

- - - - -

2 changed files:

- src/code/exports.lisp - src/code/float-trap.lisp

Changes:

===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -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"

===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -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))))))))

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/97bd0eaa99f355568b4d588863...