;;; This is set at boot/restore time and allows a host without the SMP
;;; primitives to run this code.
(define enable-smp? #f)
+
+;;; Serialized Access
+;;;
+;;; Multiple processors may use this thread system simultaneously, so
+;;; procedures that modify its data structures (or that just want to
+;;; read consistent data structures!) must arrange to serialize their
+;;; accesses. They must lock an OS-level mutex and unlock it when
+;;; they are done, and they must do this without-interrupts. While
+;;; the mutex is locked, they should NOT signal errors nor invoke
+;;; arbitrary hooks, handlers, etc. Thus there should be no need for
+;;; a recursive mutex.
+
+(define locked? #f)
+
+(define-integrable (get-interrupt-enables)
+ ((ucode-primitive get-interrupt-enables 0)))
+
+(define-integrable (only-gc-ok?)
+ (fix:= 0 (fix:andc (get-interrupt-enables) interrupt-mask/gc-ok)))
+
+(define-integrable (%lock)
+ (%if-tracing
+ ;; This happens when there is contention. It is interesting,
+ ;; but not really a problem, so is noted only while %trace?ing.
+ (complain-if locked?
+ "%lock already locked"))
+ (if enable-smp?
+ ((ucode-primitive smp-lock-threads 1) #t))
+ (complain-if (not (only-gc-ok?))
+ "%lock with wrong interrupt mask")
+ (set! locked? #t))
+
+(define-integrable (%unlock)
+ (complain-if (not locked?)
+ "%unlock not locked")
+ (if enable-smp?
+ ((ucode-primitive smp-lock-threads 1) #f))
+ (complain-if (not (only-gc-ok?))
+ "%unlock with wrong interrupt mask")
+ (set! locked? #f))
+
+(define-integrable (without-interrupts thunk)
+ (let ((interrupt-mask
+ (set-interrupt-enables!
+ (fix:and interrupt-mask/gc-ok (get-interrupt-enables)))))
+ (let ((value (thunk)))
+ (set-interrupt-enables! interrupt-mask)
+ value)))
+
+(define-integrable (with-threads-locked thunk)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (%lock)
+ (let ((value (thunk)))
+ (%unlock)
+ (set-interrupt-enables! interrupt-mask)
+ value)))
\f
(define-structure (thread
(constructor %make-thread ())
(define no-exit-value-marker
(list 'NO-EXIT-VALUE-MARKER))
-(define-integrable (thread-dead? thread)
+(define (thread-dead? thread)
+ (guarantee-thread thread 'THREAD-DEAD?)
+ ;; Assuming the machine reads and writes words atomically, the
+ ;; execution-state slot can be read without locking.
(eq? 'DEAD (thread/execution-state thread)))
\f
(define thread-population)
(add-event-receiver! event:after-restore reset-threads!)
(add-event-receiver! event:before-exit stop-thread-timer))
-(define (make-thread continuation)
- (let ((thread (%make-thread)))
- (set-thread/continuation! thread continuation)
- (add-to-population!/unsafe thread-population thread)
- (thread-running thread)
- thread))
-
-(define-integrable (without-interrupts thunk)
- (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (let ((value (thunk)))
- (set-interrupt-enables! interrupt-mask)
- value)))
-
(define (threads-list)
- (map-over-population thread-population (lambda (thread) thread)))
+ (with-threads-locked
+ (lambda ()
+ (map-over-population thread-population (lambda (thread) thread)))))
(define (thread-execution-state thread)
(guarantee-thread thread 'THREAD-EXECUTION-STATE)
(lambda ()
(call-with-current-continuation
(lambda (continuation)
- (let ((thread (make-thread continuation)))
+ (let ((thread (%make-thread)))
+ (set-thread/continuation! thread continuation)
+ (with-threads-locked
+ (lambda ()
+ (add-to-population!/unsafe thread-population thread)
+ (thread-running (%id) thread)))
(%within-continuation (let ((k return)) (set! return #f) k)
- #t
- (lambda () thread)))))
- (set-interrupt-enables! interrupt-mask/all)
+ #t
+ (lambda () thread)))))
(exit-current-thread
(with-create-thread-continuation root-continuation thunk))))))))
(define current-threads #f)
(define-integrable (%id)
- ;; To avoid task switching between accessing a processor id and
- ;; using it (e.g. passing it to %current-thread), %id should be
+ ;; To avoid switching processors between accessing the processor id
+ ;; and using it (e.g. passing it to %current-thread), %id should be
;; called without-interrupts.
- (if (not (fix:= (get-interrupt-enables) interrupt-mask/gc-ok))
- (outf-error "\n;%id: WRONG interrupt mask!"))
+ (complain-if (not (only-gc-ok?))
+ "%id: wrong interrupt mask")
(if enable-smp?
((ucode-primitive smp-id 0))
0))
(loop (fix:1+ i))))))))))
(define (thread-continuation thread)
- (guarantee-thread thread 'THREAD-CONTINUATION)
+ (guarantee-thread thread 'thread-continuation)
(thread/continuation thread))
-(define (thread-running thread)
- (%thread-running thread)
+(define (thread-running id thread)
+ (assert-locked 'thread-running)
+ (%thread-running id thread)
(%maybe-toggle-thread-timer))
-(define (%thread-running thread)
+(define (%thread-running id thread)
+ (%%trace ";"id" %thread-running "thread"\n")
+ (assert-locked '%thread-running)
(set-thread/execution-state! thread 'RUNNING)
(let ((prev last-runnable-thread))
(if prev
(set-thread/next! prev thread)
(set! first-runnable-thread thread)))
(set! last-runnable-thread thread)
+ (complain-if (not (eq? #f (thread/next thread)))
+ "%thread-running: last-runnable-thread has a next")
unspecific)
(define (thread-not-running id thread state)
- (if (not (eq? thread (%current-thread id)))
- (outf-error "\n;thread-not-running: NOT CURRENT"))
+ ;; This procedure never returns.
+ (%trace ";"id" thread-not-running: stopping "thread" in state "state"\n")
+ (assert-locked 'thread-not-running)
+ (complain-if (not (eq? thread (%current-thread id)))
+ "thread-not-running: not current")
(set-thread/execution-state! thread state)
(vector-set! current-threads id #f)
(run-first-thread id))
(define (run-first-thread id)
+ ;; This procedure never returns.
+ (assert-locked 'run-first-thread)
+ (complain-if (%current-thread id)
+ "run-first-thread: already running a thread")
(if first-runnable-thread
(let ((thread first-runnable-thread))
- (if (%current-thread id)
- (outf-error "\n;run-first-thread: ALREADY running a thread!"))
+ (%%trace ";"id" run-first-thread: running "thread"\n")
(set! first-runnable-thread (thread/next thread))
(if (not first-runnable-thread)
(set! last-runnable-thread #f)
- (if (not last-runnable-thread)
- (outf-error "\n;run-first-thread: lost last-runnable!")))
+ (complain-if (not last-runnable-thread)
+ "run-first-thread: lost last-runnable"))
(set-thread/next! thread #f)
(vector-set! current-threads id thread)
(run-thread thread))
- (wait-for-io)))
+ (begin
+ (%%trace ";"id" run-first-thread: no runnable threads\n")
+ (wait-for-io id))))
\f
(define (run-thread thread)
+ ;; This procedure never returns.
+ (%%trace ";"(%%id)" run-thread "thread"\n")
+ (assert-locked 'run-thread)
(let ((continuation (thread/continuation thread))
(fp-env (thread/floating-point-environment thread)))
- (if (not (continuation? continuation))
- (outf-error "\n;run-thread: NO CONTINUATION!"))
+ (complain-if (not (continuation? continuation))
+ "run-thread: no continuation")
(set-thread/continuation! thread #f)
(%within-continuation continuation #t
(lambda ()
(enter-float-environment fp-env)
- (%resume-current-thread thread)))))
+ (%resume-thread thread)))))
-(define (%resume-current-thread thread)
+(define (%resume-thread thread)
+ (%trace ";"(%%id)" %resume-thread "thread"\n")
+ (assert-locked '%resume-thread)
+ (complain-if (not (eq? thread (%current-thread (%%id))))
+ "%resume-thread: not current")
(if (not (thread/block-events? thread))
- (begin
- (handle-thread-events thread)
- (set-thread/block-events?! thread #f)))
+ (handle-thread-events thread))
(%maybe-toggle-thread-timer)
- (set-interrupt-enables! interrupt-mask/all))
+ (%unlock))
(define (suspend-current-thread)
(without-interrupts %suspend-current-thread))
(define (%suspend-current-thread)
- (%suspend-thread (%current-thread (%id))))
+ (let* ((id (%id))
+ (thread (%current-thread id)))
+ (%trace ";"id" %suspend-current-thread "thread"\n")
+ (%lock)
+ (%suspend-thread thread)))
(define (%suspend-thread thread)
+ (%trace ";"(%%id)" %suspend-thread "thread"\n")
+ (assert-locked '%suspend-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)))
(set-thread/block-events?! thread block-events?)
(if any-events?
- (%maybe-toggle-thread-timer)
+ (begin
+ (%maybe-toggle-thread-timer)
+ (%unlock))
(call-with-current-continuation
(lambda (continuation)
(set-thread/continuation! thread continuation)
(lambda ()
(let* ((id (%id))
(thread (%current-thread id)))
+ (%trace ";"id" stop-current-thread: "thread"\n")
(call-with-current-continuation
(lambda (continuation)
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread)
+ (%lock)
(thread-not-running id thread 'STOPPED)))))))
(define (restart-thread thread discard-events? event)
(lambda ()
(if (not (eq? 'STOPPED (thread/execution-state thread)))
(error:bad-range-argument thread restart-thread))
+ (%lock)
(if discard-events? (ring/discard-all (thread/pending-events thread)))
(if event (%signal-thread-event thread event))
- (thread-running thread)))))
+ (thread-running (%id) thread)
+ (%unlock)))))
\f
(define (disallow-preempt-current-thread)
(set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION))
;; 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.
+ (%lock)
(let* ((id (%id))
- (old (%current-thread id)))
- (let ((fp-env (enter-default-float-environment old)))
- (set! next-scheduled-timeout #f)
- (deliver-timer-events)
- (maybe-signal-io-thread-events)
- (cond ((and (not first-runnable-thread) (not old))
- (%maybe-toggle-thread-timer))
- ((not old)
- (run-first-thread id))
- ((not first-runnable-thread)
- (restore-float-environment-from-default fp-env)
- (%resume-current-thread old))
- ((eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state old))
- (restore-float-environment-from-default fp-env)
- (%resume-current-thread old))
- (else
- (%yield-thread id old fp-env))))))
+ (old (%current-thread id))
+ (fp-env (and old (enter-default-float-environment old))))
+ (%%trace ";"id" thread-timer: interrupt in "old"\n")
+ (set! next-scheduled-timeout #f)
+ (deliver-timer-events)
+ (maybe-signal-io-thread-events)
+ (cond ((and (not first-runnable-thread) (not old))
+ (%maybe-toggle-thread-timer)
+ (%%trace ";"id" thread-timer: continuing with timer set for "
+ next-scheduled-timeout"\n")
+ (%unlock))
+ ((not old)
+ (%%trace ";"id" thread-timer: switching to "
+ first-runnable-thread"\n")
+ (run-first-thread id))
+ ((not first-runnable-thread)
+ (%trace ";"id" thread-timer: no runnable threads;"
+ " continuing with "old"\n")
+ (restore-float-environment-from-default fp-env)
+ (%resume-thread old))
+ ((eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state old))
+ (%trace ";"id" thread-timer: running-without-preemption;"
+ " continuing with "old"\n")
+ (restore-float-environment-from-default fp-env)
+ (%resume-thread old))
+ (else
+ (%trace ";"id" thread-timer: yielding "old"\n")
+ (%yield-thread id old fp-env)))))
(define (yield-current-thread)
(without-interrupts
(thread (%current-thread id)))
(if thread
(let ((fp-env (enter-default-float-environment thread)))
+ (%lock)
(maybe-signal-io-thread-events)
;; Allow preemption now, since the current thread has
;; volunteered to yield control.
(set-thread/execution-state! thread 'RUNNING)
- (%yield-thread id thread fp-env)))))))
+ (%yield-thread id thread fp-env))
+ (complain-if #t "yield-current-thread: no current thread"))))))
(define (%yield-thread id thread fp-env)
+ (%trace ";"id" %yield-thread: "thread" yields to "first-runnable-thread"\n")
+ (assert-locked '%yield-thread)
+ (complain-if (not (eq? thread (%current-thread id)))
+ "%yield-thread: NOT CURRENT")
(if (not first-runnable-thread)
(begin
(restore-float-environment-from-default fp-env)
- (%resume-current-thread thread))
+ (%resume-thread thread))
(call-with-current-continuation
(lambda (continuation)
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread fp-env)
- (%thread-running thread)
+ (%thread-running id thread)
(vector-set! current-threads id #F)
(run-first-thread id)))))
(lambda ()
(let* ((id (%id))
(thread (%current-thread id)))
- (set-interrupt-enables! interrupt-mask/gc-ok)
+ (%trace ";"id" exit-current-thread: "thread" with "value"\n")
(set-thread/block-events?! thread #t)
- (ring/discard-all (thread/pending-events thread))
(dynamic-unwind thread)
+ (%lock)
+ (ring/discard-all (thread/pending-events thread))
(%deregister-io-thread-events thread #t)
(%discard-thread-timer-records thread)
(%disassociate-joined-threads thread)
(signal-thread-deadlock self "join thread" join-thread thread)
(without-interrupts
(lambda ()
+ (%lock)
(let ((value (thread/exit-value thread)))
(cond ((eq? value no-exit-value-marker)
(set-thread/joined-threads!
(thread/joined-threads thread)))
(set-thread/joined-to!
self
- (cons thread (thread/joined-to self))))
+ (cons thread (thread/joined-to self)))
+ (%trace ";"(%%id)" join-thread "self
+ " to "thread": queued\n")
+ (%unlock))
((eq? value detached-thread-marker)
+ (%unlock)
(signal-thread-detached thread))
(else
+ (%unlock)
+ (%trace ";"(%%id)" join-thread "self
+ " to "thread": signal self\n")
(signal-thread-event
self
- (event-constructor thread value))))))))))
+ (event-constructor thread value))
+ (%trace ";"(%%id)" join-thread "self
+ " to "thread": signaled self\n")
+ value))))))))
(define (detach-thread thread)
(guarantee-thread thread 'DETACH-THREAD)
(without-interrupts
(lambda ()
+ (%lock)
(if (eq? (thread/exit-value thread) detached-thread-marker)
- (signal-thread-detached thread))
- (release-joined-threads thread detached-thread-marker))))
+ (begin
+ (%unlock)
+ (signal-thread-detached thread))
+ (begin
+ (release-joined-threads thread detached-thread-marker)
+ (%unlock)))))
+ thread)
(define detached-thread-marker
(list 'DETACHED-THREAD-MARKER))
(define (release-joined-threads thread value)
+ (assert-locked 'release-joined-threads)
(set-thread/exit-value! thread value)
(do ((joined (thread/joined-threads thread) (cdr joined)))
((not (pair? joined)))
(%maybe-toggle-thread-timer))
(define (%disassociate-joined-threads thread)
+ (assert-locked '%disassociate-joined-threads)
(do ((threads (thread/joined-to thread) (cdr threads)))
((not (pair? threads)))
(set-thread/joined-threads!
(set! current-threads (vector-grow current-threads
processor-count #f)))
(else
- (if (not (subvector-filled? current-threads 1 len #f))
- (outf-error "\n;reset-threads restored MULTIPLE threads!"))
+ (complain-if (not (subvector-filled? current-threads 1 len #f))
+ "reset-threads restored multiple threads")
unspecific))))
(define (reset-threads-high!)
(make-select-registry)))
(set! io-registrations #f))
-(define (wait-for-io)
+(define (wait-for-io id)
+ ;; This procedure never returns.
+ (%%trace ";"id" wait-for-io\n")
+ (assert-locked 'wait-for-io)
+ (complain-if (not (eq? (get-interrupt-enables) interrupt-mask/gc-ok))
+ "wait-for-io: with interrupts")
+ (complain-if (%current-thread id)
+ "wait-for-io: not idle")
(%maybe-toggle-thread-timer #f)
+ (%%trace ";"id" wait-for-io: next timeout = "next-scheduled-timeout"\n")
(let ((result
(begin
+ (%%trace ";"id" wait-for-io: blocking for i/o\n")
+ (%unlock)
(set-interrupt-enables! interrupt-mask/all)
(test-select-registry io-registry #t))))
(set-interrupt-enables! interrupt-mask/gc-ok)
+ (%lock)
(signal-select-result result)
+ (complain-if (%current-thread id)
+ "wait-for-io: ALREADY running a thread")
(if first-runnable-thread
- (let ((id (%id)))
- (if (not (thread/continuation first-runnable-thread))
- (outf-error "\n;wait-for-io: BOGUS runnable"))
+ (begin
+ (complain-if (not (thread/continuation first-runnable-thread))
+ "wait-for-io: BOGUS runnable")
+ (%%trace ";"id" wait-for-io:"
+ " run-first-thread "first-runnable-thread"\n")
(run-first-thread id))
- (wait-for-io))))
+ (wait-for-io id))))
\f
(define (signal-select-result result)
+ (%%trace ";"(%%id)" signal-select-result"
+ " "(if (vector? result) (vector-ref result 0) result)"\n")
+ (assert-locked 'signal-select-result)
(cond ((vector? result)
(signal-io-thread-events (vector-ref result 0)
(vector-ref result 1)
'#(READ)))))
(define (maybe-signal-io-thread-events)
- (signal-select-result (test-select-registry io-registry #f)))
+ (assert-locked 'maybe-signal-io-thread-events)
+ (%%trace ";"(%%id)" maybe-signal-io-thread-events: testing\n")
+ (let ((result (test-select-registry io-registry #f)))
+ (signal-select-result result)
+ (%%trace ";"(%%id)" maybe-signal-io-thread-events => "
+ (if (vector? result) (vector-ref result 0) result)"\n")))
(define (block-on-io-descriptor descriptor mode)
- (without-interrupts
- (lambda ()
- (let ((result 'INTERRUPT)
- (registration-1)
- (registration-2))
- (dynamic-wind
- (lambda ()
- (let ((thread (current-thread)))
- (set! registration-1
- (%register-io-thread-event
- descriptor
- mode
- thread
- (lambda (mode)
- (set! result mode)
- unspecific)
- #f #t))
- (set! registration-2
- (%register-io-thread-event
- 'PROCESS-STATUS-CHANGE
- 'READ
- thread
- (lambda (mode)
- mode
- (set! result 'PROCESS-STATUS-CHANGE)
- unspecific)
- #f #t)))
- (%maybe-toggle-thread-timer))
- (lambda ()
- (%suspend-current-thread)
- result)
- (lambda ()
- (%maybe-deregister-io-thread-event registration-2)
- (%maybe-deregister-io-thread-event registration-1)
- (%maybe-toggle-thread-timer)))))))
+ (let ((result 'INTERRUPT)
+ (registration-1)
+ (registration-2))
+ (dynamic-wind
+ (lambda ()
+ (with-threads-locked
+ (lambda ()
+ (let ((thread (%current-thread (%id))))
+ (set! registration-1
+ (%register-io-thread-event
+ descriptor
+ mode
+ thread
+ (lambda (mode)
+ (set! result mode)
+ unspecific)
+ #f #t))
+ (set! registration-2
+ (%register-io-thread-event
+ 'PROCESS-STATUS-CHANGE
+ 'READ
+ thread
+ (lambda (mode)
+ mode
+ (set! result 'PROCESS-STATUS-CHANGE)
+ unspecific)
+ #f #t)))
+ (%maybe-toggle-thread-timer))))
+ (lambda ()
+ (%suspend-current-thread)
+ result)
+ (lambda ()
+ (with-threads-locked
+ (lambda ()
+ (%maybe-deregister-io-thread-event registration-2)
+ (%maybe-deregister-io-thread-event registration-1)
+ (%maybe-toggle-thread-timer)))))))
(define (%maybe-deregister-io-thread-event tentry)
;; Ensure that another thread does not unwind our registration.
+ (assert-locked '%maybe-deregister-io-thread-event)
(if (eq? (%current-thread (%id)) (tentry/thread tentry))
(delete-tentry! tentry)))
\f
permanent? caller)
(guarantee-select-mode mode caller)
(guarantee-thread thread caller)
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let ((registration
(%register-io-thread-event descriptor mode thread event
(if (not (tentry? tentry))
(error:wrong-type-argument tentry "I/O thread event registration"
'DEREGISTER-IO-THREAD-EVENT))
- (without-interrupts
+ (with-threads-locked
(lambda ()
(%deregister-io-thread-event tentry)
(%maybe-toggle-thread-timer))))
(define (deregister-io-descriptor-events descriptor mode)
(guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS)
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let loop ((dentry io-registrations))
(cond ((not dentry)
(%maybe-toggle-thread-timer))))
(define (%deregister-io-descriptor descriptor)
+ (%lock)
(let dloop ((dentry io-registrations))
(cond ((not dentry)
unspecific)
(dloop (dentry/next dentry)))
(else
(dloop (dentry/next dentry)))))
- (%maybe-toggle-thread-timer))
+ (%maybe-toggle-thread-timer)
+ (%unlock))
\f
(define (%register-io-thread-event descriptor mode thread event permanent?
front?)
+ (assert-locked '%register-io-thread-event)
(let ((tentry (make-tentry thread event permanent?)))
(let loop ((dentry io-registrations))
(cond ((not dentry)
tentry))
(define (%deregister-io-thread-event tentry)
+ (assert-locked '%deregister-io-thread-event)
(if (tentry/dentry tentry)
(delete-tentry! tentry)))
(define (%deregister-io-thread-events thread permanent?)
+ (assert-locked '%deregister-io-thread-events)
(let loop ((dentry io-registrations) (tentries '()))
(if (not dentry)
(do ((tentries tentries (cdr tentries)))
(error:wrong-type-argument mode "select mode" procedure)))
\f
(define (signal-io-thread-events n vfd vmode)
+ (assert-locked 'signal-io-thread-events)
(let ((search
(lambda (descriptor predicate)
(let scan-dentries ((dentry io-registrations))
(%signal-thread-event (caar events) (cdar events)))))))
(define (move-tentry-to-back! tentry)
+ (assert-locked 'move-tentry-to-back!)
(let ((next (tentry/next tentry)))
(if next
(let ((dentry (tentry/dentry tentry))
(if (not prev) (set-dentry/first-tentry! dentry next))))))
(define (delete-tentry! tentry)
+ (assert-locked 'delete-tentry!)
(let ((dentry (tentry/dentry tentry))
(prev (tentry/prev tentry))
(next (tentry/next tentry)))
;;;; Events
(define (block-thread-events)
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let ((thread (%current-thread (%id))))
(if thread
#f)))))
(define (unblock-thread-events)
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let ((thread (%current-thread (%id))))
(handle-thread-events thread)
(set-interrupt-enables! interrupt-mask)
value))
(begin
+ (complain-if #t "with-thread-events-blocked: no current thread")
(set-interrupt-enables! interrupt-mask)
(thunk))))))
(let ((thread (%current-thread (%id))))
(if thread
(thread/block-events? thread)
- #f)))))
+ (begin
+ (complain-if #t "get-thread-event-block: no current thread")
+ #f))))))
(define (set-thread-event-block! block?)
(without-interrupts
(lambda ()
(let ((thread (%current-thread (%id))))
(if thread
- (set-thread/block-events?! thread block?)))
+ (set-thread/block-events?! thread block?)
+ (complain-if #t "set-thread-event-block!: no current thread")))
unspecific)))
\f
(define (signal-thread-event thread event)
(guarantee-thread thread 'SIGNAL-THREAD-EVENT)
(without-interrupts
(lambda ()
- (let ((self (%current-thread (%id))))
+ (let* ((id (%id))
+ (self (%current-thread id)))
+ (%trace ";"id" signal-thread-event to "thread" from "self"\n")
(if (eq? thread self)
(let ((block-events? (block-thread-events)))
+ (%trace ";"id" signal-thread-event to self: await queue\n")
+ (%lock)
(%add-pending-event thread event)
+ (%unlock)
+ (%trace ";"id" signal-thread-event to self: queued\n")
(if (not block-events?)
- (unblock-thread-events)))
+ (begin
+ (%trace ";"id" signal-thread-event to self: unblock\n")
+ (unblock-thread-events))))
(begin
(if (eq? 'DEAD (thread/execution-state thread))
(signal-thread-dead thread "signal event to"
signal-thread-event thread event))
+ (%lock)
+ (%trace ";"id" signal-thread-event: %signal\n")
(%signal-thread-event thread event)
(if (and (not self) first-runnable-thread)
- (run-first-thread (%id))
- (%maybe-toggle-thread-timer))))))))
+ (begin
+ (%trace ";"id" signal-thread-event"
+ " running "first-runnable-thread"\n")
+ (run-first-thread id))
+ (begin
+ (%maybe-toggle-thread-timer)
+ (%trace ";"id" signal-thread-event: done\n")
+ (%unlock)))))))))
(define (%signal-thread-event thread event)
+ (assert-locked '%signal-thread-event)
(%add-pending-event thread event)
(if (and (not (thread/block-events? thread))
(eq? 'WAITING (thread/execution-state thread)))
- (%thread-running thread)))
+ (%thread-running (%id) thread)))
(define (%add-pending-event thread event)
;; PENDING-EVENTS has three states: (1) empty; (2) one #F event; or
;; (3) any number of non-#F events. This optimizes #F events away
;; when they aren't needed.
+ (assert-locked '%add-pending-event)
(let ((ring (thread/pending-events thread)))
(let ((count (ring/count-max-2 ring)))
(if event
(ring/enqueue ring event))))))
(define (handle-thread-events thread)
+ (%%trace ";"(%%id)" handle-thread-events for "thread"\n")
+ (assert-locked 'handle-thread-events)
(let loop ((any-events? #f))
(let ((event (ring/dequeue (thread/pending-events thread) #t)))
(if (eq? #t event)
(if event
(let ((block? (thread/block-events? thread)))
(set-thread/block-events?! thread #t)
+ (%unlock)
(event)
(set-interrupt-enables! interrupt-mask/gc-ok)
+ (%lock)
(set-thread/block-events?! thread block?)))
(loop #t))))))
(define (allow-thread-event-delivery)
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let ((thread (%current-thread (%id))))
(if thread
(handle-thread-events thread)
(set-thread/block-events?! thread block-events?))
(begin
+ (complain-if #t "allow-thread-event-delivery: no current thread")
(deliver-timer-events)
(maybe-signal-io-thread-events))))
(%maybe-toggle-thread-timer))))
(define (register-timer-event interval event)
(let ((time (+ (real-time-clock) interval)))
(let ((new-record (make-timer-record time (current-thread) event #f)))
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let loop ((record timer-records) (prev #f))
(if (or (not record) (< time (timer-record/time record)))
(unblock-thread-events)))))
(define (deliver-timer-events)
+ (assert-locked 'deliver-timer-events)
(let ((time (real-time-clock)))
+ (%%trace ";"(%%id)" deliver-timer-events: time = "time"\n")
(do ((record timer-records (timer-record/next record)))
((or (not record) (< time (timer-record/time record)))
(set! timer-records record)
(if (not (timer-record? registration))
(error:wrong-type-argument registration "timer event registration"
'DEREGISTER-TIMER-EVENT))
- (without-interrupts
+ (with-threads-locked
(lambda ()
(let loop ((record timer-records) (prev #f))
(if record
(loop next record)))))
(%maybe-toggle-thread-timer))))
-(define-integrable (threads-pending-timer-events?)
- timer-records)
-
(define (deregister-all-events)
- (let ((thread (current-thread)))
- (set-interrupt-enables! interrupt-mask/gc-ok)
- (let ((block-events? (thread/block-events? thread)))
+ (with-threads-locked
+ (lambda ()
+ (let* ((thread (%current-thread (%id)))
+ (block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #t)
(ring/discard-all (thread/pending-events thread))
(%deregister-io-thread-events thread #f)
(%discard-thread-timer-records thread)
(set-thread/block-events?! thread block-events?))
- (%maybe-toggle-thread-timer)
- (set-interrupt-enables! interrupt-mask/all)))
+ (%maybe-toggle-thread-timer))))
(define (%discard-thread-timer-records thread)
+ (assert-locked '%discard-thread-timer-records)
(let loop ((record timer-records) (prev #f))
(if record
(let ((next (timer-record/next record)))
(define (set-thread-timer-interval! interval)
(if interval
(guarantee-exact-positive-integer interval 'SET-THREAD-TIMER-INTERVAL!))
- (without-interrupts
+ (with-threads-locked
(lambda ()
(set! timer-interval interval)
(%maybe-toggle-thread-timer))))
(define (start-thread-timer)
- (without-interrupts %maybe-toggle-thread-timer))
+ (with-threads-locked %maybe-toggle-thread-timer))
(define (stop-thread-timer)
- (without-interrupts %stop-thread-timer))
+ (with-threads-locked %stop-thread-timer))
(define (with-thread-timer-stopped thunk)
- (dynamic-wind %stop-thread-timer thunk %maybe-toggle-thread-timer))
+ (dynamic-wind stop-thread-timer thunk start-thread-timer))
(define (%maybe-toggle-thread-timer #!optional consider-non-timers?)
+ (assert-locked '%maybe-toggle-thread-timer)
(let ((now (real-time-clock)))
+ (%%trace ";"(%%id)" %maybe-toggle-thread-timer "consider-non-timers?
+ " time = "now"\n")
(let ((start
(lambda (time)
(set! next-scheduled-timeout time)
+ (%%trace ";"(%%id)" thread-timer: set to "(- time now)"\n")
((ucode-primitive real-timer-set) (- time now) 0))))
(cond (timer-records
(let ((next-event-time (timer-record/time timer-records)))
;; Instead signal the interrupt now. This is ugly
;; but much simpler than refactoring the scheduler
;; so that we can do the right thing here.
- ((ucode-primitive request-interrupts! 1)
- interrupt-bit/timer)
+ (begin
+ (%%trace ";"(%%id)" thread-timer: requested\n")
+ ((ucode-primitive request-interrupts! 1)
+ interrupt-bit/timer))
(start
(if (and consider-non-timers? timer-interval)
(min next-event-time (+ now timer-interval))
(or io-registrations first-runnable-thread))
(start (+ now timer-interval)))
(else
+ (%%trace ";"(%%id)" thread-timer: stopped\n")
(%stop-thread-timer))))))
(define (%stop-thread-timer)
+ (assert-locked '%stop-thread-timer)
(if next-scheduled-timeout
(begin
((ucode-primitive real-timer-clear))
(define (lock-thread-mutex mutex)
(guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
- (without-interrupts
+ (with-threads-locked
(lambda ()
- (let ((thread (current-thread))
+ (let ((thread (%current-thread (%id)))
(owner (thread-mutex/owner mutex)))
(if (eq? owner thread)
(signal-thread-deadlock thread "lock thread mutex"
(%lock-thread-mutex mutex thread owner)))))
(define (%lock-thread-mutex mutex thread owner)
+ (assert-locked '%lock-thread-mutex)
(add-thread-mutex! thread mutex)
(if owner
(begin
(ring/enqueue (thread-mutex/waiting-threads mutex) thread)
(do () ((eq? thread (thread-mutex/owner mutex)))
- (%suspend-thread thread)))
+ (%suspend-thread thread)
+ (%lock)))
(set-thread-mutex/owner! mutex thread)))
(define (unlock-thread-mutex mutex)
(guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
- (without-interrupts
- (lambda ()
- (let ((owner (thread-mutex/owner mutex)))
- (if (and owner (not (eq? owner (current-thread))))
- (error "Don't own mutex:" mutex))
- (%unlock-thread-mutex mutex owner)))))
+ (if (with-threads-locked
+ (lambda ()
+ (let ((owner (thread-mutex/owner mutex)))
+ (if (and owner (not (eq? owner (%current-thread (%id)))))
+ #t
+ (begin
+ (%unlock-thread-mutex mutex owner)
+ #f)))))
+ (error "Don't own mutex:" mutex)))
(define (%unlock-thread-mutex mutex owner)
+ (assert-locked '%unlock-thread-mutex)
(remove-thread-mutex! owner mutex)
(if (%%unlock-thread-mutex mutex)
(%maybe-toggle-thread-timer)))
(define (%%unlock-thread-mutex mutex)
+ (assert-locked '%%unlock-thread-mutex)
(let ((thread (ring/dequeue (thread-mutex/waiting-threads mutex) #f)))
(set-thread-mutex/owner! mutex thread)
(if thread (%signal-thread-event thread #f))
\f
(define (try-lock-thread-mutex mutex)
(guarantee-thread-mutex mutex 'TRY-LOCK-THREAD-MUTEX)
- (without-interrupts
+ (with-threads-locked
(lambda ()
(and (not (thread-mutex/owner mutex))
(let ((thread (%current-thread (%id))))
(lambda () (lock-thread-mutex mutex))))
(define (%disassociate-thread-mutexes thread)
+ (assert-locked '%disassociate-thread-mutexes)
(do ((mutexes (thread/mutexes thread) (cdr mutexes)))
((not (pair? mutexes)))
(let ((mutex (car mutexes)))
(set-thread/mutexes! thread '()))
(define-integrable (add-thread-mutex! thread mutex)
+ (assert-locked 'add-thread-mutex!)
(set-thread/mutexes! thread (cons mutex (thread/mutexes thread))))
(define-integrable (remove-thread-mutex! thread mutex)
+ (assert-locked 'remove-thread-mutex!)
(set-thread/mutexes! thread (delq! mutex (thread/mutexes thread))))
\f
;;;; Circular Rings
(eq? (link/next ring) ring))
(define (ring/enqueue ring item)
+ (assert-locked 'ring/enqueue)
(let ((prev (link/prev ring)))
(let ((link (make-link prev ring item)))
(set-link/next! prev link)
(set-link/prev! ring link))))
(define (ring/dequeue ring default)
+ (assert-locked 'ring/dequeue)
(let ((link (link/next ring)))
(if (eq? link ring)
default
(link/item link)))))
(define (ring/discard-all ring)
+ (assert-locked 'ring/discard-all)
(set-link/prev! ring ring)
(set-link/next! ring ring))
(define (ring/remove-item ring item)
+ (assert-locked 'ring/remove-item)
(let loop ((link (link/next ring)))
(if (not (eq? link ring))
(if (eq? (link/item link) item)
(loop (link/next link))))))
(define (ring/count-max-2 ring)
+ (assert-locked 'ring/count-max-2)
(let ((link (link/next ring)))
(cond ((eq? link ring) 0)
((eq? (link/next link) ring) 1)
(else 2))))
(define (ring/first-item ring)
+ (assert-locked 'ring/first-item)
(link/item (link/next ring)))
(define (ring/set-first-item! ring item)
+ (assert-locked 'ring/set-first-item!)
(set-link/item! (link/next ring) item))
\f
;;;; Error Conditions
'()
(lambda (condition port)
condition
- (write-string "No current thread!" port))))
+ (write-string "No current thread." port))))
unspecific)
+
+(define-integrable (%%id)
+ (if enable-smp?
+ ((ucode-primitive smp-id 0))
+ 0))
+
+#;(define-syntax assert-locked
+ (syntax-rules ()
+ ((_ NAME)
+ #f)))
+
+(define-syntax assert-locked
+ (syntax-rules ()
+ ((_ NAME)
+ (begin
+ (if (not locked?)
+ (%outf-error ";"(%%id)" Warning: "NAME" not locked\n"))
+ (if (not (only-gc-ok?))
+ (%outf-error ";"(%%id)" Warning: "NAME" can be interrupted\n"))))))
+
+#;(define-syntax complain-if
+ (syntax-rules ()
+ ((_ FORM MSG)
+ #f)))
+
+(define-syntax complain-if
+ (syntax-rules ()
+ ((_ FORM MSG)
+ (if FORM (%outf-error* (list ";"(%%id)" "MSG"\n"))))))
+
+#;(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace?
+ (outf-error* (list . MSG))))))
+
+(define (outf-error* objects)
+ (if (not (current-thread))
+ (begin
+ (%outf-error ";"(%%id)" WARNING: no current thread for %trace\n")
+ (%outf-error* objects))
+ (apply outf-error objects)))
+
+#;(define-syntax %if-tracing
+ (syntax-rules ()
+ ((_ . BODY)
+ #f)))
+
+(define-syntax %if-tracing
+ (syntax-rules ()
+ ((_ . BODY)
+ (if %trace?
+ (begin . BODY)))))
+
+#;(define-syntax %%trace
+ (syntax-rules ()
+ ((_ . MSG)
+ #f)))
+
+(define-syntax %%trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (if %trace? (%outf-error* (list . MSG))))))
+
+(define (%outf-error . objects)
+ ;; A version of outf-error that works when current-thread is #f.
+ (%outf-error* objects))
+
+(define (%outf-error* objects)
+ ((ucode-primitive outf-error 1)
+ (apply string-append (map %->string objects))))
+
+(define (%->string object)
+ (cond ((string? object) object)
+ ((symbol? object) (symbol-name object))
+ ((number? object) (number->string object))
+ ((eq? object #f) "#f")
+ ((eq? object #!default) "#!default")
+ ((thread? object)
+ (string-append "#[thread "(number->string (hash object))"]"))
+ (else
+ (string-append "#["(symbol-name
+ (microcode-type/code->name
+ ((ucode-primitive object-type 1) object)))
+ " "(number->string (hash object))"]"))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff