/[cmucl]/src/code/float-trap.lisp
ViewVC logotype

Contents of /src/code/float-trap.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide annotations)
Wed Dec 22 02:12:51 2010 UTC (3 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, HEAD
Changes since 1.38: +8 -1 lines
Merge changes from cross-sol-x86-2010-12-20 which adds support for
Solaris/x86.  There should be no functional changes for either other
x86 ports or for the sparc port.
1 ram 1.1 ;;; -*- Package: VM -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.5 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.39 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/float-trap.lisp,v 1.39 2010/12/22 02:12:51 rtoy Exp $")
9 ram 1.5 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; This file contains stuff for controlling floating point traps. It is
13 ram 1.3 ;;; IEEE float specific, but should work for pretty much any FPU where the
14     ;;; state fits in one word and exceptions are represented by bits being set.
15 ram 1.1 ;;;
16     ;;; Author: Rob MacLachlan
17     ;;;
18     (in-package "VM")
19 rtoy 1.36 (intl:textdomain "cmucl")
20    
21 ram 1.2 (export '(current-float-trap floating-point-modes sigfpe-handler))
22 ram 1.1 (in-package "EXTENSIONS")
23 dtc 1.10 (export '(set-floating-point-modes get-floating-point-modes
24     with-float-traps-masked))
25 ram 1.1 (in-package "VM")
26    
27     (eval-when (compile load eval)
28    
29     (defconstant float-trap-alist
30     (list (cons :underflow float-underflow-trap-bit)
31     (cons :overflow float-overflow-trap-bit)
32     (cons :inexact float-inexact-trap-bit)
33     (cons :invalid float-invalid-trap-bit)
34 dtc 1.12 (cons :divide-by-zero float-divide-by-zero-trap-bit)
35     #+x86 (cons :denormalized-operand float-denormal-trap-bit)))
36 ram 1.1
37     ;;; FLOAT-TRAP-MASK -- Internal
38     ;;;
39     ;;; Return a mask with all the specified float trap bits set.
40     ;;;
41     (defun float-trap-mask (names)
42     (reduce #'logior
43     (mapcar #'(lambda (x)
44     (or (cdr (assoc x float-trap-alist))
45 rtoy 1.38 (error (intl:gettext "Unknown float trap kind: ~S.") x)))
46 ram 1.1 names)))
47 ram 1.4
48     (defconstant rounding-mode-alist
49     (list (cons :nearest float-round-to-nearest)
50     (cons :zero float-round-to-zero)
51     (cons :positive-infinity float-round-to-positive)
52     (cons :negative-infinity float-round-to-negative)))
53 ram 1.1
54     ); Eval-When (Compile Load Eval)
55    
56    
57     ;;; Interpreter stubs.
58     ;;;
59 rtoy 1.34 #+(not x86)
60 rtoy 1.33 (progn
61 ram 1.1 (defun floating-point-modes () (floating-point-modes))
62 ram 1.3 (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
63 rtoy 1.33 )
64 ram 1.1
65 rtoy 1.34 #+(and x86 (not sse2))
66     (progn
67     (defun floating-point-modes ()
68     (let ((x87-modes (vm::x87-floating-point-modes)))
69     ;; Massage the bits from x87-floating-point-modes into the order
70     ;; that the rest of the system wants them to be. (Must match
71     ;; format in the SSE2 mxcsr register.)
72     (logior (ash (logand #x3f x87-modes) 7) ; control
73     (logand #x3f (ash x87-modes -16)))))
74     (defun (setf floating-point-modes) (new)
75     (let* ((rc (ldb float-rounding-mode new))
76     (x87-modes
77     (logior (ash (logand #x3f new) 16)
78     (ash rc 10)
79     (logand #x3f (ash new -7))
80 rtoy 1.35 ;; Set precision control to be 53-bit, always.
81     ;; (The compiler takes care of handling
82     ;; single-float precision, and we don't support
83     ;; long-floats.)
84     (ash 2 8))))
85 rtoy 1.34 (setf (x87-floating-point-modes) x87-modes)))
86     )
87    
88 rtoy 1.33 #+sse2
89     (progn
90     (defun floating-point-modes ()
91     ;; Combine the modes from the FPU and SSE2 units. Since the sse
92     ;; mode contains all of the common information we want, we massage
93     ;; the x87-modes to match, and then OR the x87 and sse2 modes
94     ;; together. Note: We ignore the rounding control bits from the
95     ;; FPU and only use the SSE2 rounding control bits.
96     (let* ((x87-modes (vm::x87-floating-point-modes))
97     (sse-modes (vm::sse2-floating-point-modes))
98     (final-mode (logior sse-modes
99     (ash (logand #x3f x87-modes) 7) ; control
100     (logand #x3f (ash x87-modes -16)))))
101    
102     final-mode))
103     (defun (setf floating-point-modes) (new-mode)
104     (declare (type (unsigned-byte 24) new-mode))
105     ;; Set the floating point modes for both X87 and SSE2. This
106     ;; include the rounding control bits.
107     (let* ((rc (ldb float-rounding-mode new-mode))
108     (x87-modes
109     (logior (ash (logand #x3f new-mode) 16)
110     (ash rc 10)
111     (logand #x3f (ash new-mode -7))
112 rtoy 1.35 ;; Set precision control to be 64-bit, always. We
113     ;; don't use the x87 registers with sse2, so this
114     ;; is ok and would be the correct setting if we
115     ;; ever support long-floats.
116 rtoy 1.33 (ash 3 8))))
117     (setf (vm::sse2-floating-point-modes) new-mode)
118     (setf (vm::x87-floating-point-modes) x87-modes))
119     new-mode)
120     )
121 ram 1.1
122     ;;; SET-FLOATING-POINT-MODES -- Public
123     ;;;
124 ram 1.4 (defun set-floating-point-modes (&key (traps nil traps-p)
125     (rounding-mode nil round-p)
126     (current-exceptions nil current-x-p)
127     (accrued-exceptions nil accrued-x-p)
128 cshapiro 1.31 (fast-mode nil fast-mode-p))
129 rtoy 1.37 "This function sets options controlling the floating-point hardware. If a
130 ram 1.4 keyword is not supplied, then the current value is preserved. Possible
131     keywords:
132    
133     :TRAPS
134 ram 1.1 A list of the exception conditions that should cause traps. Possible
135 dtc 1.12 exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
136     :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
137     all traps except :INEXACT are enabled.
138 ram 1.4
139     :ROUNDING-MODE
140     The rounding mode to use when the result is not exact. Possible values
141     are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
142     Initially, the rounding mode is :NEAREST.
143    
144     :CURRENT-EXCEPTIONS
145     :ACCRUED-EXCEPTIONS
146     These arguments allow setting of the exception flags. The main use is
147     setting the accrued exceptions to NIL to clear them.
148    
149     :FAST-MODE
150     Set the hardware's \"fast mode\" flag, if any. When set, IEEE
151     conformance or debuggability may be impaired. Some machines may not
152     have this feature, in which case the value is always NIL.
153    
154     GET-FLOATING-POINT-MODES may be used to find the floating point modes
155     currently in effect."
156     (let ((modes (floating-point-modes)))
157     (when traps-p
158     (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
159     (when round-p
160     (setf (ldb float-rounding-mode modes)
161     (or (cdr (assoc rounding-mode rounding-mode-alist))
162 rtoy 1.38 (error (intl:gettext "Unknown rounding mode: ~S.") rounding-mode))))
163 ram 1.4 (when current-x-p
164     (setf (ldb float-exceptions-byte modes)
165 rtoy 1.29 (float-trap-mask current-exceptions))
166 cshapiro 1.30 #+(and darwin ppc)
167 rtoy 1.29 (when (member :invalid current-exceptions)
168     ;; Clear out the bits for the detected invalid operation
169     (setf (ldb vm:float-invalid-op-1-byte modes) 0)))
170    
171 ram 1.4 (when accrued-x-p
172     (setf (ldb float-sticky-bits modes)
173 rtoy 1.29 (float-trap-mask accrued-exceptions))
174 cshapiro 1.30 #+(and darwin ppc)
175 rtoy 1.29 (when (member :invalid current-exceptions)
176     ;; Clear out the bits for the detected invalid operation
177     (setf (ldb vm:float-invalid-op-1-byte modes) 0)))
178 ram 1.4 (when fast-mode-p
179     (if fast-mode
180     (setq modes (logior float-fast-bit modes))
181     (setq modes (logand (lognot float-fast-bit) modes))))
182     (setf (floating-point-modes) modes))
183    
184 ram 1.1 (values))
185    
186    
187 ram 1.4 ;;; GET-FLOATING-POINT-MODES -- Public
188     ;;;
189     (defun get-floating-point-modes ()
190 rtoy 1.37 "This function returns a list representing the state of the floating point
191 ram 1.4 modes. The list is in the same format as the keyword arguments to
192     SET-FLOATING-POINT-MODES, i.e.
193     (apply #'set-floating-point-modes (get-floating-point-modes))
194    
195     sets the floating point modes to their current values (and thus is a no-op)."
196     (flet ((exc-keys (bits)
197     (macrolet ((frob ()
198     `(collect ((res))
199     ,@(mapcar #'(lambda (x)
200     `(when (logtest bits ,(cdr x))
201     (res ',(car x))))
202     float-trap-alist)
203     (res))))
204     (frob))))
205     (let ((modes (floating-point-modes)))
206     `(:traps ,(exc-keys (ldb float-traps-byte modes))
207     :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
208     rounding-mode-alist))
209     :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
210     :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
211 cshapiro 1.31 :fast-mode ,(logtest float-fast-bit modes)))))
212 ram 1.4
213    
214 ram 1.1 ;;; CURRENT-FLOAT-TRAP -- Interface
215     ;;;
216     (defmacro current-float-trap (&rest traps)
217 rtoy 1.37 "Current-Float-Trap Trap-Name*
218 ram 1.1 Return true if any of the named traps are currently trapped, false
219     otherwise."
220     `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
221     (floating-point-modes)))))
222 ram 1.2
223    
224     ;;; SIGFPE-HANDLER -- Interface
225     ;;;
226     ;;; Signal the appropriate condition when we get a floating-point error.
227     ;;;
228     (defun sigfpe-handler (signal code scp)
229 emarsden 1.24 (declare (ignore signal code)
230 wlott 1.6 (type system-area-pointer scp))
231     (let* ((modes (sigcontext-floating-point-modes
232     (alien:sap-alien scp (* unix:sigcontext))))
233 ram 1.4 (traps (logand (ldb float-exceptions-byte modes)
234     (ldb float-traps-byte modes))))
235 cshapiro 1.30 #+(and darwin ppc)
236 rtoy 1.27 (let ((new-modes modes))
237     ;; Clear out all exceptions and save them to the context.
238     ;;
239     ;; XXX: Should we just clear out the bits for the traps that are
240     ;; enabled? If we did that then the accrued exceptions would be
241     ;; correct.
242     (setf (ldb float-sticky-bits new-modes) 0)
243     ;; Clear out the various sticky invalid operation bits too.
244     ;;
245     ;; XXX: Should we only do that if the invalid trap is enabled?
246     (setf (ldb float-invalid-op-1-byte new-modes) 0)
247     (setf (ldb float-invalid-op-2-byte new-modes) 0)
248     (setf (floating-point-modes) new-modes)
249     (setf (sigcontext-floating-point-modes
250     (alien:sap-alien scp (* unix:sigcontext)))
251     new-modes))
252 rtoy 1.34
253 rtoy 1.33 #+sse2
254     (let* ((new-modes modes)
255     (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes)
256     traps)))
257     ;; Clear out the status for any enabled traps. With SSE2, if
258     ;; the current exception is enabled, the next FP instruction
259     ;; will cause the exception to be signaled again. Hence, we
260     ;; need to clear out the exceptions that we are handling here.
261     (setf (ldb float-exceptions-byte new-modes) new-exceptions)
262     ;; XXX: This seems not right. Shouldn't we be setting the modes
263     ;; in the sigcontext instead? This however seems to do what we
264     ;; want.
265     (setf (vm:floating-point-modes) new-modes))
266    
267 toy 1.21 (multiple-value-bind (fop operands)
268     (let ((sym (find-symbol "GET-FP-OPERANDS" "VM")))
269     (if (fboundp sym)
270 rtoy 1.28 (funcall sym (alien:sap-alien scp (* unix:sigcontext)) modes)
271 toy 1.21 (values nil nil)))
272     (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
273     (error 'division-by-zero
274     :operation fop
275     :operands operands))
276     ((not (zerop (logand float-invalid-trap-bit traps)))
277     (error 'floating-point-invalid-operation
278     :operation fop
279     :operands operands))
280     ((not (zerop (logand float-overflow-trap-bit traps)))
281     (error 'floating-point-overflow
282     :operation fop
283     :operands operands))
284     ((not (zerop (logand float-underflow-trap-bit traps)))
285     (error 'floating-point-underflow
286     :operation fop
287     :operands operands))
288     ((not (zerop (logand float-inexact-trap-bit traps)))
289 gerd 1.22 (error 'floating-point-inexact
290 toy 1.21 :operation fop
291     :operands operands))
292     (t
293 rtoy 1.39 ;; It looks like the sigcontext on Solaris/x86 doesn't
294     ;; actually save the status word of the FPU. The
295     ;; operands also seem to be missing. Signal a general
296     ;; arithmetic error.
297     #+solaris
298     (error 'arithmetic-error :operands operands)
299     #-solaris
300 rtoy 1.38 (error (intl:gettext "SIGFPE with no exceptions currently enabled?")))))))
301 toy 1.21
302 dtc 1.10 ;;; WITH-FLOAT-TRAPS-MASKED -- Public
303     ;;;
304     (defmacro with-float-traps-masked (traps &body body)
305 rtoy 1.37 "Execute BODY with the floating point exceptions listed in TRAPS
306 dtc 1.11 masked (disabled). TRAPS should be a list of possible exceptions
307     which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
308 dtc 1.13 :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
309     accrued exceptions are cleared at the start of the body to support
310 dtc 1.14 their testing within, and restored on exit."
311 dtc 1.13 (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
312     (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
313     (trap-mask (dpb (lognot (float-trap-mask traps))
314 dtc 1.10 float-traps-byte #xffffffff))
315     (exception-mask (dpb (lognot (vm::float-trap-mask traps))
316 pw 1.16 float-sticky-bits #xffffffff))
317 rtoy 1.29 ;; On ppc if we are masking the invalid trap, we need to make
318     ;; sure we wipe out the various individual sticky bits
319     ;; representing the invalid operation. Otherwise, if we
320     ;; enable the invalid trap later, these sticky bits will cause
321     ;; an exception.
322     #+ppc
323     (invalid-mask (if (member :invalid traps)
324     (dpb 0 vm:float-invalid-op-1-byte #xffffffff)
325     #xffffffff))
326 pw 1.16 (orig-modes (gensym)))
327     `(let ((,orig-modes (floating-point-modes)))
328 dtc 1.10 (unwind-protect
329     (progn
330 dtc 1.13 (setf (floating-point-modes)
331 pw 1.16 (logand ,orig-modes ,(logand trap-mask exception-mask)))
332 dtc 1.10 ,@body)
333 dtc 1.13 ;; Restore the original traps and exceptions.
334 dtc 1.10 (setf (floating-point-modes)
335 pw 1.16 (logior (logand ,orig-modes ,(logior traps exceptions))
336 dtc 1.13 (logand (floating-point-modes)
337 toy 1.20 ,(logand trap-mask exception-mask)
338 rtoy 1.29 #+ppc
339     ,invalid-mask
340 toy 1.20 #+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))

  ViewVC Help
Powered by ViewVC 1.1.5