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

adjust online expansion to hold onto previously successful

Browse Source 
namespace-module-registry in order to encourage the bytecode cache to
hold onto likely-to-be-useful entries a while longer
This commit is contained in:
Robby Findler 2011-09-11 08:15:46 -05:00
parent 05cd55fb04
commit 273afb266d
1 changed files with 15 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/drracket/private/expanding-place.rkt
View File

@ -13,6 +13,8 @@
(define module-language-parallel-lock-client (define module-language-parallel-lock-client
'uninitialized-module-language-parallel-lock-client) 'uninitialized-module-language-parallel-lock-client)
(define old-registry-chan (make-channel))
(define (start p) (define (start p)
;; get the module-language-compile-lock in the initial message ;; get the module-language-compile-lock in the initial message
(set! module-language-parallel-lock-client (set! module-language-parallel-lock-client
@ -25,22 +27,29 @@
(define file (list-ref lst 0)) (define file (list-ref lst 0))
(define id (list-ref lst 1)) (define id (list-ref lst 1))
(handler lst (dynamic-require file id)))) (handler lst (dynamic-require file id))))
(let loop ([current-job #f]) (let loop ([current-job #f]
;; the old-registry argument holds on to the namespace-module-registry
;; from a previous run in order to keep entries in the bytecode cache
[old-registry #f])
(sync (sync
(handle-evt
old-registry-chan
(λ (reg) (loop current-job reg)))
(handle-evt (handle-evt
p p
(λ (message) (λ (message)
(cond (cond
[(eq? message 'abort) [(eq? message 'abort)
(when current-job (abort-job current-job)) (when current-job (abort-job current-job))
(loop #f)] (loop #f old-registry)]
[(vector? message) [(vector? message)
(when current-job (abort-job current-job)) (when current-job (abort-job current-job))
(define program-as-string (vector-ref message 0)) (define program-as-string (vector-ref message 0))
(define path (vector-ref message 1)) (define path (vector-ref message 1))
(define response-pc (vector-ref message 2)) (define response-pc (vector-ref message 2))
(define settings (vector-ref message 3)) (define settings (vector-ref message 3))
(loop (new-job program-as-string path response-pc settings))])))))) (loop (new-job program-as-string path response-pc settings)
old-registry)]))))))
(define (abort-job job) (define (abort-job job)
(custodian-shutdown-all (job-cust job)) (custodian-shutdown-all (job-cust job))
@ -102,6 +111,9 @@
raise-hopeless-syntax-error)) raise-hopeless-syntax-error))
(log-info "expanding-place.rkt: 09 starting expansion") (log-info "expanding-place.rkt: 09 starting expansion")
(define expanded (expand transformed-stx)) (define expanded (expand transformed-stx))
(let ([reg (namespace-module-registry (current-namespace))])
(parameterize ([current-custodian orig-cust])
(thread (λ () (channel-put old-registry-chan reg)))))
(log-info "expanding-place.rkt: 10 expanded") (log-info "expanding-place.rkt: 10 expanded")
(define handler-results (define handler-results
(for/list ([handler (in-list handlers)]) (for/list ([handler (in-list handlers)])