From: Matt Birkholz Date: Tue, 18 Aug 2015 16:57:06 +0000 (-0700) Subject: Accommodate multiple processors. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=66ffdf329a18da3cea534c2c6d153c7f0beb3ffa;p=mit-scheme.git Accommodate multiple processors. Keep the threads running on each processor in a current-threads vector. Change the running list into a runnable list: the threads that are runnable but not currently running on a processor. --- diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index e52fcf9de..0170f99a2 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -320,17 +320,26 @@ USA. #;(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)) ;;; Malloc/Free @@ -472,6 +481,9 @@ 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))) @@ -483,17 +495,21 @@ USA. #;(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) @@ -578,14 +594,14 @@ USA. (write-string "Loading FFI option" port)) kernel))))) -(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!) @@ -618,8 +634,9 @@ USA. ((_ . 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 diff --git a/src/runtime/make.scm b/src/runtime/make.scm index e6c1dbbad..396bb23a9 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 c43250fb9..551234d94 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3392,6 +3392,10 @@ USA. install-shim install-load-option install-html) + (import (runtime thread) + enable-smp? + processor-count + without-preemption) (initialization (initialize-package!))) (define-package (runtime program-copier) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 04ca856f4..f59d57086 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)) @@ -48,7 +48,7 @@ USA. (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") @@ -137,16 +137,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) @@ -154,8 +154,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. @@ -190,7 +193,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))) @@ -270,14 +285,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/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) @@ -290,30 +337,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) @@ -328,6 +384,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) @@ -337,9 +394,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) @@ -355,16 +418,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) @@ -396,50 +460,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)) @@ -460,7 +524,7 @@ 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) @@ -545,18 +609,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) @@ -849,7 +912,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)))) @@ -857,7 +920,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))))) @@ -873,15 +936,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 #!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) @@ -945,7 +1008,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) @@ -1034,14 +1097,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) @@ -1064,9 +1127,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)) @@ -1101,9 +1164,7 @@ USA. 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)))))) @@ -1153,7 +1214,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 @@ -1178,7 +1239,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 @@ -1206,7 +1267,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))))) @@ -1410,11 +1471,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)