X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ffloat-trap.lisp;h=5723d47f7929675df13c719690c235414ea4746b;hb=74a48d09e08aead6f67204878bdf9be4f448e1e8;hp=ee10e9545a7263eaad669805d3553127e8a842b4;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index ee10e95..5723d47 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -33,49 +33,47 @@ ;;; Return a mask with all the specified float trap bits set. (defun float-trap-mask (names) (reduce #'logior - (mapcar #'(lambda (x) - (or (cdr (assoc x *float-trap-alist*)) - (error "unknown float trap kind: ~S" x))) + (mapcar (lambda (x) + (or (cdr (assoc x *float-trap-alist*)) + (error "unknown float trap kind: ~S" x))) names))) -); Eval-When (Compile Load Eval) +) ; EVAL-WHEN ;;; interpreter stubs (defun floating-point-modes () (floating-point-modes)) (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new)) +;;; This function sets options controlling the floating-point +;;; hardware. If a keyword is not supplied, then the current value is +;;; preserved. Possible keywords: +;;; :TRAPS +;;; A list of the exception conditions that should cause traps. +;;; Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID, +;;; :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially +;;; all traps except :INEXACT are enabled. +;;; +;;;:ROUNDING-MODE +;;; The rounding mode to use when the result is not exact. Possible +;;; values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and +;;; :ZERO. Initially, the rounding mode is :NEAREST. +;;; +;;;:CURRENT-EXCEPTIONS +;;;:ACCRUED-EXCEPTIONS +;;; These arguments allow setting of the exception flags. The main +;;; use is setting the accrued exceptions to NIL to clear them. +;;; +;;;:FAST-MODE +;;; Set the hardware's \"fast mode\" flag, if any. When set, IEEE +;;; conformance or debuggability may be impaired. Some machines may not +;;; have this feature, in which case the value is always NIL. +;;; +;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes +;;; currently in effect. (defun set-floating-point-modes (&key (traps nil traps-p) (rounding-mode nil round-p) (current-exceptions nil current-x-p) (accrued-exceptions nil accrued-x-p) (fast-mode nil fast-mode-p)) - #!+sb-doc - "This function sets options controlling the floating-point hardware. If a - keyword is not supplied, then the current value is preserved. Possible - keywords: - - :TRAPS - A list of the exception conditions that should cause traps. Possible - exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID, - :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially - all traps except :INEXACT are enabled. - - :ROUNDING-MODE - The rounding mode to use when the result is not exact. Possible values - are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO. - Initially, the rounding mode is :NEAREST. - - :CURRENT-EXCEPTIONS - :ACCRUED-EXCEPTIONS - These arguments allow setting of the exception flags. The main use is - setting the accrued exceptions to NIL to clear them. - - :FAST-MODE - Set the hardware's \"fast mode\" flag, if any. When set, IEEE - conformance or debuggability may be impaired. Some machines may not - have this feature, in which case the value is always NIL. - - GET-FLOATING-POINT-MODES may be used to find the floating point modes - currently in effect." (let ((modes (floating-point-modes))) (when traps-p (setf (ldb float-traps-byte modes) (float-trap-mask traps))) @@ -97,20 +95,19 @@ (values)) +;;; This function returns a list representing the state of the floating +;;; point modes. The list is in the same format as the &KEY arguments to +;;; SET-FLOATING-POINT-MODES, i.e. +;;; (apply #'set-floating-point-modes (get-floating-point-modes)) +;;; sets the floating point modes to their current values (and thus is a +;;; no-op). (defun get-floating-point-modes () - #!+sb-doc - "This function returns a list representing the state of the floating point - modes. The list is in the same format as the keyword arguments to - SET-FLOATING-POINT-MODES, i.e. - (apply #'set-floating-point-modes (get-floating-point-modes)) - - sets the floating point modes to their current values (and thus is a no-op)." (flet ((exc-keys (bits) (macrolet ((frob () `(collect ((res)) - ,@(mapcar #'(lambda (x) - `(when (logtest bits ,(cdr x)) - (res ',(car x)))) + ,@(mapcar (lambda (x) + `(when (logtest bits ,(cdr x)) + (res ',(car x)))) *float-trap-alist*) (res)))) (frob)))) @@ -122,24 +119,22 @@ :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes)) :fast-mode ,(logtest float-fast-bit modes))))) +;;; Return true if any of the named traps are currently trapped, false +;;; otherwise. (defmacro current-float-trap (&rest traps) - #!+sb-doc - "Current-Float-Trap Trap-Name* - Return true if any of the named traps are currently trapped, false - otherwise." `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0) (floating-point-modes))))) ;;; Signal the appropriate condition when we get a floating-point error. (defun sigfpe-handler (signal info context) - (declare (ignore signal info)) + (declare (ignore signal info context)) (declare (type system-area-pointer context)) ;; FIXME: The find-the-detailed-problem code below went stale with ;; the big switchover to POSIX signal handling and signal contexts - ;; which are opaque at the Lisp level ca plod-0.6.7. It needs to be + ;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be ;; revived, which will require writing a C-level os-dependent ;; function to extract floating point modes, and a Lisp-level - ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function. + ;; DEFINE-ALIEN-ROUTINE to get to the C-level os-dependent function. ;; Meanwhile we just say "something went wrong". (error 'floating-point-exception) #| @@ -167,28 +162,28 @@ |# ) +;;; 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. (defmacro with-float-traps-masked (traps &body body) - #!+sb-doc - "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 (sb!vm::float-trap-mask traps)) - float-sticky-bits #xffffffff))) - `(let ((orig-modes (floating-point-modes))) + (exception-mask (dpb (lognot (float-trap-mask traps)) + float-sticky-bits #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))) + (logand ,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)) + (logior (logand ,orig-modes ,(logior traps exceptions)) (logand (floating-point-modes) ,(logand trap-mask exception-mask))))))))