From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 29 May 2013 03:10:52 +0000 (+0000)
Subject: Implement lazy switching of thread floating-point environments.
X-Git-Tag: release-9.2.0~150^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e63457ff92e82d0c5d5af79674a6296e77e5da9e;p=mit-scheme.git

Implement lazy switching of thread floating-point environments.

Should reduce the overhead of thread switching and avoid
platform-dependent objects in threads that don't mess with the
floating-point environment so that they can be dumped in bands.
---

diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm
index 1b2580cf2..29b3cae54 100644
--- a/src/runtime/floenv.scm
+++ b/src/runtime/floenv.scm
@@ -29,62 +29,143 @@ USA.
 
 (declare (usual-integrations))
 
-;;;; Floating-Point Environment
+;;;; Floating-point environment
 
-(define-primitives
-  (flo:environment float-environment 0)
-  (flo:set-environment! set-float-environment 1)
-  (flo:defer-exception-traps! defer-float-exception-traps 0)
-  (flo:update-environment! update-float-environment 1))
+;;; A floating-point environment descriptor is either #F, representing
+;;; the default environment, or a platform-dependent description of the
+;;; environment encoded in a byte vector.  A floating-point environment
+;;; descriptor may be represented by a platform-dependent byte vector
+;;; even if it is operationally equivalent to the default environment.
+;;;
+;;; The floating-point environment is stored on the physical machine,
+;;; saved in the thread records of threads that are not running, and
+;;; cached in the thread record of the thread that is running.
+;;;
+;;; When the physical machine is updated, we invalidate the cache by
+;;; setting the current thread's floating-point environment to #T.
+;;; When switching threads, if the old thread's floating-point
+;;; environment is #T, we grab the environment from the machine and
+;;; stash it in that thread before entering the new thread.  During
+;;; thread-switching, we need to be in the default floating-point
+;;; environment so that the thread system logic doesn't get confused.
+;;;
+;;; The default environment must have a platform-independent
+;;; representation so that threads that have not modified their
+;;; floating-point environments can be saved to disk in platform-
+;;; independent bands.
 
-(define (flo:deferring-exception-traps procedure)
-  (flo:preserving-environment
-   (lambda ()
-     (let ((environment (flo:defer-exception-traps!)))
-       (let ((result (procedure)))
-	 (flo:update-environment! environment)
-	 result)))))
+;;; The routines on this page are hooks for the thread system.
 
-(define (flo:ignoring-exception-traps procedure)
-  (flo:preserving-environment
-   (lambda ()
-     (flo:defer-exception-traps!)
-     (procedure))))
+;;; Save the floating-point environment and enter the default
+;;; environment for the thread timer interrupt handler.
 
-(define (flo:preserving-environment procedure)
-  (let ((environment (flo:environment)))
-    (define (swap)
-      (let ((temporary environment))
-	(set! environment (flo:environment))
-	(flo:set-environment! temporary)))
-    (dynamic-wind swap procedure swap)))
+(define (enter-default-float-environment)
+  (let ((fp-env (thread-float-environment (current-thread))))
+    (if fp-env
+	((ucode-primitive SET-FLOAT-ENVIRONMENT 1) default-environment))
+    fp-env))
 
