X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat-trap.lisp;h=4ba4d1bcb0aed553907d93e684be0571dc94dd42;hb=444d2072bc52e60a41af62ee22e343e76109212f;hp=39293abca100a32018ece11e97324c5e2dd1f512;hpb=0b3ec4b1d978b887db175b7b3bada8e727683e15;p=sbcl.git diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 39293ab..4ba4d1b 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -18,30 +18,42 @@ (defparameter *float-trap-alist* (list (cons :underflow float-underflow-trap-bit) - (cons :overflow float-overflow-trap-bit) - (cons :inexact float-inexact-trap-bit) - (cons :invalid float-invalid-trap-bit) - (cons :divide-by-zero float-divide-by-zero-trap-bit) - #!+x86 (cons :denormalized-operand float-denormal-trap-bit))) + (cons :overflow float-overflow-trap-bit) + (cons :inexact float-inexact-trap-bit) + (cons :invalid float-invalid-trap-bit) + (cons :divide-by-zero float-divide-by-zero-trap-bit) + #!+x86 (cons :denormalized-operand float-denormal-trap-bit))) (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))) + (cons :zero float-round-to-zero) + (cons :positive-infinity float-round-to-positive) + (cons :negative-infinity float-round-to-negative))) + +#!+x86 +(defparameter *precision-mode-alist* + (list (cons :24-bit float-precision-24-bit) + (cons :53-bit float-precision-53-bit) + (cons :64-bit float-precision-64-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))) + (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)) +;;; interpreter stubs for floating point modes get/setters for the +;;; alpha have been removed to alpha-vm.lisp, as they are implemented +;;; in C rather than as VOPs. +#!-(or alpha x86-64) +(progn + (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 @@ -49,13 +61,13 @@ ;;; :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. +;;; :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. ;;; ;;;: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. +;;; :ZERO. Setting this away from :NEAREST is liable to upset SBCL's +;;; maths routines which depend on it. ;;; ;;;:CURRENT-EXCEPTIONS ;;;:ACCRUED-EXCEPTIONS @@ -64,38 +76,51 @@ ;;; ;;;: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. +;;; conformance or debuggability may be impaired. Some machines don't +;;; have this feature, and some SBCL ports don't implement it anyway +;;; -- in such cases the value is always NIL. +;;; +;;;:PRECISION (x86 only) :24-bit, :53-bit and :64-bit, for the +;;;internal precision of the mantissa. ;;; ;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes -;;; currently in effect. +;;; currently in effect. See cold-init.lisp for the list of initially +;;; enabled traps + (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)) + (rounding-mode nil round-p) + (current-exceptions nil current-x-p) + (accrued-exceptions nil accrued-x-p) + (fast-mode nil fast-mode-p) + #!+x86 (precision nil precisionp)) (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))) + (float-trap-mask current-exceptions))) (when accrued-x-p (setf (ldb float-sticky-bits modes) - (float-trap-mask accrued-exceptions))) + (float-trap-mask accrued-exceptions))) (when fast-mode-p (if fast-mode - (setq modes (logior float-fast-bit modes)) - (setq modes (logand (lognot float-fast-bit) modes)))) - (setf (floating-point-modes) modes)) + (setq modes (logior float-fast-bit modes)) + (setq modes (logand (lognot float-fast-bit) modes)))) + #!+x86 + (when precisionp + (setf (ldb float-precision-control modes) + (or (cdr (assoc precision *precision-mode-alist*)) + (error "unknown precision mode: ~S" precision)))) + ;; FIXME: This apparently doesn't work on Darwin + #!-darwin (setf (floating-point-modes) modes)) (values)) -;;; This function returns a list representing the state of the floating +;;; 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)) @@ -103,64 +128,57 @@ ;;; no-op). (defun get-floating-point-modes () (flet ((exc-keys (bits) - (macrolet ((frob () - `(collect ((res)) - ,@(mapcar #'(lambda (x) - `(when (logtest bits ,(cdr x)) - (res ',(car x)))) - *float-trap-alist*) - (res)))) - (frob)))) + (macrolet ((frob () + `(collect ((res)) + ,@(mapcar (lambda (x) + `(when (logtest bits ,(cdr x)) + (res ',(car x)))) + *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*)) - :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))))) + :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes) + *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) + #!+x86 :precision + #!+x86 ,(car (rassoc (ldb float-precision-control modes) + *precision-mode-alist*)))))) ;;; Return true if any of the named traps are currently trapped, false ;;; otherwise. (defmacro current-float-trap (&rest traps) `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0) - (floating-point-modes))))) + (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 (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. 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. - ;; Meanwhile we just say "something went wrong". - (error 'floating-point-exception) - #| (let* ((modes (context-floating-point-modes - (sb!alien:sap-alien context (* os-context-t)))) - (traps (logand (ldb float-exceptions-byte modes) - (ldb float-traps-byte modes)))) - (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'floating-point-inexact)) - #!+FreeBSD - ((zerop (ldb float-exceptions-byte modes)) - ;; I can't tell what caused the exception!! - (error 'floating-point-exception - :traps (getf (get-floating-point-modes) :traps))) - (t - (error "SIGFPE with no exceptions currently enabled?")))) - |# - ) + (sb!alien:sap-alien context (* os-context-t)))) + (traps (logand (ldb float-exceptions-byte modes) + (ldb float-traps-byte modes)))) + (with-interrupts + (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) + (error 'division-by-zero)) + ((not (zerop (logand float-invalid-trap-bit traps))) + (error 'floating-point-invalid-operation)) + ((not (zerop (logand float-overflow-trap-bit traps))) + (error 'floating-point-overflow)) + ((not (zerop (logand float-underflow-trap-bit traps))) + (error 'floating-point-underflow)) + ((not (zerop (logand float-inexact-trap-bit traps))) + (error 'floating-point-inexact)) + #!+freebsd + ((zerop (ldb float-exceptions-byte modes)) + ;; I can't tell what caused the exception!! + (error 'floating-point-exception + :traps (getf (get-floating-point-modes) :traps))) + (t + (error 'floating-point-exception)))))) ;;; Execute BODY with the floating point exceptions listed in TRAPS ;;; masked (disabled). TRAPS should be a list of possible exceptions @@ -170,19 +188,20 @@ ;;; to support their testing within, and restored on exit. (defmacro with-float-traps-masked (traps &body body) (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))) + (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 (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))) - ,@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)))))))) + (progn + (setf (floating-point-modes) + (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)) + (logand (floating-point-modes) + ,(logand trap-mask exception-mask))))))))