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.

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index c0a983edbf5724d07cbddcda2d7724c43ac6fec4..e4068edd870306a78c7fa18319eb66b75b69e58e 100644 (file)
--- 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)))
 \f
 
@@ -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)))))
 \f
 
-(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 4fdef37bfc5e0b7c79ddbe0bd702fb49badb65b3..cf6ead3093ddfd42f00b132cfdb3ae090b778daf 100644 (file)
--- 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 00e1024a9576780a2f4045b203f841530f9ed801..4bb1457d98a6547257b57b10e168644aff4701ea 100644 (file)
--- 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 aa5119723d8a3e746a80193fcbbabb4232d0792d..1dc711187510203717c39546a8362aa6f2381286 100644 (file)
--- 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)))
 \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)
@@ -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))
 \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/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)))
 \f
 (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)))
 \f
 (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)
 \f
 (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)