(%outf-error "current-thread: no current thread")
#f)))
-(define (call-with-current-thread return? procedure)
- (%assert (interrupt-mask-ok?)
- "call-with-current-thread: wrong interrupt mask")
- (let ((thread first-running-thread))
- (cond (thread (procedure thread))
- ((not return?)
- (%outf-error "call-with-current-thread: starting one up")
- (%lock)
- (run-first-thread)))))
-
(define (console-thread)
(thread-mutex-owner (port/thread-mutex console-i/o-port)))
(define (suspend-current-thread)
(without-interrupts
(lambda ()
- (call-with-current-thread #f
- (lambda (thread)
- (%lock)
- (%suspend-thread thread))))))
+ (%lock)
+ (%suspend-thread first-running-thread))))
(define (%suspend-thread thread)
(%assert-locked '%suspend-thread)
(define (stop-current-thread)
(%assert first-running-thread "stop-current-thread: no current thread")
- (without-interrupts
- (lambda ()
- (call-with-current-thread #f
- (lambda (thread)
- (call-with-current-continuation
- (lambda (continuation)
- (set-thread/continuation! thread continuation)
- (maybe-save-thread-float-environment! thread)
- (%lock)
- (thread-not-running thread 'STOPPED))))))))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((thread first-running-thread))
+ (set-thread/continuation! thread continuation)
+ (maybe-save-thread-float-environment! thread)
+ (set-interrupt-enables! interrupt-mask/in-threads)
+ (%lock)
+ (thread-not-running thread 'STOPPED)))))
(define (restart-thread thread discard-events? event)
(guarantee-thread thread 'RESTART-THREAD)
(define (yield-current-thread)
(without-interrupts
(lambda ()
- (call-with-current-thread #t
- (lambda (thread)
- (%lock)
- ;; Allow preemption now, since the current thread has
- ;; volunteered to yield control.
- (set-thread/execution-state! thread 'RUNNING)
- (yield-thread thread))))))
+ (let ((thread first-running-thread))
+ (%lock)
+ ;; Allow preemption now, since the current thread has
+ ;; volunteered to yield control.
+ (set-thread/execution-state! thread 'RUNNING)
+ (yield-thread thread)))))
(define (yield-thread thread #!optional fp-env)
(%assert-locked 'yield-thread)
(define (unblock-thread-events)
(with-thread-lock
(lambda ()
- (call-with-current-thread #t
- (lambda (thread)
- (handle-thread-events thread)
- (set-thread/block-events?! thread #f))))))
+ (let ((thread first-running-thread))
+ (handle-thread-events thread)
+ (set-thread/block-events?! thread #f)))))
(define (with-thread-events-blocked thunk)
(let ((block-events? (block-thread-events)))