From e92b588985f45606460a712684367f131df40f86 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Jan 2009 16:50:32 +0000 Subject: [PATCH] macro-expansion performance tweaks svn: r12972 --- collects/r5rs/main.ss | 2 + collects/scheme/private/more-scheme.ss | 70 ++++++++++++++------------ src/mzscheme/src/env.c | 9 +++- src/mzscheme/src/module.c | 34 +++++++++++++ src/mzscheme/src/stxobj.c | 15 +++++- 5 files changed, 94 insertions(+), 36 deletions(-) diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index 8c166179c2..e44267bdc0 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -164,6 +164,8 @@ ;; quote has to create mpairs: (syntax-local-lift-expression (let loop ([form #'form]) (syntax-case form () + [(a ...) + #`(mlist . #,(map loop (syntax->list #'(a ...))))] [(a . b) #`(mcons #,(loop #'a) #,(loop #'b))] [#(a ...) diff --git a/collects/scheme/private/more-scheme.ss b/collects/scheme/private/more-scheme.ss index 66aa55ca94..3f89be4be1 100644 --- a/collects/scheme/private/more-scheme.ss +++ b/collects/scheme/private/more-scheme.ss @@ -210,6 +210,16 @@ (define handler-prompt-key (make-continuation-prompt-tag)) + (define (call-handled-body body-thunk) + (with-continuation-mark + break-enabled-key + false-thread-cell + (call-with-continuation-prompt + body-thunk + handler-prompt-key + ;; On escape, apply the handler thunk + (lambda (thunk) (thunk))))) + (define-syntaxes (with-handlers with-handlers*) (let ([wh (lambda (disable-break?) @@ -222,44 +232,38 @@ [(handler-name ...) (generate-temporaries (map (lambda (x) 'with-handlers-handler) (syntax->list #'(handler ...))))]) (quasisyntax/loc stx - (let ([pred-name pred] ... - [handler-name handler] ...) + (let-values ([(pred-name) pred] ... + [(handler-name) handler] ...) ;; Capture current break parameterization, so we can use it to ;; evaluate the body (let ([bpz (continuation-mark-set-first #f break-enabled-key)]) ;; Disable breaks here, so that when the exception handler jumps ;; to run a handler, breaks are disabled for the handler - (with-continuation-mark - break-enabled-key - false-thread-cell - (call-with-continuation-prompt - (lambda () - ;; Restore the captured break parameterization for - ;; evaluating the `with-handlers' body. In this - ;; special case, no check for breaks is needed, - ;; because bpz is quickly restored past call/ec. - ;; Thus, `with-handlers' can evaluate its body in - ;; tail position. - (with-continuation-mark - break-enabled-key - bpz - (with-continuation-mark - exception-handler-key - (lambda (e) - ;; Deliver a thunk to the escape handler: - (abort-current-continuation - handler-prompt-key - (lambda () - (#,(if disable-break? - #'select-handler/no-breaks - #'select-handler/breaks-as-is) - e bpz - (list (cons pred-name handler-name) ...))))) - (let () - expr1 expr ...)))) - handler-prompt-key - ;; On escape, apply the handler thunk - (lambda (thunk) (thunk))))))))])))]) + (call-handled-body + (lambda () + ;; Restore the captured break parameterization for + ;; evaluating the `with-handlers' body. In this + ;; special case, no check for breaks is needed, + ;; because bpz is quickly restored past call/ec. + ;; Thus, `with-handlers' can evaluate its body in + ;; tail position. + (with-continuation-mark + break-enabled-key + bpz + (with-continuation-mark + exception-handler-key + (lambda (e) + ;; Deliver a thunk to the escape handler: + (abort-current-continuation + handler-prompt-key + (lambda () + (#,(if disable-break? + #'select-handler/no-breaks + #'select-handler/breaks-as-is) + e bpz + (list (cons pred-name handler-name) ...))))) + (let-values () + expr1 expr ...)))))))))])))]) (values (wh #t) (wh #f)))) (define (call-with-exception-handler exnh thunk) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index d39eaef82c..43affd3fea 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -4731,6 +4731,7 @@ local_lift_expr(int argc, Scheme_Object *argv[]) Scheme_Object *id, *local_mark, *expr, *data, *vec, *id_sym; Scheme_Lift_Capture_Proc cp; Scheme_Object *orig_expr; + char buf[24]; expr = argv[0]; if (!SCHEME_STXP(expr)) @@ -4753,7 +4754,13 @@ local_lift_expr(int argc, Scheme_Object *argv[]) expr = scheme_add_remove_mark(expr, local_mark); - id_sym = scheme_intern_exact_parallel_symbol("lifted", 6); + /* We don't really need a new symbol each time, since the mark + will generate new bindings. But lots of things work better or faster + when different bindings have different symbols. Use env->genv->id_counter + to help keep name generation deterministic within a module. */ + sprintf(buf, "lifted.%d", env->genv->id_counter++); + id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); id = scheme_add_remove_mark(id, scheme_new_mark()); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 28156d0998..581bc8569f 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4083,6 +4083,18 @@ static void *eval_module_body_k(void) return NULL; } +#if 0 +# define LOG_RUN_DECLS long start_time +# define LOG_START_RUN(mod) (start_time = scheme_get_process_milliseconds()) +# define LOG_END_RUN(mod) (printf("Ran %s [%d msec]\n", \ + scheme_write_to_string(mod->modname, NULL), \ + scheme_get_process_milliseconds() - start_time)) +#else +# define LOG_RUN_DECLS /* empty */ +# define LOG_START_RUN(mod) /* empty */ +# define LOG_END_RUN(mod) /* empty */ +#endif + static void eval_module_body(Scheme_Env *menv) { Scheme_Thread *p; @@ -4092,6 +4104,7 @@ static void eval_module_body(Scheme_Env *menv) int i, cnt; int volatile save_phase_shift; mz_jmp_buf newbuf, * volatile savebuf; + LOG_RUN_DECLS; menv->running = 1; menv->ran = 1; @@ -4104,6 +4117,8 @@ static void eval_module_body(Scheme_Env *menv) return; } + LOG_START_RUN(menv->module); + save_runstack = scheme_push_prefix(menv, m->prefix, m->me->src_modidx, menv->link_midx, 0, menv->phase); @@ -4149,6 +4164,8 @@ static void eval_module_body(Scheme_Env *menv) scheme_pop_prefix(save_runstack); } + + LOG_END_RUN(menv->module); } void scheme_run_module(Scheme_Env *menv, int set_ns) @@ -5218,6 +5235,18 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info) return data; } +#if 0 +# define LOG_EXPAND_DECLS long start_time +# define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds()) +# define LOG_END_EXPAND(mod) (printf("Expanded/compiled %s [%d msec]\n", \ + scheme_write_to_string(mod->modname, NULL), \ + scheme_get_process_milliseconds() - start_time)) +#else +# define LOG_EXPAND_DECLS /* empty */ +# define LOG_START_EXPAND(mod) /* empty */ +# define LOG_END_EXPAND(mod) /* empty */ +#endif + static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { @@ -5229,6 +5258,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *mbval, *orig_ii; int saw_mb, check_mb = 0; int restore_confusing_name = 0; + LOG_EXPAND_DECLS; if (!scheme_is_toplevel(env)) scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); @@ -5256,6 +5286,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, rmp = scheme_intern_resolved_module_path(rmp); m->modname = rmp; + LOG_START_EXPAND(m); + if (SAME_OBJ(m->modname, kernel_modname)) { /* Too confusing. Give it a different name while compiling. */ Scheme_Object *k2; @@ -5492,6 +5524,8 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, menv->rename_set = NULL; } + LOG_END_EXPAND(m); + SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm); return fm; } diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 72c2581d4f..2d7a8d2d80 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -2318,7 +2318,7 @@ static Scheme_Object *make_mapped_k(void) static void make_mapped(Scheme_Cert *cert) { - Scheme_Cert *stop; + Scheme_Cert *stop, *c2; Scheme_Object *pr; Scheme_Hash_Table *ht; @@ -2349,7 +2349,18 @@ static void make_mapped(Scheme_Cert *cert) make_mapped(stop); } - ht = scheme_make_hash_table_equal(); + /* Check whether an `eq?' table will work: */ + for (c2 = cert; c2 != stop; c2 = c2->next) { + if (c2->key) + break; + if (!SCHEME_INTP(c2->mark)) + break; + } + + if (c2 == stop) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = scheme_make_hash_table_equal(); pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop); cert->mapped = pr;