From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 20 Dec 2014 16:15:03 +0000 (-0700)
Subject: smp: Check for SIGCHLD in thread timer interrupt handler.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3b4bc23f80435895ec1d3b9ca6c0c20f1afb4b59;p=mit-scheme.git

smp: Check for SIGCHLD in thread timer interrupt handler.

An idle thread might get a SIGCHLD, wake and run the thread timer
interrupt handler (since there is no subprocess-status-change
interrupt) and return to idle.  If it is not the io-waiter, it does
not call test-select-registry nor otherwise notice the subprocess
status change.

Funnel all status change notifications through handle-subprocess-
status-change.  It uses the last-global-tick variable to remember the
tick when threads blocking on status changes were last woken.
---

diff --git a/src/runtime/process.scm b/src/runtime/process.scm
index 5df6f15a5..b2ae8111d 100644
--- a/src/runtime/process.scm
+++ b/src/runtime/process.scm
@@ -259,7 +259,14 @@ USA.
       ((3) 'JOB-CONTROL)
       (else (error "Illegal process job-control status:" n)))))
 
+(define last-global-tick '())
+
 (define (handle-subprocess-status-change)
+  (let ((latest-tick (subprocess-global-status-tick)))
+    (if (not (eq? latest-tick last-global-tick))
+	(begin
+	  (signal-subprocess-status-change)
+	  (set! last-global-tick latest-tick))))
   (if (eq? 'NT microcode-id/operating-system)
       (for-each (lambda (process)
 		  (if (memq (subprocess-status process) '(EXITED SIGNALLED))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c18b6067c..4ecd6737a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3847,6 +3847,10 @@ USA.
 	  handle-subprocess-status-change)
   (export (runtime socket)
 	  handle-subprocess-status-change)
+  (export (runtime thread)
+	  handle-subprocess-status-change)
+  (import (runtime thread)
+	  signal-subprocess-status-change)
   (initialization (initialize-package!)))
 
 (define-package (runtime synchronous-subprocess)
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index aec8de6a0..cdc984b1c 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -418,6 +418,7 @@ USA.
     (set! next-scheduled-timeout #f)
     (deliver-timer-events)
     (maybe-signal-io-thread-events)
+    (maybe-signal-subprocess-status)
     (cond ((and (not first-runnable-thread) (not old))
 	   (%maybe-toggle-thread-timer)
 	   (%%trace ";"id" thread-timer: continuing with timer set for "
@@ -654,18 +655,25 @@ USA.
 				  (vector-ref result 1)
 				  (vector-ref result 2)))
 	((eq? 'PROCESS-STATUS-CHANGE result)
-	 (signal-io-thread-events 1
-				  '#(PROCESS-STATUS-CHANGE)
-				  '#(READ)))))
+	 (handle-subprocess-status-change))))
+
+(define (signal-subprocess-status-change)
+  (%%trace ";"(%%id)" signal-subprocess-status-change\n")
+  (signal-io-thread-events 1 '#(PROCESS-STATUS-CHANGE) '#(READ)))
 
 (define (maybe-signal-io-thread-events)
-  (assert-locked 'maybe-signal-io-thread-events)
   (%%trace ";"(%%id)" maybe-signal-io-thread-events: testing\n")
+  (assert-locked 'maybe-signal-io-thread-events)
   (let ((result (test-select-registry io-registry #f)))
     (signal-select-result result)
     (%%trace ";"(%%id)" maybe-signal-io-thread-events => "
 	     (if (vector? result) (vector-ref result 0) result)"\n")))
 
+(define (maybe-signal-subprocess-status)
+  (assert-locked 'maybe-signal-subprocess-status)
+  (%%trace ";"(%%id)" maybe-signal-subprocess-status\n")
+  (handle-subprocess-status-change))
+
 (define (block-on-io-descriptor descriptor mode)
   (let ((result 'INTERRUPT)
 	(thread (current-thread)))