From: Matt Birkholz Date: Wed, 8 Jul 2015 23:48:11 +0000 (-0700) Subject: Serialize access to (runtime thread) internals. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dffdb139a6bf6a5aefd259213cf072d3942de5b9;p=mit-scheme.git Serialize access to (runtime thread) internals. Multiple processors may use the 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, all 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. The nonrecursive mutex's atomic sections are implemented in uni- processing worlds by masking all interrupts. Inside, a LOCKED? flag is set and cleared and asserts check that the thread system is locked (or not!). Allowing GC interrupts in these sections is left as an exercise. The channel-close and process-delete primitives are called inside the thread system's atomic deregistration operations to ensure that the timer interrupt or wait-for-io (i.e. test-select-registry called on another processor) do not use the invalid descriptors. --- diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm index 866673bc0..e28d5fe10 100644 --- a/src/runtime/intrpt.scm +++ b/src/runtime/intrpt.scm @@ -236,7 +236,7 @@ USA. (vector-set! system-interrupt-vector timer-slot timer-interrupt-handler) (vector-set! interrupt-mask-vector timer-slot - interrupt-mask/gc-ok) + interrupt-mask/none) (vector-set! system-interrupt-vector character-slot external-interrupt-handler) diff --git a/src/runtime/io.scm b/src/runtime/io.scm index eabe2236c..d8038206e 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -96,9 +96,10 @@ USA. (with-gc-finalizer-lock open-channels (lambda () (if (channel-open? channel) - (begin - (%deregister-io-descriptor (channel-descriptor-for-select channel)) - (remove-from-locked-gc-finalizer! open-channels channel)))))) + (deregister-io-descriptor (channel-descriptor-for-select channel) + (lambda () + (remove-from-locked-gc-finalizer! + open-channels channel))))))) (define-integrable (channel-open? channel) (if (channel-descriptor channel) #t #f)) diff --git a/src/runtime/process.scm b/src/runtime/process.scm index bf8f2bfef..549cb2812 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -183,8 +183,13 @@ USA. (begin (poll-subprocess-status process) (close-subprocess-i/o process) - (deregister-subprocess process) - (remove-from-gc-finalizer! subprocess-finalizer process)))) + (with-gc-finalizer-lock + subprocess-finalizer + (lambda () + (deregister-subprocess process + (lambda () + (remove-from-locked-gc-finalizer! + subprocess-finalizer process)))))))) (define (subprocess-wait process) (let ((result #f) @@ -220,6 +225,11 @@ USA. status)))) (define (poll-subprocess-status process) + (with-thread-lock + (lambda () + (%poll-subprocess-status process)))) + +(define (%poll-subprocess-status process) (let ((index (subprocess-index process))) (if (and index ((ucode-primitive process-status-sync 1) index)) (begin @@ -251,7 +261,7 @@ USA. (else (error "Illegal process job-control status:" n))))) (define (handle-subprocess-status-change) - (without-interrupts %handle-subprocess-status-change) + (with-thread-lock %handle-subprocess-status-change) (if (eq? 'NT microcode-id/operating-system) (for-each (lambda (process) (if (memq (subprocess-status process) '(EXITED SIGNALLED)) @@ -264,7 +274,7 @@ USA. (for-each (lambda (weak) (let ((subprocess (weak-car weak))) (if subprocess - (poll-subprocess-status subprocess)))) + (%poll-subprocess-status subprocess)))) (gc-finalizer-items subprocess-finalizer)) (%signal-subprocess-status-change)))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 627b2af9d..6b331db3b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3310,7 +3310,7 @@ USA. remove-from-select-registry! test-select-registry) (import (runtime thread) - %deregister-io-descriptor) + deregister-io-descriptor) (import (runtime gc-finalizer) with-gc-finalizer-lock remove-from-locked-gc-finalizer!) @@ -3870,10 +3870,13 @@ USA. (export (runtime thread) %handle-subprocess-status-change) (import (runtime thread) + with-thread-lock deregister-subprocess %signal-subprocess-status-change) (import (runtime gc-finalizer) - gc-finalizer-items) + gc-finalizer-items + remove-from-locked-gc-finalizer! + with-gc-finalizer-lock) (initialization (initialize-package!))) (define-package (runtime synchronous-subprocess) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 46f933411..cea1468bd 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -32,6 +32,46 @@ USA. ;;; This allows a host without the SMP primitives to avoid calling them. (define enable-smp? #f) +(define locked? #f) + +(define-integrable get-interrupt-enables + (ucode-primitive get-interrupt-enables 0)) + +(define-integrable interrupt-mask/in-threads interrupt-mask/none) + +(define-integrable (interrupt-mask-ok?) + (fix:= 0 (get-interrupt-enables))) + +(define (%lock) + (%assert (interrupt-mask-ok?) "%lock: wrong interrupt mask") + (%assert (not locked?) "%lock: already locked") + (if enable-smp? + (if (not ((ucode-primitive smp-lock-threads 1) #t)) + (error "Could not lock the thread system."))) + (set! locked? #t)) + +(define (%unlock) + (%assert (interrupt-mask-ok?) "%unlock: wrong interrupt mask") + (%assert locked? "%unlock: not locked") + (set! locked? #f) + (if enable-smp? + (if (not ((ucode-primitive smp-lock-threads 1) #f)) + (%assert #f "%unlock: failed")))) + +(define-integrable (without-interrupts thunk) + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/in-threads))) + (let ((value (thunk))) + (set-interrupt-enables! interrupt-mask) + value))) + +(define-integrable (with-thread-lock thunk) + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/in-threads))) + (%lock) + (let ((value (thunk))) + (%unlock) + (set-interrupt-enables! interrupt-mask) + value))) + (define (with-obarray-lock thunk) ;; Serialize with myriad parts of the microcode that hack the ;; obarray element of the fixed-objects vector. @@ -40,11 +80,8 @@ USA. (let ((value (thunk))) (if ((ucode-primitive smp-lock-obarray 1) #f) value - (begin - (outf-error ";with-obarray-lock: unlock failed\n") - #f))) - (begin - (outf-error ";with-obarray-lock: lock failed\n"))) + (%assert "with-obarray-lock: unlock failed"))) + (%assert "with-obarray-lock: lock failed")) (without-interrupts thunk))) (define-structure (thread @@ -133,7 +170,8 @@ USA. (let ((first (%make-thread (make-1d-table/unsafe)))) (set-thread/exit-value! first detached-thread-marker) (add-to-population!/unsafe thread-population first) - (%thread-running first))) + (set! first-running-thread first) + (set! last-running-thread first))) (define (initialize-high!) ;; Called later in the cold load, when more of the runtime is initialized. @@ -175,23 +213,10 @@ USA. (set! io-registrations #f) (set! subprocess-registrations '())) -(define (make-thread continuation) - (let ((thread (%make-thread (make-1d-table)))) - (set-thread/continuation! thread continuation) - (set-thread/root-dynamic-state! thread - (continuation/dynamic-state continuation)) - (add-to-population! 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-thread-lock + (lambda () + (map-over-population thread-population (lambda (thread) thread))))) (define (thread-execution-state thread) (guarantee-thread thread 'THREAD-EXECUTION-STATE) @@ -208,13 +233,20 @@ USA. (lambda (return) (%within-continuation root-continuation #t (lambda () - (call-with-current-continuation - (lambda (continuation) - (let ((thread (make-thread continuation))) + (let ((thread (%make-thread (make-1d-table)))) + (call-with-current-continuation + (lambda (continuation) + (set-thread/continuation! thread continuation) + (set-thread/root-dynamic-state! thread + (continuation/dynamic-state + continuation)) + (with-thread-lock + (lambda () + (add-to-population!/unsafe thread-population thread) + (thread-running thread))) (%within-continuation (let ((k return)) (set! return #f) k) #t (lambda () thread))))) - (set-interrupt-enables! interrupt-mask/all) (exit-current-thread (with-create-thread-continuation root-continuation thunk)))))))) @@ -237,18 +269,19 @@ USA. (lambda (continuation) (let ((condition (make-condition condition-type:no-current-thread - continuation - 'BOUND-RESTARTS - '()))) + continuation '() '()))) (signal-thread-event thread (lambda () (error condition))))))) + (%lock) (run-first-thread)))) (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?) (run-first-thread))))) + ((not return?) (%lock) (run-first-thread))))) (define (console-thread) (thread-mutex-owner (port/thread-mutex console-i/o-port))) @@ -258,25 +291,26 @@ USA. (define (thread-continuation thread) (guarantee-thread thread 'THREAD-CONTINUATION) - (without-interrupts - (lambda () - (and (eq? 'WAITING (thread/execution-state thread)) - (thread/continuation thread))))) + (thread/continuation thread)) (define (thread-running thread) (%thread-running thread) (%maybe-toggle-thread-timer)) (define (%thread-running thread) + (%assert-locked '%thread-running) (set-thread/execution-state! thread 'RUNNING) (let ((prev last-running-thread)) (if prev (set-thread/next! prev thread) (set! first-running-thread thread))) (set! last-running-thread thread) + (%assert (eq? #f (thread/next thread)) + "%thread-running: last-running-thread has a next") unspecific) (define (thread-not-running thread state) + (%assert-locked 'thread-not-running) (set-thread/execution-state! thread state) (let ((thread* (thread/next thread))) (set-thread/next! thread #f) @@ -284,6 +318,7 @@ USA. (run-first-thread)) (define (run-first-thread) + (%assert-locked 'run-first-thread) (if first-running-thread (run-thread first-running-thread) (begin @@ -291,40 +326,50 @@ USA. (wait-for-io)))) (define (run-thread thread) + (%assert-locked 'run-thread) (let ((continuation (thread/continuation thread)) (fp-env (thread/floating-point-environment thread))) + (%assert (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) + (%assert-locked '%resume-thread) (if (not (thread/block-events? thread)) (begin (handle-thread-events thread) + (%maybe-toggle-thread-timer) (set-thread/block-events?! thread #f))) - (%maybe-toggle-thread-timer)) + (%unlock)) (define (suspend-current-thread) - (without-interrupts %suspend-current-thread)) - -(define (%suspend-current-thread) - (call-with-current-thread #f - (lambda (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) - (call-with-current-continuation - (lambda (continuation) - (set-thread/continuation! thread continuation) - (maybe-save-thread-float-environment! thread) - (set-thread/block-events?! thread #f) - (thread-not-running thread 'WAITING))))))))) + (without-interrupts + (lambda () + (call-with-current-thread #f + (lambda (thread) + (%lock) + (%suspend-thread thread)))))) + +(define (%suspend-thread thread) + (%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? + (begin + (%maybe-toggle-thread-timer) + (%unlock)) + (call-with-current-continuation + (lambda (continuation) + (set-thread/continuation! thread continuation) + (maybe-save-thread-float-environment! thread) + (set-thread/block-events?! thread #f) + (thread-not-running thread 'WAITING))))))) (define (stop-current-thread) (without-interrupts @@ -335,6 +380,7 @@ USA. (lambda (continuation) (set-thread/continuation! thread continuation) (maybe-save-thread-float-environment! thread) + (%lock) (thread-not-running thread 'STOPPED)))))))) (define (restart-thread thread discard-events? event) @@ -344,7 +390,7 @@ USA. (prompt-for-confirmation "Restarting other thread; discard events in its queue") discard-events?))) - (without-interrupts + (with-thread-lock (lambda () (if (not (eq? 'STOPPED (thread/execution-state thread))) (error:bad-range-argument thread restart-thread)) @@ -362,14 +408,15 @@ 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 ((fp-env (enter-default-float-environment first-running-thread))) (set! next-scheduled-timeout #f) - (set-interrupt-enables! interrupt-mask/gc-ok) (deliver-timer-events) (maybe-signal-io-thread-events) (let ((thread first-running-thread)) (cond ((not thread) - (%maybe-toggle-thread-timer)) + (%maybe-toggle-thread-timer) + (%unlock)) ((thread/continuation thread) (run-thread thread)) ((not (eq? 'RUNNING-WITHOUT-PREEMPTION @@ -377,25 +424,27 @@ USA. (yield-thread thread fp-env)) (else (restore-float-environment-from-default fp-env) - (%resume-current-thread thread)))))) + (%resume-thread 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)))))) (define (yield-thread thread #!optional fp-env) + (%assert-locked 'yield-thread) (let ((next (thread/next thread))) (if (not next) (begin (if (not (default-object? fp-env)) (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) @@ -414,10 +463,11 @@ USA. (define (exit-current-thread value) (let ((thread (current-thread))) - (set-interrupt-enables! interrupt-mask/gc-ok) (set-thread/block-events?! thread #t) - (ring/discard-all (thread/pending-events thread)) (dynamic-unwind thread (thread/root-dynamic-state thread)) + (set-interrupt-enables! interrupt-mask/in-threads) + (%lock) + (ring/discard-all (thread/pending-events thread)) (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (%deregister-subprocess-events thread) @@ -434,6 +484,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! @@ -442,10 +493,13 @@ USA. (thread/joined-threads thread))) (set-thread/joined-to! self - (cons thread (thread/joined-to self)))) + (cons thread (thread/joined-to self))) + (%unlock)) ((eq? value detached-thread-marker) + (%unlock) (signal-thread-detached thread)) (else + (%unlock) (signal-thread-event self (event-constructor thread value)))))))))) @@ -454,14 +508,21 @@ USA. (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))) @@ -472,6 +533,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! @@ -501,14 +563,20 @@ USA. next) (define (wait-for-io) + (%assert-locked 'wait-for-io) + (%assert (interrupt-mask-ok?) "wait-for-io: wrong interrupt mask") (%maybe-toggle-thread-timer #f) - (let ((result (test-select-registry io-registry #t))) + (let ((result (begin + (%unlock) + (test-select-registry io-registry #t)))) + (%lock) (signal-select-result result) (if first-running-thread (run-thread first-running-thread) (wait-for-io)))) (define (signal-select-result result) + (%assert-locked 'signal-select-result) (cond ((vector? result) (signal-io-thread-events (vector-ref result 0) (vector-ref result 1) @@ -516,17 +584,28 @@ USA. ((eq? 'PROCESS-STATUS-CHANGE result) (%handle-subprocess-status-change)) ((eq? 'INTERRUPT result) + (%unlock) (set-interrupt-enables! interrupt-mask/all) (handle-interrupts) - (set-interrupt-enables! interrupt-mask/gc-ok)))) + (set-interrupt-enables! interrupt-mask/in-threads) + (%lock)))) (define (handle-interrupts) #t) (define (maybe-signal-io-thread-events) - (if io-registrations + (%assert-locked 'maybe-signal-io-thread-events) + (if (or io-registrations + (registered-subprocesses-running?)) (signal-select-result (test-select-registry io-registry #f)))) +(define-integrable (registered-subprocesses-running?) + (find (lambda (registration) + (eq? 'RUNNING (subprocess-status + (subprocess-registration/subprocess + registration)))) + subprocess-registrations)) + (define (block-on-io-descriptor descriptor mode) (let ((result 'INTERRUPT) (registration #f)) @@ -583,7 +662,7 @@ USA. (define (register-io-thread-event descriptor mode thread event) (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT) (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT) - (without-interrupts + (with-thread-lock (lambda () (let ((registration (%register-io-thread-event descriptor mode thread event))) @@ -593,21 +672,21 @@ USA. (define (deregister-io-thread-event registration) (if (and (pair? registration) (eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT)) - ((cdr registration)) + (with-thread-lock (cdr registration)) (deregister-io-thread-event* registration))) (define (deregister-io-thread-event* tentry) (if (not (tentry? tentry)) (error:wrong-type-argument tentry "IO thread event registration" 'DEREGISTER-IO-THREAD-EVENT)) - (without-interrupts + (with-thread-lock (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-thread-lock (lambda () (let loop ((dentry io-registrations)) (cond ((not dentry) @@ -626,7 +705,13 @@ USA. (loop (dentry/next dentry))))) (%maybe-toggle-thread-timer)))) -(define (%deregister-io-descriptor descriptor) +(define (deregister-io-descriptor descriptor close-descriptor!) + (with-thread-lock + (lambda () + (%deregister-io-descriptor* descriptor) + (close-descriptor!)))) + +(define (%deregister-io-descriptor* descriptor) (let dloop ((dentry io-registrations)) (cond ((not dentry) unspecific) @@ -655,6 +740,7 @@ USA. (%maybe-toggle-thread-timer)) (define (%register-io-thread-event descriptor mode thread event) + (%assert-locked '%register-io-thread-event) (let ((tentry (make-tentry thread event))) (let loop ((dentry io-registrations)) (cond ((not dentry) @@ -685,10 +771,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) + (%assert-locked '%deregister-io-thread-events) (let loop ((dentry io-registrations) (tentries '())) (if (not dentry) (do ((tentries tentries (cdr tentries))) @@ -709,6 +797,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)) @@ -746,6 +835,7 @@ USA. (%signal-thread-event (caar events) (cdar events))))))) (define (delete-tentry! tentry) + (%assert-locked 'delete-tentry!) (let ((dentry (tentry/dentry tentry)) (prev (tentry/prev tentry)) (next (tentry/next tentry))) @@ -776,7 +866,7 @@ USA. ;;;; Events (define (block-thread-events) - (without-interrupts + (with-thread-lock (lambda () (let ((thread first-running-thread)) (if thread @@ -786,7 +876,7 @@ USA. #f))))) (define (unblock-thread-events) - (without-interrupts + (with-thread-lock (lambda () (call-with-current-thread #t (lambda (thread) @@ -794,64 +884,54 @@ USA. (set-thread/block-events?! thread #f)))))) (define (with-thread-events-blocked thunk) - (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (let ((thread first-running-thread)) - (if thread - (let ((block-events? (thread/block-events? thread))) - (set-thread/block-events?! thread #t) - (let ((value - ((ucode-primitive with-stack-marker 3) - (lambda () - (set-interrupt-enables! interrupt-mask) - (let ((value (thunk))) - (set-interrupt-enables! interrupt-mask/gc-ok) - value)) - 'WITH-THREAD-EVENTS-BLOCKED - block-events?))) - (let ((thread first-running-thread)) - (if thread - (set-thread/block-events?! thread block-events?))) - (set-interrupt-enables! interrupt-mask) - value)) - (begin - (set-interrupt-enables! interrupt-mask) - (thunk)))))) + (let ((block-events? (block-thread-events))) + (let ((value + ((ucode-primitive with-stack-marker 3) + thunk + 'WITH-THREAD-EVENTS-BLOCKED + block-events?))) + (if (not block-events?) + (unblock-thread-events)) + value))) (define (get-thread-event-block) - (without-interrupts - (lambda () - (let ((thread first-running-thread)) - (if thread - (thread/block-events? thread) - #f))))) + (let ((thread first-running-thread)) + (if thread + (thread/block-events? thread) + #f))) (define (set-thread-event-block! block?) - (without-interrupts - (lambda () - (let ((thread first-running-thread)) - (if thread - (set-thread/block-events?! thread block?))) - unspecific))) + (let ((thread first-running-thread)) + (if thread + (set-thread/block-events?! thread block?))) + unspecific) (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))) - (%add-pending-event thread event) + (with-thread-lock + (lambda () + (%add-pending-event thread event))) (if (not block-events?) (unblock-thread-events))) - (without-interrupts - (lambda () - (if (eq? 'DEAD (thread/execution-state thread)) - (signal-thread-dead thread "signal event to" - signal-thread-event thread event)) - (%signal-thread-event thread event) - (if (and (not self) first-running-thread) - (run-thread first-running-thread) - (%maybe-toggle-thread-timer))))))) + (begin + (if (eq? 'DEAD (thread/execution-state thread)) + (signal-thread-dead thread "signal event to" + signal-thread-event thread event)) + (without-interrupts + (lambda () + (%lock) + (%signal-thread-event thread event) + (if (and (not self) first-running-thread) + (run-thread first-running-thread) + (begin + (%maybe-toggle-thread-timer) + (%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))) @@ -861,6 +941,7 @@ USA. ;; 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 @@ -872,6 +953,7 @@ USA. (ring/enqueue ring event)))))) (define (handle-thread-events thread) + (%assert-locked 'handle-thread-events) (let loop ((any-events? #f)) (let ((event (ring/dequeue (thread/pending-events thread) #t))) (if (eq? #t event) @@ -880,13 +962,16 @@ USA. (if event (let ((block? (thread/block-events? thread))) (set-thread/block-events?! thread #t) + (%unlock) + (set-interrupt-enables! interrupt-mask/all) (event) - (set-interrupt-enables! interrupt-mask/gc-ok) + (set-interrupt-enables! interrupt-mask/in-threads) + (%lock) (set-thread/block-events?! thread block?))) (loop #t)))))) (define (allow-thread-event-delivery) - (without-interrupts + (with-thread-lock (lambda () (let ((thread first-running-thread)) (if thread @@ -907,7 +992,7 @@ USA. (define (register-gc-event event) (guarantee-procedure-of-arity event 1 'register-gc-event) - (without-interrupts + (with-thread-lock (lambda () (let* ((thread first-running-thread) (entry (weak-assq thread gc-events))) @@ -916,20 +1001,20 @@ USA. (set! gc-events (cons (weak-cons thread event) gc-events))))))) (define (deregister-gc-event) - (without-interrupts + (with-thread-lock (lambda () (let ((entry (weak-assq first-running-thread gc-events))) (if entry (set! gc-events (delq! entry gc-events))))))) (define (registered-gc-event) - (without-interrupts + (with-thread-lock (lambda () (let ((entry (weak-assq first-running-thread gc-events))) (and entry (weak-cdr entry)))))) (define (signal-gc-events statistic) - (without-interrupts + (with-thread-lock (lambda () (set! gc-events (filter! weak-car gc-events)) (for-each @@ -981,37 +1066,39 @@ USA. (guarantee-procedure-of-arity event 1 'register-subprocess-event) (let ((registration (make-subprocess-registration subprocess status thread event))) - (without-interrupts - (lambda () - (set! subprocess-registrations - (cons registration subprocess-registrations)) - (let ((current (subprocess-status subprocess))) - (if (not (eq? status current)) - (begin - (%signal-thread-event - thread (and event (lambda () (event current)))) - (set-subprocess-registration/status! registration current)))))) + (with-thread-lock + (lambda () + (set! subprocess-registrations + (cons registration subprocess-registrations)) + (let ((current (subprocess-status subprocess))) + (if (not (eq? status current)) + (begin + (%signal-thread-event + thread (and event (lambda () (event current)))) + (set-subprocess-registration/status! registration current)))))) registration)) (define (deregister-subprocess-event registration) (guarantee-subprocess-registration registration 'DEREGISTER-IO-DESCRIPTOR-EVENTS) - (without-interrupts + (with-thread-lock (lambda () (set! subprocess-registrations (delq! registration subprocess-registrations))))) -(define (deregister-subprocess subprocess) - (without-interrupts +(define (deregister-subprocess subprocess delete-subprocess!) + (with-thread-lock (lambda () (set! subprocess-registrations (filter! (lambda (registration) (not (eq? subprocess (subprocess-registration/subprocess registration)))) - subprocess-registrations))))) + subprocess-registrations)) + (delete-subprocess!)))) (define (%deregister-subprocess-events thread) + (%assert-locked '%deregister-subprocess-events) (set! subprocess-registrations (filter! (lambda (registration) @@ -1019,6 +1106,7 @@ USA. subprocess-registrations))) (define (%signal-subprocess-status-change) + (%assert-locked '%signal-subprocess-status-change) (for-each (lambda (registration) (let ((status (subprocess-status @@ -1047,7 +1135,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-thread-lock (lambda () (let loop ((record timer-records) (prev #f)) (if (or (not record) (< time (timer-record/time record))) @@ -1071,6 +1159,7 @@ USA. (unblock-thread-events))))) (define (deliver-timer-events) + (%assert-locked 'deliver-timer-events) (let ((time (real-time-clock))) (do ((record timer-records (timer-record/next record))) ((or (not record) (< time (timer-record/time record))) @@ -1086,7 +1175,7 @@ USA. (if (not (timer-record? registration)) (error:wrong-type-argument registration "timer event registration" 'DEREGISTER-TIMER-EVENT)) - (without-interrupts + (with-thread-lock (lambda () (let loop ((record timer-records) (prev #f)) (if record @@ -1098,23 +1187,21 @@ 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-thread-lock + (lambda () + (let* ((thread first-running-thread) + (block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #t) (ring/discard-all (thread/pending-events thread)) (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (%deregister-subprocess-events 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))) @@ -1132,21 +1219,22 @@ USA. (define (set-thread-timer-interval! interval) (if interval (guarantee-exact-positive-integer interval 'SET-THREAD-TIMER-INTERVAL!)) - (without-interrupts + (with-thread-lock (lambda () (set! timer-interval interval) (%maybe-toggle-thread-timer)))) (define (start-thread-timer) - (without-interrupts %maybe-toggle-thread-timer)) + (with-thread-lock %maybe-toggle-thread-timer)) (define (stop-thread-timer) - (without-interrupts %stop-thread-timer)) + (with-thread-lock %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))) (let ((start (lambda (time) @@ -1168,6 +1256,7 @@ USA. ((and consider-non-timers? timer-interval (or io-registrations + (registered-subprocesses-running?) (let ((current-thread first-running-thread)) (and current-thread (thread/next current-thread))))) @@ -1176,6 +1265,7 @@ USA. (%stop-thread-timer)))))) (define (%stop-thread-timer) + (%assert-locked '%stop-thread-timer) (if next-scheduled-timeout (begin ((ucode-primitive real-timer-clear)) @@ -1218,39 +1308,49 @@ USA. (define (lock-thread-mutex mutex) (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX) - (without-interrupts - (lambda () - (let ((thread (current-thread)) - (owner (thread-mutex/owner mutex))) - (if (eq? owner thread) - (signal-thread-deadlock thread "lock thread mutex" - lock-thread-mutex mutex)) - (%lock-thread-mutex mutex thread owner))))) + (if (with-thread-lock + (lambda () + (let ((thread first-running-thread) + (owner (thread-mutex/owner mutex))) + (if (eq? owner thread) + #t + (begin + (%lock-thread-mutex mutex thread owner) + #f))))) + (signal-thread-deadlock first-running-thread "lock thread mutex" + lock-thread-mutex mutex))) (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-current-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-thread-lock + (lambda () + (let ((owner (thread-mutex/owner mutex))) + (if (and owner (not (eq? owner (current-thread)))) + #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)) @@ -1258,7 +1358,7 @@ USA. (define (try-lock-thread-mutex mutex) (guarantee-thread-mutex mutex 'TRY-LOCK-THREAD-MUTEX) - (without-interrupts + (with-thread-lock (lambda () (and (not (thread-mutex/owner mutex)) (let ((thread (current-thread))) @@ -1290,18 +1390,22 @@ USA. (grabbed-lock?)) (dynamic-wind (lambda () - (let ((owner (thread-mutex/owner mutex))) - (if (eq? owner thread) - (begin - (set! grabbed-lock? #f) - unspecific) - (begin - (set! grabbed-lock? #t) - (%lock-thread-mutex mutex thread owner))))) + (with-thread-lock + (lambda () + (let ((owner (thread-mutex/owner mutex))) + (if (eq? owner thread) + (begin + (set! grabbed-lock? #f) + unspecific) + (begin + (set! grabbed-lock? #t) + (%lock-thread-mutex mutex thread owner))))))) thunk (lambda () - (if (and grabbed-lock? (eq? (thread-mutex/owner mutex) thread)) - (%unlock-thread-mutex mutex thread)))))) + (with-thread-lock + (lambda () + (if (and grabbed-lock? (eq? (thread-mutex/owner mutex) thread)) + (%unlock-thread-mutex mutex thread)))))))) (define (with-thread-mutex-unlocked mutex thunk) (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-UNLOCKED) @@ -1309,20 +1413,25 @@ USA. (released-lock?)) (dynamic-wind (lambda () - (let ((owner (thread-mutex/owner mutex))) - (if (not (eq? owner thread)) - (set! released-lock? #f) - (begin - (set! released-lock? #t) - (%unlock-thread-mutex mutex owner))))) + (with-thread-lock + (lambda () + (let ((owner (thread-mutex/owner mutex))) + (if (not (eq? owner thread)) + (set! released-lock? #f) + (begin + (set! released-lock? #t) + (%unlock-thread-mutex mutex owner))))))) thunk (lambda () (if released-lock? - (let ((owner (thread-mutex/owner mutex))) - (if (not (eq? owner thread)) - (%lock-thread-mutex mutex thread owner)))))))) + (with-thread-lock + (lambda () + (let ((owner (thread-mutex/owner mutex))) + (if (not (eq? owner thread)) + (%lock-thread-mutex mutex thread owner)))))))))) (define (%disassociate-thread-mutexes thread) + (%assert-locked '%disassociate-thread-mutexes) (do ((mutexes (thread/mutexes thread) (cdr mutexes))) ((not (pair? mutexes))) (let ((mutex (car mutexes))) @@ -1332,9 +1441,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)))) ;;;; Error Conditions @@ -1423,4 +1534,52 @@ USA. (lambda (condition port) condition (write-string "No current thread!" port)))) - unspecific) \ No newline at end of file + unspecific) + +#;(define-syntax %assert + (syntax-rules () + ((_ EXPR . MSG) + #f))) + +(define-syntax %assert + (syntax-rules () + ((_ EXPR . MSG) + (if (not EXPR) + (%outf-error . MSG))))) + +#;(define-syntax %assert-locked + (syntax-rules () + ((_ NAME) + #f))) + +(define-syntax %assert-locked + (syntax-rules () + ((_ NAME) + (%assert-locked* NAME)))) + +(define (%assert-locked* caller) + (if (not locked?) + (%outf-error caller" not locked")) + (if (not (interrupt-mask-ok?)) + (%outf-error caller" can be interrupted"))) + +(define (%outf-error . msg) + ((ucode-primitive outf-error 1) + (apply string-append `("; ",@(map %->string msg)"\n")))) + +(define (%->string object) + (cond ((string? object) object) + ((symbol? object) (symbol-name object)) + ((number? object) (number->string object)) + ((eq? object #f) "#f") + ((eq? object #t) "#t") + ((eq? object #!default) "#!default") + ;;((thread? object) + ;; The hash procedure now uses the thread system (will deadlock). + ;; (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))"]" + " 0x"(number->string (object-datum object) 16)"]")))) \ No newline at end of file