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

macro-expansion performance tweaks

Browse Source 
svn: r12972
This commit is contained in:
Matthew Flatt 2009-01-02 16:50:32 +00:00
parent 9e42e5c876
commit e92b588985
5 changed files with 94 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/r5rs/main.ss
View File

@ -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 ...)

70
collects/scheme/private/more-scheme.ss
View File

@ -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)

9
src/mzscheme/src/env.c
View File

@ -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());

34
src/mzscheme/src/module.c
View File

@ -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;
}

15
src/mzscheme/src/stxobj.c
View File

@ -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;