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

expander: adjust module-path-index cache implementation

Browse Source 
Change the implementation to one that is a simpler and slightly more
effective.
This commit is contained in:
Matthew Flatt 2020-05-19 15:18:50 -06:00
parent b7908e97a1
commit 12bc1b3841
2 changed files with 96 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
racket/src/expander/common/module-path.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require racket/private/place-local
ffi/unsafe/atomic
racket/fixnum
"../compile/serialize-property.rkt"
"../common/performance.rkt"
"contract.rkt"
@ -190,6 +191,8 @@
(fprintf port "=~a" (module-path-index-resolved r))])
(write-string ">" port)))
(define empty-shift-cache '())
;; Serialization of a module path index is handled specially, because they
;; must be shared across phases of a module
(define deserialize-module-path-index
@ -259,7 +262,7 @@
[(and (pair? mod-path) (eq? 'submod (car mod-path)))
(loop (cadr mod-path))]
[else base])))
(module-path-index mod-path keep-base #f #f)]))
(module-path-index mod-path keep-base #f empty-shift-cache)]))
(define (module-path-index-resolve/maybe base load?)
(if (module-path-index? base)
@ -282,7 +285,7 @@
(define make-self-module-path-index
(case-lambda
[(name) (module-path-index #f #f name #f)]
[(name) (module-path-index #f #f name empty-shift-cache)]
[(name enclosing)
(make-self-module-path-index (build-module-name name
(and enclosing
@ -310,7 +313,7 @@
(begin0
(or (let ([e (hash-ref generic-self-mpis r #f)])
(and e (ephemeron-value e)))
(let ([mpi (module-path-index #f #f r #f)])
(let ([mpi (module-path-index #f #f r empty-shift-cache)])
(hash-set! generic-self-mpis r (make-ephemeron r mpi))
mpi))
(end-atomic)))
@ -346,28 +349,35 @@
[(shift-cache-ref (module-path-index-shift-cache shifted-base) mpi)]
[else
(define shifted-mpi
(module-path-index (module-path-index-path mpi) shifted-base #f #f))
(shift-cache-set! (module-path-index-shift-cache! shifted-base) mpi shifted-mpi)
(module-path-index (module-path-index-path mpi) shifted-base #f empty-shift-cache))
(shift-cache-set! shifted-base shifted-mpi)
shifted-mpi])])]))
(define (module-path-index-shift-cache! mpi)
(or (let ([cache (module-path-index-shift-cache mpi)])
(and cache
(weak-box-value cache)
cache))
(let ([cache (make-weak-box (box #hasheq()))])
(set-module-path-index-shift-cache! mpi cache)
cache)))
(define (shift-cache-ref cache mpi)
(for/or ([wb (in-list cache)])
(define v (weak-box-value wb))
(and v
(equal? (module-path-index-path v)
(module-path-index-path mpi))
v)))
(define (shift-cache-ref cache v)
(and cache
(let ([b (weak-box-value cache)])
(and b (hash-ref (unbox b) v #f)))))
(define (shift-cache-set! cache v r)
(define b (weak-box-value cache))
(when b
(set-box! b (hash-set (unbox b) v r))))
(define (shift-cache-set! base v)
(define new-cache
(cons (make-weak-box v)
;; Prune empty cache entries, and keep only up to a certain
;; number of cached values to avoid quadratic behavior.
(let loop ([n 32] [l (module-path-index-shift-cache base)])
(cond
[(null? l) null]
[(eqv? n 0) null]
[(not (weak-box-value (car l)))
(loop n (cdr l))]
[else
(let ([r (loop (fx- n 1) (cdr l))])
(if (eq? r (cdr l))
l
(cons (car l) r)))]))))
(set-module-path-index-shift-cache! base new-cache))
;; A constant module path index to represent the top level
(define top-level-module-path-index

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

@ -2876,6 +2876,7 @@ static const char *startup_source =
" extra-depth_0)"
"(unsafe-place-local-set! cell.4$2 extra-depth_0)"
"(unsafe-place-local-set! cell.1$10(current-thread)))))))))))))))"
" (define-values (not-an-fX.1) (lambda (who_0 v_0) (begin 'not-an-fX (raise-argument-error who_0 \"fixnum?\" v_0))))"
"(define-values(prop:serialize serialize? serialize-ref)(make-struct-type-property 'serialize))"
"(define-values"
"(prop:serialize-fill! serialize-fill!? serialize-fill!-ref)"
@ -4586,6 +4587,7 @@ static const char *startup_source =
"(make-struct-field-accessor -ref_0 3 'shift-cache)"
"(make-struct-field-mutator -set!_0 2 'resolved)"
"(make-struct-field-mutator -set!_0 3 'shift-cache))))"
"(define-values(empty-shift-cache) '())"
"(define-values"
"(deserialize-module-path-index)"
"(case-lambda"
@ -4738,7 +4740,7 @@ static const char *startup_source =
"(let-values() base_0)))))))))"
" loop_0)"
" mod-path_0)))"
"(module-path-index2.1 mod-path_0 keep-base_0 #f #f)))))))))))))))"
"(module-path-index2.1 mod-path_0 keep-base_0 #f empty-shift-cache)))))))))))))))"
"(case-lambda"
"((mod-path_0 base_0)(begin 'module-path-index-join(module-path-index-join_0 mod-path_0 base_0 #f)))"
"((mod-path_0 base_0 submod5_0)(module-path-index-join_0 mod-path_0 base_0 submod5_0)))))"
@ -4776,7 +4778,7 @@ static const char *startup_source =
"(define-values"
"(make-self-module-path-index)"
"(case-lambda"
"((name_0)(begin(module-path-index2.1 #f #f name_0 #f)))"
"((name_0)(begin(module-path-index2.1 #f #f name_0 empty-shift-cache)))"
"((name_0 enclosing_0)"
"(make-self-module-path-index"
"(let-values(((name19_0) name_0)((temp20_0)(if enclosing_0(1/module-path-index-resolve enclosing_0) #f)))"
@ -4797,7 +4799,7 @@ static const char *startup_source =
"(if e_0(ephemeron-value e_0) #f))))"
"(if or-part_0"
" or-part_0"
"(let-values(((mpi_0)(module-path-index2.1 #f #f r_0 #f)))"
"(let-values(((mpi_0)(module-path-index2.1 #f #f r_0 empty-shift-cache)))"
"(begin(hash-set!(unsafe-place-local-ref cell.1$8) r_0(make-ephemeron r_0 mpi_0)) mpi_0))))"
"(end-atomic)))))))"
"(define-values"
@ -4835,31 +4837,70 @@ static const char *startup_source =
" c1_0"
"(let-values()"
"(let-values(((shifted-mpi_0)"
"(module-path-index2.1(module-path-index-path mpi_0) shifted-base_0 #f #f)))"
"(begin"
"(shift-cache-set!(module-path-index-shift-cache! shifted-base_0) mpi_0 shifted-mpi_0)"
" shifted-mpi_0)))))))))))))))"
"(define-values"
"(module-path-index-shift-cache!)"
"(lambda(mpi_0)"
"(begin"
"(let-values(((or-part_0)"
"(let-values(((cache_0)(module-path-index-shift-cache mpi_0)))"
"(if cache_0(if(weak-box-value cache_0) cache_0 #f) #f))))"
"(if or-part_0"
" or-part_0"
"(let-values(((cache_0)(make-weak-box(box '#hasheq()))))"
"(begin(set-module-path-index-shift-cache! mpi_0 cache_0) cache_0)))))))"
"(module-path-index2.1"
"(module-path-index-path mpi_0)"
" shifted-base_0"
" #f"
" empty-shift-cache)))"
"(begin(shift-cache-set! shifted-base_0 shifted-mpi_0) shifted-mpi_0)))))))))))))))"
"(define-values"
"(shift-cache-ref)"
"(lambda(cache_0 v_0)"
"(begin(if cache_0(let-values(((b_0)(weak-box-value cache_0)))(if b_0(hash-ref(unbox b_0) v_0 #f) #f)) #f))))"
"(lambda(cache_0 mpi_0)"
"(begin"
"(let-values(((lst_0) cache_0))"
"(begin"
"(if(variable-reference-from-unsafe?(#%variable-reference))(void)(let-values()(check-list lst_0)))"
"((letrec-values(((for-loop_0)"
"(lambda(result_0 lst_1)"
"(begin"
" 'for-loop"
"(if(pair? lst_1)"
"(let-values(((wb_0)(unsafe-car lst_1))((rest_0)(unsafe-cdr lst_1)))"
"(let-values(((result_1)"
"(let-values()"
"(let-values(((result_1)"
"(let-values()"
"(let-values()"
"(let-values(((v_0)(weak-box-value wb_0)))"
"(if v_0"
"(if(equal?"
"(module-path-index-path v_0)"
"(module-path-index-path mpi_0))"
" v_0"
" #f)"
" #f))))))"
"(values result_1)))))"
"(if(if(not((lambda x_0 result_1) wb_0))(not #f) #f)"
"(for-loop_0 result_1 rest_0)"
" result_1)))"
" result_0)))))"
" for-loop_0)"
" #f"
" lst_0))))))"
"(define-values"
"(shift-cache-set!)"
"(lambda(cache_0 v_0 r_0)"
"(lambda(base_0 v_0)"
"(begin"
"(let-values(((b_0)(weak-box-value cache_0)))"
"(if b_0(let-values()(set-box! b_0(hash-set(unbox b_0) v_0 r_0)))(void))))))"
"(let-values(((new-cache_0)"
"(cons"
"(make-weak-box v_0)"
"((letrec-values(((loop_0)"
"(lambda(n_0 l_0)"
"(begin"
" 'loop"
"(if(null? l_0)"
"(let-values() null)"
"(if(eqv? n_0 0)"
"(let-values() null)"
"(if(not(weak-box-value(car l_0)))"
"(let-values()(loop_0 n_0(cdr l_0)))"
"(let-values()"
"(let-values(((r_0)(loop_0(fx- n_0 1)(cdr l_0))))"
"(if(eq? r_0(cdr l_0)) l_0(cons(car l_0) r_0)))))))))))"
" loop_0)"
" 32"
"(module-path-index-shift-cache base_0)))))"
"(set-module-path-index-shift-cache! base_0 new-cache_0)))))"
"(define-values(top-level-module-path-index)(make-self-module-path-index(1/make-resolved-module-path 'top-level)))"
"(define-values(top-level-module-path-index?)(lambda(mpi_0)(begin(eq? top-level-module-path-index mpi_0))))"
"(define-values(non-self-module-path-index?)(lambda(mpi_0)(begin(if(module-path-index-path mpi_0) #t #f))))"
@ -5278,7 +5319,6 @@ static const char *startup_source =
"(pop-syntax-context!)"
"(lambda(state_0)"
"(begin(let-values(((b_0)(serialize-state-syntax-context state_0)))(set-box! b_0(cdr(unbox b_0)))))))"
" (define-values (not-an-fX.1) (lambda (who_0 v_0) (begin 'not-an-fX (raise-argument-error who_0 \"fixnum?\" v_0))))"
"(define-values(root-tag)(unsafe-root-continuation-prompt-tag))"
"(define-values(default-val.1$2) #f)"
"(define-values"