smp: Use process-status-sync-all only while threads are locked.
authorMatt Birkholz <puck@birchwood-abbey.net>
Thu, 12 Mar 2015 18:37:05 +0000 (11:37 -0700)
committerMatt Birkholz <puck@birchwood-abbey.net>
Thu, 12 Mar 2015 18:37:05 +0000 (11:37 -0700)
Subprocess-global-status-tick now just returns (runtime subprocess)'s
global-status-tick.  Thus process-status-sync-all is used in
single-threaded fashion in handle-subprocess-status-change, which is
used by the test-select- procedures to clear the condition that causes
the test-select- primitives to always return 'process-status-change.

Handle-subprocess-status-change is now only called in test-select-
descriptor.  The non-locking version, %handle-subprocess-status-
change, is only called in io-waiter's wait-for-io loop (the only place
where test-select-registry is used).

Punted the block? parameter to test-select-descriptor.  This procedure
should never be used to block Scheme.  Only the call to test-select-
registry in the wait-for-io loop should block.

src/runtime/io.scm
src/runtime/process.scm
src/runtime/runtime.pkg
src/runtime/thread.scm

index 84481bcaab55fd269025801685d85c3da8f38d8a..1c0cff227604f455f7d67400267c1c3b70d61cab 100644 (file)
@@ -177,11 +177,9 @@ USA.
   (let loop ()
     (let ((n (%channel-read channel buffer start end)))
       (if (eq? n #t)
-         (begin
-           (handle-subprocess-status-change)
-           (if (channel-blocking? channel)
-               (loop)
-               #f))
+         (if (channel-blocking? channel)
+             (loop)
+             #f)
          n))))
 
 (define (%channel-read channel buffer start end)
@@ -208,11 +206,9 @@ USA.
   (let loop ()
     (let ((n (%channel-write channel buffer start end)))
       (if (eq? n #t)
-         (begin
-           (handle-subprocess-status-change)
-           (if (channel-blocking? channel)
-               (loop)
-               #f))
+         (if (channel-blocking? channel)
+             (loop)
+             #f)
          n))))
 
 (define (%channel-write channel buffer start end)
@@ -542,36 +538,33 @@ USA.
 (define (channel-has-input? channel)
   (let ((descriptor (channel-descriptor-for-select channel)))
     (let loop ()
-      (let ((mode (test-select-descriptor descriptor #f 'READ)))
+      (let ((mode (test-select-descriptor descriptor 'READ)))
        (if (pair? mode)
            (or (eq? (car mode) 'READ)
                (eq? (car mode) 'READ/WRITE))
-           (begin
-             (if (eq? mode 'PROCESS-STATUS-CHANGE)
-                 (handle-subprocess-status-change))
-             (loop)))))))
+           (loop))))))
 
 (define-integrable (channel-descriptor-for-select channel)
   ((ucode-primitive channel-descriptor 1) (channel-descriptor channel)))
 
 (define (test-for-io-on-descriptor descriptor block? mode)
-  (or (let ((rmode (test-select-descriptor descriptor #f mode)))
+  (or (let ((rmode (test-select-descriptor descriptor mode)))
        (if (pair? rmode)
            (simplify-select-registry-mode rmode)
            rmode))
       (and block?
           (block-on-io-descriptor descriptor mode))))
 
-(define (test-select-descriptor descriptor block? mode)
+(define (test-select-descriptor descriptor mode)
   (let ((result
         ((ucode-primitive test-select-descriptor 3)
          descriptor
-         block?
+         #f
          (encode-select-registry-mode mode))))
     (cond ((>= result 0) (decode-select-registry-mode result))
          ((= result -1) 'INTERRUPT)
          ((= result -2)
-          (subprocess-global-status-tick)
+          (handle-subprocess-status-change)
           'PROCESS-STATUS-CHANGE)
          (else
           (error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
@@ -633,9 +626,7 @@ USA.
            (deallocate-select-registry-result-vectors vfd vmode)
            (cond ((= 0 result) #f)
                  ((= -1 result) 'INTERRUPT)
-                 ((= -2 result)
-                  (subprocess-global-status-tick)
-                  'PROCESS-STATUS-CHANGE)
+                 ((= -2 result) 'PROCESS-STATUS-CHANGE)
                  (else
                   (error "Illegal result from TEST-SELECT-REGISTRY:"
                          result))))))))
index a08a5bdb2b7d97fcb7e2aa27930feaab5f07d698..c2ad76fe8bda22ea231109dc91431fd439d3a9c9 100644 (file)
@@ -224,11 +224,7 @@ USA.
        tick)))
 
 (define (subprocess-global-status-tick)
-  (if ((ucode-primitive process-status-sync-all 0))
-      (let ((tick (cons #f #f)))
-       (set! global-status-tick tick)
-       tick)
-      global-status-tick))
+  global-status-tick)
 
 (define (convert-subprocess-status status)
   (case status
@@ -249,17 +245,8 @@ USA.
       ((3) 'JOB-CONTROL)
       (else (error "Illegal process job-control status:" n)))))
 \f
-(define last-global-tick '())
-
-(define (handle-status-change signaler)
-  (let ((latest-tick (subprocess-global-status-tick)))
-    (if (not (eq? latest-tick last-global-tick))
-       (begin
-         (signaler)
-         (set! last-global-tick latest-tick)))))
-
 (define (handle-subprocess-status-change)
-  (handle-status-change signal-subprocess-status-change)
+  (with-threads-locked %handle-subprocess-status-change)
   (if (eq? 'NT microcode-id/operating-system)
       (for-each (lambda (process)
                  (if (memq (subprocess-status process) '(EXITED SIGNALLED))
@@ -267,7 +254,10 @@ USA.
                (subprocess-list))))
 
 (define (%handle-subprocess-status-change)
-  (handle-status-change %signal-subprocess-status-change))
+  (if ((ucode-primitive process-status-sync-all 0))
+      (begin
+       (set! global-status-tick (cons #f #f))
+       (%signal-subprocess-status-change))))
 
 (define-integrable subprocess-job-control-available?
   (ucode-primitive os-job-control? 0))
index cfb2169b576581aceb619f3b7a2f012610f1a984..80d6355a71acb0a6926c02d9a79d91ab2e9474bf 100644 (file)
@@ -3873,8 +3873,8 @@ USA.
   (export (runtime thread)
          %handle-subprocess-status-change)
   (import (runtime thread)
-         %signal-subprocess-status-change
-         signal-subprocess-status-change)
+         with-threads-locked
+         %signal-subprocess-status-change)
   (initialization (initialize-package!)))
 
 (define-package (runtime synchronous-subprocess)
index ddf49817e379fce4da9603b2401839b09758580f..3301419421b764748a45ba1bacd09bb0f891e574 100644 (file)
@@ -46,8 +46,8 @@ USA.
 
 (define locked? #f)
 
-(define-integrable (get-interrupt-enables)
-  ((ucode-primitive get-interrupt-enables 0)))
+(define-integrable get-interrupt-enables
+  (ucode-primitive get-interrupt-enables 0))
 
 (define-integrable (only-gc-ok?)
   (fix:= 0 (fix:andc (get-interrupt-enables) interrupt-mask/gc-ok)))
@@ -729,10 +729,6 @@ USA.
        ((eq? 'PROCESS-STATUS-CHANGE result)
         (%handle-subprocess-status-change))))
 
-(define (signal-subprocess-status-change)
-  (%%trace ";"(%%id)" signal-subprocess-status-change\n")
-  (with-threads-locked %signal-subprocess-status-change))
-
 (define (%signal-subprocess-status-change)
   (%%trace ";"(%%id)" %signal-subprocess-status-change\n")
   (assert-locked '%signal-subprocess-status-change)