From d177ba6f373517a2b465bd392e26569fedd3c337 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sat, 11 Jul 2015 11:49:15 -0700 Subject: [PATCH] Accommodate multiple processors. Keep the threads running on each processor in the current-threads vector. Change the running list into a runnable list: the threads that are runnable but not currently running on a processor. --- src/runtime/ffi.scm | 52 +++++--- src/runtime/make.scm | 3 +- src/runtime/runtime.pkg | 2 + src/runtime/thread.scm | 282 ++++++++++++++++++++++++---------------- 4 files changed, 210 insertions(+), 129 deletions(-) diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index c0a983edb..e4068edd8 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -295,6 +295,11 @@ USA. (define-integrable (c-poke-bytes alien offset count buffer start) ((ucode-primitive c-poke-bytes 5) alien offset count buffer start)) +(define-integrable (processor-id) + (if enable-smp? + ((ucode-primitive smp-id 0)) + 0)) + (define (c-enum-name value enum-name constants) enum-name (let loop ((consts constants)) @@ -318,16 +323,20 @@ USA. (call-alien* alien-function args)))) (define (call-alien* alien-function args) - (let ((old-top calloutback-stack)) + (let* ((id (processor-id)) + (old-top (vector-ref calloutback-stacks id))) (%if-tracing (outf-error ";"(tindent)"=> "alien-function" "args"\n") - (set! calloutback-stack (cons (cons alien-function args) old-top))) + (vector-set! calloutback-stacks id + (cons (cons alien-function args) old-top))) (let ((value (apply (ucode-primitive c-call -1) alien-function args))) (%if-tracing - (%assert (eq? old-top (cdr calloutback-stack)) - "call-alien: freak stack" calloutback-stack) - (set! calloutback-stack old-top) - (outf-error ";"(tindent)"<= "value"\n")) + (%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) + (outf-error ";"(tindent id)"<= "value"\n")) value))) @@ -472,23 +481,30 @@ USA. ;; 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))) (if (not procedure) (error:bad-range-argument id 'apply-callback)) (normalize-aliens! args) - (let ((old-top calloutback-stack)) + (let* ((id (processor-id)) + (old-top (vector-ref calloutback-stacks id))) (%if-tracing - (outf-error ";"(tindent)"=>> "procedure" "args"\n") - (set! calloutback-stack (cons (cons procedure args) old-top))) + (outf-error ";"(tindent id)"=>> "procedure" "args"\n") + (vector-set! calloutback-stacks id (cons (cons procedure args) old-top))) (let ((value (apply-callback-proc procedure args))) (%if-tracing - (%assert (and (pair? calloutback-stack) - (eq? old-top (cdr calloutback-stack))) - "callback-handler: freak stack" calloutback-stack) - (set! calloutback-stack old-top) - (outf-error ";"(tindent)"<<= "value"\n")) + (%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) + (outf-error ";"(tindent id)"<<= "value"\n")) value)))) (define (apply-callback-proc procedure args) @@ -574,7 +590,7 @@ USA. kernel))))) -(define calloutback-stack '()) +(define calloutback-stacks) (define %trace? #f) @@ -584,7 +600,7 @@ USA. (reset-callbacks!) (set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000)) (set! %trace? #f) - (set! calloutback-stack '())) + (set! calloutback-stacks (make-vector processor-count '()))) (define (initialize-package!) (reset-package!) @@ -611,5 +627,5 @@ USA. (if %trace? (outf-error MSG ...))))) -(define (tindent) - (make-string (* 2 (length calloutback-stack)) #\space)) \ No newline at end of file +(define (tindent id) + (make-string (* 2 (length (vector-ref calloutback-stacks id))) #\space)) \ No newline at end of file diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 4fdef37bf..cf6ead309 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -378,7 +378,8 @@ USA. ("events" . (RUNTIME EVENT-DISTRIBUTOR)) ("gdatab" . (RUNTIME GLOBAL-DATABASE)) ("gcfinal" . (RUNTIME GC-FINALIZER)) - ("string" . (RUNTIME STRING)))) + ("string" . (RUNTIME STRING)) + ("vector" . (RUNTIME VECTOR)))) (load-files (lambda (files) (do ((files files (cdr files))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 00e1024a9..4bb1457d9 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3368,6 +3368,8 @@ USA. install-load-option install-html) (import (runtime thread) + enable-smp? + processor-count without-preemption) (initialization (initialize-package!))) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index aa5119723..1dc711187 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -24,7 +24,7 @@ USA. |# -;;;; Multiple Threads of Control +;;;; Multiple Processors of Multiple Threads of Control ;;; package: (runtime thread) (declare (usual-integrations)) @@ -50,7 +50,7 @@ USA. (if enable-smp? (if (not (eq? #t ((ucode-primitive smp-lock-threads 1) #t))) (error "Could not lock the thread system."))) - (set! locked? #t)) + (set! locked? (%%id))) (define-integrable (unlock) (%assert (interrupt-mask-ok?) "unlock: wrong interrupt mask") @@ -88,7 +88,7 @@ USA. value))) (define (without-preemption thunk) - (let* ((thread first-running-thread) + (let* ((thread (current-thread)) (state (thread/execution-state thread))) (set-thread/execution-state! thread 'RUNNING-WITHOUT-PREEMPTION) (let ((value (thunk))) @@ -164,16 +164,16 @@ USA. (eq? 'DEAD (thread/execution-state thread))) (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) @@ -181,8 +181,11 @@ USA. (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. @@ -217,7 +220,19 @@ USA. (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))) @@ -272,14 +287,46 @@ USA. (let-fluid root-continuation-default continuation thunk)) -(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/none))) + (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/none) + (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) @@ -292,30 +339,39 @@ USA. (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))) (define (run-thread thread) (%assert-locked 'run-thread) @@ -330,6 +386,7 @@ USA. (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) @@ -339,9 +396,15 @@ USA. (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) @@ -357,16 +420,17 @@ USA. (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) @@ -398,50 +462,50 @@ 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. - (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)) @@ -462,11 +526,11 @@ USA. (%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) - (let ((self first-running-thread)) + (let ((self (current-thread))) (if (eq? thread self) (signal-thread-deadlock self "join thread" join-thread thread) (begin @@ -547,18 +611,17 @@ USA. 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))) (define (signal-select-result result) (%assert-locked 'signal-select-result) @@ -851,7 +914,7 @@ USA. (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)))) @@ -859,7 +922,7 @@ USA. (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))))) @@ -875,15 +938,15 @@ USA. 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) (define (signal-thread-event thread event) (guarantee-thread thread 'SIGNAL-THREAD-EVENT) - (let ((self first-running-thread)) + (let ((self (current-thread))) (if (eq? thread self) (let ((block-events? (block-thread-events))) (with-thread-lock @@ -944,7 +1007,7 @@ USA. (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) @@ -961,7 +1024,7 @@ USA. (guarantee-procedure-of-arity event 1 'register-gc-event) (with-thread-lock (lambda () - (let* ((thread first-running-thread) + (let* ((thread (%thread (%id))) (entry (weak-assq thread gc-events))) (if entry (weak-set-cdr! entry event) @@ -970,14 +1033,14 @@ USA. (define (deregister-gc-event) (with-thread-lock (lambda () - (let ((entry (weak-assq first-running-thread gc-events))) + (let ((entry (weak-assq (%thread (%id)) gc-events))) (if entry (set! gc-events (delq! entry gc-events))))))) (define (registered-gc-event) (with-thread-lock (lambda () - (let ((entry (weak-assq first-running-thread gc-events))) + (let ((entry (weak-assq (%thread (%id)) gc-events))) (and entry (weak-cdr entry)))))) (define (signal-gc-events statistic) @@ -1034,20 +1097,20 @@ USA. (let ((registration (make-subprocess-registration subprocess status thread event))) (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)))))) + (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) + 'DEREGISTER-SUBPROCESS-EVENT) (with-thread-lock (lambda () (set! subprocess-registrations @@ -1163,14 +1226,14 @@ USA. (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) @@ -1193,9 +1256,9 @@ USA. (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)) @@ -1230,9 +1293,7 @@ USA. timer-interval (or io-registrations (registered-subprocesses-running?) - (let ((current-thread first-running-thread)) - (and current-thread - (thread/next current-thread))))) + first-runnable-thread)) (start (+ now timer-interval))) (else (%stop-thread-timer)))))) @@ -1282,7 +1343,7 @@ USA. (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 @@ -1307,7 +1368,7 @@ USA. (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 @@ -1335,7 +1396,7 @@ USA. (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))))) @@ -1539,11 +1600,12 @@ USA. (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) -- 2.25.1