Use llrb-tree for pending processes to conserve some ressources and use only one thread to forrward SIGHCLD to.

Signed-off-by: Peter Bex <peter@more-magic.net>

2 files changed, 71 insertions, 36 deletions

diff --git a/scsh-process.egg b/scsh-process.egg
index 3189b27..25b83f8 100644
--- a/scsh-process.egg
+++ b/scsh-process.egg
@@ -4,7 +4,7 @@
  (author "Peter Bex")
  (category os)
  (license "BSD")
- (dependencies srfi-18 srfi-69)
+ (dependencies srfi-18 llrb-tree)
  (test-dependencies test)
  (components
   (extension scsh-process
diff --git a/scsh-process.scm b/scsh-process.scm
index 596a6b5..d6121c1 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -57,12 +57,12 @@
 (cond-expand
   (chicken-5 (import (chicken base) (chicken condition) (chicken io)
                      (chicken port) (chicken file) (chicken file posix)
-                     (chicken string)
-                     (chicken process) (chicken process signal)
-                     srfi-18 srfi-69))
+                     (chicken string) (chicken process)
+                     (chicken process signal) srfi-18 llrb-fixnum-table))
   (else (import chicken)
         (use data-structures (rename extras (read-file read-list))
-             utils files ports posix srfi-1 srfi-18 srfi-69)))
+             utils files ports posix srfi-1 srfi-18)
+        (use llrb-fixnum-table)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Process bookkeeping ;;
@@ -94,19 +94,47 @@
 ;; Deprecated
 (define process? scsh-process?)
 
-(define *scsh-pending-processes* (make-hash-table))
+(define-values
+  (clear-scsh-pending-processes!
+   add-scsh-pending-process!
+   scsh-pending-process-ref/default
+   remove-scsh-pending-process!
+   scsh-pending-process-fold
+   snapshot-scsh-pending-process)
+  (let ()
+     
+(define *scsh-pending-processes* (make-table))
 
 (define (clear-scsh-pending-processes!)
-  (set! *scsh-pending-processes* (make-hash-table)))
+  (set! *scsh-pending-processes* (make-table)))
 
 (define (add-scsh-pending-process! pid)
   (let* ((c (make-condition-variable pid))
          (process (make-scsh-process pid #f #f c)))
-    (hash-table-set! *scsh-pending-processes* pid process)
+    (table-update! *scsh-pending-processes* pid (lambda (x) process) (lambda () #f))
     process))
 
+(define (scsh-pending-process-ref/default pid default)
+  (table-ref/default *scsh-pending-processes* pid default))
+
 (define (remove-scsh-pending-process! pid)
-  (hash-table-delete! *scsh-pending-processes* pid))
+  (table-delete! *scsh-pending-processes* pid))
+
+(define (scsh-pending-process-fold proc nil)
+  (table-fold *scsh-pending-processes* proc nil))
+
+(define (snapshot-scsh-pending-process)
+  (let ((copy (table-copy *scsh-pending-processes*)))
+    (lambda (pid) (table-ref/default copy pid #f))))
+
+    (values
+     clear-scsh-pending-processes!
+     add-scsh-pending-process!
+     scsh-pending-process-ref/default
+     remove-scsh-pending-process!
+     scsh-pending-process-fold
+     snapshot-scsh-pending-process
+     )))
 
 (define wait #f)
 
@@ -128,11 +156,10 @@
           ;; handler will drop the pid from the pending list.
           (let ((pending-before
                  (if pid-or-process
-                     *scsh-pending-processes*
-                     (hash-table-copy *scsh-pending-processes*)))
+                     #f
+                     (snapshot-scsh-pending-process)))
                 (p (if (and pid-or-process (number? pid-or-process))
-                       (hash-table-ref/default *scsh-pending-processes*
-                                               pid-or-process #f)
+                       (scsh-pending-process-ref/default pid-or-process #f)
                        pid-or-process)))
             (if (and p (scsh-process-exit-status p))
                 (values (scsh-process-exit-status p)
@@ -164,8 +191,7 @@
                                           (scsh-process-ok? p)
                                           (scsh-process-pid p))))))
                        (else
-                        (and-let* ((p (or p (hash-table-ref/default
-                                             pending-before pid #f))))
+                        (and-let* ((p (or p (pending-before pid))))
                           (scsh-process-exit-status-set! p status)
                           (scsh-process-ok?-set! p ok?)
                           (condition-variable-broadcast!
@@ -183,28 +209,37 @@
                    (syntax-rules ()
                      ((_ val) (the (or boolean (procedure (fixnum) . *)) val))))
                   (else (syntax-rules () ((_ val) val))))))
-     (let ((old-handler (workaround (signal-handler signal/chld))))
+     (let* ((old-handler (workaround (signal-handler signal/chld)))
+            (rst #f) ;; restart scan if true
+            (handler
+             ;; Run the signal handler in another thread. This is needed
+             ;; because the current thread may be waiting on a condition
+             ;; variable, and we can't wake ourselves up.
+             (thread-start!
+              (lambda ()
+                (do () (#f)
+                  (set! rst #f)
+                  (scsh-pending-process-fold
+                   (lambda (pid p i)
+                     (and
+                      p
+                      (not (scsh-process-exit-status p))
+                      (receive (pid ok? status)
+                               (posix-process-wait pid #t)
+                               (if (and (not (zero? pid)) p)
+                                   (begin
+                                     (scsh-process-exit-status-set! p status)
+                                     (scsh-process-ok?-set! p ok?)
+                                     (condition-variable-broadcast!
+                                      (scsh-process-child-condition p))
+                                     ;; The GC can clean it up
+                                     (remove-scsh-pending-process! pid))))))
+                   #f)
+                  (unless rst (thread-suspend! (current-thread))))))
+             ))
        (lambda (signal)
-         ;; Run the signal handler in another thread. This is needed
-         ;; because the current thread may be waiting on a condition
-         ;; variable, and we can't wake ourselves up.
-         (thread-start!
-          (lambda ()
-            (for-each (lambda (pid)
-                        (handle-exceptions exn
-                            ;; User might have waited manually
-                            (begin (remove-scsh-pending-process! pid) (void))
-                          (receive (pid ok? status)
-                              (posix-process-wait pid #t)
-                            (unless (zero? pid)
-                              (let ((p (hash-table-ref *scsh-pending-processes* pid)))
-                                (scsh-process-exit-status-set! p status)
-                                (scsh-process-ok?-set! p ok?)
-                                (condition-variable-broadcast!
-                                 (scsh-process-child-condition p))
-                                ;; The GC can clean it up
-                                (remove-scsh-pending-process! pid))))))
-                      (hash-table-keys *scsh-pending-processes*))))
+         (set! rst #t)
+         (thread-resume! handler)
          (when old-handler (old-handler signal)))))))
 
 (define (signal-process proc sig)