From 29c3f404a73830d05e5e34f748ad293fa3ff9e45 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 21 Dec 2014 12:02:38 -0700 Subject: [PATCH] smp: Serialize access to (runtime thread) internals. --- src/runtime/thread.scm | 608 ++++++++++++++++++++++++++++++----------- 1 file changed, 453 insertions(+), 155 deletions(-) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index c4c90de9d..89e0ee9b7 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -32,6 +32,62 @@ USA. ;;; 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))) (define-structure (thread (constructor %make-thread ()) @@ -94,7 +150,10 @@ USA. (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))) (define thread-population) @@ -129,21 +188,10 @@ USA. (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) @@ -162,11 +210,15 @@ USA. (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)))))))) @@ -184,11 +236,11 @@ USA. (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)) @@ -214,77 +266,103 @@ USA. (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)))) (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) @@ -297,10 +375,12 @@ USA. (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) @@ -314,9 +394,11 @@ USA. (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))))) (define (disallow-preempt-current-thread) (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION)) @@ -328,24 +410,36 @@ USA. ;; 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 @@ -354,22 +448,28 @@ USA. (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))))) @@ -384,10 +484,11 @@ USA. (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) @@ -403,6 +504,7 @@ USA. (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! @@ -411,26 +513,43 @@ USA. (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))) @@ -441,6 +560,7 @@ USA. (%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! @@ -487,8 +607,8 @@ USA. (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!) @@ -496,22 +616,40 @@ USA. (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)))) (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) @@ -522,47 +660,55 @@ USA. '#(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))) @@ -578,7 +724,7 @@ USA. 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 @@ -590,14 +736,14 @@ USA. (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) @@ -618,6 +764,7 @@ USA. (%maybe-toggle-thread-timer)))) (define (%deregister-io-descriptor descriptor) + (%lock) (let dloop ((dentry io-registrations)) (cond ((not dentry) unspecific) @@ -643,10 +790,12 @@ USA. (dloop (dentry/next dentry))) (else (dloop (dentry/next dentry))))) - (%maybe-toggle-thread-timer)) + (%maybe-toggle-thread-timer) + (%unlock)) (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) @@ -684,10 +833,12 @@ USA. 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))) @@ -710,6 +861,7 @@ USA. (error:wrong-type-argument mode "select mode" procedure))) (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)) @@ -749,6 +901,7 @@ USA. (%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)) @@ -760,6 +913,7 @@ USA. (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))) @@ -792,7 +946,7 @@ USA. ;;;; Events (define (block-thread-events) - (without-interrupts + (with-threads-locked (lambda () (let ((thread (%current-thread (%id)))) (if thread @@ -802,7 +956,7 @@ USA. #f))))) (define (unblock-thread-events) - (without-interrupts + (with-threads-locked (lambda () (let ((thread (%current-thread (%id)))) (handle-thread-events thread) @@ -829,6 +983,7 @@ USA. (set-interrupt-enables! interrupt-mask) value)) (begin + (complain-if #t "with-thread-events-blocked: no current thread") (set-interrupt-enables! interrupt-mask) (thunk)))))) @@ -838,45 +993,66 @@ USA. (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))) (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 @@ -888,6 +1064,8 @@ USA. (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) @@ -896,13 +1074,15 @@ USA. (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 @@ -913,6 +1093,7 @@ USA. (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)))) @@ -932,7 +1113,7 @@ USA. (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))) @@ -956,7 +1137,9 @@ USA. (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) @@ -971,7 +1154,7 @@ USA. (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 @@ -983,22 +1166,20 @@ USA. (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))) @@ -1016,25 +1197,29 @@ USA. (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))) @@ -1043,8 +1228,10 @@ USA. ;; 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)) @@ -1054,9 +1241,11 @@ USA. (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)) @@ -1094,9 +1283,9 @@ USA. (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" @@ -1104,29 +1293,36 @@ USA. (%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)) @@ -1134,7 +1330,7 @@ USA. (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)))) @@ -1155,6 +1351,7 @@ USA. (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))) @@ -1164,9 +1361,11 @@ USA. (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)))) ;;;; Circular Rings @@ -1186,12 +1385,14 @@ USA. (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 @@ -1202,10 +1403,12 @@ USA. (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) @@ -1216,15 +1419,18 @@ USA. (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)) ;;;; Error Conditions @@ -1312,5 +1518,97 @@ USA. '() (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 -- 2.25.1