- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][master] Indent nicely.
by Raymond Toy 18 Jan '16

18 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 909ad007 by Raymond Toy at 2016-01-17T20:57:41Z Indent nicely. - - - - - 1 changed file: - src/code/bignum.lisp Changes: ===================================== src/code/bignum.lisp ===================================== --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -3721,5 +3721,5 @@ friends is working. (%shrd x carry-in shift) #-x86 (ldb (byte vm:word-bits 0) - (logior (ash x (- shift)) - (ash carry-in (- vm:word-bits shift))))) + (logior (ash x (- shift)) + (ash carry-in (- vm:word-bits shift))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/909ad0074d079350b658f0f66…

1 0

[Git][cmucl/cmucl][master] Add bignum::%shld and bignum::%shrd
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: ddc980d5 by Raymond Toy at 2016-01-16T14:34:19Z Add bignum::%shld and bignum::%shrd These are useful for multi-precision shifts. For x86, we can use the shld and shrd instructions. For others, we just use basic logical operations. - - - - - 3 changed files: - src/code/bignum.lisp - src/compiler/generic/vm-fndb.lisp - src/compiler/x86/arith.lisp Changes: ===================================== src/code/bignum.lisp ===================================== --- a/src/code/bignum.lisp +++ b/src/code/bignum.lisp @@ -3697,3 +3697,29 @@ friends is working. (unless (= newlen len) (%bignum-set-length result newlen)) result)) + +;; Shift X left by Shift bits, shifting in bits from Carry-in. +;; Basically treat x:carry-in as a 64-bit value and shift it left, +;; returning the top bignum-type bits. +(defun %shld (x carry-in shift) + (declare (type bignum-element-type x carry-in) + (type (unsigned-byte 5) shift)) + #+x86 + (%shld x carry-in shift) + #-x86 + (ldb (byte vm:word-bits 0) + (logior (ash x shift) + (ash carry-in (- shift vm:word-bits))))) + +;; Shift X right by Shift bits, shifting in bits from Carry-in. +;; Basically treat carry-in:x as a 64-bit value and shift it right, +;; returning the low bignum-type bits. +(defun %shrd (x carry-in shift) + (declare (type bignum-element-type x carry-in) + (type (unsigned-byte 5) shift)) + #+x86 + (%shrd x carry-in shift) + #-x86 + (ldb (byte vm:word-bits 0) + (logior (ash x (- shift)) + (ash carry-in (- vm:word-bits shift))))) ===================================== src/compiler/generic/vm-fndb.lisp ===================================== --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -288,6 +288,13 @@ (bignum-element-type (mod #+amd64 64 #-amd64 32)) bignum-element-type (foldable flushable movable)) + +#+x86 +(defknown (bignum::%shld bignum::%shrd) + (bignum-element-type bignum-element-type (unsigned-byte 5)) + bignum-element-type + (foldable flushable movable)) + ;;;; Bit-bashing routines. ===================================== src/compiler/x86/arith.lisp ===================================== --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1579,6 +1579,86 @@ (inst mov tmp y) (inst shr tmp 18) (inst xor y tmp))) + +(define-vop (bignum-shld) + (:policy :fast-safe) + (:translate bignum::%shld) + (:args (x :scs (unsigned-reg) :target r) + (shift-in :scs (unsigned-reg)) + (amount :scs (unsigned-reg) :target cl)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from (:argument 2) :to (:result 0)) cl) + (:generator 4 + (move cl amount) + (cond ((location= x r) + (inst shld x shift-in :cl)) + (t + (move temp x) + (inst shld temp shift-in :cl) + (move r temp))))) + +(define-vop (bignum-shld-c) + (:policy :fast-safe) + (:translate bignum::%shld) + (:args (x :scs (unsigned-reg) :target r) + (shift-in :scs (unsigned-reg))) + (:info shift) + (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:generator 3 + (cond ((location= x r) + (inst shld x shift-in shift)) + (t + (move temp x) + (inst shld temp shift-in shift) + (move r temp))))) + +(define-vop (bignum-shrd) + (:policy :fast-safe) + (:translate bignum::%shrd) + (:args (x :scs (unsigned-reg) :target r) + (shift-in :scs (unsigned-reg)) + (amount :scs (unsigned-reg) :target cl)) + (:arg-types unsigned-num unsigned-num unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:temporary (:sc unsigned-reg :offset ecx-offset + :from (:argument 2) :to (:result 0)) cl) + (:generator 4 + (move cl amount) + (cond ((location= x r) + (inst shrd x shift-in :cl)) + (t + (move temp x) + (inst shrd temp shift-in :cl) + (move r temp))))) + +(define-vop (bignum-shrd-c) + (:policy :fast-safe) + (:translate bignum::%shrd) + (:args (x :scs (unsigned-reg)) + (shift-in :scs (unsigned-reg))) + (:info shift) + (:arg-types unsigned-num unsigned-num (:constant (unsigned-byte 5))) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg :from (:argument 0) :to (:result 0)) temp) + (:generator 3 + (cond ((location= x r) + (inst shrd x shift-in shift)) + (t + (move temp x) + (inst shrd temp shift-in shift) + (move r temp))))) + + ;;; Modular arithmetic ;;; logical operations View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/ddc980d5637cb21305e35c1a9…

1 0

[Git][cmucl/cmucl][master] Fix up shld/shrd instructions.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 8058d410 by Raymond Toy at 2016-01-16T13:01:37Z Fix up shld/shrd instructions. o Need to define a new instruction format for these double shifts; they look like ext-reg-reg/mem but there's no width field. o Clean up emit-double-shift slightly. o Update double-shift-inst-printer-list to support both immediate shift or shifts in CL. - - - - - 1 changed file: - src/compiler/x86/insts.lisp Changes: ===================================== src/compiler/x86/insts.lisp ===================================== --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -859,6 +859,18 @@ ;; optional fields (imm)) +;; Double shift instructions. Like ext-reg-reg/mem but there's no +;; width field. +(disassem:define-instruction-format (ext-reg-reg/mem-shift 24) + (prefix :field (byte 8 0) :value #b00001111) + (op :field (byte 8 8)) + (reg/mem :fields (list (byte 2 22) (byte 3 16)) + :type 'reg/mem) + (reg :field (byte 3 19) :type 'reg) + ;; optional fields + (imm)) + + ;;; ---------------------------------------------------------------- ;;; this section added by jrd, for fp instructions. @@ -1535,24 +1547,22 @@ (defun emit-double-shift (segment opcode dst src amt) (let ((size (matching-operand-size dst src))) (when (eq size :byte) - (error "Double shifts can only be used with words.")) + (error "Double shifts cannot be used with byte registers.")) (maybe-emit-operand-size-prefix segment size) (emit-byte segment #b00001111) (emit-byte segment (dpb opcode (byte 1 3) (if (eq amt :cl) #b10100101 #b10100100))) - #+nil - (emit-ea segment dst src) - (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this + (emit-ea segment dst (reg-tn-encoding src)) (unless (eq amt :cl) (emit-byte segment amt)))) (eval-when (compile eval) (defun double-shift-inst-printer-list (op) - `(#+nil - (ext-reg-reg/mem-imm ((op ,(logior op #b100)) - (imm nil :type signed-imm-byte))) - (ext-reg-reg/mem ((op ,(logior op #b101))) - (:name :tab reg/mem ", " 'cl))))) + `((ext-reg-reg/mem-shift ((op ,(logior op #b100)) + (imm nil :type signed-imm-byte)) + (:name :tab reg/mem ", " reg ", " imm)) + (ext-reg-reg/mem-shift ((op ,(logior op #b101))) + (:name :tab reg/mem ", " reg ", " 'cl))))) (define-instruction shld (segment dst src amt) (:declare (type (or (member :cl) (mod 32)) amt)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/8058d410e86a77a6839d4c422…

1 0

[Git][cmucl/cmucl][master] Regenerated.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 06a68321 by Raymond Toy at 2016-01-16T12:58:43Z Regenerated. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -6654,7 +6654,9 @@ msgid "" msgstr "" #: src/code/save.lisp -msgid "An alist mapping environment variables (as keywords) to either values" +msgid "" +"An alist mapping each environment variable (as a keyword) to its\n" +" value." msgstr "" #: src/code/save.lisp @@ -13122,8 +13124,9 @@ msgid "" "\n" " The keyword arguments have the following meanings:\n" " :env -\n" -" An A-LIST mapping keyword environment variables to simple-string\n" -" values.\n" +" An A-LIST mapping keyword environment variables to\n" +" simple-string values. This is the shell environment for\n" +" Program. Defaults to *environment-list*.\n" " :wait -\n" " If non-NIL (default), wait until the created process finishes. If\n" " NIL, continue running Lisp until the program finishes.\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/06a683219621cc8e381b3d6ee…

1 0

[Git][cmucl/cmucl][master] Add comment on why RESTORE_FPU is needed.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6feaee2d by Raymond Toy at 2016-01-16T08:37:03Z Add comment on why RESTORE_FPU is needed. - - - - - 1 changed file: - src/lisp/x86-arch.c Changes: ===================================== src/lisp/x86-arch.c ===================================== --- a/src/lisp/x86-arch.c +++ b/src/lisp/x86-arch.c @@ -320,6 +320,12 @@ sigtrap_handler(HANDLER_ARGS) /* This is just for info in case monitor wants to print an approx */ current_control_stack_pointer = (unsigned long *) SC_SP(os_context); + + /* + * In many places in the switch below, we eventually throw instead + * of returning from the signal handler. So, just in case, set + * the current FPU modes from the saved context. + */ RESTORE_FPU(os_context); /* View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/6feaee2df686c62509f7c2292…

1 0

[Git][cmucl/cmucl][master] Actually remove RESTORE_FPU's that were #if'ed out.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 17932a00 by Raymond Toy at 2016-01-16T08:33:55Z Actually remove RESTORE_FPU's that were #if'ed out. - - - - - 1 changed file: - src/lisp/interrupt.c Changes: ===================================== src/lisp/interrupt.c ===================================== --- a/src/lisp/interrupt.c +++ b/src/lisp/interrupt.c @@ -252,10 +252,6 @@ interrupt_handle_now(HANDLER_ARGS) handler = interrupt_handlers[signal]; -#if 0 - RESTORE_FPU(context); -#endif - if (handler.c == (void (*)(HANDLER_ARGS)) SIG_IGN) return; @@ -335,9 +331,6 @@ 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); } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/17932a00d691bb2dada5da81f…

1 0

[Git][cmucl/cmucl][master] Better description for run-program :env
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: f613124b by Raymond Toy at 2016-01-16T08:24:09Z Better description for run-program :env Fix #18. - - - - - 1 changed file: - src/code/run-program.lisp Changes: ===================================== src/code/run-program.lisp ===================================== --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -471,8 +471,9 @@ The keyword arguments have the following meanings: :env - - An A-LIST mapping keyword environment variables to simple-string - values. + An A-LIST mapping keyword environment variables to + simple-string values. This is the shell environment for + Program. Defaults to *environment-list*. :wait - If non-NIL (default), wait until the created process finishes. If NIL, continue running Lisp until the program finishes. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/f613124b7479c364d557e5f70…

1 0

[Git][cmucl/cmucl][master] Better docstring for *environment-list*
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6ac8b5f6 by Raymond Toy at 2016-01-16T08:18:00Z Better docstring for *environment-list* Fix #17. - - - - - 1 changed file: - src/code/save.lisp Changes: ===================================== src/code/save.lisp ===================================== --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -36,7 +36,8 @@ might not be.") (defvar *environment-list* nil - "An alist mapping environment variables (as keywords) to either values") + "An alist mapping each environment variable (as a keyword) to its + value.") (defvar *environment-list-initialized* nil "Non-NIL if environment-init has been called") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/6ac8b5f6ee9fd9553d6ed2885…

1 0

[Git][cmucl/cmucl][master] 6 commits: Handle FP exceptions better.
by Raymond Toy 16 Jan '16

16 Jan '16

Raymond Toy pushed to branch master at cmucl / cmucl Commits: e63bc1e9 by Raymond Toy at 2016-01-09T19:00:37Z Handle FP exceptions better. Don't restore the fpu state from the context in the interrupt handler code (interrupt_handle_now) because that just makes the fpu state the same as the sigcontext that received the exception. I think this was done to reset the x87 fpu precision to 53-bit so that lisp can continue with default double-float rounding. This isn't needed anymore since lisp doesn't use x87 anymore. In SIGFPE-HANDLER, don't modify the current fp state based on the state from the sigcontext. These two items cause the arithmetic-error exception printer to trigger inexact when printing out the args. We add a few debugging prints for now so we can see what the FP state is in the handler. Remove them later. - - - - - da2ff74d by Raymond Toy at 2016-01-10T14:13:10Z Handle FPU exceptions better. In sigfpe-handler, don't modify the modes; just use whatever they are. (They should be the default values.) In with-float-traps-*, actually just restore the floating-point mode to the exact original mode instead of trying to mask things out. - - - - - d9763e90 by Raymond Toy at 2016-01-10T15:42:41Z In WITH-FLOAT-TRAPS-*, remove the unused junk modifying the state. We just want to return the original modes, so remove all the old commented out stuff that was modifying the original modes to some strange state. This makes a lot more sense to me if WITH-FLOAT-TRAPS-* actually restored the modes exactly as they were before running the body. - - - - - d7850f57 by Raymond Toy at 2016-01-12T21:21:40Z Restore the FPU state before exiting. Put an unwind-protect around the error calls. The cleanup form restores the floating-point modes from the sigcontext so that the mode is restored. This is needed, I think, because we throw so that the signal handler doesn't return so the sigcontext isn't restored. If we don't restore the fpu state, it's set to the default processor state. We want the default state when calling error. In this way, things like (* 1d300 1d300) signals an overflow, and when we throw to top-level, the floating-point modes are restored to their original values they had before. - - - - - 1fab9bf3 by Raymond Toy at 2016-01-13T21:34:39Z Clean up sigfpe-handler; add comments. - - - - - 94bb2d9d by Raymond Toy at 2016-01-16T16:02:25Z Merge branch 'rtoy-15-handle-fpu-exceptions' into 'master' Handle FPU exceptions better Fix #15 Handle FPU exceptions better in sigfpe-handler. Linux now passes all of the tests, including the inexact tests. We can correctly print out the operands (if available) when we receive an inexact exception. The floating point modes are preserved as much as possible when we throw from an arithmetic-error. See merge request !7 - - - - - 2 changed files: - src/code/float-trap.lisp - src/lisp/interrupt.c Changes: ===================================== src/code/float-trap.lisp ===================================== --- 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 ===================================== src/lisp/interrupt.c ===================================== --- 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); } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/5c10ab93105fa6e095bbcbb0…

1 0

[Git][cmucl/cmucl][rtoy-15-handle-fpu-exceptions] Clean up sigfpe-handler; add comments.
by Raymond Toy 14 Jan '16

14 Jan '16

Raymond Toy pushed to branch rtoy-15-handle-fpu-exceptions at cmucl / cmucl Commits: 1fab9bf3 by Raymond Toy at 2016-01-13T21:34:39Z Clean up sigfpe-handler; add comments. - - - - - 1 changed file: - src/code/float-trap.lisp Changes: ===================================== src/code/float-trap.lisp ===================================== --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -312,7 +312,6 @@ ;;; ;;; Signal the appropriate condition when we get a floating-point error. ;;; -(defvar *debug-sigfpe-handler* nil) (defun sigfpe-handler (signal code scp) (declare (ignore signal) (type system-area-pointer scp)) @@ -385,54 +384,53 @@ (error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)" code)))) ;; Cleanup - #+(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) - #+nil - (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. - - (when *debug-sigfpe-handler* - (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)))))) + #+(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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1fab9bf37ce138dba85e5fb85…

1 0