;;; 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.
(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)))
\f
(define-structure (thread
(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.
(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)
(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))))))))
(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)))
(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)
(run-first-thread))
(define (run-first-thread)
+ (%assert-locked 'run-first-thread)
(if first-running-thread
(run-thread first-running-thread)
(begin
(wait-for-io))))
\f
(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
(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)
(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))
;; 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
(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)
\f
(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)
(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/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))))))))))
(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)))
(%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!
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))))
\f
(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)
((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))
(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)))
(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)
(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)
(%maybe-toggle-thread-timer))
\f
(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)
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)))
(error:wrong-type-argument mode "select mode" procedure)))
\f
(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))
(%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)))
;;;; Events
(define (block-thread-events)
- (without-interrupts
+ (with-thread-lock
(lambda ()
(let ((thread first-running-thread))
(if thread
#f)))))
(define (unblock-thread-events)
- (without-interrupts
+ (with-thread-lock
(lambda ()
(call-with-current-thread #t
(lambda (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)))))
+ (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)
\f
(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)))
;; 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
(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)
(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
(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)))
(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
(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)
subprocess-registrations)))
(define (%signal-subprocess-status-change)
+ (%assert-locked '%signal-subprocess-status-change)
(for-each
(lambda (registration)
(let ((status (subprocess-status
(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)))
(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)))
(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
(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)))
(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)
((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)))))
(%stop-thread-timer))))))
(define (%stop-thread-timer)
+ (%assert-locked '%stop-thread-timer)
(if next-scheduled-timeout
(begin
((ucode-primitive real-timer-clear))
(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))
(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)))
(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)
(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)))
(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))))
\f
;;;; Error Conditions
(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
projects / mit-scheme.git / commitdiff