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