;;; 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. (%status #f) ; The cached exit status of the process; ; #f if we haven't wait(2)'d the process yet. ;; Make proc objects print like #{proc 2318}. ((disclose p) (list "proc" (proc:pid p)))) ;;; Indexing this table by pid requires a linear scan. ;;; Probably not an important op, tho. (define process-table (make-population)) (define (maybe-pid->proc pid) (call/cc (lambda (quit) ;; Search the table. (walk-population (lambda (p) (if (= (proc:pid p) pid) (quit p))) process-table) #f))) (define (pid->proc pid . maybe-probe?) (let ((probe? (optional-arg 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. (add-to-population! p process-table) 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) (>= pid 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. ;;; ;;; - 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. ;;; ;;; - 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). ;;; ;;; - Reaping can be encouraged by calling (REAP-ZOMBIES). ;;; (autoreap-policy [new-policy]) (define *autoreap-policy* 'early) ; 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))))) old-policy)) ;;; (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) (let lp () (receive (pid status) (%wait-any wait/poll) (if pid (begin (add-reaped-proc! pid status) (lp)) status)))) ;;; This list contains procs that haven't exited yet. FORK adds new ;;; procs to the list. When a proc exits, it is removed from the list. ;;; Being on this list keeps live children's proc objects from being gc'd. (define unexited-procs '()) (define (new-child-proc pid) (let ((proc (make-proc pid))) (add-to-population! proc process-table) (set! unexited-procs (cons proc unexited-procs)) proc)) (define (mark-proc-exited proc) (set! unexited-procs (del proc unexited-procs))) ;;; (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. ;;; WAIT waits for a specific process. Currently, if the autoreap policy is ;;; 'early, it also does a (reap-zombies) Before performing a waitpid(2) ;;; systcall, wait first consults the proc object to see if a/the process has ;;; been reaped already. If so, its saved status is returned immediately. ;;; ;;; (wait-any [flags]) => [proc status] ;;; [#f #f] => non-blocking, none ready. ;;; [#f #t] => no more. ;;; (wait-process-group [pid/proc flags]) => [proc status] ;;; [#f #f] => non-blocking, none ready. ;;; [#f #t] => no more. (define (wait pid/proc . maybe-flags) (if (not *autoreap-policy*) (reap-zombies)) (let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait)) (proc (->proc pid/proc))) (cond ((proc:%status proc) => ; Already reaped. (lambda (status) (mark-proc-waited! proc) ; Not eligible for a WAIT-ANY. status)) (else ; Really wait. (cache-wait-status proc (%wait-pid (proc:pid proc) flags)))))) (define (cache-wait-status proc status) (cond ((and (integer? status) (not (status:stop-sig status))) ; He's dead, Jim. (set-proc:%status proc status) ; Cache exit status. (mark-proc-exited proc))) ; We're now gc'able. status) ;;; (wait-any [flags]) -> [proc status] (define (wait-any . maybe-flags) (let ((flags (check-arg integer? (optional-arg maybe-flags 0) wait-any))) (if (not *autoreap-policy*) (reap-zombies)) (cond ((get-reaped-proc!) => ; Check internal table. (lambda (proc) (values proc (proc:%status proc)))) ; Hit. (else (receive (pid status) (%wait-any flags) ; Really wait. (if pid (let ((proc (pid->proc pid))) (cache-wait-status proc status) (values proc status)) (values pid status))))))) ; pid = #f -- Empty poll. ;;; (wait-process-group [proc-group flags]) ;;; ;;; If you are doing process-group waits, you do *not* want to use ;;; early autoreaping, since the reaper loses process-group information. (define (wait-process-group . args) (receive (proc-group flags) (parse-optionals args 0 0) (check-arg integer? flags wait-process-group) (if (not *autoreap-policy*) (reap-zombies)) (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) (if err (if (= err errno/intr) (lp) (errno-error err %wait-pid pid flags)) (and (not (zero? pid)) status))))) ; pid=0 => none ready. (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. ;;; Whenever WAIT, WAIT-ANY, WAIT-PROCESS-GROUP waits on a process to exit, ;;; it removes the process from this table if it's in it. ;;; This code is bogus -- we use weak pointers. We need populations that ;;; support deletion or filtering. (define reaped-procs '()) ; Reaped, but not yet waited. (define (filter-weak-ptr-list pred lis) (reverse (reduce (lambda (wptr result) (let ((val (weak-pointer-ref wptr))) (if (and val (pred val)) (cons wptr result) result))) '() lis))) ;;; Add a newly-reaped proc to the list. (define (add-reaped-proc! pid status) (cond ((maybe-pid->proc pid) => (lambda (proc) (set-proc:%status proc status) (set! reaped-procs (cons (make-weak-pointer proc) reaped-procs)))) (else (error "Child pid mysteriously missing proc object." pid)))) ;;; Pop one off the list. (define (get-reaped-proc!) (and (pair? reaped-procs) (let ((proc (weak-pointer-ref (car reaped-procs)))) (set! reaped-procs (cdr reaped-procs)) (or proc (get-reaped-proc!))))) ;;; PROC no longer eligible to be in the list. Delete it. (define (mark-proc-waited! proc) (set! reaped-procs (filter-weak-ptr-list (lambda (elt) (not (eq? proc elt))) reaped-procs))) ;;; The mark-proc-waited! machinery above is a crock. It is inefficient -- ;;; we should have a flag in the proc saying if it's eligible for a WAIT-ANY. ;;; Starts off #t, changes to #f after a wait. On a #t->#f transition, we ;;; delete it from the WAIT-ANY population. Right now, every time the user ;;; waits on the proc, we re-delete it from the population -- which is ;;; a no-op after the first time.