From dc14a68162346e1f7924be2db4aad26d3f9d9136 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 8 Jun 2017 06:59:58 -0600 Subject: [PATCH] fix performance problem in expander For a term (lambda (arg-id ...) (define def-id _rhs) ... (arg-id def-id) ...) the expander could take quadratic time in the number of `def-id`s due to walking an environment to remove use-site scopes. (The variant of the expander rewritten in Racket didn't have this problem.) --- .../tests/racket/optimize.rktl | 31 +++++++++++++++++++ racket/src/racket/src/compenv.c | 7 +++++ racket/src/racket/src/compile.c | 10 ++++-- racket/src/racket/src/mzmark_compenv.inc | 2 ++ racket/src/racket/src/mzmarksrc.c | 1 + racket/src/racket/src/schpriv.h | 1 + racket/src/racket/src/syntax.c | 2 +- 7 files changed, 50 insertions(+), 4 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index a4e89f457c..9bb6b6b5b3 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -6008,6 +6008,37 @@ (for ([s (in-list 'obviously-not-a-list)]) (unknown random-configuration))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Make sure the expander and compiler don't go quadratic +;; for +;; (lambda (arg-id ...) (define def-id _rhs) ... (arg-id def-id) ...) + +(let () + (define (gensym-n n) + (let loop ([i n]) + (if (zero? i) + '() + (cons (gensym) (loop (sub1 i)))))) + + (define (time-it n) + (let ([start (current-process-milliseconds)]) + (let* ([args (gensym-n n)] + [defns (gensym-n n)]) + (eval + `(lambda ,args + ,@(map (lambda (defn) `(define ,defn ',defn)) defns) + ,@(map (lambda (arg defn) `(,arg ,defn)) args defns)))) + (- (current-process-milliseconds) start))) + + (let loop ([tries 3]) + (let ([a (time-it 100)] + [b (time-it 1000)]) + ;; n lg(n) is ok, n^2 is not + (when (b . > . (* 50 a)) + (if (zero? tries) + (test 'fail "compilation took too long" (/ b a 1.0)) + (loop (sub1 tries))))))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index 2454118a4f..e79cd67780 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -262,6 +262,13 @@ Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, Schem init_compile_data(frame); + if (flags & SCHEME_USE_SCOPES_TO_NEXT) { + if (base->use_scopes_next) + frame->use_scopes_next = base->use_scopes_next; + else + frame->use_scopes_next = base; + } + return frame; } diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index 605bbfdbb7..dc2b8be6bd 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -792,9 +792,13 @@ Scheme_Object *scheme_revert_use_site_scopes(Scheme_Object *o, Scheme_Comp_Env * SCHEME_STX_REMOVE); } if (env->flags & (SCHEME_FOR_INTDEF | SCHEME_INTDEF_FRAME | SCHEME_INTDEF_SHADOW)) { - env = env->next; - if (!env) - break; + if (env->use_scopes_next) + env = env->use_scopes_next; + else { + env = env->next; + if (!env) + break; + } } else break; } diff --git a/racket/src/racket/src/mzmark_compenv.inc b/racket/src/racket/src/mzmark_compenv.inc index 4c97201a10..1fb9641673 100644 --- a/racket/src/racket/src/mzmark_compenv.inc +++ b/racket/src/racket/src/mzmark_compenv.inc @@ -16,6 +16,7 @@ static int mark_comp_env_MARK(void *p, struct NewGC *gc) { gcMARK2(e->insp, gc); gcMARK2(e->prefix, gc); gcMARK2(e->next, gc); + gcMARK2(e->use_scopes_next, gc); gcMARK2(e->scopes, gc); gcMARK2(e->value_name, gc); gcMARK2(e->observer, gc); @@ -54,6 +55,7 @@ static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->insp, gc); gcFIXUP2(e->prefix, gc); gcFIXUP2(e->next, gc); + gcFIXUP2(e->use_scopes_next, gc); gcFIXUP2(e->scopes, gc); gcFIXUP2(e->value_name, gc); gcFIXUP2(e->observer, gc); diff --git a/racket/src/racket/src/mzmarksrc.c b/racket/src/racket/src/mzmarksrc.c index 7f5fa9af90..8f20fb78ef 100644 --- a/racket/src/racket/src/mzmarksrc.c +++ b/racket/src/racket/src/mzmarksrc.c @@ -1293,6 +1293,7 @@ mark_comp_env { gcMARK2(e->insp, gc); gcMARK2(e->prefix, gc); gcMARK2(e->next, gc); + gcMARK2(e->use_scopes_next, gc); gcMARK2(e->scopes, gc); gcMARK2(e->value_name, gc); gcMARK2(e->observer, gc); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index dec7ec6346..257b7b8917 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -2881,6 +2881,7 @@ typedef struct Scheme_Comp_Env Scheme_Object *expand_result_adjust_arg; struct Scheme_Comp_Env *next; + struct Scheme_Comp_Env *use_scopes_next; /* fast-forward for use-site scope revert */ } Scheme_Comp_Env; #define LAMBDA_HAS_REST 1 diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 857c1c65c3..babc06a5fc 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -1284,7 +1284,7 @@ Scheme_Object *scheme_stx_adjust_scopes(Scheme_Object *o, Scheme_Scope_Set *scop return stx_adjust_scopes(o, scopes, phase, mode, &mutate); } -/* For each continuation frame, we need to keep track of various sets of scopes: +/* For each environment frame, we need to keep track of various sets of scopes: - bind scopes (normally 0 or 1) are created for the binding context - use-site scopes are created for macro expansions that need them - intdef scopes are for immediately nested internal-definition contexts;