+ Lock for the process table
+ Use wait-lock to glue waiting and the process object together + Delete the pid/weak-pointer pair in the process table if the process object gets finalized
This commit is contained in:
parent
47d41db14e
commit
54efae2318
|
@ -42,11 +42,16 @@
|
|||
(make-reinitializer (lambda ()
|
||||
(set! process-table (make-integer-table))))
|
||||
|
||||
(define process-table-lock (make-lock))
|
||||
(define (process-table-ref n)
|
||||
(weak-table-ref process-table n))
|
||||
(with-lock process-table-lock
|
||||
(lambda ()
|
||||
(weak-table-ref process-table n))))
|
||||
|
||||
(define (process-table-set! n val)
|
||||
(weak-table-set! process-table n val))
|
||||
(with-lock process-table-lock
|
||||
(lambda ()
|
||||
(weak-table-set! process-table n val))))
|
||||
|
||||
(define (maybe-pid->proc pid)
|
||||
(process-table-ref pid))
|
||||
|
@ -150,8 +155,8 @@
|
|||
(let lp ((event (most-recent-sigevent)))
|
||||
(let ((next-event (next-sigevent event interrupt/post-gc)))
|
||||
(*post/gc-handler*)
|
||||
(lp next-event))))
|
||||
'*post/gc-handler*-thread))
|
||||
(lp next-event))))
|
||||
'*post/gc-handler*-thread))
|
||||
|
||||
(define set-post/gc-handler! start-set-post/gc-handler!)
|
||||
|
||||
|
@ -195,10 +200,13 @@
|
|||
;;; reap this special pid
|
||||
;;; return status or #f
|
||||
(define (reap-pid pid)
|
||||
(let ((status (atomic-wait pid wait/poll)))
|
||||
(if status
|
||||
(waited-by-reap pid status))
|
||||
status))
|
||||
(with-lock
|
||||
wait-lock
|
||||
(lambda ()
|
||||
(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)
|
||||
|
@ -212,6 +220,7 @@
|
|||
;;; Finalizer for procobjs
|
||||
;;;
|
||||
(define (procobj-finalizer procobj)
|
||||
(process-table-set! (proc:pid procobj) #f)
|
||||
(if (not (proc:finished? procobj))
|
||||
(need-reaping-add! (proc:pid procobj))))
|
||||
|
||||
|
@ -222,14 +231,18 @@
|
|||
|
||||
(define (reap-zombies)
|
||||
(let lp ()
|
||||
(obtain-lock wait-lock)
|
||||
(receive (pid status)
|
||||
(%wait-any (bitwise-ior wait/poll wait/stopped-children))
|
||||
(if pid
|
||||
(begin (waited-by-reap pid status)
|
||||
(release-lock wait-lock)
|
||||
; (format (current-error-port)
|
||||
; "Reaping ~d[~d]~%" pid status)
|
||||
(lp))
|
||||
status))))
|
||||
(begin
|
||||
(release-lock wait-lock)
|
||||
status)))))
|
||||
|
||||
|
||||
|
||||
|
@ -260,7 +273,7 @@
|
|||
|
||||
|
||||
;;; With this lock, we ensure that only one thread may call
|
||||
;;; really-wait for a given pid
|
||||
;;; really-wait for a given pid and manipulates the associated process object
|
||||
|
||||
(define wait-lock (make-lock))
|
||||
|
||||
|
@ -272,26 +285,29 @@
|
|||
status)))
|
||||
;; save the event before we check for finished
|
||||
(let ((pre-event (most-recent-sigevent)))
|
||||
(cond ((atomic-wait proc (bitwise-ior flags wait/poll)) => win)
|
||||
(with-lock
|
||||
wait-lock
|
||||
(lambda ()
|
||||
(cond ((atomic-wait proc (bitwise-ior flags wait/poll)) => win)
|
||||
|
||||
((zero? (bitwise-and flags wait/poll))
|
||||
;; we have to block and hence use the event system
|
||||
(let lp ((pre-event pre-event))
|
||||
(cond ((atomic-wait proc (bitwise-ior flags wait/poll))
|
||||
=> win)
|
||||
(else
|
||||
(lp (next-sigevent pre-event interrupt/chld))))))
|
||||
(else #f)))))
|
||||
((zero? (bitwise-and flags wait/poll))
|
||||
;; we have to block and hence use the event system
|
||||
(let lp ((pre-event pre-event))
|
||||
(cond ((atomic-wait proc (bitwise-ior flags wait/poll))
|
||||
=> win)
|
||||
(else
|
||||
(release-lock wait-lock)
|
||||
(let ((next-event (next-sigevent pre-event interrupt/chld)))
|
||||
(obtain-lock wait-lock)
|
||||
(lp next-event))))))
|
||||
(else #f)))))))
|
||||
|
||||
|
||||
;;; -> process-object proc status/#f
|
||||
(define (atomic-wait proc flags)
|
||||
(with-lock
|
||||
wait-lock
|
||||
(lambda ()
|
||||
(cond ((proc:finished? proc)
|
||||
(placeholder-value (proc:status proc)))
|
||||
(else (really-wait (proc:pid proc) (bitwise-ior flags wait/poll)))))))
|
||||
(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
|
||||
|
@ -315,7 +331,8 @@
|
|||
(cond ((maybe-pid->proc pid) =>
|
||||
(lambda (proc)
|
||||
(obituary proc status)
|
||||
(push-reaped-proc proc)))))
|
||||
(push-reaped-proc proc)
|
||||
))))
|
||||
|
||||
|
||||
;;; All you have to do, if a wait on proc was successful
|
||||
|
@ -373,13 +390,16 @@
|
|||
(define (really-wait-any flags)
|
||||
(if (zero? (bitwise-and flags wait/poll))
|
||||
(error "real-wait-any without wait/poll" flags))
|
||||
(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))))
|
||||
(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]
|
||||
|
@ -424,7 +444,10 @@
|
|||
|
||||
;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Direct interfaces to waitpid(2) call.
|
||||
;;; Direct interfaces to waitpid(2) call. As opposed to %wait-pid 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.
|
||||
|
||||
|
|
Loading…
Reference in New Issue