143 lines
4.9 KiB
Scheme
143 lines
4.9 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.
|
|
|
|
;;; 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
|
|
|
|
(foreign-source
|
|
"extern int errno;"
|
|
""
|
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
|
"#include \"sighandlers1.h\""
|
|
"" "")
|
|
|
|
;;; Blocking interrupts
|
|
;;; I think all of this code (and associated C code) has been obsoleted by
|
|
;;; the new system that uses S48's sigblocking machinery.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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-blocked-interrupts mask body ...)
|
|
(with-blocked-interrupts* mask (lambda () body ...)))
|
|
|
|
(define (with-blocked-interrupts* mask thunk)
|
|
(let ((old-mask #f))
|
|
(dynamic-wind
|
|
(lambda () (set! old-mask (set-blocked-interrupts! mask)))
|
|
thunk
|
|
(lambda () (set-blocked-interrupts! old-mask)))))
|
|
|
|
(define (set-blocked-interrupts! mask)
|
|
(receive (hi-out lo-out)
|
|
(%set-blocked-interrupts! (hi8 mask) (lo24 mask))
|
|
(compose-8/24 hi-out lo-out)))
|
|
|
|
|
|
(define (blocked-interrupts)
|
|
(call-with-values %blocked-interrupts compose-8/24))
|
|
|
|
(define-foreign %set-blocked-interrupts! (set_procmask (fixnum hi)
|
|
(fixnum lo))
|
|
fixnum ; hi
|
|
fixnum) ; lo
|
|
|
|
(define-foreign %blocked-interrupts (get_procmask)
|
|
fixnum ; hi
|
|
fixnum) ; lo
|
|
|
|
|
|
;;; 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 (default-handler sig)
|
|
(lambda (enabled-interrupts) (%do-default-sigaction sig)))
|
|
|
|
(define-foreign %do-default-sigaction (do_default_sigaction (fixnum signal))
|
|
ignore)
|
|
|
|
|
|
;;; HANDLER is #f (ignore), #t (default), or an integer procedure.
|
|
;;; 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.
|
|
|
|
;;; Should have extra args, MASK & FLAGS.
|
|
(define (set-signal-handler sig handler)
|
|
(let ((handler (if (eq? handler #t) ; Hack the default handler.
|
|
(default-handler sig)
|
|
handler)))
|
|
(receive (handler flags) ; Should be (handler mask flags).
|
|
(%set-signal-handler! sig handler 0)
|
|
handler)))
|
|
|
|
(define (signal-handler sig)
|
|
(receive (handler flags) (%signal-handler sig)
|
|
handler))
|
|
|
|
(define (%signal-handler sig)
|
|
(receive (err handler flags) (%%signal-handler sig)
|
|
(if err (errno-error err %signal-handler sig)
|
|
(values handler flags))))
|
|
|
|
;;; (%set-signal-handler! sig handler [mask flags]) -> [handler mask flags]
|
|
;;; Except no MASK for now.
|
|
|
|
(define (%set-signal-handler! sig handler . args)
|
|
(let-optionals args ((flags 0))
|
|
(receive (err handler flags)
|
|
(%%set-signal-handler! sig handler flags)
|
|
(if err
|
|
(errno-error err %set-signal-handler! sig handler flags)
|
|
(values handler flags)))))
|
|
|
|
(define-foreign %%set-signal-handler! (set_sig_handler (fixnum signal)
|
|
(desc handler)
|
|
(fixnum flags))
|
|
desc ; #f or errno
|
|
desc ; handler
|
|
fixnum) ; flags
|
|
|
|
(define-foreign %%signal-handler (get_sig_handler (fixnum signal))
|
|
desc ; #f or errno
|
|
desc ; handler
|
|
fixnum) ; flags
|
|
|
|
(define-foreign %%install-new-handler-vec
|
|
(install_new_handler_vector (vector-desc vec))
|
|
ignore)
|