suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fully enable places

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2018-09-09 09:04:19 -06:00
parent bf9a5f2730
commit 9776e4cd8e
19 changed files with 116 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test/tests/racket/place-channel-fd2.rkt
View File

@ -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

3
racket/src/cs/demo/io.ss
View File

@ -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

3
racket/src/cs/demo/thread.ss
View File

@ -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)

3
racket/src/cs/main.sps
View File

@ -490,8 +490,7 @@
(regexp-place-init!)
(expander-place-init!)
(initialize-place!)
(lambda (finish)
(finish)
(lambda ()
(let ([f (dynamic-require mod sym)])
(f pch)))))

4
racket/src/cs/rumble/char.ss
View File

@ -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

6
racket/src/cs/rumble/engine.ss
View File

@ -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)])

6
racket/src/cs/rumble/error.ss
View File

@ -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)))

72
racket/src/cs/rumble/hash.ss
View File

@ -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))))

3
racket/src/cs/rumble/place.ss
View File

@ -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)

6
racket/src/cs/rumble/prefab.ss
View File

@ -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)

39
racket/src/cs/rumble/struct.ss
View File

@ -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))

61
racket/src/cs/rumble/thread-local.ss
View File

@ -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)])))

2
racket/src/io/host/processor-count.rkt
View File

@ -4,4 +4,4 @@
(provide processor-count)
(define (processor-count)
1 #;(rktio_processor_count rktio))
(rktio_processor_count rktio))

3
racket/src/thread/bootstrap.rkt
View File

@ -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"

1
racket/src/thread/place-message.rkt
View File

@ -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)])

29
racket/src/thread/place.rkt
View File

@ -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

3
racket/src/thread/schedule.rkt
View File

@ -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))
;; ----------------------------------------

5
racket/src/thread/thread-group.rkt
View File

@ -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)

2
racket/src/thread/thread.rkt
View File

@ -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 ()