380 lines
13 KiB
Scheme
380 lines
13 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-init-name "sighandlers")
|
|
|
|
(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) )))
|
|
ans)))
|
|
|
|
(define (interrupt-enabled? int mask)
|
|
(not (zero? (bitwise-and (arithmetic-shift 1 int) mask))))
|
|
|
|
(define (interrupt-enable int mask)
|
|
(bitwise-ior (arithmetic-shift 1 int) mask))
|
|
|
|
(define *enabled-interrupts*
|
|
(let lp ((i 0) (mask 0))
|
|
(if (= i number-of-interrupts)
|
|
mask
|
|
(lp (+ i 1) (interrupt-enable i mask)))))
|
|
|
|
(define (enabled-interrupts) *enabled-interrupts*)
|
|
|
|
|
|
;;; 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.
|
|
;;;
|
|
;;; I think you should...
|
|
(define (set-enabled-interrupts new-enabled-interrupts)
|
|
(do ((int 0 (+ int 1)))
|
|
((= int number-of-interrupts) new-enabled-interrupts)
|
|
(let ((old-state (interrupt-enabled? int *enabled-interrupts*))
|
|
(new-state (interrupt-enabled? int new-enabled-interrupts)))
|
|
(cond ((and old-state (not new-state))
|
|
(vector-set! blockade-vector int (block-interrupt int)))
|
|
((and (not old-state) new-state)
|
|
(let ((blockade (vector-ref blockade-vector int)))
|
|
(if (not blockade)
|
|
(error "there was no blockade" int))
|
|
(unblock-interrupt blockade)
|
|
(vector-set! blockade-vector int #f)))
|
|
(else 'unchanged))))
|
|
(set! *enabled-interrupts* new-enabled-interrupts))
|
|
|
|
;;; Enableing/Disableing = Unblocking/Blocking
|
|
;;;
|
|
;;; issues:
|
|
;;; + prevent delivery of the interrupt => install fake handler in
|
|
;;; low-interrupt
|
|
;;; + support setting of handler during blocking => install fake
|
|
;;; set-proc in interrupt-handler-vector
|
|
;;; + record if an interrupt occures while interupt blocked => pending?
|
|
;;; + restore everything after interrupt unublocked => reinstall handler
|
|
;;; in low-interrupt, set-proc in interrupt-handler-vector
|
|
;;; + if pending? interrupt: call handler
|
|
|
|
;(define-record-type blockade :blockade
|
|
; (really-make-blockade interrupt-vector-cell pending? low-int-set!)
|
|
; blockade?
|
|
; (interrupt-vector-cell blockade:interrupt-vector-cell)
|
|
; (pending? blockade:pending? set-blockade:pending?)
|
|
; (low-int-set! blockade:low-int-set!))
|
|
|
|
(define-record blockade
|
|
interrupt-vector-cell
|
|
low-int-set! ; proc to set interrupt in low-interrupt
|
|
(pending? #f))
|
|
|
|
|
|
(define blockade-vector (make-vector number-of-interrupts #f))
|
|
|
|
;;; do nothing in low-interrupt, the new handler will be recorded in the
|
|
;;; interrupt-handler-vector however
|
|
(define (fake-set-interrupt blockade)
|
|
(lambda (new-handler)
|
|
#f))
|
|
|
|
;;; to be installed in low-interrupt
|
|
(define (fake-handler blockade)
|
|
(lambda a
|
|
(if (not (blockade:pending? blockade))
|
|
(set-blockade:pending? blockade a))))
|
|
|
|
;;; generate blockade and install fake handler and set-proc
|
|
(define (block-interrupt int)
|
|
(let* ((handler-setter-cell (vector-ref *interrupt-handlers-vector* int))
|
|
(low-int-set! (cdr handler-setter-cell))
|
|
(blockade (make-blockade handler-setter-cell
|
|
low-int-set!)))
|
|
; fade out the low-interupt-set
|
|
(set-cdr! handler-setter-cell (fake-set-interrupt blockade))
|
|
; set the fake handler in low-interupt:
|
|
((blockade:low-int-set! blockade) (fake-handler blockade))
|
|
blockade))
|
|
|
|
|
|
(define (unblock-interrupt blockade)
|
|
(let ((handler (car (blockade:interrupt-vector-cell blockade))))
|
|
; install the handler that resides in the vector
|
|
(let ((low-int-set! (blockade:low-int-set! blockade)))
|
|
(low-int-set! handler)
|
|
; reinstall the low-interrupt-setter
|
|
(set-cdr! (blockade:interrupt-vector-cell blockade)
|
|
low-int-set!)
|
|
(if (blockade:pending? blockade)
|
|
(apply handler (blockade:pending? blockade))))))
|
|
|
|
|
|
(define-simple-syntax (with-enabled-interrupts interrupt-set body ...)
|
|
(begin
|
|
(with-enabled-interrupts* interrupt-set (lambda () body ...))))
|
|
|
|
(define (with-enabled-interrupts* interrupt-set thunk)
|
|
(let ((before *enabled-interrupts*))
|
|
(set-enabled-interrupts interrupt-set)
|
|
(let ((return (thunk)))
|
|
(set-enabled-interrupts before)
|
|
return)))
|
|
|
|
|
|
; Fakes vm vector
|
|
;;; car is the actual handler, cdr is a proc to set handler in
|
|
;;; low-interrupt system
|
|
|
|
(define *interrupt-handlers-vector*
|
|
(make-vector number-of-interrupts (cons #f #f)))
|
|
|
|
(define (interrupt-handlers-vector)
|
|
*interrupt-handlers-vector*)
|
|
|
|
(define (interrupt-handler-ref int)
|
|
(if (or (< int 0) (>= int number-of-interrupts))
|
|
(error "ill signum in interrupt-handler-ref" int)
|
|
(car (vector-ref *interrupt-handlers-vector* int))))
|
|
|
|
;;; the handler is not interested in the enabled interupts of the vm
|
|
;;; but in those managed here
|
|
(define (make-handler handler)
|
|
(lambda (enabled-low)
|
|
(handler (enabled-interrupts))))
|
|
|
|
(define (set-interrupt-handler! int handler)
|
|
(if (or (< int 0) (>= int number-of-interrupts))
|
|
(error "ill signum in set-interrupt-handler!" int)
|
|
(let ((handler-setter (vector-ref *interrupt-handlers-vector* int))
|
|
(handler-enabled-here (make-handler handler)))
|
|
(if (not (cdr handler-setter)) ; not yet registered?
|
|
(let ((setter (low-interrupt-register
|
|
int handler-enabled-here)))
|
|
(vector-set! *interrupt-handlers-vector*
|
|
int
|
|
(cons handler setter)))
|
|
(begin
|
|
((cdr handler-setter) handler-enabled-here) ; set it with setter
|
|
(set-car! (vector-ref *interrupt-handlers-vector* int)
|
|
handler))))))
|
|
|
|
|
|
;;; 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 (make-vector 32)))
|
|
(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)))
|
|
ohandler))
|
|
|
|
; (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 (interrupt-handler-ref 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 interactive?)
|
|
(do ((int 0 (+ int 1)))
|
|
((= int number-of-interrupts))
|
|
(set-interrupt-handler
|
|
int
|
|
(lambda a #f)))
|
|
(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)))))
|
|
(let ((scheduler-initial-thread (current-thread)))
|
|
(if (not (eq? (thread-name scheduler-initial-thread)
|
|
'scheduler-initial-thread))
|
|
(error "sighandler did not find scheduler-initial-thread, but"
|
|
scheduler-initial-thread))
|
|
|
|
;; Note: this will prevent any other system to work, since it pushes
|
|
;; a new command level !
|
|
(if interactive?
|
|
(set-interrupt-handler interrupt/keyboard
|
|
(lambda stuff
|
|
((structure-ref threads-internal schedule-event)
|
|
scheduler-initial-thread
|
|
(enum
|
|
(structure-ref threads-internal event-type)
|
|
interrupt)
|
|
(enum interrupt keyboard)))))))
|
|
|
|
;;; 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)))
|