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

module name resolver: adjust resolver cache

Browse Source 
The default module name resolver uses a cache to map module names to
resolved-path information. The cache was weak in a way that turns out
to be much weaker on Racket CS, essentially because Chez Scheme is
tuned to fire a minor GC more frequently.

The new cache cuts 45 minutes(!) from a 2h15m single-process
distribution build of Racket CS on Linux. That brings it under a factor
of 1.5 of the non-CS build time, instead of over a factor of 2.

Thanks to Caner and Sam for pointing out LONG ago (maybe a year ago)
that the cache works badly for Pycket. Since the cache doesn't make a
big difference for `racketcs -cl racket`, though, it took me this long
to understand that it can be such a big deal for Racket CS when
performing a distribution build.
This commit is contained in:
Matthew Flatt 2019-06-13 16:43:47 -06:00
parent 61bf75962c
commit 4c01f60d56
2 changed files with 43 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
racket/src/expander/boot/handler.rkt
View File

@ -194,25 +194,28 @@
reg
(make-ephemeron reg v)))
;; weak map from `lib' path + current-library-paths to symbols:
;; We'd like to use a weak `equal?'-based hash table here,
;; but that's not kill-safe. Instead, we use a non-thread-safe
;; custom hash table; a race could lose cache entries, but
;; that's ok.
(define CACHE-N 512)
(define-place-local -path-cache (make-vector CACHE-N #f))
(define (path-cache-get p)
(let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)]
[w (vector-ref -path-cache i)]
[l (and w (weak-box-value w))])
(and l
(let ([a (assoc p l)])
(and a (cdr a))))))
(define (path-cache-set! p v)
(let* ([i (modulo (abs (equal-hash-code p)) CACHE-N)]
[w (vector-ref -path-cache i)]
[l (and w (weak-box-value w))])
(vector-set! -path-cache i (make-weak-box (cons (cons p v) (or l null))))))
;; Weak map from a module registries to a cache that maps module
;; references to resolved-module information. The idea behind mapping
;; from a registry is that changes made to the collection mapping
;; (e.g., by installing a package) reliably take effect when changing
;; namespaces, so using the same namespace may not see the change.
;; Also, we only cache on successful loads, so changing the mapping
;; for that namespace probably doesn't make sense, anyway, for
;; anything that was successfully loaded.
(define-place-local path-caches (make-weak-hasheq))
(define (path-cache-get p reg)
(define cache (hash-ref path-caches reg #hash()))
(hash-ref cache p #f))
(define (path-cache-set! p reg v)
(define current-cache (hash-ref path-caches reg #hash()))
;; Limit cache memory use by flushing the whole thing when it
;; reaches a maximum size:
(define cache (if (= (hash-count current-cache) 1024)
#hash()
current-cache))
(hash-set! path-caches reg (hash-set cache p v)))
(define -loading-filename (gensym))
(define -loading-prompt-tag (make-continuation-prompt-tag 'module-loading))
@ -459,7 +462,7 @@
;; collection
(cond
[(symbol? s)
(or (path-cache-get (cons s (get-reg)))
(or (path-cache-get s (get-reg))
(let-values ([(cols file) (split-relative-string (symbol->string s) #f)])
(let* ([f-file (if (null? cols)
"main.rkt"
@ -478,7 +481,7 @@
#t))))]
[(string? s)
(let* ([dir (get-dir)])
(or (path-cache-get (cons s dir))
(or (path-cache-get (cons s dir) #f)
(let-values ([(cols file) (split-relative-string s #f)])
(if (null? cols)
(build-path dir (ss->rkt file))
@ -498,7 +501,7 @@
s
(path->complete-path s (get-dir)))))]
[(eq? (car s) 'lib)
(or (path-cache-get (cons s (get-reg)))
(or (path-cache-get s (get-reg))
(let*-values ([(cols file) (split-relative-string (cadr s) #f)]
[(old-style?) (if (null? (cddr s))
(and (null? cols)
@ -650,7 +653,10 @@
(eq? (car s) 'lib))))
(path-cache-set! (if (string? s)
(cons s (get-dir))
(cons s (get-reg)))
s)
(if (string? s)
#f
(get-reg))
(vector filename
normal-filename
name
@ -687,7 +693,7 @@
(define (boot)
(set! -module-hash-table-table (make-weak-hasheq))
(set! -path-cache (make-vector CACHE-N #f))
(set! path-caches (make-weak-hasheq))
(seal)
(current-module-name-resolver standard-module-name-resolver)
(current-load/use-compiled default-load/use-compiled)

237
racket/src/racket/src/startup.inc
View File

@ -2406,210 +2406,6 @@ static const char *startup_source =
"(void))"
"(if getkey_0(sort lst_0 less?_0 getkey_0 cache-keys?_0)(sort lst_0 less?_0)))))))))))"
"(define-values"
"(bad-list)"
" (lambda (who_0 orig-l_0) (begin (raise-mismatch-error who_0 \"not a proper list: \" orig-l_0))))"
"(define-values"
"(bad-item)"
" (lambda (who_0 a_0 orig-l_0) (begin (raise-mismatch-error who_0 \"non-pair found in list: \" a_0 \" in \" orig-l_0))))"
"(define-values"
"(1/assq 1/assv 1/assoc assf)"
"(let-values()"
"(let-values()"
"(let-values(((assq_0)"
"(lambda(x_0 l_0)"
"(begin"
" 'assq"
"((letrec-values(((loop_0)"
"(lambda(l_1 t_0)"
"(begin"
" 'loop"
"(if(pair? l_1)"
"(let-values()"
"(let-values(((a_0)(unsafe-car l_1)))"
"(if(pair? a_0)"
"(if(eq? x_0(unsafe-car a_0))"
" a_0"
"(let-values(((l_2)(unsafe-cdr l_1)))"
"(if(pair? l_2)"
"(let-values()"
"(let-values(((a_1)(unsafe-car l_2)))"
"(if(pair? a_1)"
"(if(eq? x_0(unsafe-car a_1))"
" a_1"
"(let-values(((t_1)(unsafe-cdr t_0))"
"((l_3)(unsafe-cdr l_2)))"
"(if(eq? l_3 t_1)"
"(bad-list 'assq l_0)"
"(loop_0 l_3 t_1))))"
"(bad-item 'assq a_1 l_0))))"
"(if(null? l_2)"
"(let-values() #f)"
"(let-values()(bad-list 'assq l_0))))))"
"(bad-item 'assq a_0 l_0))))"
"(if(null? l_1)"
"(let-values() #f)"
"(let-values()(bad-list 'assq l_0))))))))"
" loop_0)"
" l_0"
" l_0))))"
"((assv_0)"
"(lambda(x_0 l_0)"
"(begin"
" 'assv"
"((letrec-values(((loop_0)"
"(lambda(l_1 t_0)"
"(begin"
" 'loop"
"(if(pair? l_1)"
"(let-values()"
"(let-values(((a_0)(unsafe-car l_1)))"
"(if(pair? a_0)"
"(if(eqv? x_0(unsafe-car a_0))"
" a_0"
"(let-values(((l_2)(unsafe-cdr l_1)))"
"(if(pair? l_2)"
"(let-values()"
"(let-values(((a_1)(unsafe-car l_2)))"
"(if(pair? a_1)"
"(if(eqv? x_0(unsafe-car a_1))"
" a_1"
"(let-values(((t_1)(unsafe-cdr t_0))"
"((l_3)(unsafe-cdr l_2)))"
"(if(eq? l_3 t_1)"
"(bad-list 'assv l_0)"
"(loop_0 l_3 t_1))))"
"(bad-item 'assv a_1 l_0))))"
"(if(null? l_2)"
"(let-values() #f)"
"(let-values()(bad-list 'assv l_0))))))"
"(bad-item 'assv a_0 l_0))))"
"(if(null? l_1)"
"(let-values() #f)"
"(let-values()(bad-list 'assv l_0))))))))"
" loop_0)"
" l_0"
" l_0))))"
"((assoc_0)"
"(case-lambda"
"((x_0 l_0)"
"(begin"
" 'assoc"
"((letrec-values(((loop_0)"
"(lambda(l_1 t_0)"
"(begin"
" 'loop"
"(if(pair? l_1)"
"(let-values()"
"(let-values(((a_0)(unsafe-car l_1)))"
"(if(pair? a_0)"
"(if(equal? x_0(unsafe-car a_0))"
" a_0"
"(let-values(((l_2)(unsafe-cdr l_1)))"
"(if(pair? l_2)"
"(let-values()"
"(let-values(((a_1)(unsafe-car l_2)))"
"(if(pair? a_1)"
"(if(equal? x_0(unsafe-car a_1))"
" a_1"
"(let-values(((t_1)(unsafe-cdr t_0))"
"((l_3)(unsafe-cdr l_2)))"
"(if(eq? l_3 t_1)"
"(bad-list 'assoc l_0)"
"(loop_0 l_3 t_1))))"
"(bad-item 'assoc a_1 l_0))))"
"(if(null? l_2)"
"(let-values() #f)"
"(let-values()(bad-list 'assoc l_0))))))"
"(bad-item 'assoc a_0 l_0))))"
"(if(null? l_1)"
"(let-values() #f)"
"(let-values()(bad-list 'assoc l_0))))))))"
" loop_0)"
" l_0"
" l_0)))"
"((x_0 l_0 is-equal?_0)"
"(begin"
"(if(if(procedure? is-equal?_0)(procedure-arity-includes? is-equal?_0 2) #f)"
"(void)"
" (let-values () (raise-argument-error 'assoc \"(any/c any/c . -> . any/c)\" is-equal?_0)))"
"((letrec-values(((loop_0)"
"(lambda(l_1 t_0)"
"(begin"
" 'loop"
"(if(pair? l_1)"
"(let-values()"
"(let-values(((a_0)(unsafe-car l_1)))"
"(if(pair? a_0)"
"(if(is-equal?_0 x_0(unsafe-car a_0))"
" a_0"
"(let-values(((l_2)(unsafe-cdr l_1)))"
"(if(pair? l_2)"
"(let-values()"
"(let-values(((a_1)(unsafe-car l_2)))"
"(if(pair? a_1)"
"(if(is-equal?_0 x_0(unsafe-car a_1))"
" a_1"
"(let-values(((t_1)(unsafe-cdr t_0))"
"((l_3)(unsafe-cdr l_2)))"
"(if(eq? l_3 t_1)"
"(bad-list 'assoc l_0)"
"(loop_0 l_3 t_1))))"
"(bad-item 'assoc a_1 l_0))))"
"(if(null? l_2)"
"(let-values() #f)"
"(let-values()(bad-list 'assoc l_0))))))"
"(bad-item 'assoc a_0 l_0))))"
"(if(null? l_1)"
"(let-values() #f)"
"(let-values()(bad-list 'assoc l_0))))))))"
" loop_0)"
" l_0"
" l_0)))))"
"((assf_0)"
"(lambda(f_0 l_0)"
"(begin"
" 'assf"
"(begin"
"(if(if(procedure? f_0)(procedure-arity-includes? f_0 1) #f)"
"(void)"
" (let-values () (raise-argument-error 'assf \"(any/c . -> . any/c)\" f_0)))"
"((letrec-values(((loop_0)"
"(lambda(l_1 t_0)"
"(begin"
" 'loop"
"(if(pair? l_1)"
"(let-values()"
"(let-values(((a_0)(unsafe-car l_1)))"
"(if(pair? a_0)"
"(if((lambda(__0 a_1)(f_0 a_1)) #f(unsafe-car a_0))"
" a_0"
"(let-values(((l_2)(unsafe-cdr l_1)))"
"(if(pair? l_2)"
"(let-values()"
"(let-values(((a_1)(unsafe-car l_2)))"
"(if(pair? a_1)"
"(if((lambda(__0 a_2)(f_0 a_2))"
" #f"
"(unsafe-car a_1))"
" a_1"
"(let-values(((t_1)(unsafe-cdr t_0))"
"((l_3)(unsafe-cdr l_2)))"
"(if(eq? l_3 t_1)"
"(bad-list 'assf l_0)"
"(loop_0 l_3 t_1))))"
"(bad-item 'assf a_1 l_0))))"
"(if(null? l_2)"
"(let-values() #f)"
"(let-values()(bad-list 'assf l_0))))))"
"(bad-item 'assf a_0 l_0))))"
"(if(null? l_1)"
"(let-values() #f)"
"(let-values()(bad-list 'assf l_0))))))))"
" loop_0)"
" l_0"
" l_0))))))"
"(values assq_0 assv_0 assoc_0 assf_0)))))"
"(define-values"
"(filter)"
"(lambda(f_0 list_0)"
"(begin"
@ -65228,27 +65024,19 @@ static const char *startup_source =
"(define-values"
"(registry-table-set!)"
"(lambda(reg_0 v_0)(begin(hash-set!(unsafe-place-local-ref cell.1) reg_0(make-ephemeron reg_0 v_0)))))"
"(define-values(CACHE-N) 512)"
"(define-values(cell.2)(unsafe-make-place-local(make-vector CACHE-N #f)))"
"(define-values(cell.2)(unsafe-make-place-local(make-weak-hasheq)))"
"(define-values"
"(path-cache-get)"
"(lambda(p_0)"
"(lambda(p_0 reg_0)"
"(begin"
"(let-values(((i_0)(modulo(abs(equal-hash-code p_0)) CACHE-N)))"
"(let-values(((w_0)(vector-ref(unsafe-place-local-ref cell.2) i_0)))"
"(let-values(((l_0)(if w_0(weak-box-value w_0) #f)))"
"(if l_0(let-values(((a_0)(1/assoc p_0 l_0)))(if a_0(cdr a_0) #f)) #f)))))))"
"(let-values(((cache_0)(hash-ref(unsafe-place-local-ref cell.2) reg_0 '#hash())))(hash-ref cache_0 p_0 #f)))))"
"(define-values"
"(path-cache-set!)"
"(lambda(p_0 v_0)"
"(lambda(p_0 reg_0 v_0)"
"(begin"
"(let-values(((i_0)(modulo(abs(equal-hash-code p_0)) CACHE-N)))"
"(let-values(((w_0)(vector-ref(unsafe-place-local-ref cell.2) i_0)))"
"(let-values(((l_0)(if w_0(weak-box-value w_0) #f)))"
"(vector-set!"
"(unsafe-place-local-ref cell.2)"
" i_0"
"(make-weak-box(cons(cons p_0 v_0)(let-values(((or-part_0) l_0))(if or-part_0 or-part_0 null)))))))))))"
"(let-values(((current-cache_0)(hash-ref(unsafe-place-local-ref cell.2) reg_0 '#hash())))"
"(let-values(((cache_0)(if(=(hash-count current-cache_0) 1024) '#hash() current-cache_0)))"
"(hash-set!(unsafe-place-local-ref cell.2) reg_0(hash-set cache_0 p_0 v_0)))))))"
"(define-values(-loading-filename)(gensym))"
"(define-values(-loading-prompt-tag)(make-continuation-prompt-tag 'module-loading))"
"(define-values(cell.3)(unsafe-make-place-local #f))"
@ -65579,7 +65367,7 @@ static const char *startup_source =
"(let-values(((s-parsed_0)"
"(if(symbol? s_1)"
"(let-values()"
"(let-values(((or-part_0)(path-cache-get(cons s_1(get-reg_0)))))"
"(let-values(((or-part_0)(path-cache-get s_1(get-reg_0))))"
"(if or-part_0"
" or-part_0"
"(let-values(((cols_0 file_0)"
@ -65605,7 +65393,7 @@ static const char *startup_source =
"(if(string? s_1)"
"(let-values()"
"(let-values(((dir_0)(get-dir_0)))"
"(let-values(((or-part_0)(path-cache-get(cons s_1 dir_0))))"
"(let-values(((or-part_0)(path-cache-get(cons s_1 dir_0) #f)))"
"(if or-part_0"
" or-part_0"
"(let-values(((cols_0 file_0)(split-relative-string s_1 #f)))"
@ -65631,7 +65419,7 @@ static const char *startup_source =
"(if(complete-path? s_1) s_1(path->complete-path s_1(get-dir_0))))))"
"(if(eq?(car s_1) 'lib)"
"(let-values()"
"(let-values(((or-part_0)(path-cache-get(cons s_1(get-reg_0)))))"
"(let-values(((or-part_0)(path-cache-get s_1(get-reg_0))))"
"(if or-part_0"
" or-part_0"
"(let-values(((cols_0 file_0)"
@ -65833,7 +65621,8 @@ static const char *startup_source =
" #f)"
"(let-values()"
"(path-cache-set!"
"(if(string? s_1)(cons s_1(get-dir_0))(cons s_1(get-reg_0)))"
"(if(string? s_1)(cons s_1(get-dir_0)) s_1)"
"(if(string? s_1) #f(get-reg_0))"
"(vector"
" filename_0"
" normal-filename_0"
@ -65883,7 +65672,7 @@ static const char *startup_source =
"(begin"
"(begin"
"(unsafe-place-local-set! cell.1(make-weak-hasheq))"
"(unsafe-place-local-set! cell.2(make-vector CACHE-N #f))"
"(unsafe-place-local-set! cell.2(make-weak-hasheq))"
"(seal)"
"(1/current-module-name-resolver standard-module-name-resolver)"
"(1/current-load/use-compiled default-load/use-compiled)"