X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-exception.lisp;h=0c5e7b7a97321d89af05d7c46020f9f94e5eed09;hb=ebf551c18ccd32e6fa9349cd5edb5b2a51e92ac2;hp=f01acf731bda22c0503af558210804b57e73f4a0;hpb=b43b6e70ce48d959d77f7f56be9d11aa101fdd7d;p=sbcl.git diff --git a/src/code/target-exception.lisp b/src/code/target-exception.lisp index f01acf7..0c5e7b7 100644 --- a/src/code/target-exception.lisp +++ b/src/code/target-exception.lisp @@ -34,25 +34,42 @@ ;;; ;;; This specific bit of functionality may well be implemented entirely ;;; in the runtime. -#| +#|| (defun sigint-%break (format-string &rest format-arguments) (flet ((break-it () (apply #'%break 'sigint format-string format-arguments))) (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it))) -|# +||# -;;; Map Windows Exception code to condition names +;;; Map Windows Exception code to condition names: symbols or strings (defvar *exception-code-map* - (list - ;; Floating point exceptions - (cons +exception-flt-divide-by-zero+ 'division-by-zero) - (cons +exception-flt-invalid-operation+ 'floating-point-invalid-operation) - (cons +exception-flt-underflow+ 'floating-point-underflow) - (cons +exception-flt-overflow+ 'floating-point-overflow) - (cons +exception-flt-inexact-result+ 'floating-point-inexact) - (cons +exception-flt-denormal-operand+ 'floating-point-exception) - (cons +exception-flt-stack-check+ 'floating-point-exception) - (cons +exception-stack-overflow+ 'sb!kernel::control-stack-exhausted))) + (macrolet ((cons-name (symbol) + `(cons ,symbol ,(remove #\+ (substitute #\_ #\- (string symbol)))))) + (list + ;; Floating point exceptions + (cons +exception-flt-divide-by-zero+ 'division-by-zero) + (cons +exception-flt-invalid-operation+ 'floating-point-invalid-operation) + (cons +exception-flt-underflow+ 'floating-point-underflow) + (cons +exception-flt-overflow+ 'floating-point-overflow) + (cons +exception-flt-inexact-result+ 'floating-point-inexact) + (cons +exception-flt-denormal-operand+ 'floating-point-exception) + (cons +exception-flt-stack-check+ 'floating-point-exception) + ;; Stack overflow + (cons +exception-stack-overflow+ 'sb!kernel::control-stack-exhausted) + ;; Various + (cons-name +exception-single-step+) + (cons-name +exception-access-violation+) ; FIXME: should turn into MEMORY-FAULT-ERROR + ; plus the faulting address + (cons-name +exception-array-bounds-exceeded+) + (cons-name +exception-breakpoint+) + (cons-name +exception-datatype-misalignment+) + (cons-name +exception-illegal-instruction+) + (cons-name +exception-in-page-error+) + (cons-name +exception-int-divide-by-zero+) + (cons-name +exception-int-overflow+) + (cons-name +exception-invalid-disposition+) + (cons-name +exception-noncontinuable-exception+) + (cons-name +exception-priv-instruction+)))) (define-alien-type () (struct exception-record @@ -73,7 +90,7 @@ (sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame)))) (if condition-name (error condition-name) - (error "An exception occurred in context ~S: ~S. (Exception code: ~S)" + (error "An exception occurred in context ~S: ~S. (Exception code: ~S)" context-sap exception-record-sap code)))) ;;;; etc. @@ -84,3 +101,103 @@ ;;; I don't know if we still need this or not. Better safe for now. (defun receive-pending-interrupt () (receive-pending-interrupt)) + +(in-package "SB!UNIX") + +#!+sb-thread +(progn + (defun receive-pending-interrupt () + (receive-pending-interrupt)) + + (defmacro with-interrupt-bindings (&body body) + `(let* + ;; KLUDGE: Whatever is on the PCL stacks before the interrupt + ;; handler runs doesn't really matter, since we're not on the + ;; same call stack, really -- and if we don't bind these (esp. + ;; the cache one) we can get a bogus metacircle if an interrupt + ;; handler calls a GF that was being computed when the interrupt + ;; hit. + ((sb!pcl::*cache-miss-values-stack* nil) + (sb!pcl::*dfun-miss-gfs-on-stack* nil)) + ,@body)) + +;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit. + (defmacro nlx-protect (protected-form &rest cleanup-froms) + (with-unique-names (completep) + `(let ((,completep nil)) + (without-interrupts + (unwind-protect + (progn + (allow-with-interrupts + ,protected-form) + (setq ,completep t)) + (unless ,completep + ,@cleanup-froms)))))) + + (declaim (inline %unblock-deferrable-signals)) + (sb!alien:define-alien-routine ("unblock_deferrable_signals" + %unblock-deferrable-signals) + sb!alien:void + (where sb!alien:unsigned) + (old sb!alien:unsigned)) + + (defun block-deferrable-signals () + (%block-deferrable-signals 0 0)) + + (defun unblock-deferrable-signals () + (%unblock-deferrable-signals 0 0)) + + (declaim (inline %block-deferrables-and-return-mask %apply-sigmask)) + (sb!alien:define-alien-routine ("block_deferrables_and_return_mask" + %block-deferrables-and-return-mask) + sb!alien:unsigned) + (sb!alien:define-alien-routine ("apply_sigmask" + %apply-sigmask) + sb!alien:void + (mask sb!alien:unsigned)) + + (defmacro without-interrupts/with-deferrables-blocked (&body body) + (let ((mask-var (gensym))) + `(without-interrupts + (let ((,mask-var (%block-deferrables-and-return-mask))) + (unwind-protect + (progn ,@body) + (%apply-sigmask ,mask-var)))))) + + (defun invoke-interruption (function) + (without-interrupts + ;; Reset signal mask: the C-side handler has blocked all + ;; deferrable signals before funcalling into lisp. They are to be + ;; unblocked the first time interrupts are enabled. With this + ;; mechanism there are no extra frames on the stack from a + ;; previous signal handler when the next signal is delivered + ;; provided there is no WITH-INTERRUPTS. + (let ((sb!unix::*unblock-deferrables-on-enabling-interrupts-p* t)) + (with-interrupt-bindings + (let ((sb!debug:*stack-top-hint* + (nth-value 1 (sb!kernel:find-interrupted-name-and-frame)))) + (allow-with-interrupts + (nlx-protect + (funcall function) + ;; We've been running with deferrables + ;; blocked in Lisp called by a C signal + ;; handler. If we return normally the sigmask + ;; in the interrupted context is restored. + ;; However, if we do an nlx the operating + ;; system will not restore it for us. + (when sb!unix::*unblock-deferrables-on-enabling-interrupts-p* + ;; This means that storms of interrupts + ;; doing an nlx can still run out of stack. + (unblock-deferrable-signals))))))))) + + (defmacro in-interruption ((&key) &body body) + #!+sb-doc + "Convenience macro on top of INVOKE-INTERRUPTION." + `(dx-flet ((interruption () ,@body)) + (invoke-interruption #'interruption))) + + (defun sb!kernel:signal-cold-init-or-reinit () + #!+sb-doc + "Enable all the default signals that Lisp knows how to deal with." + (unblock-deferrable-signals) + (values)))