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 (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))
  24   #'equal)
  25
  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))
  31   #'equal)
  32
  33 #+x86
  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))
  38   #'equal)
  39
  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)
  43     (reduce #'logior
  44             (mapcar (lambda (x)
  45                       (or (cdr (assoc x +float-trap-alist+))
  46                           (error "unknown float trap kind: ~S" x)))
  47                     names))))
  48
  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.
  52 #-(or x86-64 mips)
  53 (progn
  54   (defun floating-point-modes ()
  55     (floating-point-modes))
  56   (defun (setf floating-point-modes) (new)
  57     (setf (floating-point-modes) new)))
  58
  59 (defun set-floating-point-modes (&key
  60                                  (traps nil traps-p)
  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:
  69
  70  :TRAPS
  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.
  74
  75 :ROUNDING-MODE
  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.
  80
  81 :CURRENT-EXCEPTIONS
  82 :ACCRUED-EXCEPTIONS
  83    These arguments allow setting of the exception flags. The main
  84    use is setting the accrued exceptions to NIL to clear them.
  85
  86 :FAST-MODE
  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.
  91
  92 :PRECISION (x86 only)
  93   :24-bit, :53-bit and :64-bit, for the internal precision of the mantissa.
  94
  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
  97 in effect."
  98   (let ((modes (floating-point-modes)))
  99     (when traps-p
 100       (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
 101     (when round-p
 102       (setf (ldb float-rounding-mode modes)
 103             (or (cdr (assoc rounding-mode +rounding-mode-alist+))
 104                 (error "unknown rounding mode: ~S" rounding-mode))))
 105     (when current-x-p
 106       (setf (ldb float-exceptions-byte modes)
 107             (float-trap-mask current-exceptions)))
 108     (when accrued-x-p
 109       (setf (ldb float-sticky-bits modes)
 110             (float-trap-mask accrued-exceptions)))
 111     (when fast-mode-p
 112       (if fast-mode
 113           (setq modes (logior float-fast-bit modes))
 114           (setq modes (logand (lognot float-fast-bit) modes))))
 115     #+x86
 116     (when precisionp
 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
 121     #-(and darwin ppc)
 122     (setf (floating-point-modes) modes))
 123   (values))
 124
 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.
 129
 130   (apply #'set-floating-point-modes (get-floating-point-modes))
 131
 132 sets the floating point modes to their current values (and thus is a no-op)."
 133   (flet ((exc-keys (bits)
 134            (macrolet ((frob ()
 135                         `(collect ((res))
 136                            ,@(mapcar (lambda (x)
 137                                        `(when (logtest bits ,(cdr x))
 138                                           (res ',(car x))))
 139                                      +float-trap-alist+)
 140                            (res))))
 141              (frob))))
 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)
 149         #+x86 :precision
 150         #+x86 ,(car (rassoc (ldb float-precision-control modes)
 151                              +precision-mode-alist+))))))
 152
 153 ;;; FIXME: For some unknown reason, NetBSD/x86 won't run with the
 154 ;;; :INVALID trap enabled. That should be fixed, but not today...
 155 ;;;
 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
 159 ;;; desired.
 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))
 165
 166 (defun float-cold-init-or-reinit ()
 167   (apply #'set-floating-point-modes *saved-floating-point-modes*))
 168
 169 (defun float-deinit ()
 170   (setf *saved-floating-point-modes* (get-floating-point-modes)))
 171
 172 ;;; Return true if any of the named traps are currently trapped, false
 173 ;;; otherwise.
 174 (defmacro current-float-trap (&rest traps)
 175   `(logtest ,(dpb (float-trap-mask traps) float-traps-byte 0)
 176             (floating-point-modes)))
 177
 178 ;;; SIGFPE code to floating-point error
 179 #-win32
 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))
 189   #'equal)
 190
 191 ;;; Signal the appropriate condition when we get a floating-point error.
 192 #-win32
 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)
 198      (with-interrupts
 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)
 204               :operation op
 205               :operands operands)))))
 206
 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)))
 227     #+ppc64
 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)))
 233        (unwind-protect
 234             (progn
 235               (setf (floating-point-modes)
 236                     (logand ,orig-modes ,(logand trap-mask exception-mask)))
 237               ,@body)
 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))))))))