From: Taylor R Campbell <campbell@mumble.net>
Date: Mon, 1 Jul 2013 15:15:25 +0000 (+0000)
Subject: Don't assume there is a current thread when interrupted.
X-Git-Tag: release-9.2.0~146
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=83dcf806feb364919a51e686910cd3d892affb37;p=mit-scheme.git

Don't assume there is a current thread when interrupted.

Fixes error `No current thread!' when the thread timer interrupt
handler tries to find the interrupted thread's floating-point
environment and there is no current thread.
---

diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm
index 29b3cae54..df05a585d 100644
--- a/src/runtime/floenv.scm
+++ b/src/runtime/floenv.scm
@@ -59,8 +59,17 @@ USA.
 ;;; Save the floating-point environment and enter the default
 ;;; environment for the thread timer interrupt handler.
 
-(define (enter-default-float-environment)
-  (let ((fp-env (thread-float-environment (current-thread))))
+(define (enter-default-float-environment interrupted-thread)
+  (let ((fp-env
+	 (if interrupted-thread
+	     (let ((fp-env (thread-float-environment interrupted-thread)))
+	       (if (eqv? fp-env #t)
+		   (let ((fp-env ((ucode-primitive FLOAT-ENVIRONMENT 0))))
+		     (set-thread-float-environment! interrupted-thread fp-env)
+		     fp-env)
+		   fp-env))
+	     ;; No idea what environment we're in.  Assume the worst.
+	     ((ucode-primitive FLOAT-ENVIRONMENT 0)))))
     (if fp-env
 	((ucode-primitive SET-FLOAT-ENVIRONMENT 1) default-environment))
     fp-env))
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 7cc203009..218365943 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -296,7 +296,7 @@ USA.
   ;; Preserve the floating-point environment here to guarantee that the
   ;; thread timer won't raise or clear exceptions (particularly the
   ;; inexact result exception) that the interrupted thread cares about.
-  (let ((fp-env (enter-default-float-environment)))
+  (let ((fp-env (enter-default-float-environment first-running-thread)))
     (set! next-scheduled-timeout #f)
     (set-interrupt-enables! interrupt-mask/gc-ok)
     (deliver-timer-events)