diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 6ed3d03602c8bd005e214a6b7014779950869a19..b9dadf91083db730e4f90f64e2159a0a1134fc6e 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -319,102 +319,118 @@ (alien:sap-alien scp (* unix:sigcontext)))) (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) - #+(and darwin ppc) - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) - ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; Clear out all exceptions and save them to the context. - ;; - ;; XXX: Should we just clear out the bits for the traps that are - ;; enabled? If we did that then the accrued exceptions would be - ;; correct. - (setf (ldb float-sticky-bits new-modes) 0) - ;; Clear out the various sticky invalid operation bits too. - ;; - ;; XXX: Should we only do that if the invalid trap is enabled? - (setf (ldb float-invalid-op-1-byte new-modes) 0) - (setf (ldb float-invalid-op-2-byte new-modes) 0) - ;; Clear the FP exception summary bit too. - (setf (ldb float-exceptions-summary-byte new-modes) 0) - ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) - (setf (floating-point-modes) new-modes) - (setf (sigcontext-floating-point-modes - (alien:sap-alien scp (* unix:sigcontext))) - new-modes)) - - #+sse2 - (let* ((new-modes modes) - (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) - traps))) - ;; Clear out the status for any enabled traps. With SSE2, if - ;; the current exception is enabled, the next FP instruction - ;; will cause the exception to be signaled again. Hence, we - ;; need to clear out the exceptions that we are handling here. - (setf (ldb float-exceptions-byte new-modes) new-exceptions) - ;; XXX: This seems not right. Shouldn't we be setting the modes - ;; in the sigcontext instead? This however seems to do what we - ;; want. - (setf (vm:floating-point-modes) new-modes)) + (multiple-value-bind (fop operands) (let ((sym (find-symbol "GET-FP-OPERANDS" "VM"))) (if (fboundp sym) (funcall sym (alien:sap-alien scp (* unix:sigcontext)) modes) (values nil nil))) - (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero - :operation fop - :operands operands)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation - :operation fop - :operands operands)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow - :operation fop - :operands operands)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow - :operation fop - :operands operands)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'floating-point-inexact - :operation fop - :operands operands)) - #+x86 - ((not (zerop (logand float-denormal-trap-bit traps))) - (error 'floating-point-denormal-operand - :operation fop - :operands operands)) - (t - ;; It looks like the sigcontext on Solaris/x86 doesn't - ;; actually save the status word of the FPU. The - ;; operands also seem to be missing. Signal a general - ;; arithmetic error. - #+(and x86 solaris) - (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" - code) - ;; For all other x86 ports, we should only get here if - ;; the SIGFPE was caused by an integer overflow on - ;; division. For sparc and ppc, I (rtoy) don't think - ;; there's any other way to get here since integer - ;; overflows aren't signaled. - ;; - ;; In that case, FOP should be /, so we can generate a - ;; nice arithmetic-error. It's possible to use CODE, - ;; which is supposed to indicate what caused the - ;; exception, but each OS is different, so we don't; FOP - ;; can tell us. - #-(and x86 solaris) - (if fop - (error 'arithmetic-error - :operation fop - :operands operands) - (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" - code))))))) + ;; Don't let throws get away without resetting the + ;; floating-point modes back to the original values which we get + ;; from the sigcontext. Because we can throw, we never return + ;; from the signal handler so the sigcontext is never restored. + ;; This means we need to restore the fpu state ourselves. + (unwind-protect + (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) + (error 'division-by-zero + :operation fop + :operands operands)) + ((not (zerop (logand float-invalid-trap-bit traps))) + (error 'floating-point-invalid-operation + :operation fop + :operands operands)) + ((not (zerop (logand float-overflow-trap-bit traps))) + (error 'floating-point-overflow + :operation fop + :operands operands)) + ((not (zerop (logand float-underflow-trap-bit traps))) + (error 'floating-point-underflow + :operation fop + :operands operands)) + ((not (zerop (logand float-inexact-trap-bit traps))) + (error 'floating-point-inexact + :operation fop + :operands operands)) + #+x86 + ((not (zerop (logand float-denormal-trap-bit traps))) + (error 'floating-point-denormal-operand + :operation fop + :operands operands)) + (t + ;; It looks like the sigcontext on Solaris/x86 doesn't + ;; actually save the status word of the FPU. The + ;; operands also seem to be missing. Signal a general + ;; arithmetic error. + #+(and x86 solaris) + (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" + code) + ;; For all other x86 ports, we should only get here if + ;; the SIGFPE was caused by an integer overflow on + ;; division. For sparc and ppc, I (rtoy) don't think + ;; there's any other way to get here since integer + ;; overflows aren't signaled. + ;; + ;; In that case, FOP should be /, so we can generate a + ;; nice arithmetic-error. It's possible to use CODE, + ;; which is supposed to indicate what caused the + ;; exception, but each OS is different, so we don't; FOP + ;; can tell us. + #-(and x86 solaris) + (if fop + (error 'arithmetic-error + :operation fop + :operands operands) + (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" + code)))) + ;; Cleanup + (let* ((new-modes modes) + (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) + traps))) + #+(and darwin ppc) + (progn + ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) + ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + ;; Clear out all exceptions. + ;; + ;; XXX: Should we just clear out the bits for the traps that are + ;; enabled? If we did that then the accrued exceptions would be + ;; correct. + (setf (ldb float-sticky-bits new-modes) 0) + ;; Clear out the various sticky invalid operation bits too. + ;; + ;; XXX: Should we only do that if the invalid trap is enabled? + (setf (ldb float-invalid-op-1-byte new-modes) 0) + (setf (ldb float-invalid-op-2-byte new-modes) 0) + ;; Clear the FP exception summary bit too. + (setf (ldb float-exceptions-summary-byte new-modes) 0) + ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) + (setf (floating-point-modes) new-modes)) + + #+sse2 + (progn + ;; Clear out the status for any enabled traps. With SSE2, if + ;; the current exception is enabled, the next FP instruction + ;; will cause the exception to be signaled again. Hence, we + ;; need to clear out the exceptions that we are handling here. + (setf (ldb float-exceptions-byte new-modes) new-exceptions) + #+nil + (progn + (format *debug-io* "sigcontext modes: #x~4x (~A)~%" + modes (decode-floating-point-modes modes)) + (format *debug-io* "current modes: #x~4x (~A)~%" + (vm:floating-point-modes) (get-floating-point-modes)) + (format *debug-io* "new modes: #x~x (~A)~%" + new-modes (decode-floating-point-modes new-modes))) + (setf (vm:floating-point-modes) new-modes)) + + #-(or sse2 (and darwin ppc)) + (progn + ;; Apparently nothing needed for sparc it seems The FPU + ;; state in the signal handler is unchanged and it seems we + ;; don't need to reset it any way when we throw out. + )))))) (macrolet ((with-float-traps (name merge-traps docstring) @@ -440,6 +456,10 @@ ;; representing the invalid operation. Otherwise, if we ;; enable the invalid trap later, these sticky bits will cause ;; an exception. + ;; + ;; FIXME: Consider removing these for ppc. Since + ;; we now restore the original modes exactly, I + ;; don't think these are needed anymore. #+ppc (invalid-mask (if (member :invalid traps) (dpb 0 @@ -456,14 +476,8 @@ (logand (,',merge-traps ,orig-modes ,trap-mask) ,exception-mask))) ,@body) - ;; Restore the original traps and exceptions. - (setf (floating-point-modes) - (logior (logand ,orig-modes ,(logior traps exceptions)) - (logand (floating-point-modes) - ,(logand trap-mask exception-mask) - #+ppc - ,invalid-mask - #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))))))) + ;; Restore the modes exactly as they were. + (setf (floating-point-modes) ,orig-modes))))))))) ;; WITH-FLOAT-TRAPS-MASKED -- Public (with-float-traps masked logand diff --git a/src/lisp/interrupt.c b/src/lisp/interrupt.c index a87bc579a1481e56851138133d510d581a3eaeec..e28209cda3dc5afad2d2b0e0355f2216e4830b86 100644 --- a/src/lisp/interrupt.c +++ b/src/lisp/interrupt.c @@ -252,7 +252,9 @@ interrupt_handle_now(HANDLER_ARGS) handler = interrupt_handlers[signal]; +#if 0 RESTORE_FPU(context); +#endif if (handler.c == (void (*)(HANDLER_ARGS)) SIG_IGN) return; @@ -333,7 +335,9 @@ maybe_now_maybe_later(HANDLER_ARGS) setup_pending_signal(signal, code, context); arch_set_pseudo_atomic_interrupted(context); } else { +#if 0 RESTORE_FPU(context); +#endif interrupt_handle_now(signal, code, context); }