1 ;;;; This file contains stuff for controlling floating point traps. It
2 ;;;; is IEEE float specific, but should work for pretty much any FPU
3 ;;;; where the state fits in one word and exceptions are represented
4 ;;;; by bits being set.
6 ;;;; This software is part of the SBCL system. See the README file for
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
17 (defconstant-eqx +float-trap-alist
+
18 `((:underflow .
,float-underflow-trap-bit
)
19 (:overflow .
,float-overflow-trap-bit
)
20 (:inexact .
,float-inexact-trap-bit
)
21 (:invalid .
,float-invalid-trap-bit
)
22 (:divide-by-zero .
,float-divide-by-zero-trap-bit
)
23 #+x86
(:denormalized-operand .
,float-denormal-trap-bit
))
26 (defconstant-eqx +rounding-mode-alist
+
27 `((:nearest .
,float-round-to-nearest
)
28 (:zero .
,float-round-to-zero
)
29 (:positive-infinity .
,float-round-to-positive
)
30 (:negative-infinity .
,float-round-to-negative
))
34 (defconstant-eqx +precision-mode-alist
+
35 `((:24-bit .
,float-precision-24-bit
)
36 (:53-bit .
,float-precision-53-bit
)
37 (:64-bit .
,float-precision-64-bit
))
40 ;;; Return a mask with all the specified float trap bits set.
41 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
42 (defun float-trap-mask (names)
45 (or (cdr (assoc x
+float-trap-alist
+))
46 (error "unknown float trap kind: ~S" x
)))
49 ;;; interpreter stubs for floating point modes get/setters for
50 ;;; some architectures have been removed, as they are implemented
51 ;;; in C rather than as VOPs.
54 (defun floating-point-modes ()
55 (floating-point-modes))
56 (defun (setf floating-point-modes
) (new)
57 (setf (floating-point-modes) new
)))
59 (defun set-floating-point-modes (&key
61 (rounding-mode nil round-p
)
62 (current-exceptions nil current-x-p
)
63 (accrued-exceptions nil accrued-x-p
)
64 (fast-mode nil fast-mode-p
)
65 #+x86
(precision nil precisionp
))
66 "This function sets options controlling the floating-point
67 hardware. If a keyword is not supplied, then the current value is
68 preserved. Possible keywords:
71 A list of the exception conditions that should cause traps.
72 Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
73 :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND.
76 The rounding mode to use when the result is not exact. Possible
77 values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and
78 :ZERO. Setting this away from :NEAREST is liable to upset SBCL's
79 maths routines which depend on it.
83 These arguments allow setting of the exception flags. The main
84 use is setting the accrued exceptions to NIL to clear them.
87 Set the hardware's \"fast mode\" flag, if any. When set, IEEE
88 conformance or debuggability may be impaired. Some machines don't
89 have this feature, and some SBCL ports don't implement it anyway
90 -- in such cases the value is always NIL.
93 :24-bit, :53-bit and :64-bit, for the internal precision of the mantissa.
95 GET-FLOATING-POINT-MODES may be used to find the floating point modes
96 currently in effect. SAVE-LISP-AND-DIE preserves the floating point modes
98 (let ((modes (floating-point-modes)))
100 (setf (ldb float-traps-byte modes
) (float-trap-mask traps
)))
102 (setf (ldb float-rounding-mode modes
)
103 (or (cdr (assoc rounding-mode
+rounding-mode-alist
+))
104 (error "unknown rounding mode: ~S" rounding-mode
))))
106 (setf (ldb float-exceptions-byte modes
)
107 (float-trap-mask current-exceptions
)))
109 (setf (ldb float-sticky-bits modes
)
110 (float-trap-mask accrued-exceptions
)))
113 (setq modes
(logior float-fast-bit modes
))
114 (setq modes
(logand (lognot float-fast-bit
) modes
))))
117 (setf (ldb float-precision-control modes
)
118 (or (cdr (assoc precision
+precision-mode-alist
+))
119 (error "unknown precision mode: ~S" precision
))))
120 ;; FIXME: This apparently doesn't work on Darwin
122 (setf (floating-point-modes) modes
))
125 (defun get-floating-point-modes ()
126 "This function returns a list representing the state of the floating
127 point modes. The list is in the same format as the &KEY arguments to
128 SET-FLOATING-POINT-MODES, i.e.
130 (apply #'set-floating-point-modes (get-floating-point-modes))
132 sets the floating point modes to their current values (and thus is a no-op)."
133 (flet ((exc-keys (bits)
136 ,@(mapcar (lambda (x)
137 `(when (logtest bits
,(cdr x
))
142 (let ((modes (floating-point-modes)))
143 `(:traps
,(exc-keys (ldb float-traps-byte modes
))
144 :rounding-mode
,(car (rassoc (ldb float-rounding-mode modes
)
145 +rounding-mode-alist
+))
146 :current-exceptions
,(exc-keys (ldb float-exceptions-byte modes
))
147 :accrued-exceptions
,(exc-keys (ldb float-sticky-bits modes
))
148 :fast-mode
,(logtest float-fast-bit modes
)
150 #+x86
,(car (rassoc (ldb float-precision-control modes
)
151 +precision-mode-alist
+))))))
153 ;;; FIXME: For some unknown reason, NetBSD/x86 won't run with the
154 ;;; :INVALID trap enabled. That should be fixed, but not today...
156 ;;; PRINT seems not to like x86 NPX denormal floats like
157 ;;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are
158 ;;; disabled by default. Joe User can explicitly enable them if
160 (define-load-time-global *saved-floating-point-modes
*
161 '(:traps
(:overflow
#-
(or netbsd ppc
) :invalid
:divide-by-zero
)
162 :rounding-mode
:nearest
:current-exceptions nil
163 :accrued-exceptions nil
:fast-mode nil
164 #+x86
:precision
#+x86
:53-bit
))
166 (defun float-cold-init-or-reinit ()
167 (apply #'set-floating-point-modes
*saved-floating-point-modes
*))
169 (defun float-deinit ()
170 (setf *saved-floating-point-modes
* (get-floating-point-modes)))
172 ;;; Return true if any of the named traps are currently trapped, false
174 (defmacro current-float-trap
(&rest traps
)
175 `(logtest ,(dpb (float-trap-mask traps
) float-traps-byte
0)
176 (floating-point-modes)))
178 ;;; SIGFPE code to floating-point error
180 (defconstant-eqx +sigfpe-code-error-alist
+
181 `((,sb-unix
::fpe-intovf . floating-point-overflow
)
182 (,sb-unix
::fpe-intdiv . division-by-zero
)
183 (,sb-unix
::fpe-fltdiv . division-by-zero
)
184 (,sb-unix
::fpe-fltovf . floating-point-overflow
)
185 (,sb-unix
::fpe-fltund . floating-point-underflow
)
186 (,sb-unix
::fpe-fltres . floating-point-inexact
)
187 (,sb-unix
::fpe-fltinv . floating-point-invalid-operation
)
188 (,sb-unix
::fpe-fltsub . floating-point-exception
))
191 ;;; Signal the appropriate condition when we get a floating-point error.
193 (defun sigfpe-handler (signal info context
)
194 (declare (ignore signal
))
195 (declare (type system-area-pointer info
))
196 (let ((code (sb-unix::siginfo-code info
)))
197 (multiple-value-bind (op operands
) (sb-di::decode-arithmetic-error-operands context
)
199 ;; Reset the accumulated exceptions, may be needed on other
200 ;; platforms too, at least Linux doesn't seem to require it.
201 #+sunos
(setf (ldb sb-vm
:float-sticky-bits
(floating-point-modes)) 0)
202 (error (or (cdr (assoc code
+sigfpe-code-error-alist
+))
203 'floating-point-exception
)
205 :operands operands
)))))
207 ;;; Execute BODY with the floating point exceptions listed in TRAPS
208 ;;; masked (disabled). TRAPS should be a list of possible exceptions
209 ;;; which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
210 ;;; :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The
211 ;;; respective accrued exceptions are cleared at the start of the body
212 ;;; to support their testing within, and restored on exit.
213 (defmacro with-float-traps-masked
(traps &body body
)
214 (let ((traps (dpb (float-trap-mask traps
) float-traps-byte
0))
215 (exceptions (dpb (float-trap-mask traps
) float-sticky-bits
0))
216 (trap-mask (dpb (lognot (float-trap-mask traps
))
217 float-traps-byte
#xffffffff
))
218 (exception-mask (dpb (lognot (float-trap-mask traps
))
219 float-sticky-bits
#xffffffff
))
220 ;; MIPS has a second set of "accumulated exceptions" which are
221 ;; actually used to cause the exception to be delivered, and
222 ;; which can be set from user code. Compute the mask here,
223 ;; and clear them below.
224 #+mips
(cause-mask (dpb (lognot (float-trap-mask traps
))
225 float-exceptions-byte
#xffffffff
))
226 (orig-modes (gensym)))
228 (unless (logbitp float-invalid-trap-bit
(ldb float-sticky-bits exception-mask
))
229 ;; float-invalid-trap-bit is just a summary of this bits which
230 ;; all have to be cleared invidually.
231 (setf (ldb float-invalid-byte exception-mask
) 0))
232 `(let ((,orig-modes
(floating-point-modes)))
235 (setf (floating-point-modes)
236 (logand ,orig-modes
,(logand trap-mask exception-mask
)))
238 ;; Restore the original traps and exceptions.
239 (setf (floating-point-modes)
240 (logior (logand ,orig-modes
,(logior traps exceptions
))
241 (logand (floating-point-modes)
242 ,(logand trap-mask exception-mask
243 #+mips cause-mask
))))))))