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 ;;; Return a mask with all the specified float trap bits set.
  34 (defun float-trap-mask (names)
  35   (reduce #'logior
  36           (mapcar #'(lambda (x)
  37                       (or (cdr (assoc x *float-trap-alist*))
  38                           (error "unknown float trap kind: ~S" x)))
  39                   names)))
  40 ) ; EVAL-WHEN
  41
  42 ;;; interpreter stubs
  43 (defun floating-point-modes () (floating-point-modes))
  44 (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
  45
  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:
  49 ;;; :TRAPS
  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.
  54 ;;;
  55 ;;;:ROUNDING-MODE
  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.
  59 ;;;
  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.
  64 ;;;
  65 ;;;:FAST-MODE
  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.
  69 ;;;
  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)))
  78     (when traps-p
  79       (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
  80     (when round-p
  81       (setf (ldb float-rounding-mode modes)
  82             (or (cdr (assoc rounding-mode *rounding-mode-alist*))
  83                 (error "unknown rounding mode: ~S" rounding-mode))))
  84     (when current-x-p
  85       (setf (ldb float-exceptions-byte modes)
  86             (float-trap-mask current-exceptions)))
  87     (when accrued-x-p
  88       (setf (ldb float-sticky-bits modes)
  89             (float-trap-mask accrued-exceptions)))
  90     (when fast-mode-p
  91       (if fast-mode
  92           (setq modes (logior float-fast-bit modes))
  93           (setq modes (logand (lognot float-fast-bit) modes))))
  94     (setf (floating-point-modes) modes))
  95
  96   (values))
  97
  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
 103 ;;; no-op).
 104 (defun get-floating-point-modes ()
 105   (flet ((exc-keys (bits)
 106            (macrolet ((frob ()
 107                         `(collect ((res))
 108                            ,@(mapcar #'(lambda (x)
 109                                          `(when (logtest bits ,(cdr x))
 110                                             (res ',(car x))))
 111                                      *float-trap-alist*)
 112                            (res))))
 113              (frob))))
 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)))))
 121
 122 ;;; Return true if any of the named traps are currently trapped, false
 123 ;;; otherwise.
 124 (defmacro current-float-trap (&rest traps)
 125   `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
 126                        (floating-point-modes)))))
 127
 128 ;;; Signal the appropriate condition when we get a floating-point error.
 129 (defun sigfpe-handler (signal info context)
 130   (declare (ignore signal info))
 131   (declare (ignore context)) ; stub!
 132   (declare (type system-area-pointer context))
 133   ;; FIXME: The find-the-detailed-problem code below went stale with
 134   ;; the big switchover to POSIX signal handling and signal contexts
 135   ;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be
 136   ;; revived, which will require writing a C-level os-dependent
 137   ;; function to extract floating point modes, and a Lisp-level
 138   ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function.
 139   ;; Meanwhile we just say "something went wrong".
 140   (error 'floating-point-exception)
 141   #|
 142   (let* ((modes (context-floating-point-modes
 143                  (sb!alien:sap-alien context (* os-context-t))))
 144          (traps (logand (ldb float-exceptions-byte modes)
 145                         (ldb float-traps-byte modes))))
 146     (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
 147            (error 'division-by-zero))
 148           ((not (zerop (logand float-invalid-trap-bit traps)))
 149            (error 'floating-point-invalid-operation))
 150           ((not (zerop (logand float-overflow-trap-bit traps)))
 151            (error 'floating-point-overflow))
 152           ((not (zerop (logand float-underflow-trap-bit traps)))
 153            (error 'floating-point-underflow))
 154           ((not (zerop (logand float-inexact-trap-bit traps)))
 155            (error 'floating-point-inexact))
 156           #!+FreeBSD
 157           ((zerop (ldb float-exceptions-byte modes))
 158            ;; I can't tell what caused the exception!!
 159            (error 'floating-point-exception
 160                   :traps (getf (get-floating-point-modes) :traps)))
 161           (t
 162            (error "SIGFPE with no exceptions currently enabled?"))))
 163   |#
 164   )
 165
 166 ;;; Execute BODY with the floating point exceptions listed in TRAPS
 167 ;;; masked (disabled). TRAPS should be a list of possible exceptions
 168 ;;; which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
 169 ;;; :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The
 170 ;;; respective accrued exceptions are cleared at the start of the body
 171 ;;; to support their testing within, and restored on exit.
 172 (defmacro with-float-traps-masked (traps &body body)
 173   (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
 174         (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
 175         (trap-mask (dpb (lognot (float-trap-mask traps))
 176                         float-traps-byte #xffffffff))
 177         (exception-mask (dpb (lognot (sb!vm::float-trap-mask traps))
 178                              float-sticky-bits #xffffffff))
 179         (orig-modes (gensym)))
 180     `(let ((,orig-modes (floating-point-modes)))
 181       (unwind-protect
 182            (progn
 183              (setf (floating-point-modes)
 184                    (logand ,orig-modes ,(logand trap-mask exception-mask)))
 185              ,@body)
 186         ;; Restore the original traps and exceptions.
 187         (setf (floating-point-modes)
 188               (logior (logand ,orig-modes ,(logior traps exceptions))
 189                       (logand (floating-point-modes)
 190                               ,(logand trap-mask exception-mask))))))))