unspecific)
(define (thread-not-running thread state)
- (%trace ";thread-not-running: stopping "thread" in state "state"\n")
(set-thread/execution-state! thread state)
(let ((thread* (thread/next thread)))
(set-thread/next! thread #f)
(run-first-thread))
(define (run-first-thread)
- (%trace ";run-first-thread "first-running-thread"\n")
(if first-running-thread
(run-thread first-running-thread)
(begin
(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 ((block-events? (thread/block-events? thread)))
;; 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 (enter-default-float-environment first-running-thread)))
(set! next-scheduled-timeout #f)
(set-interrupt-enables! interrupt-mask/gc-ok)
(maybe-signal-io-thread-events)
(let ((thread first-running-thread))
(cond ((not thread)
- (%maybe-toggle-thread-timer)
- (%trace ";thread-timer: continuing with timer set for "
- next-scheduled-timeout"\n"))
+ (%maybe-toggle-thread-timer))
((thread/continuation thread)
- (%trace ";thread-timer: switching to "thread"\n")
(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")
(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 ()
(define (yield-thread thread #!optional fp-env)
(let ((next (thread/next thread)))
- (%trace ";yield-thread: "thread" yields to "next"\n")
(if (not next)
(begin
(if (not (default-object? fp-env))
\f
(define (exit-current-thread value)
(let ((thread (current-thread)))
- (%trace ";exit-current-thread: "thread" with "value"\n")
(set-interrupt-enables! interrupt-mask/gc-ok)
(set-thread/block-events?! thread #t)
(ring/discard-all (thread/pending-events thread))
(define (wait-for-io)
(%maybe-toggle-thread-timer #f)
- (%trace ";wait-for-io: next timeout = "next-scheduled-timeout"\n")
(let ((catch-errors
(lambda (thunk)
(let ((thread (console-thread)))
(let ((result
(catch-errors
(lambda ()
- (%trace ";wait-for-io: blocking for i/o\n")
(set-interrupt-enables! interrupt-mask/all)
(test-select-registry io-registry #t)))))
(set-interrupt-enables! interrupt-mask/gc-ok)
(let ((thread first-running-thread))
(if thread
(if (thread/continuation thread)
- (begin
- (%trace ";wait-for-io: running "thread"\n")
- (run-thread thread))
- (begin
- (%trace ";wait-for-io: continuing "thread"\n")
- (%maybe-toggle-thread-timer)))
- (begin
- (%trace ";wait-for-io: looping\n")
- (wait-for-io)))))))
+ (run-thread thread)
+ (%maybe-toggle-thread-timer))
+ (wait-for-io))))))
\f
(define (signal-select-result result)
(cond ((vector? result)
(dynamic-wind %stop-thread-timer thunk %maybe-toggle-thread-timer))
(define (%maybe-toggle-thread-timer #!optional consider-non-timers?)
- (%trace ";%maybe-toggle-thread-timer "consider-non-timers?"\n")
(let ((now (real-time-clock)))
(let ((start
(lambda (time)