From 9f04d990796b277d0ee9055c4746f66c78d82ace Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 8 Jul 2015 17:36:52 -0700 Subject: [PATCH] Eliminate non-local exits from the thread system(?). --- src/runtime/thread.scm | 153 ++++++++++++++++++++++------------------- 1 file changed, 84 insertions(+), 69 deletions(-) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index cea1468bd..40356879b 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -390,13 +390,19 @@ USA. (prompt-for-confirmation "Restarting other thread; discard events in its queue") discard-events?))) - (with-thread-lock - (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))))) + (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)))))) (define (disallow-preempt-current-thread) (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION)) @@ -408,8 +414,8 @@ 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))) + (%lock) (set! next-scheduled-timeout #f) (deliver-timer-events) (maybe-signal-io-thread-events) @@ -482,40 +488,43 @@ USA. (let ((self (current-thread))) (if (eq? thread self) (signal-thread-deadlock self "join thread" join-thread thread) - (without-interrupts - (lambda () - (%lock) - (let ((value (thread/exit-value thread))) - (cond ((eq? value no-exit-value-marker) - (set-thread/joined-threads! - thread - (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 - (event-constructor thread value)))))))))) + (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) + (%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) + (set-interrupt-enables! mask)) + ((eq? value detached-thread-marker) + (%unlock) + (set-interrupt-enables! mask) + (signal-thread-detached thread)) + (else + (%unlock) + (set-interrupt-enables! mask) + (signal-thread-event + self + (event-constructor thread value))))))))) (define (detach-thread thread) (guarantee-thread thread 'DETACH-THREAD) - (without-interrupts - (lambda () - (%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))))) + (let ((mask (set-interrupt-enables! interrupts-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)))) thread) (define detached-thread-marker @@ -920,15 +929,15 @@ USA. (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))))))))) + (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) + (%lock) + (%signal-thread-event thread event) + (if (and (not self) first-running-thread) + (run-thread first-running-thread) + (begin + (%maybe-toggle-thread-timer) + (%unlock) + (set-interrupt-enables! mask)))))))) (define (%signal-thread-event thread event) (%assert-locked '%signal-thread-event) @@ -1308,17 +1317,20 @@ USA. (define (lock-thread-mutex mutex) (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX) - (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))) + (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 first-running-thread "lock thread mutex" + lock-thread-mutex mutex)) + (begin + (%lock-thread-mutex mutex thread owner) + (%unlock) + (set-interrupt-enables! mask)))))) (define (%lock-thread-mutex mutex thread owner) (%assert-locked '%lock-thread-mutex) @@ -1333,15 +1345,18 @@ USA. (define (unlock-thread-mutex mutex) (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX) - (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))) + (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) + (%lock) + (let ((owner (thread-mutex/owner mutex))) + (if (and owner (not (eq? owner (current-thread)))) + (begin + (%unlock) + (set-interrupt-enables! mask) + (error "Don't own mutex:" mutex)) + (begin + (%unlock-thread-mutex mutex owner) + (%unlock) + (set-interrupt-enables! mask)))))) (define (%unlock-thread-mutex mutex owner) (%assert-locked '%unlock-thread-mutex) @@ -1373,7 +1388,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)))) -- 2.25.1