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

expander: another cache layer for binding

Browse Source 
Add a cache on binding lookup that is like the old expander --- a
small cache that is consulted before the more general cache that is
already in place.

The new cache layer primarily helps when a single identifier is
compared to a sequence of other identifiers.
This commit is contained in:
Matthew Flatt 2018-03-18 14:59:24 -06:00
parent 60471c2691
commit 77a978fb10
6 changed files with 9130 additions and 8926 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
racket/src/expander/syntax/binding.rkt
View File

@ -12,7 +12,8 @@
"local-binding.rkt"
"datum-map.rkt"
"../expand/rename-trans.rkt"
"../common/module-path.rkt")
"../common/module-path.rkt"
"cache.rkt")
(provide
binding-frame-id
@ -169,7 +170,7 @@
(syntax-mpi-shifts s))
(syntax-scope-propagations+tamper s))])]))
;; Use `resolve` instead of `resolve+shift` when the module of a
;; Use `resolve+shift` instead of `resolve` when the module of a
;; module binding is relevant or when `free-identifier=?` equivalences
;; (as installed by a binding to a rename transfomer) are relevant;
;; module path index shifts attached to `s` are taken into account in
@ -181,48 +182,64 @@
#:unbound-sym? [unbound-sym? #f]
;; For resolving bulk bindings in `free-identifier=?` chains:
#:extra-shifts [extra-shifts null])
(define immediate-b (resolve s phase
#:ambiguous-value ambiguous-value
#:exactly? exactly?
#:extra-shifts extra-shifts))
(define b (if (and immediate-b
(not immediate?)
(binding-free=id immediate-b))
(resolve+shift (binding-free=id immediate-b) phase
#:extra-shifts (append extra-shifts (syntax-mpi-shifts s))
#:ambiguous-value ambiguous-value
#:exactly? exactly?
#:unbound-sym? unbound-sym?)
immediate-b))
(define can-cache? (and (not exactly?) (not immediate?) (null? extra-shifts)))
(cond
[(module-binding? b)
(define mpi-shifts (syntax-mpi-shifts s))
(cond
[(null? mpi-shifts)
b]
[else
(define mod (module-binding-module b))
(define shifted-mod (apply-syntax-shifts mod mpi-shifts))
(define nominal-mod (module-binding-nominal-module b))
(define shifted-nominal-mod (if (eq? mod nominal-mod)
shifted-mod
(apply-syntax-shifts nominal-mod mpi-shifts)))
(if (and (eq? mod shifted-mod)
(eq? nominal-mod shifted-nominal-mod)
(not (binding-free=id b))
(null? (module-binding-extra-nominal-bindings b)))
b
(module-binding-update b
#:module shifted-mod
#:nominal-module shifted-nominal-mod
#:free=id (and (binding-free=id b)
(syntax-transfer-shifts (binding-free=id b) s))
#:extra-nominal-bindings
(for/list ([b (in-list (module-binding-extra-nominal-bindings b))])
(apply-syntax-shifts-to-binding b mpi-shifts))))])]
[(and (not b) unbound-sym?)
(syntax-e s)]
[else b]))
[(and can-cache?
(resolve+shift-cache-get s phase))
=> (lambda (b)
(if (eq? b '#:none)
(and unbound-sym? (syntax-content s))
b))]
[else
(define immediate-b (resolve s phase
#:ambiguous-value ambiguous-value
#:exactly? exactly?
#:extra-shifts extra-shifts))
(define b (if (and immediate-b
(not immediate?)
(binding-free=id immediate-b))
(resolve+shift (binding-free=id immediate-b) phase
#:extra-shifts (append extra-shifts (syntax-mpi-shifts s))
#:ambiguous-value ambiguous-value
#:exactly? exactly?
#:unbound-sym? unbound-sym?)
immediate-b))
(cond
[(module-binding? b)
(define mpi-shifts (syntax-mpi-shifts s))
(cond
[(null? mpi-shifts)
b]
[else
(define mod (module-binding-module b))
(define shifted-mod (apply-syntax-shifts mod mpi-shifts))
(define nominal-mod (module-binding-nominal-module b))
(define shifted-nominal-mod (if (eq? mod nominal-mod)
shifted-mod
(apply-syntax-shifts nominal-mod mpi-shifts)))
(define result-b
(if (and (eq? mod shifted-mod)
(eq? nominal-mod shifted-nominal-mod)
(not (binding-free=id b))
(null? (module-binding-extra-nominal-bindings b)))
b
(module-binding-update b
#:module shifted-mod
#:nominal-module shifted-nominal-mod
#:free=id (and (binding-free=id b)
(syntax-transfer-shifts (binding-free=id b) s))
#:extra-nominal-bindings
(for/list ([b (in-list (module-binding-extra-nominal-bindings b))])
(apply-syntax-shifts-to-binding b mpi-shifts)))))
(when can-cache?
(resolve+shift-cache-set! s phase result-b))
result-b])]
[else
(when can-cache?
(resolve+shift-cache-set! s phase (or b '#:none)))
(or b
(and unbound-sym?
(syntax-content s)))])]))
;; Apply accumulated module path index shifts
(define (apply-syntax-shifts mpi shifts)

66
racket/src/expander/syntax/cache.rkt
View File

@ -1,13 +1,22 @@
#lang racket/base
(require "../common/set.rkt")
(require racket/fixnum
"../common/set.rkt")
(provide clear-resolve-cache!
resolve-cache-get
resolve-cache-set!
resolve+shift-cache-get
resolve+shift-cache-set!
cache-or-reuse-set
cache-or-reuse-hash)
;; ----------------------------------------
;; Cache bindings resolutions with a fairly weak
;; cache keyed on a symbol, phase, and scope sets.
(define cache (box (make-weak-box #f)))
(define clear-resolve-cache!
@ -15,11 +24,13 @@
[(sym)
(define c (weak-box-value (unbox* cache)))
(when c
(hash-remove! c sym))]
(hash-remove! c sym))
(set-box*! shifted-cache #f)]
[()
(define c (weak-box-value (unbox* cache)))
(when c
(hash-clear! c))]))
(hash-clear! c))
(set-box*! shifted-cache #f)]))
(struct entry (scs smss phase binding)
#:authentic)
@ -46,6 +57,49 @@
;; ----------------------------------------
;; Cache binding resolutions keyed on an identifier and
;; phase; this is a very small cache that is consulted
;; before the more general one above; it's even cheaper
;; to check, and it avoids re-shifting module bindings
;; when it hits. It can be especially effective when
;; comparing one identifier to a sequence of other
;; identifiers.
(define SHIFTED-CACHE-SIZE 16) ; power of 2
;; Cache box contains #f or a weak box of a vector:
(define shifted-cache (box #f))
(define shifted-cache-pos 0)
(struct shifted-entry (s phase binding)
#:authentic)
(define (shifted-cache-vector)
(define wb (unbox* shifted-cache))
(cond
[(and wb (weak-box-value wb))
=> (lambda (vec) vec)]
[else
(define vec (make-vector SHIFTED-CACHE-SIZE #f))
(set-box*! shifted-cache (make-weak-box vec))
vec]))
(define (resolve+shift-cache-get s phase)
(define vec (shifted-cache-vector))
(for/or ([e (in-vector vec)])
(and e
(eq? s (shifted-entry-s e))
(eqv? phase (shifted-entry-phase e))
(shifted-entry-binding e))))
(define (resolve+shift-cache-set! s phase b)
(define vec (shifted-cache-vector))
(define p shifted-cache-pos)
(vector*-set! vec p (shifted-entry s phase b))
(set! shifted-cache-pos (fxand (fx+ 1 p) (fx- SHIFTED-CACHE-SIZE 1))))
;; ----------------------------------------
;; For scope sets and propagation hashes, we don't intern, but we
;; approximate interning by checking against a small set of recently
;; allocated scope sets or propagation hashes. That's good enough to
@ -54,7 +108,7 @@
;; an macro-introduced syntax prevents the usual
;; child-is-same-as-parent sharing detecting from working well enough.
(define NUM-CACHE-SLOTS 8)
(define NUM-CACHE-SLOTS 8) ; power of 2
(define cached-sets (make-weak-box (make-vector NUM-CACHE-SLOTS #f)))
(define cached-sets-pos 0)
@ -73,8 +127,8 @@
(same? s s2)
s2))
(begin
(vector-set! vec cached-pos s)
(set! cached-pos (modulo (add1 cached-pos) NUM-CACHE-SLOTS))
(vector*-set! vec cached-pos s)
(set! cached-pos (fxand (fx+ 1 cached-pos) (fx- NUM-CACHE-SLOTS 1)))
s))))
(define-cache-or-reuse cache-or-reuse-set cached-sets cached-sets-pos set=?)

4
racket/src/racket/src/jitcommon.c
View File

@ -509,7 +509,7 @@ static int common1b(mz_jit_state *jitter, void *_data)
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish_lwe(ts_scheme_unbox_star, ref);
(void)mz_finish_lwe(ts_scheme_unbox_star, ref); /* doesn't return */
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, sjc.unbox_star_fail_code, scheme_false);
@ -521,7 +521,7 @@ static int common1b(mz_jit_state *jitter, void *_data)
jit_prepare(2);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_R0);
(void)mz_finish_lwe(ts_scheme_set_box_star, ref);
(void)mz_finish_lwe(ts_scheme_set_box_star, ref); /* doesn't return */
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, sjc.set_box_star_fail_code, scheme_false);

6
racket/src/racket/src/jitinline.c
View File

@ -4137,11 +4137,11 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
(void)jit_calli(sjc.set_box_code);
else
(void)jit_calli(sjc.set_box_star_fail_code);
if (!for_star) {
if (!for_star)
ref2 = jit_jmpi(jit_forward());
mz_patch_branch(ref);
} else
else
ref2 = NULL;
mz_patch_branch(ref);
if (!unsafe) {
jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)0x0));
(void)jit_bmsi_ul(reffail, JIT_R2, 0x1);

15
racket/src/racket/src/list.c
View File

@ -937,17 +937,17 @@ scheme_init_unsafe_list (Scheme_Startup_Env *env)
scheme_addto_prim_instance("unsafe-unbox*", p, env);
scheme_unsafe_unbox_star_proc = p;
REGISTER_SO(scheme_unsafe_set_box_star_proc);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("unsafe-set-box!", p, env);
scheme_unsafe_set_box_star_proc = p;
REGISTER_SO(scheme_unsafe_set_box_star_proc);
p = scheme_make_immed_prim(unsafe_set_box_star, "unsafe-set-box*!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_AD_HOC_OPT);
scheme_addto_prim_instance("unsafe-set-box*!", p, env);
scheme_unsafe_set_box_star_proc = p;
p = scheme_make_prim_w_arity(scheme_box_cas, "unsafe-box*-cas!", 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
@ -1915,6 +1915,11 @@ Scheme_Object *scheme_unbox_star(Scheme_Object *obj)
return SCHEME_BOX_VAL(obj);
}
static void bad_cas_box(Scheme_Object *box)
{
scheme_wrong_contract("box-cas!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &box);
}
Scheme_Object *scheme_box_cas(int argc, Scheme_Object *argv[])
XFORM_SKIP_PROC
{
@ -1923,11 +1928,11 @@ XFORM_SKIP_PROC
Scheme_Object *nv = argv[2];
/* This procedure is used for both the safe and unsafe version, but
* the JIT elides the checking for the unsafe version.
*/
the JIT elides the checking for the unsafe version. */
if (!SCHEME_MUTABLE_BOXP(box)) {
scheme_wrong_contract("box-cas!", "(and/c box? (not/c immutable?) (not/c impersonator?))", 0, 1, &box);
bad_cas_box(box);
return NULL;
}
#ifdef MZ_USE_FUTURES

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

File diff suppressed because it is too large Load Diff