(in-package "SB!VM")
-(file-comment
- "$Header$")
-
(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)
(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)))
(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)
#|
|#
)
+;;; 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))))))))
projects / sbcl.git / blobdiff