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)))
43 (defun floating-point-modes () (floating-point-modes))
44 (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
46 ;;; This function sets options controlling the floating-point
47 ;;; hardware. If a keyword is not supplied, then the current value is
48 ;;; preserved. Possible keywords:
50 ;;; A list of the exception conditions that should cause traps.
51 ;;; Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
52 ;;; :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
53 ;;; all traps except :INEXACT are enabled.
56 ;;; The rounding mode to use when the result is not exact. Possible
57 ;;; values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and
58 ;;; :ZERO. Initially, the rounding mode is :NEAREST.
60 ;;;:CURRENT-EXCEPTIONS
61 ;;;:ACCRUED-EXCEPTIONS
62 ;;; These arguments allow setting of the exception flags. The main
63 ;;; use is setting the accrued exceptions to NIL to clear them.
66 ;;; Set the hardware's \"fast mode\" flag, if any. When set, IEEE
67 ;;; conformance or debuggability may be impaired. Some machines may not
68 ;;; have this feature, in which case the value is always NIL.
70 ;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes
71 ;;; currently in effect.
72 (defun set-floating-point-modes (&key (traps nil traps-p)
73 (rounding-mode nil round-p)
74 (current-exceptions nil current-x-p)
75 (accrued-exceptions nil accrued-x-p)
76 (fast-mode nil fast-mode-p))
77 (let ((modes (floating-point-modes)))
79 (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
81 (setf (ldb float-rounding-mode modes)
82 (or (cdr (assoc rounding-mode *rounding-mode-alist*))
83 (error "unknown rounding mode: ~S" rounding-mode))))
85 (setf (ldb float-exceptions-byte modes)
86 (float-trap-mask current-exceptions)))
88 (setf (ldb float-sticky-bits modes)
89 (float-trap-mask accrued-exceptions)))
92 (setq modes (logior float-fast-bit modes))
93 (setq modes (logand (lognot float-fast-bit) modes))))
94 (setf (floating-point-modes) modes))
98 ;;; This function returns a list representing the state of the floating
99 ;;; point modes. The list is in the same format as the &KEY arguments to
100 ;;; SET-FLOATING-POINT-MODES, i.e.
101 ;;; (apply #'set-floating-point-modes (get-floating-point-modes))
102 ;;; sets the floating point modes to their current values (and thus is a
104 (defun get-floating-point-modes ()
105 (flet ((exc-keys (bits)
108 ,@(mapcar #'(lambda (x)
109 `(when (logtest bits ,(cdr x))
114 (let ((modes (floating-point-modes)))
115 `(:traps ,(exc-keys (ldb float-traps-byte modes))
116 :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
117 *rounding-mode-alist*))
118 :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
119 :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
120 :fast-mode ,(logtest float-fast-bit modes)))))
122 ;;; Return true if any of the named traps are currently trapped, false
124 (defmacro current-float-trap (&rest traps)
125 `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
126 (floating-point-modes)))))
128 ;;; Signal the appropriate condition when we get a floating-point error.
129 (defun sigfpe-handler (signal info context)
130 (declare (ignore signal info context))
131 (declare (type system-area-pointer context))
132 ;; FIXME: The find-the-detailed-problem code below went stale with
133 ;; the big switchover to POSIX signal handling and signal contexts
134 ;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be
135 ;; revived, which will require writing a C-level os-dependent
136 ;; function to extract floating point modes, and a Lisp-level
137 ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function.
138 ;; Meanwhile we just say "something went wrong".
139 (error 'floating-point-exception)
141 (let* ((modes (context-floating-point-modes
142 (sb!alien:sap-alien context (* os-context-t))))
143 (traps (logand (ldb float-exceptions-byte modes)
144 (ldb float-traps-byte modes))))
145 (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
146 (error 'division-by-zero))
147 ((not (zerop (logand float-invalid-trap-bit traps)))
148 (error 'floating-point-invalid-operation))
149 ((not (zerop (logand float-overflow-trap-bit traps)))
150 (error 'floating-point-overflow))
151 ((not (zerop (logand float-underflow-trap-bit traps)))
152 (error 'floating-point-underflow))
153 ((not (zerop (logand float-inexact-trap-bit traps)))
154 (error 'floating-point-inexact))
156 ((zerop (ldb float-exceptions-byte modes))
157 ;; I can't tell what caused the exception!!
158 (error 'floating-point-exception
159 :traps (getf (get-floating-point-modes) :traps)))
161 (error "SIGFPE with no exceptions currently enabled?"))))
165 ;;; Execute BODY with the floating point exceptions listed in TRAPS
166 ;;; masked (disabled). TRAPS should be a list of possible exceptions
167 ;;; which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
168 ;;; :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The
169 ;;; respective accrued exceptions are cleared at the start of the body
170 ;;; to support their testing within, and restored on exit.
171 (defmacro with-float-traps-masked (traps &body body)
172 (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
173 (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
174 (trap-mask (dpb (lognot (float-trap-mask traps))
175 float-traps-byte #xffffffff))
176 (exception-mask (dpb (lognot (sb!vm::float-trap-mask traps))
177 float-sticky-bits #xffffffff))
178 (orig-modes (gensym)))
179 `(let ((,orig-modes (floating-point-modes)))
182 (setf (floating-point-modes)
183 (logand ,orig-modes ,(logand trap-mask exception-mask)))
185 ;; Restore the original traps and exceptions.
186 (setf (floating-point-modes)
187 (logior (logand ,orig-modes ,(logior traps exceptions))
188 (logand (floating-point-modes)
189 ,(logand trap-mask exception-mask))))))))