scsh-0.6/scsh/procobj.scm

;;; Unix wait & process objects for scsh
;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers.

;;; This is a GC'd abstraction for Unix process id's.
; ;; The problem with Unix pids is (a) they clutter up the kernel
;;; process table until you wait(2) them, and (b) you can only
;;; wait(2) them once. Scsh's process objects are similar, but
;;; allow the storage to be allocated in the scsh address space,
;;; and out of the kernel process table, and they can be waited on
;;; multiple times.

;;; Process objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-record proc		; A process object
  pid		; Proc's pid.
  (finished? #f)                ; Running, stopped, done
  (status (make-placeholder))	; The cached exit status of the process
  (zombie #t)                   ; Misnomer.  Whether or not the process has
                                ; (not) been waited on.
  ;; Make proc objects print like #{proc 2318}.
  ((disclose p) (list "proc" (proc:pid p))))

;; Weak pointer tables.  Much more efficient than populations.
;; Maps pids to processes.  Unexited processes are strong pointers, exited
;; procs are weak pointers (to allow gc'ing).

(define process-table (make-integer-table))

(define (weak-table-ref t n)
  (let ((r (table-ref t n)))
    (if (weak-pointer? r)
	(weak-pointer-ref r)
	r)))

(define (weak-table-set! t n s)
  (table-set! t n (make-weak-pointer s)))

(define (weaken-table-ref! t n)
  (weak-table-set! t n (weak-table-ref t n)))

(define (maybe-pid->proc pid)
  (weak-table-ref process-table pid))

(define (pid->proc pid . maybe-probe?)
  (let ((probe? (:optional maybe-probe? #f)))
    (or (maybe-pid->proc pid)
	(case probe?
	  ((#f)     (error "Pid has no corresponding process object" pid))
	  ((create) (let ((p (make-proc pid))) 	; Install a new one.
		      ;; Weak because we don't know what's up with this thing.
		      (weak-table-set! process-table pid p)
		      p))
	  (else     #f)))))
	     
;;; Coerce pids and procs to procs.

(define (->proc proc/pid)
  (cond ((proc? proc/pid) proc/pid)
	((and (integer? proc/pid) (>= proc/pid 0))
	 (pid->proc proc/pid))
	(else (error "Illegal parameter" ->proc proc/pid))))


;;; Is X a pid or a proc?

(define (pid/proc? x) (or (proc? x) (and (integer? x) (>= x 0))))


;;; Process reaping
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; "Reaping" a process means using wait(2) to move its exit status from the
;;; kernel's process table into scsh, thus cleaning up the kernel's process
;;; table and saving the value in a gc'd data structure, where it can be
;;; referenced multiple times.
;;;
;;; - Stopped processes are never reaped, only dead ones.  (May change -df)
;;; 
;;; - Stopped process status codes are never cached in proc objects, 
;;;   only status codes for dead processes. So you can wait for a
;;;   dead process multiple times, but only once per process-stop.
;;;   (May change -df)
;;; 
;;; - Unfortunately, reaping a process loses the information specifying its
;;;   process group, so if a process is reaped into scsh, it cannot be
;;;   waited for by WAIT-PROCESS-GROUP. Notice that only dead processes are
;;;   reaped, not suspended ones. Programs almost never use WAIT-PROCESS-GROUP
;;;   to wait for dead processes, so this is not likely to be a problem. If
;;;   it is, turn autoreaping off with (autoreap-policy #f).
;;;   (This never worked right, and it might be wiped out completely -fd)
;;; 
;;; - Reaping can be encouraged by calling (REAP-ZOMBIES).

;;; (autoreap-policy [new-policy])
;;; Watch this area

(define *autoreap-policy* #f) ; Not exported from this module.

(define (autoreap-policy . maybe-policy)
  (let ((old-policy *autoreap-policy*))
    (if (pair? maybe-policy)
	(let ((new-policy (car maybe-policy)))
	  (cond ((pair? (cdr maybe-policy))
		 (error "Too many args to autoreap-policy" maybe-policy))
		((not (memq new-policy '(early #f)))
		 (error "Illegal autoreap policy." new-policy))
		(else (set! *autoreap-policy* new-policy)
		      (if (eq? new-policy 'early)
			  (set! procobj-handler
			    (lambda (enabled-ints) (reap-zombies))))))))
    old-policy))

;;; New (scsh 0.6)

(define (install-autoreaping)
  (set! procobj-handler
    (lambda (enabled-ints)
      (reap-zombies))))

;;; (reap-zombies)  => bool
;;;   Move any zombies from the kernel process table into scsh.
;;;   Return true if no more outstanding children; #f if some still live.

(define (reap-zombies)
  (display "reap-zombies was called" (current-error-port))
  (newline)
  (let lp ()
    (receive (pid status) (%wait-any (bitwise-ior wait/poll wait/stopped-children))
      (if pid
	  (begin (add-reaped-proc! pid status)
;		 (format (current-error-port)
;			 "Reaping ~d[~d]~%" pid status)
		 (lp))
	  status))))

(define (new-child-proc pid)
  (let ((proc (make-proc pid)))
    (table-set! process-table pid proc)
    proc))

(define (mark-proc-exited proc)
  (weaken-table-ref! process-table (proc:pid proc)))

;;; (WAIT proc/pid [flags])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; (wait proc/pid [flags]) => status or #f
;;;
;;; FLAGS (default 0) is the exclusive or of the following:
;;;     wait/poll	
;;;		Return #f immediately if there are no 
;;;		unwaited children available. 
;;; 	wait/stopped-children
;;; 		Report on suspended children as well.
;;;
;;;     If the process hasn't terminated (or suspended, if wait/stopped 
;;; 	is set) and wait/poll is set, return #f.
;;; (I'm working on the flags -df)

(define (wait pid/proc . maybe-flags)
  (let* ((flags (:optional maybe-flags 0))
	 (proc (->proc pid/proc))
	 (win (lambda (status)
		(mark-proc-waited! proc) ; Not eligible for a WAIT-ANY
		status)))
    (if (or (zero? (bitwise-and flags wait/poll))
	    (proc:finished? proc)) 
	(win (placeholder-value (proc:status proc)))
	(proc:finished? proc))))

;;; Another way to do it:
;;; Every time we reap a process, we pop out of our SIGCHLD
;;; block so that we can service an interrupt if the system
;;; so wishes.
;(define (wait/pid pid)
;  ((let lp ()
;     (blocking signal/chld
;       (or (waited pid)	; Previously waited or reaped
;	    (receive (next-dead status) (reap-a-pid)
;	      (if (= pid next-dead) (lambda () status)
;		  lp)))))))

;The above seems to use Olin's event model.  Even so, I'm not
;sure that's the best way to do that.

;Generally correct idea, tho

(define (cache-wait-status proc status)
  (cond ((and (integer? status)
	      (not (status:stop-sig status)))	; He's dead, Jim.
	 (placeholder-set! (proc:status proc) status)	; Cache exit status.
	 (mark-proc-exited proc)))	; We're now gc'able.
  status)


;;; (wait-any [flags]) => [proc status]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     [#f #f] => non-blocking, none ready.
;;;     [#f #t] => no more.

(define (wait-any . maybe-flags)
  (let ((flags (:optional maybe-flags 0)))
    (if (zero? (bitwise-and flags wait/poll))
	(let ((win (get-reaped-proc!)))
	  (values win (placeholder-value (proc:status win))))

	;The rest of this is quite crude and can be safely ignored. -df

	(if (maybe-obtain-lock reaped-proc-pop-lock)
	    (if (eq? reaped-proc-head reaped-proc-tail)
		(begin
		  (release-lock reaped-proc-pop-lock)
		  (values #f #f))
		(let* ((retnode (placeholder-value reaped-proc-head))
		       (retval (weak-pointer-ref (reaped-proc:proc retnode))))
		  (set! reaped-proc-head (reaped-proc:next retnode))
		  (release-lock reaped-proc-pop-lock)
		  (if retval
		      (values retval (placeholder-value (proc:status retval)))
		      (values #f #f))
	    (values #f #f)))))))

;;; (wait-process-group [proc-group flags]) => [proc status]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     [#f #f] => non-blocking, none ready.
;;;     [#f #t] => no more.
;;;
;;; 
;;; If you are doing process-group waits, you do *not* want to use 
;;; early autoreaping, since the reaper loses process-group information.
;;; (I'm working on it -df)

(define (wait-process-group . args)
  (let-optionals args ((proc-group 0) (flags 0))
    (let ((proc-group (cond ((integer? proc-group) proc-group)
			     ((proc? proc-group)    (proc:pid proc-group))
			     (else (error "Illegal argument" wait-process-group
					  proc-group)))))
      (receive (pid status) (%wait-process-group proc-group flags)
	(if pid
	    (let ((proc (pid->proc pid)))
	      (cache-wait-status proc status)
	      (values proc status))
	    (values pid status))))))		; pid = #f -- Empty poll.



;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Direct interfaces to waitpid(2) call.
;;; [#f #f] means no processes ready on a non-blocking wait.
;;; [#f #t] means no waitable process on wait-any.

(define (%wait-pid pid flags)
  (let lp ()
    (receive (err pid status) (%wait-pid/errno pid flags)
      (cond ((not err) (and (not (zero? pid)) status))	; pid=0 => none ready.
	    ((= err errno/intr) (lp))
	    (else (errno-error err %wait-pid pid flags))))))

(define (%wait-any flags)
  (let lp ()
    (receive (err pid status) (%wait-pid/errno -1 flags)
      (cond (err (cond ((= err errno/child) (values #f #t))	; No more.
		       ((= err errno/intr)  (lp))
		       (else (errno-error err %wait-any flags))))
	    ((zero? pid) (values #f #f))			; None ready.
	    (else (values pid status))))))

(define (%wait-process-group pgrp flags)
  (let lp ()
    (receive (err pid status) (%wait-pid/errno (- pgrp) flags)
      (cond (err (cond ((= err errno/child) (values #f #t))	; No more.
		       ((= err errno/intr) (lp))
		       (else (errno-error err %wait-process-group pgrp flags))))
	    ((zero? pid) (values #f #f))			; None ready.
	    (else (values pid status))))))


;;; Reaped process table
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; We keep track of procs that have been reaped but not yet waited on by
;;; the user's code. These proces are eligible for return by WAIT-ANY.
;;; We keep track of these so that WAIT-ANY will hand them out exactly once.
;;; What this code needs is traditional condition variables.

;;; This is (so far) reliable in the following ways:
;;; 1. No process will be returned twice by wait-any, ever.  Even two different
;;;    wait-anys.
;;; 2. Being un-reaped will not prevent garbage collection.
;;;    (actually, there seems to be a problem with this -df)
;;; 3. If a process is waited on, or is gc'ed, wait-any will do the Right
;;;    Thing.

;;; And UNreliable in the following ways:
;;; 1. If a wait and a wait-any are blocking simultaneously, the wait will
;;;    always return the object.  However, whether the wait-any will or not
;;;    is based on racing semaphores.
;;; 2. While processes can still be garbage collected, the nodes on the
;;;    wait-any list will not, and if the program never wait-any's, the queue
;;;    will snake around, eating up memory like pac-man with the munchies.
;;; 3. The process may be garbage collected before wait-any gets to it, and
;;;    that's just tough.

;;; -df

(define-record reaped-proc
  proc
  (next (make-placeholder))
  prev)

(define reaped-proc-tail (make-placeholder))
(define reaped-proc-head reaped-proc-tail)
(define reaped-proc-push-lock (make-lock))
(define reaped-proc-pop-lock (make-lock))          ;;; Zippy sez: pop lock!

(define (push-reaped-proc proc)
  (obtain-lock reaped-proc-push-lock)
  (let ((push-me (make-reaped-proc (make-weak-pointer proc) reaped-proc-tail)))
    (placeholder-set! reaped-proc-tail push-me)
;    (add-finalizer! proc (lambda ignore (remove-reaped-proc push-me)))
    (set! reaped-proc-tail (reaped-proc:next push-me)))
  (release-lock reaped-proc-push-lock))

(define (remove-reaped-proc reaped-proc)
  (spawn (lambda ()                 ;This is blocking, so should run by itself
	   (placeholder-set! (reaped-proc:prev reaped-proc)
			     (placeholder-value
			      (reaped-proc:next reaped-proc))))
	 "reaped-proc-removing-thread"))

(define (pop-reaped-proc)
  (obtain-lock reaped-proc-pop-lock)        ;;; pop lock pop lock pop lock!
  (let ((pop-me (placeholder-value reaped-proc-head)))
    (set! reaped-proc-head (reaped-proc:next pop-me))
    (release-lock reaped-proc-pop-lock)
    (weak-pointer-ref (reaped-proc:proc pop-me))))

(define (add-reaped-proc! pid status)
  (cond ((maybe-pid->proc pid) =>
	 (lambda (proc)
	   (placeholder-set! (proc:status proc) status)
	   (set-proc:finished? proc #t)
	   (push-reaped-proc proc)
	   (mark-proc-exited proc))
	 (else (warn "Exiting child pid has no proc object." pid status)))))

;;; Pop one off the list.
(define (get-reaped-proc!)
  (let loop ((try (pop-reaped-proc)))
    (if (and try (proc:zombie try))
	try
	(loop (pop-reaped-proc)))))

;;; PROC no longer eligible to be in the list. Delete it.
(define (mark-proc-waited! proc)
  (set-proc:zombie proc #f))