X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffloat-trap.lisp;h=886fc8e813cbad1915d0c826cca12370400731b2;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=2a772a5eb0e5f20c3907910c7cfe43b21bbfb024;hpb=50305b602c3953440af716137a56f50cd204375d;p=sbcl.git diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 2a772a5..886fc8e 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -30,18 +30,30 @@ (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))) + (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. +#!-alpha +(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,16 +76,23 @@ ;;; ;;;: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)) + (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))) @@ -91,7 +110,13 @@ (if fast-mode (setq modes (logior float-fast-bit modes)) (setq modes (logand (lognot float-fast-bit) modes)))) - (setf (floating-point-modes) 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)) @@ -105,9 +130,9 @@ (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)))) @@ -117,7 +142,10 @@ *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))))) + :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. @@ -127,17 +155,8 @@ ;;; Signal the appropriate condition when we get a floating-point error. (defun sigfpe-handler (signal info context) - (declare (ignore 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) @@ -158,9 +177,7 @@ (error 'floating-point-exception :traps (getf (get-floating-point-modes) :traps))) (t - (error "SIGFPE with no exceptions currently enabled?")))) - |# - ) + (error 'floating-point-exception))))) ;;; Execute BODY with the floating point exceptions listed in TRAPS ;;; masked (disabled). TRAPS should be a list of possible exceptions