From: Matt Birkholz Date: Tue, 18 Aug 2015 01:38:24 +0000 (-0700) Subject: Serialize access to (runtime thread) internals. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e63a8ab3f7a139307dc215fdedfb4b4ce1bf9c2c;p=mit-scheme.git Serialize access to (runtime thread) internals. Multiple processors may use the thread system simultaneously, so its procedures and timer interrupt handler must arrange to serialize. They must lock/unlock an OS-level mutex and run without interrupts. While the mutex is locked, they must not signal errors and may not invoke arbitrary hooks, handlers, etc. (The mutex is not recursive.) Inside the mutex's atomic sections a LOCKED? flag is set. Asserts check that the thread system is locked when necessary. 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 7124c1890..0c197aeb9 100644 --- a/src/runtime/intrpt.scm +++ b/src/runtime/intrpt.scm @@ -115,13 +115,20 @@ USA. args (abort->nearest "Aborting! Out of memory")) -(define (after-gc-interrupt-handler interrupt-code interrupt-enables) - interrupt-code interrupt-enables - (trigger-gc-daemons!) - ;; By clearing the interrupt after running the daemons we ignore an - ;; GC that occurs while we are running the daemons. This helps - ;; prevent us from getting into a loop just running the daemons. - (clear-interrupts! interrupt-bit/after-gc)) +(define after-gc-interrupt-handler + (let ((running? #f)) + (named-lambda (after-gc-interrupt-handler interrupt-code interrupt-enables) + (declare (ignore interrupt-code interrupt-enables)) + (clear-interrupts! interrupt-bit/after-gc) + (set-interrupt-enables! interrupt-mask/timer-ok) + ;; By checking that this handler is not still running we ignore + ;; GCs that occur while we are running the daemons. This helps + ;; prevent us from getting into a loop just running the daemons. + (if (not running?) + (begin + (set! running? #t) + (trigger-gc-daemons!) + (set! running? #f)))))) (define event:console-resize) (define (console-resize-handler interrupt-code interrupt-enables) @@ -152,6 +159,7 @@ USA. interrupt-code interrupt-mask (clear-interrupts! interrupt-bit/kbd) (let ((char (tty-next-interrupt-char))) + (set-interrupt-enables! interrupt-mask/timer-ok) (let ((handler (vector-ref keyboard-interrupt-vector char))) (if (not handler) (error "Bad interrupt character:" char)) @@ -226,8 +234,7 @@ USA. interrupt-mask/none) (vector-set! interrupt-mask-vector gc-slot - ;; interrupt-mask/none - (fix:lsh 1 global-gc-slot)) + interrupt-mask/none) (vector-set! system-interrupt-vector timer-slot timer-interrupt-handler) @@ -237,12 +244,12 @@ USA. (vector-set! system-interrupt-vector character-slot external-interrupt-handler) (vector-set! interrupt-mask-vector character-slot - interrupt-mask/timer-ok) + interrupt-mask/gc-ok) (vector-set! system-interrupt-vector after-gc-slot after-gc-interrupt-handler) (vector-set! interrupt-mask-vector after-gc-slot - interrupt-mask/timer-ok) + interrupt-mask/gc-ok) (vector-set! system-interrupt-vector suspend-slot suspend-interrupt-handler) diff --git a/src/runtime/io.scm b/src/runtime/io.scm index b28b104b1..c7fc931d1 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 c570a3698..4d7fafd0b 100644 --- a/src/runtime/process.scm +++ b/src/runtime/process.scm @@ -184,8 +184,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) @@ -221,6 +226,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 @@ -274,7 +284,7 @@ USA. (guarantee-procedure-of-arity event 1 'register-subprocess-event) (let ((registration (make-subprocess-registration subprocess status thread event))) - (without-interrupts + (with-thread-lock (lambda () (set! subprocess-registrations (cons registration subprocess-registrations)) @@ -289,20 +299,27 @@ USA. (define (deregister-subprocess-event registration) (guarantee-subprocess-registration registration 'DEREGISTER-SUBPROCESS-EVENT) - (without-interrupts + (with-thread-lock (lambda () (set! subprocess-registrations (delq! registration subprocess-registrations))))) -(define (deregister-subprocess subprocess) - (without-interrupts - (lambda () - (set! subprocess-registrations - (filter! - (lambda (registration) - (not (eq? subprocess - (subprocess-registration/subprocess registration)))) - subprocess-registrations))))) +(define (deregister-subprocess subprocess delete-subprocess!) + (let ((error? + (with-thread-lock + (lambda () + (set! subprocess-registrations + (filter! + (lambda (registration) + (not (eq? subprocess (subprocess-registration/subprocess + registration)))) + subprocess-registrations)) + (ignore-errors + (lambda () + (delete-subprocess!) + #f)))))) + (if error? + (signal-condition error?)))) (define (deregister-subprocess-events thread) (set! subprocess-registrations @@ -312,7 +329,7 @@ USA. subprocess-registrations))) (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)) @@ -325,7 +342,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)) (for-each (lambda (registration) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index c1f0b0c4e..c43250fb9 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3335,7 +3335,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!) @@ -3900,9 +3900,12 @@ USA. (import (runtime thread) %signal-thread-event subprocess-registrations - subprocess-support-loaded?) + subprocess-support-loaded? + with-thread-lock) (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) @@ -5064,7 +5067,6 @@ USA. (export () assert-thread-mutex-owned block-thread-events - condition-type:no-current-thread condition-type:thread-control-error condition-type:thread-dead condition-type:thread-deadlock diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index ccac4b395..04ca856f4 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -31,6 +31,41 @@ 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-ok?) + (eq? interrupt-mask/gc-ok (get-interrupt-enables))) + +(define-integrable (lock) + (%assert (not locked?) "lock: already locked!") + (set-interrupt-enables! interrupt-mask/gc-ok) + (%lock)) + +(define (%lock) + (if enable-smp? + ((ucode-primitive smp-lock-threads 1) #t)) + (set! locked? #t)) + +(define-integrable (unlock) + (%assert (interrupt-mask-ok?) "unlock: wrong interrupt mask") + (%assert locked? "unlock: not locked") + (%unlock) + (set-interrupt-enables! interrupt-mask/all)) + +(define (%unlock) + (set! locked? #f) + (if enable-smp? + ((ucode-primitive smp-lock-threads 1) #f))) + +(define-integrable (with-thread-lock thunk) + (lock) + (let ((value (thunk))) + (unlock) + value)) (define-structure (thread (constructor %make-thread (properties)) @@ -119,7 +154,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. @@ -161,21 +197,6 @@ 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 (without-preemption thunk) (let* ((thread (current-thread)) (state (thread/execution-state thread))) @@ -191,10 +212,10 @@ USA. (without-preemption (lambda () (if (not (eq? #t ((ucode-primitive smp-lock-obarray 1) #t))) - (outf-error "\nwith-obarray-lock: lock failed\n")) + (%outf-error "\nwith-obarray-lock: lock failed\n")) (let ((value (thunk))) (if (not (eq? #t ((ucode-primitive smp-lock-obarray 1) #f))) - (outf-error "\nwith-obarray-lock: unlock failed\n")) + (%outf-error "\nwith-obarray-lock: unlock failed\n")) value))) (let* ((mask (set-interrupt-enables! interrupt-mask/gc-ok)) (value (thunk))) @@ -202,7 +223,9 @@ USA. 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) @@ -219,13 +242,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)))))))) @@ -241,25 +271,7 @@ USA. thunk)) (define (current-thread) - (or first-running-thread - (let ((thread (console-thread))) - (if thread - (call-with-current-continuation - (lambda (continuation) - (let ((condition - (make-condition condition-type:no-current-thread - continuation - 'BOUND-RESTARTS - '()))) - (signal-thread-event thread - (lambda () - (error condition))))))) - (run-first-thread)))) - -(define (call-with-current-thread return? procedure) - (let ((thread first-running-thread)) - (cond (thread (procedure thread)) - ((not return?) (run-first-thread))))) + first-running-thread) (define (console-thread) (thread-mutex-owner (port/thread-mutex console-i/o-port))) @@ -269,25 +281,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) @@ -295,6 +308,7 @@ USA. (run-first-thread)) (define (run-first-thread) + (%assert-locked 'run-first-thread) (if first-running-thread (run-thread first-running-thread) (begin @@ -302,51 +316,55 @@ 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))))))))) + (lock) + (suspend-thread first-running-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 - (lambda () - (call-with-current-thread #f - (lambda (thread) - (call-with-current-continuation - (lambda (continuation) - (set-thread/continuation! thread continuation) - (maybe-save-thread-float-environment! thread) - (thread-not-running thread 'STOPPED)))))))) + (call-with-current-continuation + (lambda (continuation) + (let ((thread first-running-thread)) + (set-thread/continuation! thread continuation) + (maybe-save-thread-float-environment! thread) + (lock) + (thread-not-running thread 'STOPPED))))) (define (restart-thread thread discard-events? event) (guarantee-thread thread 'RESTART-THREAD) @@ -355,13 +373,18 @@ USA. (prompt-for-confirmation "Restarting other thread; discard events in its queue") discard-events?))) - (without-interrupts - (lambda () - (if (not (eq? 'STOPPED (thread/execution-state thread))) - (error:bad-range-argument thread restart-thread)) - (if discard-events? (ring/discard-all (thread/pending-events thread))) - (if event (%signal-thread-event thread event)) - (thread-running thread))))) + (lock) + (if (not (eq? 'STOPPED (thread/execution-state thread))) + (begin + (unlock) + (error:bad-range-argument thread restart-thread)) + (begin + (if discard-events? + (ring/discard-all (thread/pending-events thread))) + (if event + (%signal-thread-event thread event)) + (thread-running thread) + (unlock))))) (define (disallow-preempt-current-thread) (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION)) @@ -374,13 +397,14 @@ USA. ;; thread timer won't raise or clear exceptions (particularly the ;; inexact result exception) that the interrupted thread cares about. (let ((fp-env (enter-default-float-environment first-running-thread))) + (%lock) (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 @@ -388,26 +412,25 @@ 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) - ;; Allow preemption now, since the current thread has - ;; volunteered to yield control. - (set-thread/execution-state! thread 'RUNNING) - (maybe-signal-io-thread-events) - (yield-thread thread)))))) + (lock) + (let ((thread first-running-thread)) + ;; Allow preemption now, since the current thread has + ;; volunteered to yield control. + (set-thread/execution-state! thread 'RUNNING) + (maybe-signal-io-thread-events) + (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) @@ -426,10 +449,10 @@ 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)) + (lock) + (ring/discard-all (thread/pending-events thread)) (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (%deregister-subprocess-events thread) @@ -444,36 +467,45 @@ USA. (let ((self (current-thread))) (if (eq? thread self) (signal-thread-deadlock self "join thread" join-thread thread) - (without-interrupts - (lambda () - (let ((value (thread/exit-value thread))) - (cond ((eq? value no-exit-value-marker) - (set-thread/joined-threads! - thread - (cons (cons self event-constructor) - (thread/joined-threads thread))) - (set-thread/joined-to! - self - (cons thread (thread/joined-to self)))) - ((eq? value detached-thread-marker) - (signal-thread-detached thread)) - (else - (signal-thread-event - self - (event-constructor thread value)))))))))) + (begin + (lock) + (let ((value (thread/exit-value thread))) + (cond ((eq? value no-exit-value-marker) + (set-thread/joined-threads! + thread + (cons (cons self event-constructor) + (thread/joined-threads thread))) + (set-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 + ;; Executed in the dynamic state of SELF, not THREAD(!). + (event-constructor thread value))))))))) (define (detach-thread thread) (guarantee-thread thread 'DETACH-THREAD) - (without-interrupts - (lambda () - (if (eq? (thread/exit-value thread) detached-thread-marker) - (signal-thread-detached thread)) - (release-joined-threads thread detached-thread-marker)))) + (lock) + (if (eq? (thread/exit-value 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))) @@ -484,6 +516,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! @@ -513,25 +546,38 @@ 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 (begin - (set-interrupt-enables! interrupt-mask/all) + (unlock) (test-select-registry io-registry #t)))) - (set-interrupt-enables! interrupt-mask/gc-ok) + (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) (vector-ref result 2))) ((eq? 'PROCESS-STATUS-CHANGE result) - (%handle-subprocess-status-change)))) + (%handle-subprocess-status-change)) + ((eq? 'INTERRUPT result) + (unlock) + ;; This function call is intended to force interrupt handling. + (handle-interrupts) + (lock)))) + +(define (handle-interrupts) + ;; A simple body (just #t) allows the function call to be optimized away. + ((ucode-primitive get-primitive-address 2) 'SMP-COUNT #f)) (define (maybe-signal-io-thread-events) + (%assert-locked 'maybe-signal-io-thread-events) (if (or io-registrations (not (null? subprocess-registrations))) (signal-select-result (test-select-registry io-registry #f)))) @@ -591,7 +637,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))) @@ -601,21 +647,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) @@ -634,7 +680,19 @@ USA. (loop (dentry/next dentry))))) (%maybe-toggle-thread-timer)))) -(define (%deregister-io-descriptor descriptor) +(define (deregister-io-descriptor descriptor close-descriptor!) + (let ((error? + (with-thread-lock + (lambda () + (deregister-io-descriptor* descriptor) + (ignore-errors + (lambda () + (close-descriptor!) + #f)))))) + (if error? + (signal-condition error?)))) + +(define (deregister-io-descriptor* descriptor) (let dloop ((dentry io-registrations)) (cond ((not dentry) unspecific) @@ -663,6 +721,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) @@ -693,10 +752,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))) @@ -717,6 +778,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)) @@ -754,6 +816,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))) @@ -784,62 +847,37 @@ USA. ;;;; Events (define (block-thread-events) - (without-interrupts + (with-thread-lock (lambda () - (let ((thread first-running-thread)) - (if thread - (let ((result (thread/block-events? thread))) - (set-thread/block-events?! thread #t) - result) - #f))))) + (let* ((thread first-running-thread) + (result (thread/block-events? thread))) + (set-thread/block-events?! thread #t) + result)))) (define (unblock-thread-events) - (without-interrupts + (with-thread-lock (lambda () - (call-with-current-thread #t - (lambda (thread) - (handle-thread-events thread) - (set-thread/block-events?! thread #f)))))) + (let ((thread first-running-thread)) + (handle-thread-events thread) + (set-thread/block-events?! thread #f))))) (define (with-thread-events-blocked thunk) - (let ((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))))) + (thread/block-events? first-running-thread)) (define (set-thread-event-block! block?) - (without-interrupts - (lambda () - (let ((thread first-running-thread)) - (if thread - (set-thread/block-events?! thread block?))) - unspecific))) + (set-thread/block-events?! first-running-thread block?) + unspecific) (define (signal-thread-event thread event #!optional no-error?) (guarantee-thread thread 'SIGNAL-THREAD-EVENT) @@ -848,22 +886,26 @@ USA. no-error?))) (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)) - (if (not noerr?) - (signal-thread-dead thread "signal event to" - signal-thread-event thread event)) - (begin - (%signal-thread-event thread event) - (if (and (not self) first-running-thread) - (run-thread first-running-thread) - (%maybe-toggle-thread-timer))))))))) + (begin + (lock) + (if (eq? 'DEAD (thread/execution-state thread)) + (begin + (unlock) + (if (not noerr?) + (signal-thread-dead thread "signal event to" + signal-thread-event thread event))) + (begin + (%signal-thread-event thread event) + (%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))) @@ -873,6 +915,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 @@ -884,6 +927,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) @@ -892,25 +936,22 @@ 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-thread-lock (lambda () - (let ((thread first-running-thread)) - (if thread - (let ((block-events? (thread/block-events? thread))) - (set-thread/block-events?! thread #f) - (deliver-timer-events) - (maybe-signal-io-thread-events) - (handle-thread-events thread) - (set-thread/block-events?! thread block-events?)) - (begin - (deliver-timer-events) - (maybe-signal-io-thread-events)))) + (let* ((thread first-running-thread) + (block-events? (thread/block-events? thread))) + (set-thread/block-events?! thread #f) + (deliver-timer-events) + (maybe-signal-io-thread-events) + (handle-thread-events thread) + (set-thread/block-events?! thread block-events?)) (%maybe-toggle-thread-timer)))) ;;;; Subprocess Events @@ -919,6 +960,7 @@ USA. (define subprocess-support-loaded? #f) (define (%deregister-subprocess-events thread) + (%assert-locked '%deregister-subprocess-events) (if subprocess-support-loaded? (deregister-subprocess-events thread))) @@ -937,7 +979,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))) @@ -961,6 +1003,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))) @@ -976,7 +1019,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 @@ -988,23 +1031,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))) @@ -1022,21 +1063,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) @@ -1067,6 +1109,7 @@ USA. (%stop-thread-timer)))))) (define (%stop-thread-timer) + (%assert-locked '%stop-thread-timer) (if next-scheduled-timeout (begin ((ucode-primitive real-timer-clear)) @@ -1109,39 +1152,50 @@ 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))))) + (lock) + (let ((thread first-running-thread) + (owner (thread-mutex/owner mutex))) + (if (eq? owner thread) + (begin + (unlock) + (signal-thread-deadlock thread "lock thread mutex" + lock-thread-mutex mutex)) + (begin + (%lock-thread-mutex mutex thread owner) + (unlock))))) (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))))) + (lock) + (let ((thread first-running-thread) + (owner (thread-mutex/owner mutex))) + (if (and owner (not (eq? owner thread))) + (begin + (unlock) + (error "Don't own mutex:" mutex)) + (begin + (%unlock-thread-mutex mutex owner) + (unlock))))) (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)) @@ -1149,10 +1203,10 @@ 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))) + (let ((thread first-running-thread)) (set-thread-mutex/owner! mutex thread) (add-thread-mutex! thread mutex) #t))))) @@ -1164,7 +1218,7 @@ USA. (lambda () (unlock-thread-mutex mutex)))) (define (without-thread-mutex-lock mutex thunk) - (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-LOCK) + (guarantee-thread-mutex mutex 'WITHOUT-THREAD-MUTEX-LOCK) (dynamic-wind (lambda () (unlock-thread-mutex mutex)) thunk (lambda () (lock-thread-mutex mutex)))) @@ -1192,18 +1246,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) @@ -1211,20 +1269,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))) @@ -1234,9 +1297,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 @@ -1253,7 +1318,6 @@ USA. (define condition-type:thread-dead) (define signal-thread-dead) (define thread-dead/verb) -(define condition-type:no-current-thread) (define (initialize-error-conditions!) (set! condition-type:thread-control-error @@ -1319,10 +1383,52 @@ USA. (set! thread-dead/verb (condition-accessor condition-type:thread-dead 'VERB)) - (set! condition-type:no-current-thread - (make-condition-type 'NO-CURRENT-THREAD condition-type:control-error - '() - (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