;;; Unix waitt & process objects for scsh
;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers.
;;; Copyright (c) 2010 Clinton Ebadi

;;; Renamed from procobj.scm for Guile Facade

(define-module (scsh process-object)
  #:use-module (scsh define-record)
  #:use-module (scsh system-error)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 weak-vector)
  #:export (proc
	    proc:pid

	    autoreap-policy

	    ;; should these be exported from a different module? --clinton
	    wait
	    wait-any
	    wait-process-group

	    wait/poll
	    wait/stopped-children))

;;; 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) (proc:finished? p))))

(define procobj-guardian-lock (make-mutex))
(define %procobj-guardian (make-guardian))

(define (procobj-guardian . args)
  (with-mutex procobj-guardian-lock
    (apply procobj-guardian args)))

;; Unfortunately there is no way to specify the name of the constructor-
;; function in Olins define-record macro, so I had to do this...
(define (make-procobj pid)
  (let ((procobj (make-proc pid)))
    (procobj-guardian procobj)
    procobj))

;; 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).
;; 
;; JMG: why ever unexited processes were strong pointer, this won't work 
;; with (autoreap-policy 'late), since then gc waits for the strong pointer
;; until it wait(2)s and the strong pointer waits for wait(2) which is 
;; nothing but a deadlock

(define process-table (make-weak-value-hash-table ))
(define process-table-lock (make-mutex))

(define (process-table-ref n)
  (with-mutex process-table-lock
    (hashv-ref process-table n)))

(define (process-table-set! n val)
  (with-lock process-table-lock
    (hashv-set! process-table n val)))

(define (process-table-delete-procobj! procobj)
  (with-lock process-table-lock
    (if (eq? (hashv-ref process-table (proc:pid procobj))
	     procobj)
	(hashv-remove! process-table (proc:pid procobj)))))

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

(define* (pid->proc pid probe?)
  (or (maybe-pid->proc pid)
      (case probe?
	((#f)     (error "Pid has no corresponding process object" pid))
	((create) (new-child-proc pid))
	(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 'create))
	(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 #:optional new-policy)
  (let ((old-policy *autoreap-policy*))
    (cond ((not (memq new-policy '(early late #f)))
	   (error "Illegal autoreap policy." new-policy))
	  (else (set! *autoreap-policy* new-policy)
		(cond ((eq? new-policy 'early)
		       (start-reaping)
		       (set-sigchld-handler! early-sigchld-handler)
		       (set-post/gc-handler! notify-reap-need-reaping))
			    
		      ((eq? new-policy 'late)
		       (start-reaping)
		       (set-sigchld-handler! late-sigchld-handler)
		       (set-post/gc-handler! notify-reap-need-reaping))

		      (else
		       (stop-reaping)
		       (set-sigchld-handler! noauto-sigchld-handler)
		       (set-post/gc-handler! 
			(lambda ()
			  #f))))))
    old-policy))


;;; we don't register the post/gc-handler until the first police change
;;; --- this made sense, but why?
(define *post/gc-handler* 
  (lambda () (error "*post/gc-handler* was not defined")))

(define (really-set-post/gc-handler! handler)
  (monitor
   (remove-hook! after-gc-hook *post/gc-handler*)
   (set! *post/gc-handler* handler)
   (add-hook! after-gc-hook *post/gc-handler*)))

(define (start-set-post/gc-handler! handler)
  (monitor
   (set! set-post/gc-handler! really-set-post/gc-handler!)
   (set-post/gc-handler! handler)))

(define set-post/gc-handler! start-set-post/gc-handler!)

(define %sigchld-other-handler #f)

;;; Used to notify `wait' that another child has died (seems a bit
;;; convoluted for `really-wait' to never block, but I'm not sure why
;;; it behaves that way and so am leaving it alone for now)
(define sigchld-condition (make-condition-variable))

(define (wait-for-sigchld lock)
  (wait-condition-variable sigchld-condition lock))

(define (%sigchld-handler)
  (monitor ; not sure if this needs to be thread exclusive
   (if (procedure? %sigchld-other-handler)
       (%sigchld-other-handler))
   (*sigchld-handler*)
   (broadcast-condition-variable sigchld-condition)))

(define (*sigchld-handler*) (early-sigchld-handler))

;;; Attempts to coexist with other SIGCHLD handlers. Does not work if
;;; the handler is written in C
(define (set-sigchld-handler! handler)
  (monitor
   (let ((current-handler (car (sigaction SIGCHLD))))
     (if (and (procedure? current-handler)
	      (not (eq? current-handler %sigchld-handler)))
	 (set! %sigchld-other-handler current-handler))
     (sigaction SIGCHLD %sigchld-handler SA_NOCLDSTOP))
   (set! *sigchld-handler* handler)))

;;; Not implementing for now --clinton
;; (define (with-autoreaping thunk)
;;   (set! *autoreap-policy* 'early)
;;   (run-as-long-as
;;    (lambda ()
;;      (let lp ((event (most-recent-sigevent)))
;;        (let ((next-event (next-sigevent event interrupt/chld)))
;; 	 (*sigchld-handler*)
;; 	 (lp next-event))))
;;    thunk
;;    (structure-ref threads-internal spawn-on-root)
;;    'auto-reaping))

;;; This list contains pids whose proc-obj were gc'd before they died
;;; We try to reap them after every gc and maybe on every SIGCHLD
(define need-reaping '())

(define need-reaping-lock (make-mutex 'recursive))
(define need-reaping-condition (make-condition-variable))
(define need-reaping-thread #f)

(define (start-reaping)
  (cond (need-reaping-thread
	 (cancel-thread need-reaping-thread)
	 ;; should wake up the reap thread and cause the cancellation
	 ;; to be delivered when relocking the need-reaping-lock
	 (signal-condition-variable need-reaping-condition)
	 (set! need-reaping-thread #f)))
  (set! need-reaping-thread
	(call-with-new-thread reap-need-reaping-process)))

(define (notify-reap-need-reaping)
  (signal-condition-variable need-reaping-condition))

(define (need-reaping-add! pid)
  (with-mutex need-reaping-lock
    (set! need-reaping (cons pid need-reaping))))

(define (need-reaping-remove! pid)
  (with-mutex need-reaping-lock
    (set! need-reaping (delete pid need-reaping))))

(define (reap-need-reaping-process)
  (let reap-loop ()
    (with-mutex need-reaping-lock
      (wait-condition-variable need-reaping-condition need-reaping-lock)
      (let finalize-procobjs ((procobj (procobj-guardian)))
	(cond ((proc? procobj)
	         (process-table-delete-procobj! procobj)
		 (if (not (proc:finished? procobj))
		     (need-reaping-add! (proc:pid procobj)))
		 (finalize-procobjs (procobj-guardian)))))
      (set! need-reaping (filter (lambda (pid) (not (reap-pid pid))) need-reaping)))
    (reap-loop)))

;;; reap this special pid
;;; return status or #f 
(define (reap-pid pid)
  (with-mutex wait-lock
    (let ((status (atomic-wait pid wait/poll)))
      (if status 
	  (waited-by-reap pid status))
      status)))
	
;;; Handler for SIGCHLD according policy
(define (late-sigchld-handler) #f)

(define (early-sigchld-handler)
  (reap-zombies))

(define (noauto-sigchld-handler) #f)


;;; (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 ()
    (lock-mutex wait-lock)
    (receive (pid status)
      (%wait-any (bitwise-ior wait/poll wait/stopped-children))
      (if (and pid (not (status:stop-sig status)))
	  (begin (waited-by-reap pid status)
		 (unlock-mutex wait-lock)
;		 (format (current-error-port)
;			 "Reaping ~d[~d]~%" pid status)
		 (lp))
	  (begin 
	    (unlock-mutex wait-lock)
	    status)))))



(define (new-child-proc pid)
  (let ((proc (make-procobj pid)))
    (process-table-set! pid proc)
    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)

;;; JMG: We have to be careful about wait/poll and autoreap-policy:
;;; If it was 'late at anytime, we may missed the exit of pid/proc
;;; So we cannot just block and hope reap-zombies will give us the status


(define wait/poll WNOHANG)
(define wait/stopped-children WUNTRACED)

;;; With this lock, we ensure that only one thread may call
;;; really-wait for a given pid and manipulates the associated process object

(define wait-lock (make-mutex))

(define* (wait pid/proc #:optional (flags 0))
  (let* ((proc (->proc pid/proc))
	 (win (lambda (status)
		(waited-by-wait proc status)
		status)))
    ;; save the event before we check for finished
    (let ((pre-event (most-recent-sigevent)))
      (with-lock 
       wait-lock
       (lambda () 
	 (cond ((atomic-wait proc (bitwise-ior flags wait/poll)) => win)
	       ((zero? (bitwise-and flags wait/poll))
		;; blocking
		(let lp ()
		  (wait-for-sigchld wait-lock)
		  (cond ((atomic-wait proc (bitwise-ior flags wait/poll)) 
			 => win)
			(else (lp)))))
	       (else #f)))))))
	
;;; -> process-object proc status/#f
(define (atomic-wait proc flags)
  (cond ((proc:finished? proc)
	 (placeholder-value (proc:status proc)))
	(else (really-wait (proc:pid proc) (bitwise-ior flags wait/poll)))))
	   
;;; This one is used, to wait on a positive pid
;;; We NEVER do a blocking wait syscall 
(define (really-wait pid flags)
  (if (zero? (bitwise-and flags wait/poll))   
      (error "really-wait without wait/poll"))
  (if (< pid 1)
      (error "really-wait on nonpos pid" pid))
  (receive (return_pid status)
      (waitpid pid flags)
   (cond ((zero? return_pid) #f)      ; failed wait/poll
	 ((= pid return_pid) status)  ; made it
	 (else (error "mismatch in really-wait" 
		      return_pid pid)))))
  
;;; All you have to do, if pid was reaped
;;; proc_obj is maybe no longer alive
(define (waited-by-reap pid status)
  (cond ((maybe-pid->proc pid) =>
	 (lambda (proc) 
	   (obituary proc status)
	   (push-reaped-proc proc)))))

;;; All you have to do, if a wait on proc was successful
(define (waited-by-wait proc status)
  (if (not (status:stop-sig status))
      (begin
	(obituary proc status)
	(mark-proc-waited! proc))))

;;; we know from somewhere that proc is dead
(define (obituary proc status)
  (if (not (proc? proc))
      (error "obituary: proc was not a procobj" proc))
  (need-reaping-remove! (proc:pid proc))     ; in case it started during 'late
  (placeholder-set! (proc:status proc) status)
  (set-proc:finished? proc #t))



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

(define* (wait-any #:optional (flags 0))
  (if (zero? (bitwise-and flags wait/poll))
      (begin
	(receive (pid status) 
	    ;; before we maybe block via placeholder-value
	    ;; do a really-wait-any for the ones, missed by 'late
	    (really-wait-any (bitwise-ior flags  wait/poll))
	  (if (not pid)
	      (let ((win (get-reaped-proc!)))
		(values win (placeholder-value (proc:status win))))
	      (values pid status))))

      ;; The rest of this is quite crude and can be safely ignored. -df
      ;; JMG: wait-any is crude and so its implementation
      ;; It got even worse, now that we have this fu*$#%g 'late
      ;; ... maybe cleaned up, but probably just b0rked further --clinton
      (if (reaped-proc-available?)
	  (really-wait-any flags)
	  (let ((proc (weak-pointer-ref (reaped-proc:proc (pop-reaped-proc)))))
	    (if proc
		(values proc (placeholder-value (proc:status proc)))
		(values #f #f))))))

(define (really-wait-any flags)
  (if (zero? (bitwise-and flags wait/poll))
      (error "real-wait-any without wait/poll" flags))
  (with-lock
   wait-lock
   (lambda ()
     (receive (pid status)
        (%wait-any flags)
	(if pid
	    (let ((proc (new-child-proc pid)))
	      (waited-by-wait proc status)
	      (values proc status))
	    (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 #:optional (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))))
	(win (lambda (pid status)
	       (let ((proc (pid->proc pid 'create)))
		 (if proc (waited-by-wait proc status))
		 (values proc status)))))
    (receive (pid status) 
	(%wait-process-group proc-group (bitwise-ior flags wait/poll))
      (cond (pid
	     (win pid status))
	    ((zero? (bitwise-and flags wait/poll))
	     (let lp ()
	       (wait-for-sigchld)
	       (receive (pid status) 
		   (%wait-process-group proc-group (bitwise-ior flags wait/poll))
		 (if pid
		     (win pid status)
		     (lp)))))
	    (else 
	     (values #f status))))))




;;; (%wait-any flags) (waitpid pid flags) (%wait-process-group pgrp flags)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Direct interfaces to waitpid(2) call. As opposed to waitpid this
;;; waits on any child (using -1) and gets along if no child is alive
;;; at all (i.e. catches errno/child).

;;; [#f #f] means no processes ready on a non-blocking wait.
;;; [#f #t] means no waitable process on wait-any.

(define (%wait-any flags)
  (with-errno-handler 
   ((errno packet) 
    ((ECHILD)
     (values #f #t)))
   (receive (pid status)
       (waitpid WAIT_ANY flags)
    (if (zero? pid)
	(values #f #f)			; None ready.
	(values pid status)))))

(define (%wait-process-group pgrp flags)
  (if (zero? (bitwise-and flags wait/poll))   
      (error "really-wait without wait/poll"))
  (with-errno-handler 
   ((errno packet) 
    ((ECHILD)
     (values #f #t)))
   (receive (pid status) 
	(waitpid (- pgrp) flags)
     (if (zero? pid) 
	 (values #f #f)			; None ready.
	 (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)

;;; Shim for Schem48 weak-pointer interface
(define (make-weak-pointer datum)
  (weak-vector datum))
(define (weak-pointer-ref pointer)
  (vector-ref pointer 0))
(define (weak-pointer? pointer)
  (and (weak-vector? pointer) (vector-length pointer 1)))

(define reaped-proc-tail (make-reaped-proc (make-weak-pointer #f) 'head))
(define reaped-proc-head reaped-proc-tail)
(define reaped-proc-push-lock (make-mutex))
(define reaped-proc-pop-lock (make-mutex))          ;;; Zippy sez: pop lock!

(define (reaped-proc-available?)
  (with-mutex reaped-proc-pop-lock
    (not (eq? reaped-proc-head reaped-proc-tail))))

(define (push-reaped-proc proc)
  (lock-mutex reaped-proc-push-lock)
  (let ((push-me (make-reaped-proc (make-weak-pointer proc) reaped-proc-tail)))
    (placeholder-set! (reaped-proc:next reaped-proc-tail) push-me)
    ;; doesn't look like this is needed. A few extra reaped procs may
    ;; live on, but get-reaped-proc! will skip them. Doing this with
    ;; guardian would be a huge PITA as well. --clinton
    ;;(add-finalizer! proc (make-reaped-proc-finalizer push-me))
    (set! reaped-proc-tail push-me))
  (unlock-mutex reaped-proc-push-lock))

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

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