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 (eval-when (:compile-toplevel :load-toplevel :execute)
19 (defparameter *float-trap-alist*
20 (list (cons :underflow float-underflow-trap-bit)
21 (cons :overflow float-overflow-trap-bit)
22 (cons :inexact float-inexact-trap-bit)
23 (cons :invalid float-invalid-trap-bit)
24 (cons :divide-by-zero float-divide-by-zero-trap-bit)
25 #!+x86 (cons :denormalized-operand float-denormal-trap-bit)))
27 (defparameter *rounding-mode-alist*
28 (list (cons :nearest float-round-to-nearest)
29 (cons :zero float-round-to-zero)
30 (cons :positive-infinity float-round-to-positive)
31 (cons :negative-infinity float-round-to-negative)))
33 ;;; Return a mask with all the specified float trap bits set.
34 (defun float-trap-mask (names)
37 (or (cdr (assoc x *float-trap-alist*))
38 (error "unknown float trap kind: ~S" x)))
40 ); Eval-When (Compile Load Eval)
43 (defun floating-point-modes () (floating-point-modes))
44 (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
46 (defun set-floating-point-modes (&key (traps nil traps-p)
47 (rounding-mode nil round-p)
48 (current-exceptions nil current-x-p)
49 (accrued-exceptions nil accrued-x-p)
50 (fast-mode nil fast-mode-p))
52 "This function sets options controlling the floating-point hardware. If a
53 keyword is not supplied, then the current value is preserved. Possible
57 A list of the exception conditions that should cause traps. Possible
58 exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
59 :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
60 all traps except :INEXACT are enabled.
63 The rounding mode to use when the result is not exact. Possible values
64 are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
65 Initially, the rounding mode is :NEAREST.
69 These arguments allow setting of the exception flags. The main use is
70 setting the accrued exceptions to NIL to clear them.
73 Set the hardware's \"fast mode\" flag, if any. When set, IEEE
74 conformance or debuggability may be impaired. Some machines may not
75 have this feature, in which case the value is always NIL.
77 GET-FLOATING-POINT-MODES may be used to find the floating point modes
79 (let ((modes (floating-point-modes)))
81 (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
83 (setf (ldb float-rounding-mode modes)
84 (or (cdr (assoc rounding-mode *rounding-mode-alist*))
85 (error "unknown rounding mode: ~S" rounding-mode))))
87 (setf (ldb float-exceptions-byte modes)
88 (float-trap-mask current-exceptions)))
90 (setf (ldb float-sticky-bits modes)
91 (float-trap-mask accrued-exceptions)))
94 (setq modes (logior float-fast-bit modes))
95 (setq modes (logand (lognot float-fast-bit) modes))))
96 (setf (floating-point-modes) modes))
100 (defun get-floating-point-modes ()
102 "This function returns a list representing the state of the floating
103 point modes. The list is in the same format as the &KEY arguments to
104 SET-FLOATING-POINT-MODES, i.e.
105 (apply #'set-floating-point-modes (get-floating-point-modes))
107 sets the floating point modes to their current values (and thus is a no-op)."
108 (flet ((exc-keys (bits)
111 ,@(mapcar #'(lambda (x)
112 `(when (logtest bits ,(cdr x))
117 (let ((modes (floating-point-modes)))
118 `(:traps ,(exc-keys (ldb float-traps-byte modes))
119 :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
120 *rounding-mode-alist*))
121 :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
122 :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
123 :fast-mode ,(logtest float-fast-bit modes)))))
125 (defmacro current-float-trap (&rest traps)
127 "Current-Float-Trap Trap-Name*
128 Return true if any of the named traps are currently trapped, false
130 `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
131 (floating-point-modes)))))
133 ;;; Signal the appropriate condition when we get a floating-point error.
134 (defun sigfpe-handler (signal info context)
135 (declare (ignore signal info))
136 (declare (type system-area-pointer context))
137 ;; FIXME: The find-the-detailed-problem code below went stale with
138 ;; the big switchover to POSIX signal handling and signal contexts
139 ;; which are opaque at the Lisp level ca plod-0.6.7. It needs to be
140 ;; revived, which will require writing a C-level os-dependent
141 ;; function to extract floating point modes, and a Lisp-level
142 ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function.
143 ;; Meanwhile we just say "something went wrong".
144 (error 'floating-point-exception)
146 (let* ((modes (context-floating-point-modes
147 (sb!alien:sap-alien context (* os-context-t))))
148 (traps (logand (ldb float-exceptions-byte modes)
149 (ldb float-traps-byte modes))))
150 (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
151 (error 'division-by-zero))
152 ((not (zerop (logand float-invalid-trap-bit traps)))
153 (error 'floating-point-invalid-operation))
154 ((not (zerop (logand float-overflow-trap-bit traps)))
155 (error 'floating-point-overflow))
156 ((not (zerop (logand float-underflow-trap-bit traps)))
157 (error 'floating-point-underflow))
158 ((not (zerop (logand float-inexact-trap-bit traps)))
159 (error 'floating-point-inexact))
161 ((zerop (ldb float-exceptions-byte modes))
162 ;; I can't tell what caused the exception!!
163 (error 'floating-point-exception
164 :traps (getf (get-floating-point-modes) :traps)))
166 (error "SIGFPE with no exceptions currently enabled?"))))
170 (defmacro with-float-traps-masked (traps &body body)
172 "Execute BODY with the floating point exceptions listed in TRAPS
173 masked (disabled). TRAPS should be a list of possible exceptions
174 which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
175 :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
176 accrued exceptions are cleared at the start of the body to support
177 their testing within, and restored on exit."
178 (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
179 (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
180 (trap-mask (dpb (lognot (float-trap-mask traps))
181 float-traps-byte #xffffffff))
182 (exception-mask (dpb (lognot (sb!vm::float-trap-mask traps))
183 float-sticky-bits #xffffffff)))
184 `(let ((orig-modes (floating-point-modes)))
187 (setf (floating-point-modes)
188 (logand orig-modes ,(logand trap-mask exception-mask)))
190 ;; Restore the original traps and exceptions.
191 (setf (floating-point-modes)
192 (logior (logand orig-modes ,(logior traps exceptions))
193 (logand (floating-point-modes)
194 ,(logand trap-mask exception-mask))))))))