X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=0d754e541daf96c450542648c922383c80759098;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=9ad1f365d850d17c6d531c5e503af25779a8932c;hpb=f0d511130027c6878f08d619ccc92ef588d81223;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 9ad1f36..0d754e5 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -17,62 +17,58 @@ ;;;; system calls that deal with signals +;;; Send the signal SIGNAL to the process with process id PID. SIGNAL +;;; should be a valid signal number #!-sb-fluid (declaim (inline real-unix-kill)) -(sb!alien:define-alien-routine ("kill" real-unix-kill) sb!alien:int +(sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int (pid sb!alien:int) (signal sb!alien:int)) -;;; Send the signal SIGNAL to the process with process id PID. SIGNAL -;;; should be a valid signal number or a keyword of the standard UNIX -;;; signal name. -(defun unix-kill (pid signal) - (real-unix-kill pid (unix-signal-number signal))) - +;;; Send the signal SIGNAL to the all the process in process group +;;; PGRP. SIGNAL should be a valid signal number #!-sb-fluid (declaim (inline real-unix-killpg)) -(sb!alien:define-alien-routine ("killpg" real-unix-killpg) sb!alien:int +(sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int (pgrp sb!alien:int) (signal sb!alien:int)) -;;; Send the signal SIGNAL to the all the process in process group -;;; PGRP. SIGNAL should be a valid signal number or a keyword of the -;;; standard UNIX signal name. -(defun unix-killpg (pgrp signal) - (real-unix-killpg pgrp (unix-signal-number signal))) - -;;; Set the current set of masked signals (those being blocked from +;;; Reset the current set of masked signals (those being blocked from ;;; delivery). ;;; -;;; (Note: CMU CL had a SIGMASK operator to create masks, but since -;;; SBCL only uses 0, we no longer support it. If you need it, you -;;; can pull it out of the CMU CL sources, or the old SBCL sources; -;;; but you might also consider doing things the SBCL way and moving -;;; this kind of C-level work down to C wrapper functions.) -#!-sunos -(sb!alien:define-alien-routine ("sigsetmask" unix-sigsetmask) - sb!alien:unsigned-long - (mask sb!alien:unsigned-long)) +;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK +;;; operator to create masks, but since we only ever reset to 0, we no +;;; longer support it. If you need it, you can pull it out of the CMU +;;; CL sources, or the old SBCL sources; but you might also consider +;;; doing things the SBCL way and moving this kind of C-level work +;;; down to C wrapper functions.) + +;;; When inappropriate build options are used, this also prints messages +;;; listing the signals that were masked +(sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void) + +(sb!alien:define-alien-routine "block_blockable_signals" sb!alien:void) ;;;; C routines that actually do all the work of establishing signal handlers (sb!alien:define-alien-routine ("install_handler" install-handler) - sb!alien:unsigned-long + sb!alien:unsigned-long (signal sb!alien:int) (handler sb!alien:unsigned-long)) - + ;;;; interface to enabling and disabling signal handlers -(defun enable-interrupt (signal-designator handler) - (declare (type (or function (member :default :ignore)) handler)) +(defun enable-interrupt (signal handler) + (declare (type (or function fixnum (member :default :ignore)) handler)) + (/show0 "enable-interrupt") (without-gcing - (let ((result (install-handler (unix-signal-number signal-designator) - (case handler - (:default sig_dfl) - (:ignore sig_ign) - (t - (sb!kernel:get-lisp-obj-address - handler)))))) + (let ((result (install-handler signal + (case handler + (:default sig_dfl) + (:ignore sig_ign) + (t + (sb!kernel:get-lisp-obj-address + handler)))))) (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) - (t (the function (sb!kernel:make-lisp-obj result))))))) + ((= result sig_ign) :ignore) + (t (the (or function fixnum) (sb!kernel:make-lisp-obj result))))))) (defun default-interrupt (signal) (enable-interrupt signal :default)) @@ -89,19 +85,27 @@ ;;; 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) + #!+sb-thread + (let ((foreground-thread (sb!thread::foreground-thread))) + (if (eq foreground-thread sb!thread:*current-thread*) + (apply #'%break 'sigint format-string format-arguments) + (sb!thread:interrupt-thread + foreground-thread + (lambda () (apply #'%break 'sigint format-string format-arguments))))) + #!-sb-thread (apply #'%break 'sigint format-string format-arguments)) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro define-signal-handler (name - what - &optional (function 'error)) + what + &optional (function 'error)) `(defun ,name (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) - (/show "in Lisp-level signal handler" (sap-int context)) + (/show "in Lisp-level signal handler" ,(symbol-name name) (sap-int context)) (,function ,(concatenate 'simple-string what " at #X~X") - (with-alien ((context (* os-context-t) context)) - (sap-int (sb!vm:context-pc context))))))) + (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") @@ -114,29 +118,33 @@ #!-linux (define-signal-handler sigsys-handler "bad argument to a system call") (define-signal-handler sigpipe-handler "SIGPIPE") -(define-signal-handler sigalrm-handler "SIGALRM") + +(defun sigalrm-handler (signal info context) + (declare (ignore signal info context)) + (declare (type system-area-pointer context)) + (cerror "Continue" 'sb!ext::timeout)) (defun sigquit-handler (signal code context) (declare (ignore signal code context)) - (throw 'sb!impl::toplevel-catcher nil)) + (throw 'toplevel-catcher nil)) (defun sb!kernel:signal-cold-init-or-reinit () #!+sb-doc "Enable all the default signals that Lisp knows how to deal with." - (enable-interrupt :sigint #'sigint-handler) - (enable-interrupt :sigquit #'sigquit-handler) - (enable-interrupt :sigill #'sigill-handler) - (enable-interrupt :sigtrap #'sigtrap-handler) - (enable-interrupt :sigiot #'sigiot-handler) + (enable-interrupt sigint #'sigint-handler) + (enable-interrupt sigquit #'sigquit-handler) + (enable-interrupt sigill #'sigill-handler) + (enable-interrupt sigtrap #'sigtrap-handler) + (enable-interrupt sigiot #'sigiot-handler) #!-linux - (enable-interrupt :sigemt #'sigemt-handler) - (enable-interrupt :sigfpe #'sb!vm:sigfpe-handler) - (enable-interrupt :sigbus #'sigbus-handler) - (enable-interrupt :sigsegv #'sigsegv-handler) + (enable-interrupt sigemt #'sigemt-handler) + (enable-interrupt sigfpe #'sb!vm:sigfpe-handler) + (enable-interrupt sigbus #'sigbus-handler) + (enable-interrupt sigsegv #'sigsegv-handler) #!-linux - (enable-interrupt :sigsys #'sigsys-handler) - (enable-interrupt :sigpipe #'sigpipe-handler) - (enable-interrupt :sigalrm #'sigalrm-handler) + (enable-interrupt sigsys #'sigsys-handler) + (enable-interrupt sigpipe #'sigpipe-handler) + (enable-interrupt sigalrm #'sigalrm-handler) (values)) ;;;; etc. @@ -156,20 +164,20 @@ 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))) + (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))))))) + (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))))))) |#