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 (defconstant-eqx +float-trap-alist+
  20     `((:underflow . ,float-underflow-trap-bit)
  21       (:overflow . ,float-overflow-trap-bit)
  22       (:inexact . ,float-inexact-trap-bit)
  23       (:invalid . ,float-invalid-trap-bit)
  24       (:divide-by-zero . ,float-divide-by-zero-trap-bit)
  25       #!+x86 (:denormalized-operand . ,float-denormal-trap-bit))
  26   #'equal)
  27
  28 (defconstant-eqx +rounding-mode-alist+
  29     `((:nearest . ,float-round-to-nearest)
  30       (:zero . ,float-round-to-zero)
  31       (:positive-infinity . ,float-round-to-positive)
  32       (:negative-infinity . ,float-round-to-negative))
  33   #'equal)
  34
  35 #!+x86
  36 (defconstant-eqx +precision-mode-alist+
  37     `((:24-bit . ,float-precision-24-bit)
  38       (:53-bit . ,float-precision-53-bit)
  39       (:64-bit . ,float-precision-64-bit))
  40   #'equal)
  41
  42 ;;; Return a mask with all the specified float trap bits set.
  43 (defun float-trap-mask (names)
  44   (reduce #'logior
  45           (mapcar (lambda (x)
  46                     (or (cdr (assoc x +float-trap-alist+))
  47                         (error "unknown float trap kind: ~S" x)))
  48                   names)))
  49 ) ; EVAL-WHEN
  50
  51 ;;; interpreter stubs for floating point modes get/setters for the
  52 ;;; alpha have been removed to alpha-vm.lisp, as they are implemented
  53 ;;; in C rather than as VOPs. Likewise for x86-64 and mips.
  54 #!-(or alpha x86-64 mips)
  55 (progn
  56   (defun floating-point-modes ()
  57     (floating-point-modes))
  58   (defun (setf floating-point-modes) (new)
  59     (setf (floating-point-modes) new)))
  60
  61 (defun set-floating-point-modes (&key
  62                                  (traps nil traps-p)
  63                                  (rounding-mode nil round-p)
  64                                  (current-exceptions nil current-x-p)
  65                                  (accrued-exceptions nil accrued-x-p)
  66                                  (fast-mode nil fast-mode-p)
  67                                  #!+x86 (precision nil precisionp))
  68   "This function sets options controlling the floating-point
  69 hardware. If a keyword is not supplied, then the current value is
  70 preserved. Possible keywords:
  71
  72  :TRAPS
  73    A list of the exception conditions that should cause traps.
  74    Possible exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
  75   :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND.
  76
  77 :ROUNDING-MODE
  78    The rounding mode to use when the result is not exact. Possible
  79    values are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and
  80    :ZERO.  Setting this away from :NEAREST is liable to upset SBCL's
  81    maths routines which depend on it.
  82
  83 :CURRENT-EXCEPTIONS
  84 :ACCRUED-EXCEPTIONS
  85    These arguments allow setting of the exception flags. The main
  86    use is setting the accrued exceptions to NIL to clear them.
  87
  88 :FAST-MODE
  89    Set the hardware's \"fast mode\" flag, if any. When set, IEEE
  90    conformance or debuggability may be impaired. Some machines don't
  91    have this feature, and some SBCL ports don't implement it anyway
  92    -- in such cases the value is always NIL.
  93
  94 :PRECISION (x86 only)
  95   :24-bit, :53-bit and :64-bit, for the internal precision of the mantissa.
  96
  97 GET-FLOATING-POINT-MODES may be used to find the floating point modes
  98 currently in effect. SAVE-LISP-AND-DIE preserves the floating point modes
  99 in effect."
 100   (let ((modes (floating-point-modes)))
 101     (when traps-p
 102       (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
 103     (when round-p
 104       (setf (ldb float-rounding-mode modes)
 105             (or (cdr (assoc rounding-mode +rounding-mode-alist+))
 106                 (error "unknown rounding mode: ~S" rounding-mode))))
 107     (when current-x-p
 108       (setf (ldb float-exceptions-byte modes)
 109             (float-trap-mask current-exceptions)))
 110     (when accrued-x-p
 111       (setf (ldb float-sticky-bits modes)
 112             (float-trap-mask accrued-exceptions)))
 113     (when fast-mode-p
 114       (if fast-mode
 115           (setq modes (logior float-fast-bit modes))
 116           (setq modes (logand (lognot float-fast-bit) modes))))
 117     #!+x86
 118     (when precisionp
 119       (setf (ldb float-precision-control modes)
 120             (or (cdr (assoc precision +precision-mode-alist+))
 121                 (error "unknown precision mode: ~S" precision))))
 122     ;; FIXME: This apparently doesn't work on Darwin
 123     #!-(and darwin ppc)
 124     (setf (floating-point-modes) modes))
 125   (values))
 126
 127 (defun get-floating-point-modes ()
 128   "This function returns a list representing the state of the floating
 129 point modes. The list is in the same format as the &KEY arguments to
 130 SET-FLOATING-POINT-MODES, i.e.
 131
 132   (apply #'set-floating-point-modes (get-floating-point-modes))
 133
 134 sets the floating point modes to their current values (and thus is a no-op)."
 135   (flet ((exc-keys (bits)
 136            (macrolet ((frob ()
 137                         `(collect ((res))
 138                            ,@(mapcar (lambda (x)
 139                                        `(when (logtest bits ,(cdr x))
 140                                           (res ',(car x))))
 141                                      +float-trap-alist+)
 142                            (res))))
 143              (frob))))
 144     (let ((modes (floating-point-modes)))
 145       `(:traps ,(exc-keys (ldb float-traps-byte modes))
 146         :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
 147                                      +rounding-mode-alist+))
 148         :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
 149         :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
 150         :fast-mode ,(logtest float-fast-bit modes)
 151         #!+x86 :precision
 152         #!+x86 ,(car (rassoc (ldb float-precision-control modes)
 153                              +precision-mode-alist+))))))
 154
 155 ;;; FIXME: For some unknown reason, NetBSD/x86 won't run with the
 156 ;;; :INVALID trap enabled. That should be fixed, but not today...
 157 ;;;
 158 ;;; PRINT seems not to like x86 NPX denormal floats like
 159 ;;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are
 160 ;;; disabled by default. Joe User can explicitly enable them if
 161 ;;; desired.
 162 (defvar *saved-floating-point-modes*
 163   '(:traps (:overflow #!-(or netbsd ppc) :invalid :divide-by-zero)
 164     :rounding-mode :nearest :current-exceptions nil
 165     :accrued-exceptions nil :fast-mode nil
 166     #!+x86 :precision #!+x86 :53-bit))
 167
 168 (defun float-cold-init-or-reinit ()
 169   (apply #'set-floating-point-modes *saved-floating-point-modes*))
 170
 171 (defun float-deinit ()
 172   (setf *saved-floating-point-modes* (get-floating-point-modes)))
 173
 174 ;;; Return true if any of the named traps are currently trapped, false
 175 ;;; otherwise.
 176 (defmacro current-float-trap (&rest traps)
 177   `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
 178                        (floating-point-modes)))))
 179
 180 ;;; SIGFPE code to floating-point error
 181 #!-win32
 182 (eval-when (:compile-toplevel :load-toplevel :execute)
 183   (defconstant-eqx +sigfpe-code-error-alist+
 184     `((,sb!unix::fpe-intovf . floating-point-overflow)
 185       (,sb!unix::fpe-intdiv . division-by-zero)
 186       (,sb!unix::fpe-fltdiv . division-by-zero)
 187       (,sb!unix::fpe-fltovf . floating-point-overflow)
 188       (,sb!unix::fpe-fltund . floating-point-underflow)
 189       (,sb!unix::fpe-fltres . floating-point-inexact)
 190       (,sb!unix::fpe-fltinv . floating-point-invalid-operation)
 191       (,sb!unix::fpe-fltsub . floating-point-exception))
 192     #'equal))
 193
 194 ;;; Signal the appropriate condition when we get a floating-point error.
 195 #!-win32
 196 (defun sigfpe-handler (signal info context)
 197   (declare (ignore signal))
 198   (declare (type system-area-pointer info))
 199   (let ((code (sb!unix::siginfo-code info)))
 200     (multiple-value-bind (op operands) (sb!di::decode-arithmetic-error-operands context)
 201      (with-interrupts
 202        ;; Reset the accumulated exceptions, may be needed on other
 203        ;; platforms too, at least Linux doesn't seem to require it.
 204        #!+(or sunos (and hppa linux))
 205        (setf (ldb sb!vm::float-sticky-bits (floating-point-modes)) 0)
 206        (error (or (cdr (assoc code +sigfpe-code-error-alist+))
 207                   'floating-point-exception)
 208               :operation op
 209               :operands operands)))))
 210
 211 ;;; Execute BODY with the floating point exceptions listed in TRAPS
 212 ;;; masked (disabled). TRAPS should be a list of possible exceptions
 213 ;;; which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
 214 ;;; :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The
 215 ;;; respective accrued exceptions are cleared at the start of the body
 216 ;;; to support their testing within, and restored on exit.
 217 (defmacro with-float-traps-masked (traps &body body)
 218   (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
 219         (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
 220         (trap-mask (dpb (lognot (float-trap-mask traps))
 221                         float-traps-byte #xffffffff))
 222         (exception-mask (dpb (lognot (float-trap-mask traps))
 223                              float-sticky-bits #xffffffff))
 224         ;; MIPS has a second set of "accumulated exceptions" which are
 225         ;; actually used to cause the exception to be delivered, and
 226         ;; which can be set from user code.  Compute the mask here,
 227         ;; and clear them below.
 228         #!+mips (cause-mask (dpb (lognot (float-trap-mask traps))
 229                                  float-exceptions-byte #xffffffff))
 230         (orig-modes (gensym)))
 231     `(let ((,orig-modes (floating-point-modes)))
 232       (unwind-protect
 233            (progn
 234              (setf (floating-point-modes)
 235                    (logand ,orig-modes ,(logand trap-mask exception-mask)))
 236              ,@body)
 237         ;; Restore the original traps and exceptions.
 238         (setf (floating-point-modes)
 239               (logior (logand ,orig-modes ,(logior traps exceptions))
 240                       (logand (floating-point-modes)
 241                               ,(logand trap-mask exception-mask
 242                                        #!+mips cause-mask))))))))