X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat-trap.lisp;h=4bd83cb3aeaac9fe7122536131d6a14159a40f9f;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=e0b27307236518f3c17ce7e195e0995321766b7e;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index e0b2730..4bd83cb 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -47,52 +47,54 @@ ;;; 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) +;;; in C rather than as VOPs. Likewise for x86-64 and mips. +#!-(or alpha x86-64 mips) (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 -;;; 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. -;;; -;;;:ROUNDING-MODE -;;; The rounding mode to use when the result is not exact. Possible -;;; values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and -;;; :ZERO. Setting this away from :NEAREST is liable to upset SBCL's -;;; maths routines which depend on it. -;;; -;;;: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 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. 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) +(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) #!+x86 (precision nil precisionp)) + #!+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. + +:ROUNDING-MODE + The rounding mode to use when the result is not exact. Possible + values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and + :ZERO. Setting this away from :NEAREST is liable to upset SBCL's + maths routines which depend on it. + +: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 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. SAVE-LISP-AND-DIE preserves the floating point modes +in effect." (let ((modes (floating-point-modes))) (when traps-p (setf (ldb float-traps-byte modes) (float-trap-mask traps))) @@ -117,16 +119,17 @@ (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 -;;; 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 &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)." (flet ((exc-keys (bits) (macrolet ((frob () `(collect ((res)) @@ -147,37 +150,52 @@ #!+x86 ,(car (rassoc (ldb float-precision-control modes) *precision-mode-alist*)))))) +;;; FIXME: For some unknown reason, NetBSD/x86 won't run with the +;;; :INVALID trap enabled. That should be fixed, but not today... +;;; +;;; PRINT seems not to like x86 NPX denormal floats like +;;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are +;;; disabled by default. Joe User can explicitly enable them if +;;; desired. +(defvar *saved-floating-point-modes* + '(:traps (:overflow #!-(or netbsd ppc) :invalid :divide-by-zero) + :rounding-mode :nearest :current-exceptions nil + :accrued-exceptions nil :fast-mode nil + #!+x86 :precision #!+x86 :53-bit)) + +(defun float-cold-init-or-reinit () + (apply #'set-floating-point-modes *saved-floating-point-modes*)) + +(defun float-deinit () + (setf *saved-floating-point-modes* (get-floating-point-modes))) + ;;; 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))))) +;;; SIGFPE code to floating-point error +#!-win32 +(defparameter *sigfpe-code-error-alist* + (list (cons sb!unix::fpe-intovf 'floating-point-overflow) + (cons sb!unix::fpe-intdiv 'division-by-zero) + (cons sb!unix::fpe-fltdiv 'division-by-zero) + (cons sb!unix::fpe-fltovf 'floating-point-overflow) + (cons sb!unix::fpe-fltund 'floating-point-underflow) + (cons sb!unix::fpe-fltres 'floating-point-inexact) + (cons sb!unix::fpe-fltinv 'floating-point-invalid-operation) + (cons sb!unix::fpe-fltsub 'floating-point-exception))) + ;;; Signal the appropriate condition when we get a floating-point error. +#!-win32 (defun sigfpe-handler (signal info context) - (declare (ignore signal info)) - (declare (type system-area-pointer context)) - (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 'floating-point-exception))))) + (declare (ignore signal context)) + (declare (type system-area-pointer info)) + (let ((code (sb!unix::siginfo-code info))) + (with-interrupts + (error (or (cdr (assoc code *sigfpe-code-error-alist*)) + 'floating-point-exception))))) ;;; Execute BODY with the floating point exceptions listed in TRAPS ;;; masked (disabled). TRAPS should be a list of possible exceptions