-(define (flo:with-default-environment procedure)
-  (flo:preserving-environment
-   (lambda ()
-     (flo:set-environment! (flo:default-environment))
-     (procedure))))
+;;; Restore the environment saved by ENTER-DEFAULT-FLOAT-ENVIRONMENT
+;;; when resuming a thread from the thread timer interrupt handler
+;;; without switching.
+
+(define (restore-float-environment-from-default fp-env)
+  (if fp-env
+      ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) fp-env)))
+
+;;; Enter a floating-point environment for switching to a thread.
+
+(define (enter-float-environment fp-env)
+  ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) (or fp-env default-environment)))
+
+;;; Save a floating-point environment when a thread yields or is
+;;; preempted and must let another thread run.  FP-ENV is absent when
+;;; explicitly yielding with YIELD-CURRENT-THREAD, or is the result of
+;;; ENTER-DEFAULT-FLOAT-ENVIRONMENT from the thread timer interrupt
+;;; handler.
+
+(define (maybe-save-thread-float-environment! thread #!optional fp-env)
+  (if (eqv? #t (thread-float-environment thread))
+      (set-thread-float-environment!
+       thread
+       (if (or (default-object? fp-env)
+	       (eqv? #t fp-env))
+	   ((ucode-primitive FLOAT-ENVIRONMENT 0))
+	   fp-env))))
+
+(define (use-floating-point-environment!)
+  (set-thread-float-environment! (current-thread) #t))
+
+(define (flo:environment)
+  (let ((fp-env (thread-float-environment (current-thread))))
+    (if (eqv? fp-env #t)
+	(let ((fp-env ((ucode-primitive FLOAT-ENVIRONMENT 0))))
+	  ;; Cache it now so we don't need to ask the machine again
+	  ;; when we next switch threads.  There is a harmless race
+	  ;; here if we are preempted.
+	  (set-thread-float-environment! (current-thread) fp-env)
+	  fp-env)
+	fp-env)))
+
+(define (flo:set-environment! fp-env)
+  (let ((old-fp-env (thread-float-environment (current-thread))))
+    (if (not (eqv? fp-env old-fp-env))
+	(begin
+	  ;; Update the thread cache first; if we updated the machine
+	  ;; first, then we might be preempted after that but before
+	  ;; updating the thread cache, and the thread starts running
+	  ;; again, there would be nothing to set the machine straight.
+	  (set-thread-float-environment! (current-thread) fp-env)
+	  ((ucode-primitive SET-FLOAT-ENVIRONMENT 1)
+	   (or fp-env default-environment))))))
+
+(define (flo:update-environment! fp-env)
+  (let ((old-fp-env (thread-float-environment (current-thread))))
+    (if (not (eqv? fp-env old-fp-env))
+	;; We need to prevent thread-switching between saving the
+	;; floating-point environment in the thread record and updating
+	;; the machine's state because we need the *old* state to be
+	;; still in place when the update happens so that exceptions
+	;; will be trapped.
+	;;
+	;; XXX We could just disable preemption, but we'd have to do
+	;; that in DYNAMIC-WIND in case UPDATE-FLOAT-ENVIRONMENT
+	;; signals an error, and DYNAMIC-WIND is super-expensive.
+	(without-interrupts
+	 (lambda ()
+	   (set-thread-float-environment! (current-thread) fp-env)
+	   ((ucode-primitive UPDATE-FLOAT-ENVIRONMENT 1)
+	    (or fp-env default-environment)))))))
 
 (define default-environment)
 
 (define (flo:default-environment)
-  default-environment)
+  #f)
 
 (define (reset-package!)
   (set! default-environment
-	(let ((environment (flo:environment)))
-	  (flo:set-rounding-mode! (flo:default-rounding-mode))
-	  (flo:clear-exceptions! (flo:supported-exceptions))
-	  (flo:set-trapped-exceptions! (flo:default-trapped-exceptions))
-	  (let ((environment* (flo:environment)))
-	    (flo:set-environment! environment)
-	    environment*)))
+	(without-interrupts
+	 (lambda ()
+	   (let ((fp-env ((ucode-primitive FLOAT-ENVIRONMENT 0))))
+	     ((ucode-primitive SET-FLOAT-ROUNDING-MODE 1)
+	      (%mode-name->number
+	       (flo:default-rounding-mode)
+	       '|#[(runtime floating-point-environment)reset-package!]|))
+	     ((ucode-primitive CLEAR-FLOAT-EXCEPTIONS 1)
+	      (flo:supported-exceptions))
+	     ((ucode-primitive SET-TRAPPED-FLOAT-EXCEPTIONS 1)
+	      (flo:default-trapped-exceptions))
+	     (let ((fp-env* ((ucode-primitive FLOAT-ENVIRONMENT 0))))
+	       ((ucode-primitive SET-FLOAT-ENVIRONMENT 1) fp-env)
+	       fp-env*)))))
   unspecific)
 
 (define (initialize-package!)
   (reset-package!)
   (add-event-receiver! event:after-restore reset-package!))
 
+;;;; Floating-point rounding mode
+
 (define-primitives
   (float-rounding-modes 0)
   (get-float-rounding-mode 0)
@@ -114,12 +195,14 @@ USA.
     (vector-ref float-rounding-mode-names m)))
 
 (define (flo:set-rounding-mode! mode)
+  (use-floating-point-environment!)
   (set-float-rounding-mode (%mode-name->number mode 'FLO:SET-ROUNDING-MODE!)))
 
 (define (flo:with-rounding-mode mode thunk)
   (let ((mode (%mode-name->number mode 'FLO:WITH-ROUNDING-MODE)))
     (flo:preserving-environment
      (lambda ()
+       (use-floating-point-environment!)
        (set-float-rounding-mode mode)
        (thunk)))))
 
@@ -133,6 +216,8 @@ USA.
 	  i
 	  (loop (fix:+ i 1))))))
 
+;;;; Floating-point exceptions and trapping
+
 (define-primitives
   (flo:supported-exceptions float-exceptions 0)
   (flo:exception:divide-by-zero float-divide-by-zero-exception 0)
@@ -141,17 +226,39 @@ USA.
   (flo:exception:overflow float-overflow-exception 0)
   (flo:exception:inexact-result float-inexact-result-exception 0)
   (flo:test-exceptions test-float-exceptions 1)
-  (flo:clear-exceptions! clear-float-exceptions 1)
-  (flo:raise-exceptions! raise-float-exceptions 1)
   (flo:save-exception-flags save-float-exception-flags 1)
   (flo:test-exception-flags test-float-exception-flags 2)
-  (flo:restore-exception-flags! restore-float-exception-flags 2)
   (flo:trapped-exceptions trapped-float-exceptions 0)
-  (flo:set-trapped-exceptions! set-trapped-float-exceptions 1)
-  (flo:trap-exceptions! trap-float-exceptions 1)
-  (flo:untrap-exceptions! untrap-float-exceptions 1)
   (flo:trappable-exceptions trappable-float-exceptions 0))
 
+(define (flo:clear-exceptions! exceptions)
+  (use-floating-point-environment!)
+  ((ucode-primitive CLEAR-FLOAT-EXCEPTIONS 1) exceptions))
+
+(define (flo:raise-exceptions! exceptions)
+  (use-floating-point-environment!)
+  ((ucode-primitive RAISE-FLOAT-EXCEPTIONS 1) exceptions))
+
+(define (flo:restore-exception-flags! fexcept exceptions)
+  (use-floating-point-environment!)
+  ((ucode-primitive RESTORE-FLOAT-EXCEPTION-FLAGS 2) fexcept exceptions))
+
+(define (flo:set-trapped-exceptions! exceptions)
+  (use-floating-point-environment!)
+  ((ucode-primitive SET-TRAPPED-FLOAT-EXCEPTIONS 1) exceptions))
+
+(define (flo:trap-exceptions! exceptions)
+  (use-floating-point-environment!)
+  ((ucode-primitive TRAP-FLOAT-EXCEPTIONS 1) exceptions))
+
+(define (flo:untrap-exceptions! exceptions)
+  (use-floating-point-environment!)
+  ((ucode-primitive UNTRAP-FLOAT-EXCEPTIONS 1) exceptions))
+
+(define (flo:defer-exception-traps!)
+  (use-floating-point-environment!)
+  ((ucode-primitive DEFER-FLOAT-EXCEPTION-TRAPS 0)))
+
 (define (flo:default-trapped-exceptions)
   ;; By default, we trap the standard IEEE 754 exceptions that Scheme
   ;; can safely run with trapped, in order to report errors as soon as
@@ -159,28 +266,15 @@ USA.
   ;; exception trapped (which you almost never want anyway), and there
   ;; are some non-standard exceptions which we will not trap in order
   ;; to keep behaviour consistent between host systems.
+  ;;
+  ;; XXX If you want to read the exceptions that don't trap by default,
+  ;; you must disable interrupts so that the lazy floating-point
+  ;; environment switching mechanism will work.  Is that too much of a
+  ;; burden?
   (fix:or (fix:or (flo:exception:divide-by-zero)
-                  (flo:exception:invalid-operation))
-          (fix:or (flo:exception:overflow)
-                  (flo:exception:underflow))))
-
-(define (flo:with-trapped-exceptions exceptions procedure)
-  (flo:preserving-environment
-   (lambda ()
-     (flo:set-trapped-exceptions! exceptions)
-     (procedure))))
-
-(define (flo:with-exceptions-trapped exceptions procedure)
-  (flo:preserving-environment
-   (lambda ()
-     (flo:trap-exceptions! exceptions)
-     (procedure))))
-
-(define (flo:with-exceptions-untrapped exceptions procedure)
-  (flo:preserving-environment
-   (lambda ()
-     (flo:untrap-exceptions! exceptions)
-     (procedure))))
+		  (flo:exception:invalid-operation))
+	  (fix:or (flo:exception:overflow)
+		  (flo:exception:underflow))))
 
 ;++ Include machine-dependent bits, by number rather than by name.
 
@@ -209,4 +303,51 @@ USA.
       ((UNDERFLOW) (flo:exception:underflow))
       (else (error:bad-range-argument names 'FLO:NAMES->EXCEPTIONS))))
   (guarantee-list-of-unique-symbols names 'FLO:NAMES->EXCEPTIONS)
-  (reduce fix:or 0 (map name->exceptions names)))
\ No newline at end of file
+  (reduce fix:or 0 (map name->exceptions names)))
+
+;;;; Floating-point environment utilities
+
+(define (flo:deferring-exception-traps procedure)
+  (flo:preserving-environment
+   (lambda ()
+     (let ((environment (flo:defer-exception-traps!)))
+       (begin0 (procedure)
+	 (flo:update-environment! environment))))))
+
+(define (flo:ignoring-exception-traps procedure)
+  (flo:preserving-environment
+   (lambda ()
+     (flo:defer-exception-traps!)
+     (procedure))))
+
+(define (flo:preserving-environment procedure)
+  (let ((environment (flo:environment)))
+    (define (swap)
+      (let ((temporary environment))
+	(set! environment (flo:environment))
+	(flo:set-environment! temporary)))
+    (dynamic-wind swap procedure swap)))
+
+(define (flo:with-default-environment procedure)
+  (flo:preserving-environment
+   (lambda ()
+     (flo:set-environment! (flo:default-environment))
+     (procedure))))
+
+(define (flo:with-trapped-exceptions exceptions procedure)
+  (flo:preserving-environment
+   (lambda ()
+     (flo:set-trapped-exceptions! exceptions)
+     (procedure))))
+
+(define (flo:with-exceptions-trapped exceptions procedure)
+  (flo:preserving-environment
+   (lambda ()
+     (flo:trap-exceptions! exceptions)
+     (procedure))))
+
+(define (flo:with-exceptions-untrapped exceptions procedure)
+  (flo:preserving-environment
+   (lambda ()
+     (flo:untrap-exceptions! exceptions)
+     (procedure))))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f9118acbf..6feca330f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -328,6 +328,11 @@ USA.
 	  flo:with-exceptions-untrapped
 	  flo:with-rounding-mode
 	  flo:with-trapped-exceptions)
+  (export (runtime thread)
+	  enter-default-float-environment
+	  enter-float-environment
+	  maybe-save-thread-float-environment!
+	  restore-float-environment-from-default)
   (initialization (initialize-package!)))
 
 (define-package (runtime integer-bits)
@@ -5015,6 +5020,9 @@ USA.
   (export (runtime continuation)
 	  get-thread-event-block
 	  set-thread-event-block!)
+  (export (runtime floating-point-environment)
+	  set-thread-float-environment!
+	  thread-float-environment)
   (initialization (initialize-package!)))
 
 (define-package (runtime rb-tree)
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 1b513294a..7cc203009 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -70,7 +70,10 @@ USA.
   ;; unwind the thread's state space when it is exited.
 
   (floating-point-environment #f)
-  ;; Thread-local floating-point environment.
+  ;; A floating-point environment descriptor, or #T if the thread is
+  ;; running and has modified its floating-point environment since it
+  ;; was last cached.  While a thread is running, this is a cache of
+  ;; the machine's floating-point environment.
 
   (mutexes '())
   ;; List of mutexes that this thread owns or is waiting to own.  Used
@@ -110,7 +113,6 @@ USA.
 (define (make-thread continuation)
   (let ((thread (%make-thread)))
     (set-thread/continuation! thread continuation)
-    (set-thread/floating-point-environment! thread (flo:default-environment))
     (set-thread/root-state-point! thread
 				  (current-state-point state-space:local))
     (add-to-population!/unsafe thread-population thread)
@@ -226,10 +228,9 @@ USA.
   (let ((continuation (thread/continuation thread))
 	(fp-env (thread/floating-point-environment thread)))
     (set-thread/continuation! thread #f)
-    (set-thread/floating-point-environment! thread #f)
     (%within-continuation continuation #t
       (lambda ()
-	(flo:set-environment! fp-env)
+	(enter-float-environment fp-env)
 	(%resume-current-thread thread)))))
 
 (define (%resume-current-thread thread)
@@ -245,8 +246,7 @@ USA.
 (define (%suspend-current-thread)
   (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)))
@@ -256,7 +256,7 @@ USA.
 	      (call-with-current-continuation
 	       (lambda (continuation)
 		 (set-thread/continuation! thread continuation)
-		 (set-thread/floating-point-environment! thread fp-env)
+		 (maybe-save-thread-float-environment! thread)
 		 (set-thread/block-events?! thread #f)
 		 (thread-not-running thread 'WAITING)))))))))
 
@@ -268,7 +268,7 @@ USA.
 	 (call-with-current-continuation
 	  (lambda (continuation)
 	    (set-thread/continuation! thread continuation)
-	    (set-thread/floating-point-environment! thread (flo:environment))
+	    (maybe-save-thread-float-environment! thread)
 	    (thread-not-running thread 'STOPPED))))))))
 
 (define (restart-thread thread discard-events? event)
@@ -296,8 +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 (flo:environment)))
-    (flo:set-environment! (flo:default-environment))
+  (let ((fp-env (enter-default-float-environment)))
     (set! next-scheduled-timeout #f)
     (set-interrupt-enables! interrupt-mask/gc-ok)
     (deliver-timer-events)
@@ -311,7 +310,7 @@ USA.
 		       (thread/execution-state thread)))
 	     (yield-thread thread fp-env))
 	    (else
-	     (flo:set-environment! fp-env)
+	     (restore-float-environment-from-default fp-env)
 	     (%resume-current-thread thread))))))
 
 (define (yield-current-thread)
@@ -329,20 +328,23 @@ USA.
     (if (not next)
 	(begin
 	  (if (not (default-object? fp-env))
-	      (flo:set-environment! fp-env))
+	      (restore-float-environment-from-default fp-env))
 	  (%resume-current-thread thread))
 	(call-with-current-continuation
 	 (lambda (continuation)
 	   (set-thread/continuation! thread continuation)
-	   (set-thread/floating-point-environment! thread
-						   (if (default-object? fp-env)
-						       (flo:environment)
-						       fp-env))
+	   (maybe-save-thread-float-environment! thread fp-env)
 	   (set-thread/next! thread #f)
 	   (set-thread/next! last-running-thread thread)
 	   (set! last-running-thread thread)
 	   (set! first-running-thread next)
 	   (run-thread next))))))
+
+(define (thread-float-environment thread)
+  (thread/floating-point-environment thread))
+
+(define (set-thread-float-environment! thread fp-env)
+  (set-thread/floating-point-environment! thread fp-env))
 
 (define (exit-current-thread value)
   (let ((thread (current-thread)))