X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=c555dd2f57b83034c8ecaf0932b114d321d9e3eb;hb=f3a7c6b54880895d1598b1844d7e6eba98af9e53;hp=8308012d8f324e9a1a4b0c5c2f7d09be8bea2dc8;hpb=d44781425345e5254a15200a809977944aa7ff00;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 8308012..c555dd2 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -11,19 +11,36 @@ (in-package "SB!UNIX") -(defun invoke-interruption (function) - (without-interrupts - (sb!unix::reset-signal-mask) - (funcall function))) +(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)) -(defmacro in-interruption ((&rest args) &body body) +(defun invoke-interruption (function) + (with-interrupt-bindings + (without-interrupts + ;; Reset signal mask: the C-side handler has blocked all + ;; deferrable interrupts before arranging return to lisp. This is + ;; safe because we can't get a pending interrupt before we unblock + ;; signals. + ;; + ;; FIXME: Should we not reset the _entire_ mask, but just + ;; restore it to the state before we got the interrupt? + (reset-signal-mask) + (allow-with-interrupts (funcall function))))) + +(defmacro in-interruption ((&key) &body body) #!+sb-doc "Convenience macro on top of INVOKE-INTERRUPTION." - `(invoke-interruption (lambda () ,@body) ,@args)) - -;;; These should probably be somewhere, but I don't know where. -(defconstant sig_dfl 0) -(defconstant sig_ign 1) + `(dx-flet ((interruption () ,@body)) + (invoke-interruption #'interruption))) ;;;; system calls that deal with signals @@ -73,13 +90,13 @@ (without-gcing (let ((result (install-handler signal (case handler - (:default sig_dfl) - (:ignore sig_ign) + (:default sig-dfl) + (:ignore sig-ign) (t (sb!kernel:get-lisp-obj-address #'run-handler)))))) - (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) + (cond ((= result sig-dfl) :default) + ((= result sig-ign) :ignore) (t (the (or function fixnum) (sb!kernel:make-lisp-obj result)))))))) @@ -97,15 +114,8 @@ ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that ;;; SIGINT in --disable-debugger mode will cleanly terminate the system ;;; (by respecting the *DEBUGGER-HOOK* established in that mode). -(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))) - (eval-when (:compile-toplevel :execute) - (sb!xc:defmacro define-signal-handler (name - what - &optional (function 'error)) + (sb!xc:defmacro define-signal-handler (name what &optional (function 'error)) `(defun ,name (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) @@ -116,9 +126,7 @@ (with-alien ((context (* os-context-t) context)) (sap-int (sb!vm:context-pc context)))))))) -(define-signal-handler sigint-handler "interrupted" sigint-%break) (define-signal-handler sigill-handler "illegal instruction") -(define-signal-handler sigtrap-handler "breakpoint/trap") #!-linux (define-signal-handler sigemt-handler "SIGEMT") (define-signal-handler sigbus-handler "bus error") @@ -126,6 +134,18 @@ #!-linux (define-signal-handler sigsys-handler "bad argument to a system call") +(defun sigint-handler (signal info context) + (declare (ignore signal info)) + (declare (type system-area-pointer context)) + (/show "in Lisp-level SIGINT handler" (sap-int context)) + (flet ((interrupt-it () + (with-alien ((context (* os-context-t) context)) + (%break 'sigint 'interactive-interrupt + :context context + :address (sap-int (sb!vm:context-pc context)))))) + (sb!thread:interrupt-thread (sb!thread::foreground-thread) + #'interrupt-it))) + (defun sigalrm-handler (signal info context) (declare (ignore signal info context)) (declare (type system-area-pointer context)) @@ -147,7 +167,6 @@ (enable-interrupt sigint #'sigint-handler) (enable-interrupt sigterm #'sigterm-handler) (enable-interrupt sigill #'sigill-handler) - (enable-interrupt sigtrap #'sigtrap-handler) (enable-interrupt sigiot #'sigiot-handler) #!-linux (enable-interrupt sigemt #'sigemt-handler) @@ -163,35 +182,11 @@ ;;;; etc. +;;; extract si_code from siginfo_t +(sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int + (info system-area-pointer)) + ;;; CMU CL comment: ;;; Magically converted by the compiler into a break instruction. (defun receive-pending-interrupt () (receive-pending-interrupt)) - -;;; stale code which I'm insufficiently motivated to test -- WHN 19990714 -#| -;;;; WITH-ENABLED-INTERRUPTS - -(defmacro with-enabled-interrupts (interrupt-list &body body) - #!+sb-doc - "With-enabled-interrupts ({(interrupt function)}*) {form}* - Establish function as a handler for the Unix signal interrupt which - should be a number between 1 and 31 inclusive." - (let ((il (gensym)) - (it (gensym))) - `(let ((,il NIL)) - (unwind-protect - (progn - ,@(do* ((item interrupt-list (cdr item)) - (intr (caar item) (caar item)) - (ifcn (cadar item) (cadar item)) - (forms NIL)) - ((null item) (nreverse forms)) - (when (symbolp intr) - (setq intr (symbol-value intr))) - (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il) - forms)) - ,@body) - (dolist (,it (nreverse ,il)) - (enable-interrupt (car ,it) (cadr ,it))))))) -|#