From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 20 Dec 2014 16:27:47 +0000 (-0700)
Subject: smp: Add io-waiter and arrange for ONE processor to io-wait.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=de668dc922040da0fcf5ff2268bc0bceff11b81a;p=mit-scheme.git

smp: Add io-waiter and arrange for ONE processor to io-wait.

Also, clean up the stack in SMP-IDLE.  And do NOT tail into a runnable
thread in signal-thread-event -- always return.
---

diff --git a/src/microcode/prossmp.c b/src/microcode/prossmp.c
index eab9c4797..707229d46 100644
--- a/src/microcode/prossmp.c
+++ b/src/microcode/prossmp.c
@@ -508,7 +508,15 @@ Wait for interrupts.")
   trace (";%d SMP-Idle.", self->id);
   self->state = PROCESSOR_IDLE;
 
-  assert (GET_INT_MASK == INT_Mask);
+  /* Abandon continuation. */
+  stack_pointer = STACK_BOTTOM;
+ Will_Push (CONTINUATION_SIZE);
+  SET_RC (RC_END_OF_COMPUTATION);
+  SET_EXP (SHARP_F);
+  SAVE_CONT ();
+ Pushed ();
+
+  SET_INTERRUPT_MASK (INT_Mask);
   while (! ((PENDING_INTERRUPTS_P)
 	    || OS_process_any_status_change ()))
     {
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index cdc984b1c..3195a8abc 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -285,6 +285,7 @@ USA.
   (set! last-runnable-thread thread)
   (complain-if (not (eq? #f (thread/next thread)))
 	       "%thread-running: last-runnable-thread has a next")
+  (%maybe-wake-idle-processor id)
   unspecific)
 
 (define (thread-not-running id thread state)
@@ -614,7 +615,25 @@ USA.
 (define (reset-threads-high!)
   (set! io-registry (and ((ucode-primitive have-select? 0))
 			 (make-select-registry)))
-  (set! io-registrations #f))
+  (set! io-registrations #f)
+  (set! io-waiter #f))
+
+(define io-waiter)
+
+(define (%maybe-wake-idle-processor id)
+  (%%trace ";"id" %maybe-wake-idle-processor\n")
+  (assert-locked '%maybe-wake-idle-processor)
+  (complain-if (not (only-gc-ok?))
+	       "%maybe-wake-idle-processor: with interrupts")
+  (let ((len (vector-length current-threads)))
+    (let loop ((id* 0))
+      (if (fix:< id* len)
+	  (if (and (not (%current-thread id*))
+		   (not (fix:= id* id)))
+	      (begin
+		(%%trace ";"id" waking "id*"\n")
+		((ucode-primitive smp-wake 1) id*))
+	      (loop (fix:1+ id*)))))))
 
 (define (wait-for-io id)
   ;; This procedure never returns.
@@ -624,11 +643,26 @@ USA.
 	       "wait-for-io: with interrupts")
   (complain-if (%current-thread id)
 	       "wait-for-io: not idle")
+  (if io-waiter
+      (begin
+	(%%trace ";"id" wait-for-io: idling\n")
+	(%unlock)
+	;; This primitive never returns, but it unmasks all interrupts.
+	((ucode-primitive smp-idle 0)))
+      (begin
+	(%%trace ";"id" wait-for-io: waiting\n")
+	(set! io-waiter id)
+	(io-waiter-wait id))))
+
+(define (io-waiter-wait id)
+  ;; This procedure never returns.
+  (%%trace ";"id" io-waiter-wait\n")
+  (assert-locked 'io-waiter-wait)
   (%maybe-toggle-thread-timer #f)
-  (%%trace ";"id" wait-for-io: next timeout = "next-scheduled-timeout"\n")
+  (%%trace ";"id" io-waiter-wait: next timeout = "next-scheduled-timeout"\n")
   (let ((result
 	 (begin
-	   (%%trace ";"id" wait-for-io: blocking for i/o\n")
+	   (%%trace ";"id" io-waiter-wait: blocking for i/o\n")
 	   (%unlock)
 	   (set-interrupt-enables! interrupt-mask/all)
 	   (test-select-registry io-registry #t))))
@@ -636,15 +670,16 @@ USA.
     (%lock)
     (signal-select-result result)
     (complain-if (%current-thread id)
-		 "wait-for-io: ALREADY running a thread")
+		 "io-waiter-wait: ALREADY running a thread")
     (if first-runnable-thread
 	(begin
 	  (complain-if (not (thread/continuation first-runnable-thread))
-		       "wait-for-io: BOGUS runnable")
-	  (%%trace ";"id" wait-for-io:"
+		       "io-waiter-wait: BOGUS runnable")
+	  (%%trace ";"id" io-waiter-wait:"
 		   " run-first-thread "first-runnable-thread"\n")
+	  (set! io-waiter #f)
 	  (run-first-thread id))
-	(wait-for-io id))))
+	(io-waiter-wait id))))
 
 (define (signal-select-result result)
   (%%trace ";"(%%id)" signal-select-result"
@@ -1020,15 +1055,9 @@ USA.
 	     (%lock)
 	     (%trace ";"id" signal-thread-event: %signal\n")
 	     (%signal-thread-event thread event)
-	     (if (and (not self) first-runnable-thread)
-		 (begin
-		   (%trace ";"id" signal-thread-event"
-			   " running "first-runnable-thread"\n")
-		   (run-first-thread id))
-		 (begin
-		   (%maybe-toggle-thread-timer)
-		   (%trace ";"id" signal-thread-event: done\n")
-		   (%unlock)))))))))
+	     (%maybe-toggle-thread-timer)
+	     (%trace ";"id" signal-thread-event: done\n")
+	     (%unlock)))))))
 
 (define (%signal-thread-event thread event)
   (assert-locked '%signal-thread-event)