From: Matt Birkholz Date: Thu, 9 Jul 2015 06:20:49 +0000 (-0700) Subject: Check for no-current-thread. Lose condition-type. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8e75a39a7503f83a7956d3806335ec83cad6fd87;p=mit-scheme.git Check for no-current-thread. Lose condition-type. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6b331db3b..9ceeeb101 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5035,7 +5035,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 40356879b..a05a3acda 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -46,7 +46,7 @@ USA. (%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)) + (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #t))) (error "Could not lock the thread system."))) (set! locked? #t)) @@ -55,8 +55,8 @@ USA. (%assert locked? "%unlock: not locked") (set! locked? #f) (if enable-smp? - (if (not ((ucode-primitive smp-lock-threads 1) #f)) - (%assert #f "%unlock: failed")))) + (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))) @@ -76,12 +76,14 @@ USA. ;; Serialize with myriad parts of the microcode that hack the ;; obarray element of the fixed-objects vector. (if enable-smp? - (if ((ucode-primitive smp-lock-obarray 1) #t) - (let ((value (thunk))) - (if ((ucode-primitive smp-lock-obarray 1) #f) - value - (%assert "with-obarray-lock: unlock failed"))) - (%assert "with-obarray-lock: lock failed")) + (without-interrupts + (lambda () + (if (eq? #t ((ucode-primitive smp-lock-obarray 1) #t)) + (let ((value (thunk))) + (if (eq? #t ((ucode-primitive smp-lock-obarray 1) #f)) + value + (%outf-error "with-obarray-lock: unlock failed"))) + (%outf-error "with-obarray-lock: lock failed")))) (without-interrupts thunk))) (define-structure (thread @@ -263,25 +265,19 @@ USA. (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 '() '()))) - (signal-thread-event thread - (lambda () - (error condition))))))) - (%lock) - (run-first-thread)))) + (begin + (%outf-error "current-thread: no current thread") + #f))) (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?) (%lock) (run-first-thread))))) + ((not return?) + (%outf-error "call-with-current-thread: starting one up") + (%lock) + (run-first-thread))))) (define (console-thread) (thread-mutex-owner (port/thread-mutex console-i/o-port))) @@ -372,6 +368,7 @@ USA. (thread-not-running thread 'WAITING))))))) (define (stop-current-thread) + (%assert first-running-thread "stop-current-thread: no current thread") (without-interrupts (lambda () (call-with-current-thread #f @@ -514,7 +511,7 @@ USA. (define (detach-thread thread) (guarantee-thread thread 'DETACH-THREAD) - (let ((mask (set-interrupt-enables! interrupts-mask/in-threads))) + (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) (%lock) (if (eq? (thread/exit-value thread) detached-thread-marker) (begin @@ -907,12 +904,15 @@ USA. (let ((thread first-running-thread)) (if thread (thread/block-events? thread) - #f))) + (begin + (%outf-error "get-thread-event-block: no current thread") + #f)))) (define (set-thread-event-block! block?) (let ((thread first-running-thread)) (if thread - (set-thread/block-events?! thread block?))) + (set-thread/block-events?! thread block?) + (%outf-error "set-thread-event-block!: no current thread"))) unspecific) (define (signal-thread-event thread event) @@ -925,19 +925,22 @@ USA. (%add-pending-event thread event))) (if (not block-events?) (unblock-thread-events))) - (begin + (let ((mask (set-interrupt-enables! interrupt-mask/in-threads))) + (%lock) (if (eq? 'DEAD (thread/execution-state thread)) - (signal-thread-dead thread "signal event to" - signal-thread-event thread event)) - (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)))))))) + (begin + (%unlock) + (set-interrupt-enables! mask) + (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) + (begin + (%maybe-toggle-thread-timer) + (%unlock) + (set-interrupt-enables! mask))))))))) (define (%signal-thread-event thread event) (%assert-locked '%signal-thread-event) @@ -1477,7 +1480,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 @@ -1543,12 +1545,6 @@ 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) #;(define-syntax %assert @@ -1574,9 +1570,9 @@ USA. (define (%assert-locked* caller) (if (not locked?) - (%outf-error caller" not locked")) + (%outf-error caller": not locked")) (if (not (interrupt-mask-ok?)) - (%outf-error caller" can be interrupted"))) + (%outf-error caller": can be interrupted"))) (define (%outf-error . msg) ((ucode-primitive outf-error 1)