From 5da7a55bacfc6b1597eb4c5126005536aa3d0801 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
 <address@hidden>
Date: Wed, 19 Dec 2018 12:47:28 +0100
Subject: [PATCH 2/2] Modifiy internals to line up with fixes in srfi-18.

---
 scheduler.scm | 53 ++++++++++++++++++++++++++++++-----------------------
 1 file changed, 30 insertions(+), 23 deletions(-)

diff --git a/scheduler.scm b/scheduler.scm
index 32c2743c..df4db928 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -197,6 +197,7 @@ EOF
 		      (if (>= now tmo1) ; timeout reached?
 			  (begin
 			    (##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
+			    (##sys#setislot tto 4 #f) ; clear timeout
 			    (##sys#thread-clear-blocking-state! tto)
 			    (##sys#thread-basic-unblock! tto)
 			    (loop (cdr lst)) )
@@ -288,16 +289,20 @@ EOF
 (define ##sys#timeout-list '())
 
 (define (##sys#remove-from-timeout-list t)
-  (let loop ((l ##sys#timeout-list) (prev #f))
-    (if (null? l)
-	l
-	(let ((h (##sys#slot l 0))
-	      (r (##sys#slot l 1)))
-	  (if (eq? (##sys#slot h 1) t)
-	      (if prev
-		  (set-cdr! prev r)
-		  (set! ##sys#timeout-list r))
-	      (loop r l))))))
+  (define (removeit t)
+    (let loop ((l ##sys#timeout-list) (prev #f))
+      (if (null? l)
+	  l
+	  (let ((h (##sys#slot l 0))
+		(r (##sys#slot l 1)))
+	    (if (eq? (##sys#slot h 1) t)
+		(if prev
+		    (set-cdr! prev r)
+		    (set! ##sys#timeout-list r))
+		(loop r l))))))
+  (when (##sys#slot t 4)  ;; no need to walk the queue without timeout
+     (removeit t)
+     (##sys#setislot t 4 #f))) ;; keep queue and thread state lexically in sync
 
 (define (##sys#thread-block-for-timeout! t tm)
   (dbg t " blocks for timeout " tm)
@@ -359,10 +364,12 @@ EOF
 
 (define (##sys#thread-basic-unblock! t)
   (dbg "unblocking: " t)
-  #;(if (##sys#slot t 11) ;; remove this case after testing
-      (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unclean unblock"
+  (if (##sys#slot t 11) ;; remove this case after testing
+      (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unblock with block object"
+		   (##sys#slot t 11)))
+  (if (##sys#slot t 4) ;; remove this case after testing
+      (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unblock with timeout"
 		   (##sys#slot t 11)))
-  (##sys#setislot t 4 #f)
   (##sys#add-to-ready-queue t) )
 
 (define (##sys#default-exception-handler arg)
@@ -490,16 +497,14 @@ EOF
 					 ((not (pair? p)) ; not blocked for I/O?
 					  ;; thread on fd-list is not blocked for I/O - this
 					  ;; is incorrect but will be ignored, just let it run
-					  (when (##sys#slot t 4) ; also blocked for timeout?
-					    (##sys#remove-from-timeout-list t))
+					  (##sys#remove-from-timeout-list t)  ; also blocked for timeout?
 					  (##sys#thread-clear-blocking-state! t)
 					  (##sys#thread-basic-unblock! t)
 					  (loop2 (cdr threads) keep))
 					 ((not (eq? fd (car p)))
 					  (panic (sprintf "thread is registered for I/O on unknown file-descriptor: ~S (expected ~S)" (car p) fd)))
 					 ((fdset-test inf outf (cdr p))
-					  (when (##sys#slot t 4) ; also blocked for timeout?
-					    (##sys#remove-from-timeout-list t))
+					  (##sys#remove-from-timeout-list t)
 					  (##sys#thread-clear-blocking-state! t)
 					  (##sys#thread-basic-unblock! t) 
 					  (loop2 (cdr threads) keep))
@@ -580,13 +585,15 @@ EOF
 
 ;;; Unblock thread cleanly:
 
+;;(: ##sys#thread-unblock! ((struct thread) -> boolean))
 (define (##sys#thread-unblock! t)
-  (when (or (eq? 'blocked (##sys#slot t 3))
-	    (eq? 'sleeping (##sys#slot t 3)))
-    (##sys#remove-from-timeout-list t)
-    (##sys#thread-clear-blocking-state! t)
-    (##sys#thread-basic-unblock! t) ) )
-
+  (and (let ((ts (##sys#slot t 3)))
+	 (or (eq? 'blocked ts) (eq? 'sleeping ts)))
+       (begin
+	 (##sys#remove-from-timeout-list t)
+	 (##sys#thread-clear-blocking-state! t)
+	 (##sys#thread-basic-unblock! t)
+	 #t) ) )
 
 ;;; Put a thread to sleep:
 
-- 
2.11.0