From 9be90b70c99f7bf396d7b33bb5a43c52f4f232f9 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 5 Jul 2015 17:58:03 -0700 Subject: [PATCH] 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. --- src/runtime/conpar.scm | 2 +- src/runtime/make.scm | 12 +++++++----- src/runtime/thread.scm | 44 +++++++++++++++++++++++++++++++----------- src/runtime/wind.scm | 4 ++-- 4 files changed, 43 insertions(+), 19 deletions(-) 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 -- 2.25.1