163 lines
6.0 KiB
Scheme
163 lines
6.0 KiB
Scheme
;;; Copyright (c) 1993 by Olin Shivers.
|
|
;;; Signal handler system
|
|
|
|
;;; The principal trickiness here is that we have to interface to Unix signals
|
|
;;; *through* an intermediate interface, the S48 vm's idea of interrupts.
|
|
;;; So there is a difference between delivering a signal to the underlying
|
|
;;; Unix process and delivering it to the program that runs on the VM.
|
|
;;;
|
|
;;; One effect is that we have two separate codes for the same thing -- the
|
|
;;; Unix signal code, and the S48 interrupt value. E.g., SIGNAL/TSTP and
|
|
;;; INTERRUPT/TSTP.
|
|
|
|
;;; These system calls can return EINTR or restart. In order for the S48 vm's
|
|
;;; interrupt system to detect a signal and invoke the handler, they *must*
|
|
;;; return EINTR, and this must cause a return from C to Scheme.
|
|
;;;
|
|
;;; open close dup2 accept connect
|
|
;;; read recv recvfrom recvmsg
|
|
;;; write send sendto sendmsg
|
|
;;; select
|
|
;;; wait
|
|
;;; fcntl* ioctl
|
|
;;; sigsuspend
|
|
;;; HP-UX, but I don't use: poll lockf msem_lock msgsnd msgrcv semop
|
|
;;;
|
|
;;; * Only during a F_SETLKW
|
|
;;;
|
|
;;; From rts/interrupt.scm (package interrupts, interface interrupts-interface)
|
|
;;; WITH-INTERRUPTS INTERRUPT-HANDLERS SET-ENABLED-INTERRUPTS!
|
|
;;; ENABLED-INTERRUPTS
|
|
;;; Must define WITH-INTERRUPTS* and WITH-INTERRUPTS.
|
|
|
|
(foreign-source
|
|
"extern int errno;"
|
|
""
|
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
|
"#include \"sighandlers1.h\""
|
|
"" "")
|
|
|
|
;;; Map a Unix async signal to its S48 interrupt value.
|
|
;;; -1 => Not defined.
|
|
(define-foreign %signal->interrupt (sig2interrupt (integer sig))
|
|
integer)
|
|
|
|
(define (signal->interrupt sig)
|
|
(let ((int (%signal->interrupt sig)))
|
|
(if (>= int 0) int
|
|
(error "Unix signal has no Scheme 48 interrupt." sig))))
|
|
|
|
|
|
(define (interrupt-set . interrupts)
|
|
(let lp ((ints interrupts) (ans 0))
|
|
(if (pair? ints)
|
|
(lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (- (car ints) 1))))
|
|
ans)))
|
|
|
|
(define-simple-syntax (with-enabled-interrupts mask body ...)
|
|
(with-interrupts mask (lambda () body ...)))
|
|
|
|
(define with-enabled-interrupts* with-interrupts)
|
|
|
|
|
|
;;; Get/Set signal handlers
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; When you set a signal's handler to "default," if the default for that
|
|
;;; signal is something other than "ignore," we actually install this guy.
|
|
;;; When he is called by the S48 interrupt system, he'll magically make
|
|
;;; the default action happen (by calling C code that *really* sets the
|
|
;;; handler to SIGDFL, and then re-sending the signal). This basically
|
|
;;; terminates the process, since if the default isn't "ignore," it's always
|
|
;;; "terminate" of some kind. Doing it this way means the exit code given
|
|
;;; to our waiting parent proc correctly reflects how we died, and also
|
|
;;; makes the core dump happen if it should. Details, details.
|
|
|
|
(define-foreign %do-default-sigaction (do_default_sigaction (fixnum signal))
|
|
ignore)
|
|
|
|
;;; This gives the default handler for each signal.
|
|
(define default-handler-vec
|
|
(initialize-vector 32 (lambda (sig)
|
|
;; This is the guy to call when you want signal
|
|
;; SIG handled in the default manner.
|
|
(if (memv sig signals-ignored-by-default)
|
|
(lambda (enabled-interrupts) #f)
|
|
(lambda (enabled-interrupts)
|
|
(%do-default-sigaction sig))))))
|
|
|
|
|
|
;;; HANDLER is #f (ignore), #t (default), or a procedure taking an integer
|
|
;;; argument. The interrupt is delivered to a procedure by (1) setting the
|
|
;;; ENABLED-INTERRUPTS register to 0 (i.e., blocking all interrupts), and (2)
|
|
;;; applying the procedure to the previous value of the ENABLED-INTERRUPTS
|
|
;;; register. If the procedure returns normally (i.e., it doesn't throw to a
|
|
;;; continuation), the ENABLED-INTERRUPTS register will be restored to its
|
|
;;; previous value.
|
|
|
|
(define (set-signal-handler! sig handler)
|
|
(let ((nhandler (if (eq? handler #t) ; Get SIG's default handler.
|
|
(vector-ref default-handler-vec sig)
|
|
handler))
|
|
(int (signal->interrupt sig)))
|
|
(with-enabled-interrupts 0
|
|
(let ((ohandler (vector-ref interrupt-handlers int)))
|
|
(vector-set! interrupt-handlers int nhandler)
|
|
ohandler))))
|
|
|
|
(define (signal-handler sig)
|
|
(vector-ref interrupt-handlers (signal->interrupt sig)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Set the Unix signal handler. One doesn't usually use this; one usually
|
|
;;; uses the S48 VM's interrupt system.
|
|
;;; HANDLER-CODE: 0 => ignore, 1 => default, 2 => S48 VM
|
|
;;; Returns equivalent code, additionally 3 => other handler.
|
|
;;; Raises an error exception if there's a problem.
|
|
|
|
(define (%set-unix-signal-handler! sig handler-code)
|
|
(check-arg (lambda (x) (and (integer? sig) (< 0 sig 32)))
|
|
sig
|
|
%set-unix-signal-handler!)
|
|
(check-arg (lambda (x) (and (integer? handler-code) (<= 0 handler-code 2)))
|
|
handler-code
|
|
%set-unix-signal-handler!)
|
|
(let retry ()
|
|
(receive (err old-hc) (%%set-unix-signal-handler! sig handler-code)
|
|
(cond ((not err) old-hc)
|
|
((= err errno/intr) (retry))
|
|
(else (errno-error err %set-unix-signal-handler! sig handler-code))))))
|
|
|
|
(define-foreign %%set-unix-signal-handler!
|
|
(scsh_set_sig (fixnum sig) (fixnum hc) (fixnum flags))
|
|
desc ; #f or errno
|
|
integer ; previous handler-code
|
|
integer) ; previous handler flags
|
|
|
|
(define (%unix-signal-handler sig)
|
|
(check-arg (lambda (x) (and (integer? sig) (< 0 sig 32)))
|
|
sig
|
|
%unix-signal-handler)
|
|
(let retry ()
|
|
(receive (err hc flags) (%%unix-signal-handler sig)
|
|
(cond ((not err) hc)
|
|
((= err errno/intr) (retry))
|
|
(else (errno-error err %unix-signal-handler sig))))))
|
|
|
|
(define-foreign %%unix-signal-handler (scsh_get_sig (fixnum sig))
|
|
desc ; #f or errno
|
|
integer ; previous handler-code
|
|
integer) ; previous handler flags
|
|
|
|
(define-foreign %install-unix-scsh-handlers (install_scsh_handlers) ignore)
|
|
|
|
(define-foreign %%get-int-handlers (get_int_handlers) desc)
|
|
|
|
(define (%install-scsh-handlers)
|
|
(do ((sig 32 (- sig 1)))
|
|
((< sig 0))
|
|
(let ((i (%signal->interrupt sig)))
|
|
(if (not (or (= i -1) (= sig signal/int) (= sig signal/alrm)))
|
|
(vector-set! interrupt-handlers i
|
|
(vector-ref default-handler-vec sig))))))
|