From f27f4a9d4b14e4f258d52f416917956ed93d6557 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:47:36 +0100
Subject: [PATCH] Fix issues with ##sys#force-primordial breaking
 synchronization.

---
 srfi-18.scm          | 20 ++++++--------------
 tests/mutex-test.scm | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+), 14 deletions(-)

diff --git a/srfi-18.scm b/srfi-18.scm
index 28d3cd9..c0f5f84 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -238,20 +238,12 @@
 		   (##sys#make-structure 
 		    'condition '(uncaught-exception)
 		    (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) )
-		((blocked ready sleeping)
-                 (if limit
-                     (return
-                      (if tosupplied
-                          toval
-                          (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
+		      (signal
+		       (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ) ) ) )
 	   (##sys#thread-block-for-termination! ct thread)
 	   (##sys#schedule) ) ) ) ) ) )
 
diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index d052abb..996a4f7 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -179,6 +179,54 @@ Slot  Type                           Meaning
   (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n")
   (test-exit 1))
 
+(let* ((job (lambda ()
+	      (do ((i 1 (add1 i)))
+		  ((= i 10) i)
+		(##sys#force-primordial)
+		(thread-yield!))))
+       (t (thread-start! job))
+       (r (thread-join! t)))
+  (when (not (equal? r 10))
+     (print "Forcing primordial broke thread-join! result: " r)
+     (test-exit 1)))
+
+(let* ((mux (make-mutex 'done))
+       (job (lambda ()
+	      (do ((i 1 (add1 i)))
+		  ((= i 10)
+		   (mutex-specific-set! mux i)
+		   (mutex-unlock! mux))
+		(##sys#force-primordial)
+		(thread-yield!))))
+       (t (begin
+	    (mutex-lock! mux)
+	    (thread-start! job)))
+       (r (mutex-lock! mux)))
+  (when (not (and (eq? r #t)
+		  (equal? (mutex-specific mux) 10)))
+     (print "Forcing primordial broke mutex-lock! result: " r (mutex-specific mux))
+     (test-exit 1)))
+
+(let* ((mux (make-mutex 'done))
+       (cv (make-condition-variable))
+       (job (lambda ()
+	      (do ((i 1 (add1 i)))
+		  ((= i 10)
+		   (mutex-lock! mux)
+		   (mutex-specific-set! mux i)
+		   (condition-variable-signal! cv)
+		   (mutex-unlock! mux))
+		(##sys#force-primordial)
+		(thread-yield!))))
+       (t (begin
+	    (mutex-lock! mux)
+	    (thread-start! job)))
+       (r (mutex-unlock! mux cv)))
+  (when (not (and (eq? r #t)
+		  (equal? (mutex-specific mux) 10)))
+     (print "Forcing primordial broke mutex-unlock! result: " r (mutex-specific mux))
+     (test-exit 1)))
+
 (cond-expand (dribble
 (define-for-syntax count 0)
 (define-syntax trail
-- 
2.11.0