From b2caefa73890fb7e502c0323d81aa36c1e60685b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
 <address@hidden>
Date: Wed, 19 Dec 2018 17:39:23 +0100
Subject: [PATCH 2/2] Use dedicated thread instead of forcing primordial for
 signals.

---
 scheduler.scm | 27 +++++++++++++++++++++++----
 srfi-18.scm   | 20 ++++++--------------
 2 files changed, 29 insertions(+), 18 deletions(-)

diff --git a/scheduler.scm b/scheduler.scm
index de008a1d..e8b48efd 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -222,10 +222,29 @@ EOF
 		[(eq? (##sys#slot nt 3) 'ready) (switch nt)]
 		[else (loop2)] ) ) ) ) ) )
 
-(define (##sys#force-primordial)
-  (dbg "primordial thread forced due to interrupt")
-  (##sys#setislot ##sys#primordial-thread 13 #f)
-  (##sys#thread-unblock! ##sys#primordial-thread) )
+(define ##sys#force-primordial
+  (let* ((thread #f)
+	 (install!
+	  (lambda ()
+	    (set! thread
+		  (##sys#make-thread
+		   (lambda ()
+		     (let loop ()
+		       ;; inline from (thread-suspend! (current-thread))
+		       (##sys#setslot thread 3 'suspended)
+		       (##sys#call-with-current-continuation
+			(lambda (return)
+			  (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
+			  (##sys#schedule) ) )
+		       (loop)))
+		   'suspended 'signal-handler 10)))))
+    (install!)
+    (lambda ()
+      (dbg "signal thread forced due to interrupt")
+      ;; inline from thread-resume!
+      (unless (eq? (##sys#slot thread 3) 'suspended) (install!))
+      (##sys#setslot thread 3 'ready)
+      (##sys#add-to-ready-queue thread))) )
 
 (define ready-queue-head '())
 (define ready-queue-tail '())
diff --git a/srfi-18.scm b/srfi-18.scm
index dbb572bb..5f06798f 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -181,20 +181,12 @@
 		   (##sys#make-structure 
 		    'condition '(uncaught-exception)
 		    (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) )
-		((blocked ready sleeping)
-                 (if limit
-                     (return
-                      (if tosupplied
-                          toval
-                          (##sys#signal
-                           (##sys#make-structure 'condition '(join-timeout-exception) '())) ) )
-                     (begin
-		       (##sys#thread-block-for-termination! ct thread)
-		       (##sys#schedule) ) ))
-                (else
-                 (##sys#error 'thread-join!
-                              "Internal scheduler error: unknown thread state"
-                              ct (##sys#slot thread 3)) ) ) ) )
+		(else
+		 (return
+		  (if tosupplied
+		      toval
+		      (##sys#signal
+		       (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ) ) ) )
 	   (##sys#thread-block-for-termination! ct thread)
 	   (##sys#schedule) ) ) ) ) ) )
 
-- 
2.11.0