(declare (usual-integrations))
\f
-;;;; 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))))
+\f
+(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!))
\f
+;;;; Floating-point rounding mode
+
(define-primitives
(float-rounding-modes 0)
(get-float-rounding-mode 0)
(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)))))
i
(loop (fix:+ i 1))))))
\f
+;;;; Floating-point exceptions and trapping
+
(define-primitives
(flo:supported-exceptions float-exceptions 0)
(flo:exception:divide-by-zero float-divide-by-zero-exception 0)
(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)))
+\f
(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
;; 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.
((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)))
+\f
+;;;; 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))))
;; 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
(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)
(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)
(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)))
(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)))))))))
(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)
;; 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)
(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)
(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))
\f
(define (exit-current-thread value)
(let ((thread (current-thread)))
projects / mit-scheme.git / commitdiff