scsh-0.5/scsh/sighandlers.scm

;;; 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)