scsh-0.6/scsh/sighandlers.scm

241 lines
9.0 KiB
Scheme
Raw Normal View History

;;; 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)))
;;; I'm trying to be consistent about the ! suffix -- I don't use it
;;; when frobbing process state. This is not a great rule; perhaps I
;;; should change it.
(define set-enabled-interrupts set-enabled-interrupts!)
(define-simple-syntax (with-enabled-interrupts mask body ...)
(with-interrupts mask (lambda () body ...)))
(define with-enabled-interrupts* with-interrupts)
(define interrupt/alarm (enum interrupt alarm))
(define interrupt/keyboard (enum interrupt keyboard))
;(define interrupt/memory-shortage (enum interrupt memory-shortage))
(define interrupt/post-gc (enum interrupt post-gc))
(define interrupt/i/o-completion (enum interrupt i/o-completion))
(define interrupt/chld (enum interrupt chld))
(define interrupt/cont (enum interrupt cont))
(define interrupt/hup (enum interrupt hup))
(define interrupt/quit (enum interrupt quit))
(define interrupt/term (enum interrupt term))
(define interrupt/tstp (enum interrupt tstp))
(define interrupt/usr1 (enum interrupt usr1))
(define interrupt/usr2 (enum interrupt usr2))
(define interrupt/info (enum interrupt info))
(define interrupt/io (enum interrupt io))
(define interrupt/poll (enum interrupt poll))
(define interrupt/prof (enum interrupt prof))
(define interrupt/pwr (enum interrupt pwr))
(define interrupt/urg (enum interrupt urg))
(define interrupt/vtalrm (enum interrupt vtalrm))
(define interrupt/winch (enum interrupt winch))
(define interrupt/xcpu (enum interrupt xcpu))
(define interrupt/xfsz (enum interrupt xfsz))
(define interrupt/int interrupt/keyboard)
(define interrupt/alrm interrupt/alarm)
;;; 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)
(define default-int-handler-vec
;; Non-Unix-signal interrupts just get their default values from
;; the current value of I-H.
(let ((v (copy-vector (interrupt-handlers-vector))))
(do ((sig 31 (- sig 1))) ; For each Unix signal
((< sig 0)) ; make & install a default
(let ((i (%signal->interrupt sig))) ; signal handler.
(if (>= i 0) ; Don't mess with non-signal interrupts.
(vector-set! v i (if (memv sig signals-ignored-by-default)
(lambda (enabled-interrupts) #f)
(lambda (enabled-interrupts)
(%do-default-sigaction sig)))))))
v))
;(define default-int-handler-vec
; (let ((v (make-vector interrupt-count)))
; (do ((sig 31 (- sig 1))) ; For each Unix signal
; ((< sig 0)) ; make & install a default
; (let ((i (%signal->interrupt sig))) ; signal handler.
; (vector-set! v i (if (>= i 0) ; Don't mess with non-signal interrupts.
; (if (memv sig signals-ignored-by-default)
; (lambda (enabled-interrupts) #f)
; (lambda (enabled-interrupts)
; (%do-default-sigaction sig)))
; 'default-s48-interrupt-action))))
; v))
;;; 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, the ENABLED-INTERRUPTS
;;; register will be restored to its previous value.
;;; This handler does nothing -- used when the handler is #f.
(define (noop-sig-handler enabled-interrupts) #f)
(define (set-interrupt-handler int handler)
(let ((ohandler (interrupt-handler int)))
(set-interrupt-handler! int
(case handler
((#t) (vector-ref default-int-handler-vec int))
((#f) noop-sig-handler)
(else handler)))
(cond ((and (not handler) ohandler ; Toggling from something
(int->signal int)) => ; to ignored.
(lambda (sig)
(%set-unix-signal-handler sig 0)))
((and handler (not ohandler) ; Toggling from ignored
(int->signal int)) => ; to something.
(lambda (sig)
(%set-unix-signal-handler sig 2))))
ohandler))
(define (interrupt-handler int)
(let ((handler (vector-ref (interrupt-handlers-vector) int)))
(cond ((eq? handler (vector-ref default-int-handler-vec int)) #t)
((eq? handler noop-sig-handler) #f)
(else handler))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 old-flags)
(%%set-unix-signal-handler sig handler-code 0)
(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) ; Leave ^c and
(= sig signal/alrm))) ; alarm handlers alone.
(set-interrupt-handler! i
(vector-ref default-int-handler-vec i))))))
;;; I am ashamed to say the 33 below is completely bogus.
;;; What we want is a value that is 1 + max interrupt value.
(define int->sig-vec
(let ((v (make-vector 33 #f)))
(do ((sig 32 (- sig 1)))
((< sig 0))
(let ((i (%signal->interrupt sig)))
(if (not (= i -1)) (vector-set! v i sig))))
v))
(define (int->signal i) (and (<= 0 i 32) (vector-ref int->sig-vec i)))