;;; 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))
\f
(define-structure (thread
(constructor %make-thread (properties))
(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 (without-preemption thunk)
(let* ((thread (current-thread))
(state (thread/execution-state thread)))
(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)))
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))))))))
thunk))
\f
(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)))
(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)))))))))
+ (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)
(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)))))
\f
(define (disallow-preempt-current-thread)
(set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION))
;; 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
(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)
\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))
+ (lock)
+ (ring/discard-all (thread/pending-events thread))
(%deregister-io-thread-events thread)
(%discard-thread-timer-records thread)
(%deregister-subprocess-events thread)
(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)))
(%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 (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))))
\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)
(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))))
(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!)
+ (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)
(%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
- (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)
\f
(define (signal-thread-event thread event #!optional no-error?)
(guarantee-thread thread 'SIGNAL-THREAD-EVENT)
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)))
;; 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)
(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))))
\f
;;;; Subprocess Events
(define subprocess-support-loaded? #f)
(define (%deregister-subprocess-events thread)
+ (%assert-locked '%deregister-subprocess-events)
(if subprocess-support-loaded?
(deregister-subprocess-events thread)))
\f
(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)
(%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)))))
+ (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))
(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)))))
(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))))
(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
(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
(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
projects / mit-scheme.git / commitdiff