From: Matt Birkholz Date: Fri, 10 Jul 2015 03:25:03 +0000 (-0700) Subject: Set interrupt-mask/all whenever leaving the thread system. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=04ef7340a7569e003c73d4aaa02d3240aa169e29;p=mit-scheme.git Set interrupt-mask/all whenever leaving the thread system. Punt saving and restoring interrupt masks. Replacing without- interrupts with without-interruption (with-thread-events-blocked) makes interrupts moot. They are now strictly a behind-the-scenes system mechanism. --- diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm index e28d5fe10..45d408e6a 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) + ;; 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 running? + unspecific + (begin + (set! running? #t) + (trigger-gc-daemons!) + (set! running? #f)))))) (define event:console-resize) (define (console-resize-handler interrupt-code interrupt-enables) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 89786f040..882e00280 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -42,35 +42,35 @@ USA. (define-integrable (interrupt-mask-ok?) (fix:= 0 (get-interrupt-enables))) +(define-integrable (lock) + ;; (%assert (eq? interrupt-mask/all (get-interrupt-enables)) "lock: unexpected interrupt mask") + (%assert (not locked?) "lock: already locked!") + (set-interrupt-enables! interrupt-mask/in-threads) + (%lock)) + (define (%lock) - (%assert (interrupt-mask-ok?) "%lock: wrong interrupt mask") - (%assert (not locked?) "%lock: already locked") (if enable-smp? (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #t))) (error "Could not lock the thread system."))) (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) - (%assert (interrupt-mask-ok?) "%unlock: wrong interrupt mask") - (%assert locked? "%unlock: not locked") (set! locked? #f) (if enable-smp? (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #f))) (%outf-error "%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))) + (lock) + (let ((value (thunk))) + (unlock) + value)) (define (with-obarray-lock thunk) ;; Serialize with myriad parts of the microcode that hack the @@ -337,11 +337,10 @@ USA. (handle-thread-events thread) (%maybe-toggle-thread-timer) (set-thread/block-events?! thread #f))) - (%unlock)) + (unlock)) (define (suspend-current-thread) - (set-interrupt-enables! interrupt-mask/in-threads) - (%lock) + (lock) (%suspend-thread first-running-thread)) (define (%suspend-thread thread) @@ -354,7 +353,7 @@ USA. (if any-events? (begin (%maybe-toggle-thread-timer) - (%unlock)) + (unlock)) (call-with-current-continuation (lambda (continuation) (set-thread/continuation! thread continuation) @@ -368,8 +367,7 @@ USA. (let ((thread first-running-thread)) (set-thread/continuation! thread continuation) (maybe-save-thread-float-environment! thread) - (set-interrupt-enables! interrupt-mask/in-threads) - (%lock) + (lock) (thread-not-running thread 'STOPPED))))) (define (restart-thread thread discard-events? event) @@ -379,19 +377,17 @@ USA. (prompt-for-confirmation "Restarting other thread; discard events in its queue") discard-events?))) - (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) - (%lock) - (if (not (eq? 'STOPPED (thread/execution-state thread))) - (begin - (%unlock) - (set-interrupt-enables! mask) - (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)))))) + (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))))) (define (disallow-preempt-current-thread) (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION)) @@ -411,7 +407,7 @@ USA. (let ((thread first-running-thread)) (cond ((not thread) (%maybe-toggle-thread-timer) - (%unlock)) + (unlock)) ((thread/continuation thread) (run-thread thread)) ((not (eq? 'RUNNING-WITHOUT-PREEMPTION @@ -422,14 +418,12 @@ USA. (%resume-thread thread)))))) (define (yield-current-thread) - (without-interrupts - (lambda () - (%lock) - (let ((thread first-running-thread)) - ;; Allow preemption now, since the current thread has - ;; volunteered to yield control. - (set-thread/execution-state! thread 'RUNNING) - (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) + (yield-thread thread))) (define (yield-thread thread #!optional fp-env) (%assert-locked 'yield-thread) @@ -459,8 +453,7 @@ USA. (let ((thread (current-thread))) (set-thread/block-events?! thread #t) (dynamic-unwind thread (thread/root-dynamic-state thread)) - (set-interrupt-enables! interrupt-mask/in-threads) - (%lock) + (lock) (ring/discard-all (thread/pending-events thread)) (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) @@ -476,8 +469,8 @@ USA. (let ((self first-running-thread)) (if (eq? thread self) (signal-thread-deadlock self "join thread" join-thread thread) - (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) - (%lock) + (begin + (lock) (let ((value (thread/exit-value thread))) (cond ((eq? value no-exit-value-marker) (set-thread/joined-threads! @@ -487,15 +480,12 @@ USA. (set-thread/joined-to! self (cons thread (thread/joined-to self))) - (%unlock) - (set-interrupt-enables! mask)) + (unlock)) ((eq? value detached-thread-marker) - (%unlock) - (set-interrupt-enables! mask) + (unlock) (signal-thread-detached thread)) (else - (%unlock) - (set-interrupt-enables! mask) + (unlock) (signal-thread-event self ;; Executed in the dynamic state of SELF, not THREAD(!). @@ -503,17 +493,14 @@ USA. (define (detach-thread thread) (guarantee-thread thread 'DETACH-THREAD) - (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) - (%lock) - (if (eq? (thread/exit-value thread) detached-thread-marker) - (begin - (%unlock) - (set-interrupt-enables! mask) - (signal-thread-detached thread)) - (begin - (release-joined-threads thread detached-thread-marker) - (%unlock) - (set-interrupt-enables! mask)))) + (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 @@ -582,11 +569,9 @@ USA. ((eq? 'PROCESS-STATUS-CHANGE result) (%handle-subprocess-status-change)) ((eq? 'INTERRUPT result) - (%unlock) - (set-interrupt-enables! interrupt-mask/all) + (unlock) (handle-interrupts) - (set-interrupt-enables! interrupt-mask/in-threads) - (%lock)))) + (lock)))) (define (handle-interrupts) #t) @@ -898,26 +883,25 @@ USA. (define (signal-thread-event thread event) (guarantee-thread thread 'SIGNAL-THREAD-EVENT) - (if (eq? thread first-running-thread) - (let ((block-events? (block-thread-events))) - (with-thread-lock - (lambda () - (%add-pending-event thread event))) - (if (not block-events?) - (unblock-thread-events))) - (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) - (%lock) - (if (eq? 'DEAD (thread/execution-state thread)) - (begin - (%unlock) - (set-interrupt-enables! mask) - (signal-thread-dead thread "signal event to" - signal-thread-event thread event)) - (begin - (%signal-thread-event thread event) - (%maybe-toggle-thread-timer) - (%unlock) - (set-interrupt-enables! mask)))))) + (let ((self first-running-thread)) + (if (eq? thread self) + (let ((block-events? (block-thread-events))) + (with-thread-lock + (lambda () + (%add-pending-event thread event))) + (if (not block-events?) + (unblock-thread-events))) + (begin + (lock) + (if (eq? 'DEAD (thread/execution-state thread)) + (begin + (unlock) + (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) @@ -951,11 +935,9 @@ USA. (if event (let ((block? (thread/block-events? thread))) (set-thread/block-events?! thread #t) - (%unlock) - (set-interrupt-enables! interrupt-mask/all) + (unlock) (event) - (set-interrupt-enables! interrupt-mask/in-threads) - (%lock) + (lock) (set-thread/block-events?! thread block?))) (loop #t)))))) @@ -1293,20 +1275,17 @@ USA. (define (lock-thread-mutex mutex) (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX) - (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) - (%lock) - (let ((thread first-running-thread) - (owner (thread-mutex/owner mutex))) - (if (eq? owner thread) - (begin - (%unlock) - (set-interrupt-enables! mask) - (signal-thread-deadlock thread "lock thread mutex" - lock-thread-mutex mutex)) - (begin - (%lock-thread-mutex mutex thread owner) - (%unlock) - (set-interrupt-enables! mask)))))) + (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) @@ -1316,24 +1295,21 @@ USA. (ring/enqueue (thread-mutex/waiting-threads mutex) thread) (do () ((eq? thread (thread-mutex/owner mutex))) (%suspend-thread thread) - (%lock))) + (lock))) (set-thread-mutex/owner! mutex thread))) (define (unlock-thread-mutex mutex) (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX) - (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) - (%lock) - (let ((thread first-running-thread) - (owner (thread-mutex/owner mutex))) - (if (and owner (not (eq? owner thread))) - (begin - (%unlock) - (set-interrupt-enables! mask) - (error "Don't own mutex:" mutex)) - (begin - (%unlock-thread-mutex mutex owner) - (%unlock) - (set-interrupt-enables! mask)))))) + (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)