#;(define-integrable (call-alien* alien-function args)
(apply (ucode-primitive c-call -1) alien-function args))
-;; Use this definition to maintain a callout/back stack.
+;; Use this definition to maintain a callout/back stack per processor.
(define (call-alien* alien-function args)
- (let ((old-top calloutback-stack))
- (%trace (tindent)"=> "alien-function" "args)
- (set! calloutback-stack (cons (cons alien-function args) old-top))
+ (let* ((id (processor-id))
+ (old-top (vector-ref calloutback-stacks id)))
+ (%trace (tindent id)"=> "alien-function" "args)
+ (vector-set! calloutback-stacks id
+ (cons (cons alien-function args) old-top))
(let ((value (apply (ucode-primitive c-call -1) alien-function args)))
- (%assert (eq? old-top (cdr calloutback-stack))
- "call-alien: freak stack" calloutback-stack)
- (set! calloutback-stack old-top)
- (%trace (tindent)"<= "value)
+ (%assert (eq? id (processor-id))
+ "call-alien: slipped processors")
+ (%assert (eq? old-top (cdr (vector-ref calloutback-stacks id)))
+ "call-alien: freak stack" (vector-ref calloutback-stacks id))
+ (vector-set! calloutback-stacks id old-top)
+ (%trace (tindent id)"<= "value)
value)))
+
+(define-integrable (processor-id)
+ (if enable-smp?
+ ((ucode-primitive smp-id 0))
+ 0))
\f
;;; Malloc/Free
;; by a callback trampoline. The callout should have already masked
;; all but the GC interrupts.
+ (%assert (eq? 'RUNNING-WITHOUT-PREEMPTION
+ (thread-execution-state (current-thread)))
+ "callback-handler: can be preempted")
(if (not (< id (vector-length registered-callbacks)))
(error:bad-range-argument id 'apply-callback))
(let ((procedure (vector-ref registered-callbacks id)))
#;(define-integrable (callback-handler* procedure args)
(apply-callback-proc procedure args))
-;; Use this definition to maintain a callout/back stack.
+;; Use this definition to maintain a callout/back stack per processor.
(define (callback-handler* procedure args)
- (let ((old-top calloutback-stack))
- (%trace (tindent)"=>> "procedure" "args)
- (set! calloutback-stack (cons (cons procedure args) old-top))
+ (let* ((id (processor-id))
+ (old-top (vector-ref calloutback-stacks id)))
+ (%trace (tindent id)"=>> "procedure" "args)
+ (vector-set! calloutback-stacks id (cons (cons procedure args) old-top))
(let ((value (apply-callback-proc procedure args)))
- (%assert (and (pair? calloutback-stack)
- (eq? old-top (cdr calloutback-stack)))
- "callback-handler: freak stack" calloutback-stack)
- (set! calloutback-stack old-top)
- (%trace (tindent)"<<= "value)
+ (%assert (eq? id (processor-id))
+ "callback-handler: slipped processors")
+ (%assert (and (pair? (vector-ref calloutback-stacks id))
+ (eq? old-top (cdr (vector-ref calloutback-stacks id))))
+ "callback-handler: freak stack"
+ (vector-ref calloutback-stacks id))
+ (vector-set! calloutback-stacks id old-top)
+ (%trace (tindent id)"<<= "value)
value)))
(define (apply-callback-proc procedure args)
(write-string "Loading FFI option" port))
kernel)))))
\f
-(define calloutback-stack '())
+(define calloutback-stacks)
(define (reset-package!)
(reset-alien-functions!)
(reset-malloced-aliens!)
(reset-callbacks!)
(set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
- (set! calloutback-stack '()))
+ (set! calloutback-stacks (make-vector processor-count '())))
(define (initialize-package!)
(reset-package!)
((_ . MSG)
(if %trace? (%outf-error . MSG)))))
-(define (tindent)
- (make-string (* 2 (length calloutback-stack)) #\space))
+(define (tindent id)
+ (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space))
(define (%outf-error . msg)
- (apply outf-error `("; ",@msg"\n")))
\ No newline at end of file
+ (apply outf-error `(";",(if enable-smp? ((ucode-primitive smp-id 0)) "")
+ " ",@msg"\n")))
\ No newline at end of file
|#
-;;;; Multiple Threads of Control
+;;;; Multiple Processors of Multiple Threads of Control
;;; package: (runtime thread)
(declare (usual-integrations))
(define (%lock)
(if enable-smp?
((ucode-primitive smp-lock-threads 1) #t))
- (set! locked? #t))
+ (set! locked? (%%id)))
(define-integrable (unlock)
(%assert (interrupt-mask-ok?) "unlock: wrong interrupt mask")
(eq? 'DEAD (thread/execution-state thread)))
\f
(define thread-population)
-(define first-running-thread)
-(define last-running-thread)
+(define first-runnable-thread)
+(define last-runnable-thread)
(define next-scheduled-timeout)
(define root-continuation-default)
(define (initialize-low!)
;; Called early in the cold load to create the first thread.
(set! thread-population (make-population/unsafe))
- (set! first-running-thread #f)
- (set! last-running-thread #f)
+ (set! first-runnable-thread #f)
+ (set! last-runnable-thread #f)
(set! next-scheduled-timeout #f)
(set! timer-records #f)
(set! timer-interval 100)
(let ((first (%make-thread (make-1d-table/unsafe))))
(set-thread/exit-value! first detached-thread-marker)
(add-to-population!/unsafe thread-population first)
- (set! first-running-thread first)
- (set! last-running-thread first)))
+ (vector-set! current-threads
+ (if enable-smp?
+ ((ucode-primitive smp-id 0))
+ 0)
+ first)))
(define (initialize-high!)
;; Called later in the cold load, when more of the runtime is initialized.
(define (reset-threads-low!)
(set! enable-smp?
(and ((ucode-primitive get-primitive-address 2) 'SMP-COUNT #f)
- ((ucode-primitive smp-count 0)))))
+ ((ucode-primitive smp-count 0))))
+ (set! processor-count
+ (if enable-smp? ((ucode-primitive smp-count 0)) 1))
+ (let ((len (and current-threads (vector-length current-threads))))
+ (cond ((not len)
+ (set! current-threads (make-vector processor-count #f)))
+ ((fix:< len processor-count)
+ (set! current-threads (vector-grow current-threads
+ processor-count #f)))
+ (else
+ (if (not (subvector-filled? current-threads 1 len #f))
+ (warn "reset-threads restored multiple threads"))
+ unspecific))))
(define (reset-threads-high!)
(set! io-registry (and have-select? (make-select-registry)))
(let-fluid root-continuation-default continuation
thunk))
\f
-(define (current-thread)
- first-running-thread)
+(define processor-count)
+(define current-threads #f)
+
+(define-integrable (%id)
+ ;; To avoid switching processors between accessing the processor id
+ ;; and using it (e.g. passing it to %thread), %id should be called
+ ;; with interrupts masked.
+ (%assert (interrupt-mask-ok?) "%id: wrong interrupt mask")
+ (%%id))
+
+(define-integrable (%%id)
+ (if enable-smp?
+ ((ucode-primitive smp-id 0))
+ 0))
+
+(define-integrable (%thread id)
+ (vector-ref current-threads id))
+
+(define-integrable (current-thread)
+ (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((value (%thread (%%id))))
+ (set-interrupt-enables! mask)
+ value)))
(define (console-thread)
(thread-mutex-owner (port/thread-mutex console-i/o-port)))
(define (other-running-threads?)
- (thread/next (current-thread)))
+ (or first-runnable-thread
+ (begin
+ (set-interrupt-enables! interrupt-mask/gc-ok)
+ (let* ((id (%id))
+ (found?
+ (let loop ((i 0))
+ (and (fix:< i processor-count)
+ (or (and (not (fix:= i id))
+ (%thread i))
+ (loop (fix:1+ i)))))))
+ (set-interrupt-enables! interrupt-mask/all)
+ found?))))
(define (thread-continuation thread)
(guarantee-thread thread 'THREAD-CONTINUATION)
(define (%thread-running thread)
(%assert-locked '%thread-running)
(set-thread/execution-state! thread 'RUNNING)
- (let ((prev last-running-thread))
+ (let ((prev last-runnable-thread))
(if prev
(set-thread/next! prev thread)
- (set! first-running-thread thread)))
- (set! last-running-thread thread)
+ (set! first-runnable-thread thread)))
+ (set! last-runnable-thread thread)
(%assert (eq? #f (thread/next thread))
- "%thread-running: last-running-thread has a next")
- unspecific)
+ "%thread-running: last-runnable-thread has a next"))
-(define (thread-not-running thread state)
+(define (thread-not-running id thread state)
(%assert-locked 'thread-not-running)
+ (%assert (eq? thread (%thread id)) "thread-not-running: not current")
(set-thread/execution-state! thread state)
- (let ((thread* (thread/next thread)))
- (set-thread/next! thread #f)
- (set! first-running-thread thread*))
- (run-first-thread))
+ (vector-set! current-threads id #f)
+ (run-first-thread id))
-(define (run-first-thread)
+(define (run-first-thread id)
(%assert-locked 'run-first-thread)
- (if first-running-thread
- (run-thread first-running-thread)
- (begin
- (set! last-running-thread #f)
- (wait-for-io))))
+ (%assert (not (%thread id)) "run-first-thread: still running a thread")
+ (if first-runnable-thread
+ (let ((thread first-runnable-thread))
+ (%assert (thread/continuation thread)
+ "run-first-thread: BOGUS runnable")
+ (%assert (not (%thread id))
+ "run-first-thread: ALREADY running a thread")
+ (set! first-runnable-thread (thread/next thread))
+ (if (not (thread/next thread))
+ (set! last-runnable-thread #f)
+ (%assert last-runnable-thread
+ "run-first-thread: lost last-runnable"))
+ (set-thread/next! thread #f)
+ (vector-set! current-threads id thread)
+ (run-thread thread))
+ (wait-for-io id)))
\f
(define (run-thread thread)
(%assert-locked 'run-thread)
(define (resume-thread thread)
(%assert-locked 'resume-thread)
+ (%assert (eq? thread (%thread (%%id))) "resume-thread: not current")
(if (not (thread/block-events? thread))
(begin
(handle-thread-events thread)
(define (suspend-current-thread)
(lock)
- (suspend-thread first-running-thread))
-
-(define (suspend-thread thread)
+ (let* ((id (%id))
+ (thread (%thread id))
+ (block-events? (thread/block-events? thread)))
+ ;;(%assert block-events? "suspend-current-thread: not blocking events!")
+ (suspend-thread id thread)
+ (%assert (eq? block-events? (thread/block-events? thread))
+ "suspend-current-thread cleared block-events?!")))
+
+(define (suspend-thread id thread)
(%assert-locked 'suspend-thread)
(let ((block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread)
(set-thread/block-events?! thread #f)
- (thread-not-running thread 'WAITING)))))))
+ (thread-not-running id thread 'WAITING)))))))
(define (stop-current-thread)
(call-with-current-continuation
(lambda (continuation)
- (let ((thread first-running-thread))
+ (lock)
+ (let* ((id (%id))
+ (thread (%thread id)))
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread)
- (lock)
- (thread-not-running thread 'STOPPED)))))
+ (thread-not-running id thread 'STOPPED)))))
(define (restart-thread thread discard-events? event)
(guarantee-thread 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.
- (let ((fp-env (enter-default-float-environment first-running-thread)))
+ (let* ((id (%id))
+ (old (%thread id))
+ (fp-env (and old (enter-default-float-environment old))))
(%lock)
(set! next-scheduled-timeout #f)
(deliver-timer-events)
(maybe-signal-io-thread-events)
- (let ((thread first-running-thread))
- (cond ((not thread)
- (%maybe-toggle-thread-timer)
- (unlock))
- ((thread/continuation thread)
- (run-thread thread))
- ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
- (thread/execution-state thread)))
- (yield-thread thread fp-env))
- (else
- (restore-float-environment-from-default fp-env)
- (resume-thread thread))))))
+ (cond ((not old)
+ (run-first-thread id))
+ ;; Else we interrupt a running thread (OLD).
+ ((not first-runnable-thread)
+ (restore-float-environment-from-default fp-env)
+ (resume-thread old))
+ ((eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state old))
+ (restore-float-environment-from-default fp-env)
+ (resume-thread old))
+ (else
+ (yield-thread id old fp-env)))))
(define (yield-current-thread)
(lock)
- (let ((thread first-running-thread))
+ (let* ((id (%id))
+ (thread (%thread id)))
;; 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)))
+ (yield-thread id thread)))
-(define (yield-thread thread #!optional fp-env)
+(define (yield-thread id 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-thread thread))
- (call-with-current-continuation
- (lambda (continuation)
- (set-thread/continuation! thread continuation)
- (maybe-save-thread-float-environment! thread fp-env)
- (set-thread/next! thread #f)
- (set-thread/next! last-running-thread thread)
- (set! last-running-thread thread)
- (set! first-running-thread next)
- (run-thread next))))))
+ (%assert (eq? thread (%thread id)) "yield-thread: not current")
+ (if (not first-runnable-thread)
+ (begin
+ (if (not (default-object? fp-env))
+ (restore-float-environment-from-default fp-env))
+ (resume-thread thread))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (set-thread/continuation! thread continuation)
+ (maybe-save-thread-float-environment! thread fp-env)
+ (%thread-running thread)
+ (vector-set! current-threads id #F)
+ (run-first-thread id)))))
(define (thread-float-environment thread)
(thread/floating-point-environment thread))
(%disassociate-thread-mutexes thread)
(if (eq? no-exit-value-marker (thread/exit-value thread))
(release-joined-threads thread value))
- (thread-not-running thread 'DEAD)))
+ (thread-not-running (%id) thread 'DEAD)))
(define (join-thread thread event-constructor)
(guarantee-thread thread 'JOIN-THREAD)
prev
next)
-(define (wait-for-io)
+(define (wait-for-io id)
(%assert-locked 'wait-for-io)
(%assert (interrupt-mask-ok?) "wait-for-io: wrong interrupt mask")
+ (%assert (not (%thread id)) "wait-for-io: not idle")
(%maybe-toggle-thread-timer #f)
(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))))
+ (run-first-thread id)))
\f
(define (signal-select-result result)
(%assert-locked 'signal-select-result)
(define (block-thread-events)
(with-thread-lock
(lambda ()
- (let* ((thread first-running-thread)
+ (let* ((thread (%thread (%id)))
(result (thread/block-events? thread)))
(set-thread/block-events?! thread #t)
result))))
(define (unblock-thread-events)
(with-thread-lock
(lambda ()
- (let ((thread first-running-thread))
+ (let ((thread (%thread (%id))))
(handle-thread-events thread)
(set-thread/block-events?! thread #f)))))
value)))
(define (get-thread-event-block)
- (thread/block-events? first-running-thread))
+ (thread/block-events? (current-thread)))
(define (set-thread-event-block! block?)
- (set-thread/block-events?! first-running-thread block?)
+ (set-thread/block-events?! (current-thread) block?)
unspecific)
\f
(define (signal-thread-event thread event #!optional no-error?)
(guarantee-thread thread 'SIGNAL-THREAD-EVENT)
- (let ((self first-running-thread)
+ (let ((self (current-thread))
(noerr? (and (not (default-object? no-error?))
no-error?)))
(if (eq? thread self)
(define (allow-thread-event-delivery)
(with-thread-lock
(lambda ()
- (let* ((thread first-running-thread)
+ (let* ((thread (%thread (%id)))
(block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #f)
(deliver-timer-events)
(define (deregister-all-events)
(with-thread-lock
(lambda ()
- (let* ((thread first-running-thread)
+ (let* ((thread (%thread (%id)))
(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?))
+ (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))))
(define (%discard-thread-timer-records thread)
(if interval
(guarantee-exact-positive-integer interval 'SET-THREAD-TIMER-INTERVAL!))
(with-thread-lock
- (lambda ()
- (set! timer-interval interval)
- (%maybe-toggle-thread-timer))))
+ (lambda ()
+ (set! timer-interval interval)
+ (%maybe-toggle-thread-timer))))
(define (start-thread-timer)
(with-thread-lock %maybe-toggle-thread-timer))
timer-interval
(or io-registrations
(not (null? subprocess-registrations))
- (let ((current-thread first-running-thread))
- (and current-thread
- (thread/next current-thread)))))
+ first-runnable-thread))
(start (+ now timer-interval)))
(else
(%stop-thread-timer))))))
(define (lock-thread-mutex mutex)
(guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
(lock)
- (let ((thread first-running-thread)
+ (let ((thread (%thread (%id)))
(owner (thread-mutex/owner mutex)))
(if (eq? owner thread)
(begin
(define (unlock-thread-mutex mutex)
(guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
(lock)
- (let ((thread first-running-thread)
+ (let ((thread (%thread (%id)))
(owner (thread-mutex/owner mutex)))
(if (and owner (not (eq? owner thread)))
(begin
(with-thread-lock
(lambda ()
(and (not (thread-mutex/owner mutex))
- (let ((thread first-running-thread))
+ (let ((thread (%thread (%id))))
(set-thread-mutex/owner! mutex thread)
(add-thread-mutex! thread mutex)
#t)))))
(if (not locked?)
(%outf-error caller": not locked"))
(if (not (interrupt-mask-ok?))
- (%outf-error caller": can be interrupted")))
+ (%outf-error caller": wrong interrupt mask")))
(define (%outf-error . msg)
((ucode-primitive outf-error 1)
- (apply string-append `("; ",@(map %->string msg)"\n"))))
+ (apply string-append `(";",(if enable-smp? (number->string (%%id)) "")
+ " ",@(map %->string msg)"\n"))))
(define (%->string object)
(cond ((string? object) object)
projects / mit-scheme.git / commitdiff