;;;
;;; 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)))
-|#
+||#
\f
-;;; 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
;;; 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)))
projects / sbcl.git / blobdiff