scsh-0.6/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.
;;;
;;; 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)
  (let ((number-of-interrupts (number-of-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)
	; resinstall 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 mask body ...)
;  (with-interrupts mask (lambda () body ...)))
(define-simple-syntax (with-enabled-interrupts mask body ...)
   (begin 
     ;(display "JMG:  use of  w-e-i") 
     body ...))

(define (with-enabled-interrupts* thunk thunk)
  (warn "JMG:  use of  with-enabled-interrupts*")
  (thunk))


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


(define (set-interrupt-handler! int handler)
  (if (or (< int 0) (>= int (number-of-interrupts)))
      (error "ill signum in set-interrupt-handler!" int)
      (let ((old (vector-ref *interrupt-handlers-vector* int)))
	(if (not (cdr old))  ; not yet registered?
	    (let ((setter (low-interrupt-register
			   int handler)))
	      (vector-set! *interrupt-handlers-vector* 
			   int 
			   (cons handler setter)))
	    (begin           
	      ((cdr old) handler)   ; set it with setter
	      (set-car! (vector-ref *interrupt-handlers-vector* int)
			handler))))))
	



;(define (init-interrupt)
;  (do ((sig 32 (- sig 1)))		
;	((< sig 0))			
    

;    (set-scsh-low-interrupt-handler! 
;     sig 
;     (lambda (x) #t)))
;  (set-interrupt-handler! 
;   (enum interrupt os-signal)
;   (lambda (type arg enabled-interrupts)
;     (if (= type (enum scsh-os-signal chld))
;	 (begin 
;	   (procobj-handler enabled-interrupts)))
;     ((scsh-os-signal-handler-ref type) enabled-interrupts)
;     ))
;  (display "sighandler installed")
;  #t)




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

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