X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat-trap.lisp;h=8260291ec135e70e59cc1c0aff6b6457cec0528c;hb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;hp=f99ec5b080189b5206b7898a3919cec3ee0dc935;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index f99ec5b..8260291 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -16,7 +16,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) -(defconstant float-trap-alist +(defparameter *float-trap-alist* (list (cons :underflow float-underflow-trap-bit) (cons :overflow float-overflow-trap-bit) (cons :inexact float-inexact-trap-bit) @@ -24,66 +24,63 @@ (cons :divide-by-zero float-divide-by-zero-trap-bit) #!+x86 (cons :denormalized-operand float-denormal-trap-bit))) -;;; 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))) - names))) - -(defconstant rounding-mode-alist +(defparameter *rounding-mode-alist* (list (cons :nearest float-round-to-nearest) (cons :zero float-round-to-zero) (cons :positive-infinity float-round-to-positive) (cons :negative-infinity float-round-to-negative))) -); Eval-When (Compile Load Eval) +;;; 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))) + names))) +) ; 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))) (when round-p (setf (ldb float-rounding-mode modes) - (or (cdr (assoc rounding-mode rounding-mode-alist)) - (error "Unknown rounding mode: ~S." rounding-mode)))) + (or (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "unknown rounding mode: ~S" rounding-mode)))) (when current-x-p (setf (ldb float-exceptions-byte modes) (float-trap-mask current-exceptions))) @@ -98,49 +95,46 @@ (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)))) - float-trap-alist) + *float-trap-alist*) (res)))) (frob)))) (let ((modes (floating-point-modes))) `(:traps ,(exc-keys (ldb float-traps-byte modes)) :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) - rounding-mode-alist)) + *rounding-mode-alist*)) :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes)) :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) #| @@ -168,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))))))))