From 9776e4cd8e5db50db0aa5392f630506dc42198aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 9 Sep 2018 09:04:19 -0600 Subject: [PATCH] cs: fully enable places Fix various problems with the implementation of places, and let `processor-count` return the actual number of processors. A parallel build via `raco setup` seems to work but not scale well. --- .../tests/racket/place-channel-fd2.rkt | 2 +- racket/src/cs/demo/io.ss | 3 +- racket/src/cs/demo/thread.ss | 3 +- racket/src/cs/main.sps | 3 +- racket/src/cs/rumble/char.ss | 4 +- racket/src/cs/rumble/engine.ss | 6 +- racket/src/cs/rumble/error.ss | 6 +- racket/src/cs/rumble/hash.ss | 72 ++++--------------- racket/src/cs/rumble/place.ss | 3 +- racket/src/cs/rumble/prefab.ss | 6 +- racket/src/cs/rumble/struct.ss | 39 ++++++---- racket/src/cs/rumble/thread-local.ss | 61 ++++++++++------ racket/src/io/host/processor-count.rkt | 2 +- racket/src/thread/bootstrap.rkt | 3 +- racket/src/thread/place-message.rkt | 1 + racket/src/thread/place.rkt | 29 ++++---- racket/src/thread/schedule.rkt | 3 +- racket/src/thread/thread-group.rkt | 5 +- racket/src/thread/thread.rkt | 2 +- 19 files changed, 116 insertions(+), 137 deletions(-) diff --git a/pkgs/racket-test/tests/racket/place-channel-fd2.rkt b/pkgs/racket-test/tests/racket/place-channel-fd2.rkt index 431b0790dc..05d23604ce 100644 --- a/pkgs/racket-test/tests/racket/place-channel-fd2.rkt +++ b/pkgs/racket-test/tests/racket/place-channel-fd2.rkt @@ -18,7 +18,7 @@ (define (main) (test-case - "test file descriptors copied across place channesl" + "test file descriptors copied across place channels" ;; write out "fdt.rkt" (with-output-to-file fdt #:exists 'replace (lambda () (display diff --git a/racket/src/cs/demo/io.ss b/racket/src/cs/demo/io.ss index ed31f618d5..094398e2ba 100644 --- a/racket/src/cs/demo/io.ss +++ b/racket/src/cs/demo/io.ss @@ -143,8 +143,7 @@ (set-start-place! (lambda (pch mod sym in out err cust plumber) (io-place-init! in out err cust plumber) - (lambda (finish) - (finish) + (lambda () ((hash-ref place-symbols sym) pch)))) ;; Check file port passed across places diff --git a/racket/src/cs/demo/thread.ss b/racket/src/cs/demo/thread.ss index aef2a04c3b..85f2181fdf 100644 --- a/racket/src/cs/demo/thread.ss +++ b/racket/src/cs/demo/thread.ss @@ -192,8 +192,7 @@ (hash-set! place-symbols sym proc))]) (set-start-place! (lambda (pch mod sym in out err cust plumber) - (lambda (finish) - (finish) + (lambda () ((hash-ref place-symbols sym) pch)))) (register-place-symbol! 'nothing void) diff --git a/racket/src/cs/main.sps b/racket/src/cs/main.sps index b12d71b086..7651e6d7cd 100644 --- a/racket/src/cs/main.sps +++ b/racket/src/cs/main.sps @@ -490,8 +490,7 @@ (regexp-place-init!) (expander-place-init!) (initialize-place!) - (lambda (finish) - (finish) + (lambda () (let ([f (dynamic-require mod sym)]) (f pch))))) diff --git a/racket/src/cs/rumble/char.ss b/racket/src/cs/rumble/char.ss index d15c08792c..6a91cd14a4 100644 --- a/racket/src/cs/rumble/char.ss +++ b/racket/src/cs/rumble/char.ss @@ -32,10 +32,10 @@ (and (char? v) (< (char->integer v) 256))) (define (char-general-category ch) - (or (getprop (#%char-general-category ch) 'downcase #f) + (or (with-global-lock* (getprop (#%char-general-category ch) 'downcase #f)) (let* ([s (#%char-general-category ch)] [ds (string->symbol (string-downcase (symbol->string s)))]) - (putprop s 'downcase ds) + (with-global-lock* (putprop s 'downcase ds)) ds))) ;; FIXME diff --git a/racket/src/cs/rumble/engine.ss b/racket/src/cs/rumble/engine.ss index d3a9b333a6..a57eb8b59b 100644 --- a/racket/src/cs/rumble/engine.ss +++ b/racket/src/cs/rumble/engine.ss @@ -123,13 +123,15 @@ (define (make-empty-thread-cell-values) (make-ephemeron-eq-hashtable)) -(define root-thread-cell-values (make-empty-thread-cell-values)) +(define-virtual-register root-thread-cell-values (make-empty-thread-cell-values)) + +(define original-thread-id (get-thread-id)) (define (current-engine-thread-cell-values) (let ([es (current-engine-state)]) (if es (engine-state-thread-cell-values es) - root-thread-cell-values))) + (root-thread-cell-values)))) (define (set-current-engine-thread-cell-values! new-t) (let ([current-t (current-engine-thread-cell-values)]) diff --git a/racket/src/cs/rumble/error.ss b/racket/src/cs/rumble/error.ss index bd5fce5608..1d3aead465 100644 --- a/racket/src/cs/rumble/error.ss +++ b/racket/src/cs/rumble/error.ss @@ -687,10 +687,8 @@ (current-exception-state (create-exception-state)) (base-exception-handler (lambda (v) - #; - (#%printf "~s ~s\n" - (exn->string v) - '(continuation-mark-set-traces (current-continuation-marks))) + #;(#%printf "~s\n" (exn->string v)) + #;(#%printf "~s\n" (continuation-mark-set-traces (current-continuation-marks))) (cond [(and (warning? v) (not (non-continuable-violation? v))) diff --git a/racket/src/cs/rumble/hash.ss b/racket/src/cs/rumble/hash.ss index fbe02d09eb..b604132108 100644 --- a/racket/src/cs/rumble/hash.ss +++ b/racket/src/cs/rumble/hash.ss @@ -279,21 +279,14 @@ (check who hash? ht) (check who (procedure-arity-includes/c 2) proc) (cond - [(mutable-hash? ht) + [(intmap? ht) (intmap-for-each ht proc)] + [else + ;; mutable, impersonated, and weak-equal: (let loop ([i (hash-iterate-first ht)]) (when i (let-values ([(key val) (hash-iterate-key+value ht i)]) (|#%app| proc key val)) - (loop (hash-iterate-next ht i))))] - [(intmap? ht) (intmap-for-each ht proc)] - [(weak-equal-hash? ht) (weak-hash-for-each ht proc)] - [else - ;; impersonated - (let loop ([i (hash-iterate-first ht)]) - (when i - (let-values ([(key val) (hash-iterate-key+value ht i)]) - (|#%app| proc key val) - (loop (hash-iterate-next ht i)))))])])) + (loop (hash-iterate-next ht i))))])])) (define/who hash-map (case-lambda @@ -301,25 +294,16 @@ (check who hash? ht) (check who (procedure-arity-includes/c 2) proc) (cond - [(mutable-hash? ht) + [(intmap? ht) (intmap-map ht proc)] + [else + ;; mutable, impersonated, and weak-equal: (let loop ([i (hash-iterate-first ht)]) (if (not i) '() (cons (let-values ([(key val) (hash-iterate-key+value ht i)]) (|#%app| proc key val)) - (loop (hash-iterate-next ht i)))))] - [(intmap? ht) (intmap-map ht proc)] - [(weak-equal-hash? ht) (weak-hash-map ht proc)] - [else - ;; impersonated - (let loop ([i (hash-iterate-first ht)]) - (cond - [(not i) '()] - [else - (let-values ([(key val) (hash-iterate-key+value ht i)]) - (cons (|#%app| proc key val) - (loop (hash-iterate-next ht i))))]))])] + (loop (hash-iterate-next ht i)))))])] [(ht proc try-order?) (hash-map ht proc)])) @@ -725,9 +709,12 @@ (define (weak-equal-hash-lock t) (locked-iterable-hash-lock t)) +(define (make-weak-hash-with-lock lock) + (make-weak-equal-hash lock #f #f (hasheqv) (make-weak-eq-hashtable) (make-eqv-hashtable) 0 128)) + (define make-weak-hash (case-lambda - [() (make-weak-equal-hash (make-lock 'equal?) #f #f (hasheqv) (make-weak-eq-hashtable) (make-eqv-hashtable) 0 128)] + [() (make-weak-hash-with-lock (make-lock 'equal?))] [(alist) (fill-hash! 'make-weak-hash (make-weak-hash) alist)])) (define (weak-hash-copy ht) @@ -857,41 +844,6 @@ (set-locked-iterable-hash-cells! t #f) (lock-release (weak-equal-hash-lock t))) -(define (weak-hash-for-each t proc) - (let ([ht-for-each - (lambda (ht) - (let* ([keys (hashtable-keys ht)] - [len (#%vector-length keys)]) - (let loop ([i 0]) - (unless (fx= i len) - (let ([key (#%vector-ref keys i)]) - (|#%app| proc key (hashtable-ref ht key #f))) - (loop (fx1+ i))))))]) - (ht-for-each (weak-equal-hash-vals-ht t)) - (ht-for-each (weak-equal-hash-fl-vals-ht t)))) - -(define (weak-hash-map t proc) - (let* ([ht (weak-equal-hash-vals-ht t)] - [keys (hashtable-keys ht)] - [len (#%vector-length keys)]) - (let loop ([i 0]) - (cond - [(fx= i len) - (let* ([ht (weak-equal-hash-fl-vals-ht t)] - [keys (hashtable-keys ht)] - [len (#%vector-length keys)]) - (let loop ([i 0]) - (cond - [(fx= i len) '()] - [else - (let ([key (#%vector-ref keys i)]) - (cons (|#%app| proc key (hashtable-ref ht key #f)) - (loop (fx1+ i))))])))] - [else - (let ([key (#%vector-ref keys i)]) - (cons (|#%app| proc key (hashtable-ref ht key #f)) - (loop (fx1+ i))))])))) - (define (weak-hash-count t) (fx+ (hashtable-size (weak-equal-hash-vals-ht t)) (hashtable-size (weak-equal-hash-fl-vals-ht t)))) diff --git a/racket/src/cs/rumble/place.ss b/racket/src/cs/rumble/place.ss index 11d4eb2291..33faac057c 100644 --- a/racket/src/cs/rumble/place.ss +++ b/racket/src/cs/rumble/place.ss @@ -63,8 +63,9 @@ (fork-thread (lambda () (init-virtual-registers) (place-registers (vector-copy place-register-inits)) + (root-thread-cell-values (make-empty-thread-cell-values)) (init-place-locals!) - (foreign-place-init!) + (register-as-place-main!) (let ([result (call/cc (lambda (esc) (set-box! place-esc-box esc) diff --git a/racket/src/cs/rumble/prefab.ss b/racket/src/cs/rumble/prefab.ss index e0d72e389f..b6010a8e80 100644 --- a/racket/src/cs/rumble/prefab.ss +++ b/racket/src/cs/rumble/prefab.ss @@ -1,10 +1,8 @@ -;; maps (cons prefab-key total-field-count) to rtd: -(define prefabs #f) - (define (prefab-struct-key v) (let ([v (strip-impersonator v)]) (and (record? v) - (let ([p (getprop (record-type-uid (record-rtd v)) 'prefab-key+count #f)]) + (let ([p (with-global-lock* + (getprop (record-type-uid (record-rtd v)) 'prefab-key+count #f))]) (and p (car p)))))) (define/who (prefab-key->struct-type key field-count) diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index deb694a54f..2e06a4d68b 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -446,7 +446,8 @@ (lambda (args) (args-insert args init-count auto-count auto-val pfa))))]) (when (or parent-rtd* auto-field-adder) - (putprop (record-type-uid rtd) 'field-info (make-field-info init*-count auto*-count auto-field-adder))) + (let ([field-info (make-field-info init*-count auto*-count auto-field-adder)]) + (putprop (record-type-uid rtd) 'field-info field-info))) (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name install-props!) @@ -551,13 +552,20 @@ (record-type-uid (prefab-key+count->rtd (cons prefab-key total*-count))))) +;; A weak, `equal?`-based hash table that maps (cons prefab-key +;; total-field-count) to rtd. We'll create a table without a lock, and +;; we'll use it for all places, which means that we need to use a +;; global lock to access the table. +(define prefabs #f) + +;; Call with lock: (define (prefab-ref prefab-key+count) (and prefabs - (hash-ref prefabs prefab-key+count #f))) + (weak-hash-ref prefabs prefab-key+count #f))) (define (prefab-key+count->rtd prefab-key+count) (cond - [(prefab-ref prefab-key+count) + [(with-global-lock (prefab-ref prefab-key+count)) => (lambda (rtd) rtd)] [else (let* ([prefab-key (car prefab-key+count)] @@ -585,8 +593,8 @@ => (lambda (rtd) rtd)] [else (putprop uid 'prefab-key+count prefab-key+count) - (unless prefabs (set! prefabs (make-weak-hash))) - (hash-set! prefabs prefab-key+count rtd) + (unless prefabs (set! prefabs (make-weak-hash-with-lock #f))) + (weak-hash-set! prefabs prefab-key+count rtd) (unless parent-rtd (record-type-equal-procedure rtd default-struct-equal?) (record-type-hash-procedure rtd default-struct-hash)) @@ -912,16 +920,17 @@ (struct-type-field-info parent-rtd*))) parent-guards) parent-guards)]) - (putprop (record-type-uid rtd) 'guards (if guard - (if (eq? which-end 'at-start) - ;; Normal: - (cons (cons guard (get-field-info-init*-count fi)) - parent-guards) - ;; Internal, makes primitive guards have a natural - ;; error order: - (append parent-guards - (list (cons guard (get-field-info-init*-count fi))))) - parent-guards)))))) + (let ([new-guards (if guard + (if (eq? which-end 'at-start) + ;; Normal: + (cons (cons guard (get-field-info-init*-count fi)) + parent-guards) + ;; Internal, makes primitive guards have a natural + ;; error order: + (append parent-guards + (list (cons guard (get-field-info-init*-count fi))))) + parent-guards)]) + (putprop (record-type-uid rtd) 'guards new-guards)))))) (define (unsafe-struct*-ref s i) (#3%vector-ref s i)) diff --git a/racket/src/cs/rumble/thread-local.ss b/racket/src/cs/rumble/thread-local.ss index 98b068a11b..f56bdad528 100644 --- a/racket/src/cs/rumble/thread-local.ss +++ b/racket/src/cs/rumble/thread-local.ss @@ -1,22 +1,43 @@ ;; Use `define-thread-local` for an immutable variable containing a -;; mutable value where the value can be created lazily and isn't #f +;; mutable value where the value can be created lazily and isn't #f. +;; Unlike place-local values, thread-local values are meant to work +;; form arbitrary Scheme threads (i.e., not just those created to +;; exist within some place). -(define-syntax-rule (define-thread-local id rhs) - (begin - (define cell (make-thread-parameter #f)) - (define (init) rhs) - (define-syntax (id stx) - (... - (syntax-case stx () - [(id arg ...) #'((thread-local-ref cell init) arg ...)] - [_ #'(thread-local-ref cell init)]))))) - -(define (thread-local-ref c init) - (let ([v (c)]) - (or v - (with-interrupts-disabled - (let ([v (c)]) - (or v - (let ([v (init)]) - (c v) - v))))))) +(define-virtual-register thread-local-table #f) + +(define NUM-THREAD-LOCALS 64) +(meta define thread-local-counter 64) + +(define-syntax (define-thread-local stx) + (syntax-case stx () + [(_ id rhs) + (let ([pos (sub1 thread-local-counter)]) + (set! thread-local-counter pos) + (when (negative? pos) + (error 'define-thread-local "out of thread-local slots")) + (with-syntax ([pos (#%datum->syntax #'here pos)]) + #'(begin + (define (init) rhs) + (define-syntax (id stx) + (... + (syntax-case stx () + [(id arg ...) #'((thread-local-ref pos init) arg ...)] + [_ #'(thread-local-ref pos init)]))))))])) + +(define (thread-local-ref i init) + (let ([vec (thread-local-table)]) + (cond + [(#%vector? vec) + (let ([v (#%vector-ref vec i)]) + (or v + (with-interrupts-disabled + (let ([v (#%vector-ref vec i)]) + (or v + (let ([v (init)]) + (#%vector-set! vec i v) + v))))))] + [else + (with-interrupts-disabled + (thread-local-table (#%make-vector NUM-THREAD-LOCALS #f))) + (thread-local-ref i init)]))) diff --git a/racket/src/io/host/processor-count.rkt b/racket/src/io/host/processor-count.rkt index bb463a7a8f..1a165f75ac 100644 --- a/racket/src/io/host/processor-count.rkt +++ b/racket/src/io/host/processor-count.rkt @@ -4,4 +4,4 @@ (provide processor-count) (define (processor-count) - 1 #;(rktio_processor_count rktio)) + (rktio_processor_count rktio)) diff --git a/racket/src/thread/bootstrap.rkt b/racket/src/thread/bootstrap.rkt index c08e6838f7..10306d0f6f 100644 --- a/racket/src/thread/bootstrap.rkt +++ b/racket/src/thread/bootstrap.rkt @@ -192,8 +192,7 @@ (define (start-place pch mod sym in-fd out-fd err-fd cust plumber) (io-place-init! in-fd out-fd err-fd cust plumber) - (lambda (finish) - (finish) + (lambda () ((hash-ref place-symbols sym) pch))) ;; For use in "demo.rkt" diff --git a/racket/src/thread/place-message.rkt b/racket/src/thread/place-message.rkt index c54309ef6c..8120a6284a 100644 --- a/racket/src/thread/place-message.rkt +++ b/racket/src/thread/place-message.rkt @@ -124,6 +124,7 @@ (define ph (make-placeholder #f)) (hash-set! graph v ph) (maybe-ph + ph (apply make-prefab-struct k (for/list ([e (in-vector (struct->vector v) 1)]) diff --git a/racket/src/thread/place.rkt b/racket/src/thread/place.rkt index 81828874f7..489a9ad61c 100644 --- a/racket/src/thread/place.rkt +++ b/racket/src/thread/place.rkt @@ -6,6 +6,7 @@ "schedule.rkt" "atomic.rkt" "thread.rkt" + "thread-group.rkt" (submod "thread.rkt" for-place) "custodian.rkt" (submod "custodian.rkt" scheduling) @@ -97,27 +98,27 @@ ;; Start the new place (host:fork-place (lambda () - (set-root-custodian! orig-cust) - (define finish (host:start-place child-pch path sym - child-in-fd child-out-fd child-err-fd - orig-cust orig-plumber)) (call-in-another-main-thread + orig-cust (lambda () (set! current-place new-place) + (current-thread-group root-thread-group) + (current-custodian orig-cust) (current-plumber orig-plumber) (exit-handler default-exit) - ;; The finish function reports some I/O related - ;; information to store in the place, and when that - ;; callback returns, it starts loading the specified - ;; module + (current-pseudo-random-generator (make-pseudo-random-generator)) + (current-evt-pseudo-random-generator (make-pseudo-random-generator)) + (define finish + (host:start-place child-pch path sym + child-in-fd child-out-fd child-err-fd + orig-cust orig-plumber)) (call-with-continuation-prompt (lambda () - (finish - (lambda () - (host:mutex-acquire lock) - (set-place-wakeup-handle! new-place (sandman-get-wakeup-handle)) - (host:condition-signal started) ; place is sufficiently started - (host:mutex-release lock)))) + (host:mutex-acquire lock) + (set-place-wakeup-handle! new-place (sandman-get-wakeup-handle)) + (host:condition-signal started) ; place is sufficiently started + (host:mutex-release lock) + (finish)) (default-continuation-prompt-tag) (lambda (thunk) ;; Thread ended with escape => exit with status 1 diff --git a/racket/src/thread/schedule.rkt b/racket/src/thread/schedule.rkt index 1fd85f231f..9c297466f4 100644 --- a/racket/src/thread/schedule.rkt +++ b/racket/src/thread/schedule.rkt @@ -33,8 +33,9 @@ (select-thread!)) ;; Initializes the thread system in a new place: -(define (call-in-another-main-thread thunk) +(define (call-in-another-main-thread c thunk) (make-another-initial-thread-group) + (set-root-custodian! c) (call-in-main-thread thunk)) ;; ---------------------------------------- diff --git a/racket/src/thread/thread-group.rkt b/racket/src/thread/thread-group.rkt index 0d2b4603f4..a41900d5c7 100644 --- a/racket/src/thread/thread-group.rkt +++ b/racket/src/thread/thread-group.rkt @@ -11,7 +11,7 @@ current-thread-group make-another-initial-thread-group - ;; Used by scheduler + ;; Used by scheduler and place creation root-thread-group thread-group-next! @@ -47,8 +47,7 @@ v))) (define (make-another-initial-thread-group) - (set! root-thread-group (make-root-thread-group)) - (current-thread-group root-thread-group)) + (set! root-thread-group (make-root-thread-group))) (define/who (make-thread-group [parent (current-thread-group)]) (check who thread-group? parent) diff --git a/racket/src/thread/thread.rkt b/racket/src/thread/thread.rkt index 2f30231860..452f52fb57 100644 --- a/racket/src/thread/thread.rkt +++ b/racket/src/thread/thread.rkt @@ -145,7 +145,7 @@ #:initial? [initial? #f] #:suspend-to-kill? [suspend-to-kill? #f]) (check who (procedure-arity-includes/c 0) proc) - (define p (if at-root? + (define p (if (or at-root? initial?) root-thread-group (current-thread-group))) (define e (make-engine (lambda ()