From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 11 Jul 2013 20:23:29 +0000 (-0700)
Subject: Merge branch 'master' into Gtk
X-Git-Tag: mit-scheme-pucked-9.2.12~487
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b745e3ab01105b3c6577638cfa1a6e227349dc13;p=mit-scheme.git

Merge branch 'master' into Gtk
---

b745e3ab01105b3c6577638cfa1a6e227349dc13
diff --cc src/runtime/thread.scm
index c9b328f6d,218365943..c7a5a87fb
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@@ -246,11 -244,9 +247,10 @@@ USA
    (without-interrupts %suspend-current-thread))
  
  (define (%suspend-current-thread)
 +  (%trace ";%suspend-current-thread: "first-running-thread"\n")
    (call-with-current-thread #f
      (lambda (thread)
-       (let ((fp-env (flo:environment))
- 	    (block-events? (thread/block-events? thread)))
+       (let ((block-events? (thread/block-events? thread)))
  	(set-thread/block-events?! thread #f)
  	(maybe-signal-io-thread-events)
  	(let ((any-events? (handle-thread-events thread)))
@@@ -300,9 -296,7 +300,9 @@@
    ;; 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.
 +  (%trace ";thread-timer: interrupt in "first-running-thread"\n")
-   (let ((fp-env (flo:environment)))
+   (let ((fp-env (enter-default-float-environment first-running-thread)))
 +    (flo:set-environment! (flo:default-environment))
      (set! next-scheduled-timeout #f)
      (set-interrupt-enables! interrupt-mask/gc-ok)
      (deliver-timer-events)
@@@ -317,20 -308,11 +317,20 @@@
  	     (run-thread thread))
  	    ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
  		       (thread/execution-state thread)))
 +	     (%trace ";thread-timer: yielding "thread" to "(thread/next thread)"\n")
  	     (yield-thread thread fp-env))
  	    (else
 +	     (%trace ";thread-timer: continuing with "thread"\n")
- 	     (flo:set-environment! fp-env)
+ 	     (restore-float-environment-from-default fp-env)
  	     (%resume-current-thread thread))))))
  
 +(define %trace? #f)
 +
 +(define-syntax %trace
 +  (syntax-rules ()
 +    ((_ . MSG)
 +     (if %trace? ((lambda () (outf-error . MSG)))))))
 +
  (define (yield-current-thread)
    (without-interrupts
     (lambda ()