0.9.13.30
[sbcl.git] / src / code / float-trap.lisp
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.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
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.
14
15 (in-package "SB!VM")
16
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18
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)))
26
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)))
32
33 #!+x86
34 (defparameter *precision-mode-alist*
35   (list (cons :24-bit float-precision-24-bit)
36         (cons :53-bit float-precision-53-bit)
37         (cons :64-bit float-precision-64-bit)))
38
39 ;;; Return a mask with all the specified float trap bits set.
40 (defun float-trap-mask (names)
41   (reduce #'logior
42           (mapcar (lambda (x)
43                     (or (cdr (assoc x *float-trap-alist*))
44                         (error "unknown float trap kind: ~S" x)))
45                   names)))
46 ) ; EVAL-WHEN
47
48 ;;; interpreter stubs for floating point modes get/setters for the
49 ;;; alpha have been removed to alpha-vm.lisp, as they are implemented
50 ;;; in C rather than as VOPs.
51 #!-(or alpha x86-64)
52 (progn
53   (defun floating-point-modes ()
54     (floating-point-modes))
55   (defun (setf floating-point-modes) (new)
56     (setf (floating-point-modes) new)))
57
58 ;;; This function sets options controlling the floating-point
59 ;;; hardware. If a keyword is not supplied, then the current value is
60 ;;; preserved. Possible keywords:
61 ;;; :TRAPS
62 ;;;    A list of the exception conditions that should cause traps.
63 ;;;    Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
64 ;;;    :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND.
65 ;;;
66 ;;;:ROUNDING-MODE
67 ;;;    The rounding mode to use when the result is not exact. Possible
68 ;;;    values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and
69 ;;;    :ZERO.  Setting this away from :NEAREST is liable to upset SBCL's
70 ;;;    maths routines which depend on it.
71 ;;;
72 ;;;:CURRENT-EXCEPTIONS
73 ;;;:ACCRUED-EXCEPTIONS
74 ;;;    These arguments allow setting of the exception flags. The main
75 ;;;    use is setting the accrued exceptions to NIL to clear them.
76 ;;;
77 ;;;:FAST-MODE
78 ;;;    Set the hardware's \"fast mode\" flag, if any. When set, IEEE
79 ;;;    conformance or debuggability may be impaired. Some machines don't
80 ;;;    have this feature, and some SBCL ports don't implement it anyway
81 ;;;    -- in such cases the value is always NIL.
82 ;;;
83 ;;;:PRECISION (x86 only) :24-bit, :53-bit and :64-bit, for the
84 ;;;internal precision of the mantissa.
85 ;;;
86 ;;; GET-FLOATING-POINT-MODES may be used to find the floating point modes
87 ;;; currently in effect.    See cold-init.lisp for the list of initially
88 ;;; enabled traps
89
90 (defun set-floating-point-modes (&key (traps nil traps-p)
91                                       (rounding-mode nil round-p)
92                                       (current-exceptions nil current-x-p)
93                                       (accrued-exceptions nil accrued-x-p)
94                                       (fast-mode nil fast-mode-p)
95                                  #!+x86 (precision nil precisionp))
96   (let ((modes (floating-point-modes)))
97     (when traps-p
98       (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
99     (when round-p
100       (setf (ldb float-rounding-mode modes)
101             (or (cdr (assoc rounding-mode *rounding-mode-alist*))
102                 (error "unknown rounding mode: ~S" rounding-mode))))
103     (when current-x-p
104       (setf (ldb float-exceptions-byte modes)
105             (float-trap-mask current-exceptions)))
106     (when accrued-x-p
107       (setf (ldb float-sticky-bits modes)
108             (float-trap-mask accrued-exceptions)))
109     (when fast-mode-p
110       (if fast-mode
111           (setq modes (logior float-fast-bit modes))
112           (setq modes (logand (lognot float-fast-bit) modes))))
113     #!+x86
114     (when precisionp
115       (setf (ldb float-precision-control modes)
116             (or (cdr (assoc precision *precision-mode-alist*))
117                 (error "unknown precision mode: ~S" precision))))
118     ;; FIXME: This apparently doesn't work on Darwin
119     #!-darwin (setf (floating-point-modes) modes))
120
121   (values))
122
123 ;;; This function returns a list representing the state of the floating
124 ;;; point modes. The list is in the same format as the &KEY arguments to
125 ;;; SET-FLOATING-POINT-MODES, i.e.
126 ;;;    (apply #'set-floating-point-modes (get-floating-point-modes))
127 ;;; sets the floating point modes to their current values (and thus is a
128 ;;; no-op).
129 (defun get-floating-point-modes ()
130   (flet ((exc-keys (bits)
131            (macrolet ((frob ()
132                         `(collect ((res))
133                            ,@(mapcar (lambda (x)
134                                        `(when (logtest bits ,(cdr x))
135                                           (res ',(car x))))
136                                      *float-trap-alist*)
137                            (res))))
138              (frob))))
139     (let ((modes (floating-point-modes)))
140       `(:traps ,(exc-keys (ldb float-traps-byte modes))
141         :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
142                                      *rounding-mode-alist*))
143         :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
144         :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
145         :fast-mode ,(logtest float-fast-bit modes)
146         #!+x86 :precision
147         #!+x86 ,(car (rassoc (ldb float-precision-control modes)
148                              *precision-mode-alist*))))))
149
150 ;;; Return true if any of the named traps are currently trapped, false
151 ;;; otherwise.
152 (defmacro current-float-trap (&rest traps)
153   `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
154                        (floating-point-modes)))))
155
156 ;;; Signal the appropriate condition when we get a floating-point error.
157 (defun sigfpe-handler (signal info context)
158   (declare (ignore signal info))
159   (declare (type system-area-pointer context))
160   (let* ((modes (context-floating-point-modes
161                  (sb!alien:sap-alien context (* os-context-t))))
162          (traps (logand (ldb float-exceptions-byte modes)
163                         (ldb float-traps-byte modes))))
164     (with-interrupts
165       (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
166              (error 'division-by-zero))
167             ((not (zerop (logand float-invalid-trap-bit traps)))
168              (error 'floating-point-invalid-operation))
169             ((not (zerop (logand float-overflow-trap-bit traps)))
170              (error 'floating-point-overflow))
171             ((not (zerop (logand float-underflow-trap-bit traps)))
172              (error 'floating-point-underflow))
173             ((not (zerop (logand float-inexact-trap-bit traps)))
174              (error 'floating-point-inexact))
175             #!+freebsd
176             ((zerop (ldb float-exceptions-byte modes))
177              ;; I can't tell what caused the exception!!
178              (error 'floating-point-exception
179                     :traps (getf (get-floating-point-modes) :traps)))
180             (t
181              (error 'floating-point-exception))))))
182
183 ;;; Execute BODY with the floating point exceptions listed in TRAPS
184 ;;; masked (disabled). TRAPS should be a list of possible exceptions
185 ;;; which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
186 ;;; :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The
187 ;;; respective accrued exceptions are cleared at the start of the body
188 ;;; to support their testing within, and restored on exit.
189 (defmacro with-float-traps-masked (traps &body body)
190   (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
191         (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
192         (trap-mask (dpb (lognot (float-trap-mask traps))
193                         float-traps-byte #xffffffff))
194         (exception-mask (dpb (lognot (float-trap-mask traps))
195                              float-sticky-bits #xffffffff))
196         (orig-modes (gensym)))
197     `(let ((,orig-modes (floating-point-modes)))
198       (unwind-protect
199            (progn
200              (setf (floating-point-modes)
201                    (logand ,orig-modes ,(logand trap-mask exception-mask)))
202              ,@body)
203         ;; Restore the original traps and exceptions.
204         (setf (floating-point-modes)
205               (logior (logand ,orig-modes ,(logior traps exceptions))
206                       (logand (floating-point-modes)
207                               ,(logand trap-mask exception-mask))))))))