thunk))
\f
(define (current-thread)
- (or first-running-thread
- (begin
- (%outf-error "current-thread: no current thread")
- #f)))
+ first-running-thread)
(define (console-thread)
(thread-mutex-owner (port/thread-mutex console-i/o-port)))
(define (suspend-current-thread)
(set-interrupt-enables! interrupt-mask/in-threads)
(%lock)
- (%assert first-running-thread "suspend-current-thread: no current thread")
(%suspend-thread first-running-thread))
(define (%suspend-thread thread)
(thread-not-running thread 'WAITING)))))))
(define (stop-current-thread)
- (%assert first-running-thread "stop-current-thread: no current thread")
(call-with-current-continuation
(lambda (continuation)
(let ((thread first-running-thread))
- (%assert thread "stop-current-thread: lost current thread")
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread)
(set-interrupt-enables! interrupt-mask/in-threads)
(lambda ()
(%lock)
(let ((thread first-running-thread))
- (%assert thread "yield-current-thread: no current thread")
;; Allow preemption now, since the current thread has
;; volunteered to yield control.
(set-thread/execution-state! thread 'RUNNING)
(define (join-thread thread event-constructor)
(guarantee-thread thread 'JOIN-THREAD)
(let ((self first-running-thread))
- (%assert self "join-thread: no current thread")
(if (eq? thread self)
(signal-thread-deadlock self "join thread" join-thread thread)
(let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
(define (block-thread-events)
(with-thread-lock
(lambda ()
- (let ((thread first-running-thread))
- (if thread
- (let ((result (thread/block-events? thread)))
- (set-thread/block-events?! thread #t)
- result)
- #f)))))
+ (let* ((thread first-running-thread)
+ (result (thread/block-events? thread)))
+ (set-thread/block-events?! thread #t)
+ result))))
(define (unblock-thread-events)
(with-thread-lock
(lambda ()
(let ((thread first-running-thread))
- (%assert thread "unblock-thread-events: no current thread")
(handle-thread-events thread)
(set-thread/block-events?! thread #f)))))
value)))
(define (get-thread-event-block)
- (let ((thread first-running-thread))
- (if thread
- (thread/block-events? thread)
- (begin
- (%outf-error "get-thread-event-block: no current thread")
- #f))))
+ (thread/block-events? first-running-thread))
(define (set-thread-event-block! block?)
- (let ((thread first-running-thread))
- (if thread
- (set-thread/block-events?! thread block?)
- (%outf-error "set-thread-event-block!: no current thread")))
+ (set-thread/block-events?! first-running-thread block?)
unspecific)
\f
(define (signal-thread-event thread event)
(guarantee-thread thread 'SIGNAL-THREAD-EVENT)
- (let ((self first-running-thread))
- (if (eq? thread self)
- (let ((block-events? (block-thread-events)))
- (with-thread-lock
- (lambda ()
- (%add-pending-event thread event)))
- (if (not block-events?)
- (unblock-thread-events)))
- (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
- (%lock)
- (if (eq? 'DEAD (thread/execution-state thread))
- (begin
- (%unlock)
- (set-interrupt-enables! mask)
- (signal-thread-dead thread "signal event to"
- signal-thread-event thread event))
- (begin
- (%signal-thread-event thread event)
- (if (and (not self) first-running-thread)
- (run-thread first-running-thread)
- (begin
- (%maybe-toggle-thread-timer)
- (%unlock)
- (set-interrupt-enables! mask)))))))))
+ (if (eq? thread first-running-thread)
+ (let ((block-events? (block-thread-events)))
+ (with-thread-lock
+ (lambda ()
+ (%add-pending-event thread event)))
+ (if (not block-events?)
+ (unblock-thread-events)))
+ (let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
+ (%lock)
+ (if (eq? 'DEAD (thread/execution-state thread))
+ (begin
+ (%unlock)
+ (set-interrupt-enables! mask)
+ (signal-thread-dead thread "signal event to"
+ signal-thread-event thread event))
+ (begin
+ (%signal-thread-event thread event)
+ (%maybe-toggle-thread-timer)
+ (%unlock)
+ (set-interrupt-enables! mask))))))
(define (%signal-thread-event thread event)
(%assert-locked '%signal-thread-event)
(define (allow-thread-event-delivery)
(with-thread-lock
(lambda ()
- (let ((thread first-running-thread))
- (if thread
- (let ((block-events? (thread/block-events? thread)))
- (set-thread/block-events?! thread #f)
- (deliver-timer-events)
- (maybe-signal-io-thread-events)
- (handle-thread-events thread)
- (set-thread/block-events?! thread block-events?))
- (begin
- (deliver-timer-events)
- (maybe-signal-io-thread-events))))
+ (let* ((thread first-running-thread)
+ (block-events? (thread/block-events? thread)))
+ (set-thread/block-events?! thread #f)
+ (deliver-timer-events)
+ (maybe-signal-io-thread-events)
+ (handle-thread-events thread)
+ (set-thread/block-events?! thread block-events?))
(%maybe-toggle-thread-timer))))
\f
;;;; GC Events
(define (deregister-all-events)
(with-thread-lock
(lambda ()
- (let* ((thread
- (or first-running-thread
- (%outf-error "deregister-all-events: no current thread")))
+ (let* ((thread first-running-thread)
(block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #t)
(ring/discard-all (thread/pending-events thread))
(guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
(let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
(%lock)
- (let ((thread (or first-running-thread
- (%outf-error "lock-thread-mutex: no current thread")))
+ (let ((thread first-running-thread)
(owner (thread-mutex/owner mutex)))
(if (eq? owner thread)
(begin
(%unlock)
(set-interrupt-enables! mask)
- (signal-thread-deadlock first-running-thread "lock thread mutex"
+ (signal-thread-deadlock thread "lock thread mutex"
lock-thread-mutex mutex))
(begin
(%lock-thread-mutex mutex thread owner)
(guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
(let ((mask (set-interrupt-enables! interrupt-mask/in-threads)))
(%lock)
- (let ((thread (or first-running-thread
- (%outf-error "unlock-thread-mutex: no current thread")))
+ (let ((thread first-running-thread)
(owner (thread-mutex/owner mutex)))
(if (and owner (not (eq? owner thread)))
(begin
(with-thread-lock
(lambda ()
(and (not (thread-mutex/owner mutex))
- (let ((thread
- (or first-running-thread
- (%outf-error "try-lock-thread-mutex: no current thread"))))
+ (let ((thread first-running-thread))
(set-thread-mutex/owner! mutex thread)
(add-thread-mutex! thread mutex)
#t)))))