From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 6 Jul 2015 00:58:03 +0000 (-0700)
Subject: Initialize the thread system early in the cold load.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~46
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9be90b70c99f7bf396d7b33bb5a43c52f4f232f9;p=mit-scheme.git

Initialize the thread system early in the cold load.

Thus with-thread-mutex-lock can be used during initialization of most
packages.  Avoid using the global set-interrupt-enables! binding in
dynamic-wind because it is now called so early.

This anticipates removing without-interrupts from gcfinal.scm and thus
calling with-thread-mutex-lock during make-gc-finalizer, e.g. during
the initialization of the (runtime string) package.
---

diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm
index 8dc3c0717..5d89e4b84 100644
--- a/src/runtime/conpar.scm
+++ b/src/runtime/conpar.scm
@@ -444,7 +444,7 @@ USA.
 			  marker-instance)
 			 (parser-state/block-thread-events? state)
 			 (parser-state/interrupt-mask state)))
-	      ((eq? marker-type set-interrupt-enables!)
+	      ((eq? marker-type 'SET-INTERRUPT-ENABLES!)
 	       (continue (parser-state/dynamic-state state)
 			 (parser-state/block-thread-events? state)
 			 marker-instance))
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index d7228fcb7..e04a023d2 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -372,6 +372,8 @@ USA.
       (files2
        '(("syntax-items" . (RUNTIME SYNTAX ITEMS))
 	 ("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS))
+	 ("thread" . (RUNTIME THREAD))
+	 ("wind" . (RUNTIME STATE-SPACE))
 	 ("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))
@@ -392,13 +394,15 @@ USA.
   (package-initialize '(RUNTIME POPULATION) #f #t)
   (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
   (load-files files2)
-  (package-initialize '(RUNTIME 1D-PROPERTY) #f #t)
+  (package-initialize '(RUNTIME 1D-PROPERTY) #f #t)	     ;First population.
+  (package-initialize '(RUNTIME STATE-SPACE) #f #t)
+  (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table.
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t)
   (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
   (package-initialize '(RUNTIME GC-FINALIZER) #f #t)
-  (package-initialize '(RUNTIME STRING) #f #t)
+  (package-initialize '(RUNTIME STRING) #f #t)		     ;First GC-finalizer
 
   (set! boot-defs
 	(package/environment (name->package '(RUNTIME BOOT-DEFINITIONS))))
@@ -432,7 +436,6 @@ USA.
  '(
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!)
-   (RUNTIME STATE-SPACE)
    (RUNTIME APPLY)
    (RUNTIME HASH)			; First GC daemon!
    (RUNTIME PRIMITIVE-IO)
@@ -478,8 +481,7 @@ USA.
    ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!)
    ;; Floating-point environment -- needed by threads.
    (RUNTIME FLOATING-POINT-ENVIRONMENT)
-   ;; Threads
-   (RUNTIME THREAD)
+   ((RUNTIME THREAD) INITIALIZE-HIGH!)
    ;; I/O
    (RUNTIME PORT)
    (RUNTIME OUTPUT-PORT)
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 37916cdf1..733367ab9 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -28,6 +28,9 @@ USA.
 ;;; package: (runtime thread)
 
 (declare (usual-integrations))
+
+;;; This allows a host without the SMP primitives to avoid calling them.
+(define enable-smp? #f)
 
 (define-structure (thread
 		   (constructor %make-thread ())
@@ -98,18 +101,28 @@ USA.
 (define next-scheduled-timeout)
 (define root-continuation-default)
 
-(define (initialize-package!)
-  (set! root-continuation-default (make-fluid #f))
-  (initialize-error-conditions!)
+(define (initialize-low!)
+  ;; Called early in the cold load to create the first thread.
   (set! thread-population (make-population))
   (set! first-running-thread #f)
   (set! last-running-thread #f)
   (set! next-scheduled-timeout #f)
   (set! timer-records #f)
   (set! timer-interval 100)
-  (initialize-io-blocking)
-  (add-event-receiver! event:after-restore initialize-io-blocking)
-  (detach-thread (make-thread #f))
+  (reset-threads-low!)
+  (let ((first (%make-thread)))
+    (set-thread/exit-value! first detached-thread-marker)
+    (set-thread/root-state-point! first
+				  (current-state-point state-space:local))
+    (add-to-population!/unsafe thread-population first)
+    (%thread-running first)))
+
+(define (initialize-high!)
+  ;; Called later in the cold load, when more of the runtime is initialized.
+  (set! root-continuation-default (make-fluid #f))
+  (initialize-error-conditions!)
+  (reset-threads-high!)
+  (add-event-receiver! event:after-restore reset-threads!)
   (add-event-receiver! event:before-exit stop-thread-timer)
   (named-structure/set-tag-description! thread-mutex-tag
     (make-define-structure-type 'VECTOR
@@ -130,6 +143,20 @@ USA.
 				link-tag
 				4)))
 
+(define (reset-threads!)
+  (reset-threads-low!)
+  (reset-threads-high!))
+
+(define (reset-threads-low!)
+  (set! enable-smp?
+	(and ((ucode-primitive get-primitive-address 2) 'SMP-COUNT #f)
+	     ((ucode-primitive smp-count 0)))))
+
+(define (reset-threads-high!)
+  (set! io-registry (and have-select? (make-select-registry)))
+  (set! io-registrations #f)
+  unspecific)
+
 (define (make-thread continuation)
   (let ((thread (%make-thread)))
     (set-thread/continuation! thread continuation)
@@ -465,11 +492,6 @@ USA.
   prev
   next)
 
-(define (initialize-io-blocking)
-  (set! io-registry (and have-select? (make-select-registry)))
-  (set! io-registrations #f)
-  unspecific)
-
 (define (wait-for-io)
   (%maybe-toggle-thread-timer #f)
   (let ((catch-errors
diff --git a/src/runtime/wind.scm b/src/runtime/wind.scm
index 30dbafac1..5134b673f 100644
--- a/src/runtime/wind.scm
+++ b/src/runtime/wind.scm
@@ -113,10 +113,10 @@ USA.
 		      (set-state-point/from-nearer! new-root #f)
 		      (set-state-space/nearest-point! space new-root)
 		      (with-stack-marker from-nearer
-			set-interrupt-enables! interrupt-mask))
+			'SET-INTERRUPT-ENABLES! interrupt-mask))
 		    ;; Disable interrupts again in case FROM-NEARER
 		    ;; re-enabled them.
-		    (set-interrupt-enables! interrupt-mask)
+		    ((ucode-primitive set-interrupt-enables! 1) interrupt-mask)
 		    ;; Make sure that NEW-ROOT is still the root,
 		    ;; because FROM-NEARER might have moved it.  If
 		    ;; it has been moved, find the new root, and