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

301.11

Browse Source 
svn: r2469
This commit is contained in:
Matthew Flatt 2006-03-20 20:35:36 +00:00
parent 6a4dccff65
commit 693e173dd4
18 changed files with 6031 additions and 4671 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/mzscheme/include/scheme.h
View File

@ -1078,6 +1078,7 @@ enum {
MZCONFIG_ERROR_ESCAPE_HANDLER,
MZCONFIG_ALLOW_SET_UNDEFINED,
MZCONFIG_COMPILE_MODULE_CONSTS,
MZCONFIG_USE_JIT,
MZCONFIG_CUSTODIAN,

9073
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -55,7 +55,7 @@ Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][2];
#define MAX_CONST_TOPLEVEL_DEPTH 16
#define MAX_CONST_TOPLEVEL_POS 16
Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS];
Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1];
#define TABLE_CACHE_MAX_SIZE 2048
Scheme_Hash_Table *toplevels_ht;
@ -254,33 +254,40 @@ Scheme_Env *scheme_basic_env()
}
{
int i, k;
int i, k, cnst;
#ifndef USE_TAGGED_ALLOCATION
GC_CAN_IGNORE Scheme_Toplevel *all;
all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel)
* MAX_CONST_TOPLEVEL_DEPTH
* MAX_CONST_TOPLEVEL_POS);
* MAX_CONST_TOPLEVEL_POS
* (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
# ifdef MEMORY_COUNTING_ON
scheme_misc_count += (sizeof(Scheme_Toplevel) * MAX_CONST_TOPLEVEL_DEPTH * MAX_CONST_TOPLEVEL_POS);
scheme_misc_count += (sizeof(Scheme_Toplevel)
* MAX_CONST_TOPLEVEL_DEPTH
* MAX_CONST_TOPLEVEL_POS
* (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
# endif
#endif
for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) {
for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) {
Scheme_Toplevel *v;
for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) {
Scheme_Toplevel *v;
#ifndef USE_TAGGED_ALLOCATION
v = (all++);
v = (all++);
#else
v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel));
v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel));
#endif
v->so.type = scheme_toplevel_type;
v->depth = i;
v->position = k;
v->iso.so.type = scheme_toplevel_type;
v->depth = i;
v->position = k;
SCHEME_TOPLEVEL_FLAGS(v) = cnst;
toplevels[i][k] = (Scheme_Object *)v;
toplevels[i][k][cnst] = (Scheme_Object *)v;
}
}
}
}
@ -1311,17 +1318,26 @@ Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env)
return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, env, NULL);
}
static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved)
static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, int flags)
{
Scheme_Toplevel *tl;
Scheme_Object *v, *pr;
/* Important: non-resolved can't be cached, because the ISCONST
field is modified to track mutated module-level variables. But
the value for a specific toplevel is cached in the environment
layer. */
if (resolved) {
if ((depth < MAX_CONST_TOPLEVEL_DEPTH)
&& (position < MAX_CONST_TOPLEVEL_POS))
return toplevels[depth][position];
return toplevels[depth][position][flags];
pr = scheme_make_pair(scheme_make_integer(depth), scheme_make_integer(position));
pr = (flags
? scheme_make_pair(scheme_make_integer(position),
scheme_make_integer(flags))
: scheme_make_integer(position));
pr = scheme_make_pair(scheme_make_integer(depth), pr);
v = scheme_hash_get(toplevels_ht, pr);
if (v)
return v;
@ -1329,9 +1345,10 @@ static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved)
pr = NULL;
tl = (Scheme_Toplevel *)scheme_malloc_atomic_tagged(sizeof(Scheme_Toplevel));
tl->so.type = (resolved ? scheme_toplevel_type : scheme_compiled_toplevel_type);
tl->iso.so.type = (resolved ? scheme_toplevel_type : scheme_compiled_toplevel_type);
tl->depth = depth;
tl->position = position;
SCHEME_TOPLEVEL_FLAGS(tl) = flags;
if (resolved) {
if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) {
@ -1352,7 +1369,7 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
if (rec && rec[drec].dont_mark_local_use) {
/* Make up anything; it's going to be ignored. */
return make_toplevel(0, 0, 0);
return make_toplevel(0, 0, 0, 0);
}
ht = cp->toplevels;
@ -1365,7 +1382,7 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
if (o)
return o;
o = make_toplevel(0, cp->num_toplevels, 0);
o = make_toplevel(0, cp->num_toplevels, 0, 0);
cp->num_toplevels++;
scheme_hash_set(ht, var, o);
@ -1373,6 +1390,12 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
return o;
}
Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags)
{
Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl;
return make_toplevel(tl->depth, tl->position, 0, flags);
}
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec)
{
@ -2092,7 +2115,7 @@ void create_skip_table(Scheme_Comp_Env *start_frame)
scheme_variable_type (id is a global or module-bound variable),
or
scheme_module_variable_type (id is a module-boundvariable).
scheme_module_variable_type (id is a module-bound variable).
*/
@ -2493,7 +2516,7 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok
/* compile-time env for optimization */
/*========================================================================*/
Optimize_Info *scheme_optimize_info_create(void)
Optimize_Info *scheme_optimize_info_create()
{
Optimize_Info *info;
@ -2501,6 +2524,7 @@ Optimize_Info *scheme_optimize_info_create(void)
#ifdef MZTAG_REQUIRED
info->type = scheme_rt_optimize_info;
#endif
info->inline_fuel = 16;
return info;
}
@ -2648,13 +2672,13 @@ void scheme_optimize_mutated(Optimize_Info *info, int pos)
info->use[pos] = 1;
}
Scheme_Object *scheme_optimize_reverse_unless_mutated(Optimize_Info *info, int pos)
Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated)
/* pos is in new-frame counts, and we want to produce an old-frame reference if
it's not mutated */
{
int delta = 0;
while (info) {
while (1) {
if (pos < info->new_frame)
break;
pos -= info->new_frame;
@ -2662,8 +2686,9 @@ Scheme_Object *scheme_optimize_reverse_unless_mutated(Optimize_Info *info, int p
info = info->next;
}
if (info->use && info->use[pos])
return NULL;
if (unless_mutated)
if (info->use && info->use[pos])
return NULL;
return scheme_make_local(scheme_local_type, pos + delta);
}
@ -2683,7 +2708,7 @@ int scheme_optimize_is_used(Optimize_Info *info, int pos)
return 0;
}
static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j)
static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset)
{
Scheme_Object *p, *n;
int delta = 0;
@ -2703,7 +2728,15 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
n = SCHEME_VEC_ELS(p)[1];
if (SCHEME_INT_VAL(n) == pos) {
n = SCHEME_VEC_ELS(p)[2];
if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) {
if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) {
if (!closure_offset)
break;
else {
*closure_offset = delta;
}
} else if (closure_offset) {
return NULL;
} else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) {
int pos;
pos = SCHEME_LOCAL_POS(n);
@ -2714,7 +2747,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
a value, because chaining would normally happen on the
propagate-call side. Chaining there also means that we
avoid stack overflow here. */
n = do_optimize_info_lookup(info, pos, j);
n = do_optimize_info_lookup(info, pos, j, NULL);
if (!n) {
/* Return shifted reference to other local: */
@ -2727,14 +2760,15 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
p = SCHEME_VEC_ELS(p)[0];
}
register_stat_dist(info, pos, j);
if (!closure_offset)
register_stat_dist(info, pos, j);
return NULL;
}
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos)
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset)
{
return do_optimize_info_lookup(info, pos, 0);
return do_optimize_info_lookup(info, pos, 0, closure_offset);
}
Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags)
@ -2746,6 +2780,10 @@ Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int
naya->next = info;
naya->original_frame = orig;
naya->new_frame = current;
naya->inline_fuel = info->inline_fuel;
naya->letrec_not_twice = info->letrec_not_twice;
naya->enforce_const = info->enforce_const;
naya->top_level_consts = info->top_level_consts;
return naya;
}
@ -2868,6 +2906,7 @@ Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsi
naya->prefix = info->prefix;
naya->next = info;
naya->use_jit = info->use_jit;
naya->enforce_const = info->enforce_const;
naya->size = size;
naya->oldsize = oldsize;
naya->count = mapc;
@ -2982,7 +3021,8 @@ Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr)
return make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */
SCHEME_TOPLEVEL_POS(expr),
1);
1,
SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
}
/*========================================================================*/
@ -3732,17 +3772,39 @@ rename_transformer_p(int argc, Scheme_Object *argv[])
static Scheme_Object *write_toplevel(Scheme_Object *obj)
{
int pos, flags;
Scheme_Object *pr;
pos = SCHEME_TOPLEVEL_POS(obj);
flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK);
pr = (flags
? scheme_make_pair(scheme_make_integer(pos),
scheme_make_integer(flags))
: scheme_make_integer(pos));
return scheme_make_pair(scheme_make_integer(SCHEME_TOPLEVEL_DEPTH(obj)),
scheme_make_integer(SCHEME_TOPLEVEL_POS(obj)));
pr);
}
static Scheme_Object *read_toplevel(Scheme_Object *obj)
{
int pos, depth, flags;
if (!SCHEME_PAIRP(obj)) return NULL;
return make_toplevel(SCHEME_INT_VAL(SCHEME_CAR(obj)),
SCHEME_INT_VAL(SCHEME_CDR(obj)),
1);
depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (SCHEME_PAIRP(obj)) {
pos = SCHEME_INT_VAL(SCHEME_CAR(obj));
flags = SCHEME_INT_VAL(SCHEME_CDR(obj)) & SCHEME_TOPLEVEL_FLAGS_MASK;
} else {
pos = SCHEME_INT_VAL(obj);
flags = 0;
}
return make_toplevel(depth, pos, 1, flags);
}
static Scheme_Object *write_variable(Scheme_Object *obj)

643
src/mzscheme/src/eval.c
View File

@ -47,7 +47,7 @@
needed.
Tail calls are, for the most part, gotos within scheme_do_eval(). A
C function called y the main evaluation loop can perform a
C function called by the main evaluation loop can perform a
trampoling tail call via scheme_tail_apply. The trampoline must
return to its caller without allocating any memory, because an
allocation optimization in the tail-call code assumes no GCs will
@ -63,7 +63,8 @@
implemented by C functions outside the loop. Continuation
applications are handled directly in scheme_do_eval(). That leaves
calls to closures, which are also performed within scheme_do_eval()
(so that most tail calls avoid the trampoline).
(so that most tail calls avoid the trampoline), and native code,
which is analogous to a primitive.
The eval half of the loop detects a limited set of core syntactic
forms, such as application and letrecs. Otherwise, it dispatches to
@ -80,12 +81,14 @@
Compilation:
Compilation works in two passes. The first pass, called "compile",
performs most of the work and tracks variable usage (including
whether a variable is mutated or not). The second pass, called
"resolve", finishes compilation by computing variable offsets and
indirections (often mutating the records produced by the first
pass).
Compilation works in three passes. The first pass, called
"compile", performs most of the work and tracks variable usage
(including whether a variable is mutated or not). The second pass,
called "optimize", performs constant propagation, constant folding,
and function inlining; this pass mutates records produced by the
first pass. The third pass, called "resolve", finishes compilation
by computing variable offsets and indirections (often mutating the
records produced by the first pass).
Top-level variables (global or module) are referenced through the
Scheme stack, so that the variables can be "re-linked" each time a
@ -177,6 +180,7 @@ static Scheme_Object *expand_stx_to_top_form(int argc, Scheme_Object **argv);
static Scheme_Object *top_introduce_stx(int argc, Scheme_Object **argv);
static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv);
static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv);
static Scheme_Object *use_jit(int argc, Scheme_Object **argv);
static Scheme_Object *app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
@ -439,6 +443,11 @@ scheme_init_eval (Scheme_Env *env)
"compile-allow-set!-undefined",
MZCONFIG_ALLOW_SET_UNDEFINED),
env);
scheme_add_global_constant("compile-enforce-module-constants",
scheme_register_parameter(compile_module_constants,
"compile-enforce-module-constants",
MZCONFIG_COMPILE_MODULE_CONSTS),
env);
scheme_add_global_constant("eval-jit-enabled",
scheme_register_parameter(use_jit,
@ -686,7 +695,7 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
int scheme_omittable_expr(Scheme_Object *o, int vals)
/* Checks whether the bytecode `o' returns `vals' values with no
side-effects. */
side-effects. -1 for vals means that any return count is ok. */
{
Scheme_Type vtype;
@ -702,10 +711,10 @@ int scheme_omittable_expr(Scheme_Object *o, int vals)
|| (vtype == scheme_unclosed_procedure_type)
|| (vtype == scheme_compiled_unclosed_procedure_type)
|| (vtype == scheme_case_lambda_sequence_type))
return (vals == 1);
return ((vals == 1) || (vals < 0));
if ((vtype == scheme_compiled_quote_syntax_type)) {
return (vals == 1);
return ((vals == 1) || (vals < 0));
}
if ((vtype == scheme_branch_type)) {
@ -745,10 +754,10 @@ int scheme_omittable_expr(Scheme_Object *o, int vals)
if ((vtype == scheme_application_type)) {
/* Look for multiple values */
Scheme_App_Rec *app = (Scheme_App_Rec *)o;
if (app->num_args == vals) {
if ((app->num_args == vals) || (vals < 0)) {
if (SAME_OBJ(scheme_values_func, app->args[0])) {
int i;
for (i = vals; i--; ) {
for (i = app->num_args; i--; ) {
if (!scheme_omittable_expr(app->args[i + 1], 1))
return 0;
}
@ -759,7 +768,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals)
}
if ((vtype == scheme_application2_type)) {
if (vals == 1) {
if ((vals == 1) || (vals < 0)) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
if (SAME_OBJ(scheme_values_func, app->rator)) {
if (scheme_omittable_expr(app->rand, 1))
@ -770,7 +779,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals)
}
if ((vtype == scheme_application3_type)) {
if (vals == 2) {
if ((vals == 2) || (vals < 0)) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
if (SAME_OBJ(scheme_values_func, app->rator)) {
if (scheme_omittable_expr(app->rand1, 1)
@ -1139,7 +1148,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
total++;
} else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first))
&& scheme_omittable_expr(v, 1)) {
&& scheme_omittable_expr(v, -1)) {
/* A value that is not the result. We'll drop it. */
total++;
} else {
@ -1164,7 +1173,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
if (count == 1) {
if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1)) {
/* We can't optimize (begin expr cont) to expr because
/* We can't optimize (begin0 expr cont) to expr because
exp is not in tail position in the original (so we'd mess
up continuation marks. */
addconst = 1;
@ -1193,9 +1202,9 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
o->array[i++] = a[j];
}
} else if (opt
&& ((opt > 0 && (k < total))
&& (((opt > 0) && (k < total))
|| ((opt < 0) && k))
&& scheme_omittable_expr(v, 1)) {
&& scheme_omittable_expr(v, -1)) {
/* Value not the result. Do nothing. */
} else
o->array[i++] = v;
@ -1482,6 +1491,188 @@ Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info)
return first;
}
/*========================================================================*/
/* uncompile */
/*========================================================================*/
#if 0
/* For debugging, currently incomplete: */
static Scheme_Object *uncompile(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_uncompile_expr(Scheme_Object *expr, Resolve_Prefix *prefix);
static Scheme_Object *uncompile_k()
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
Resolve_Prefix *prefix = (Resolve_Prefix *)p->ku.k.p2;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
return scheme_uncompile_expr(expr, prefix);
}
Scheme_Object *scheme_uncompile_expr(Scheme_Object *expr, Resolve_Prefix *prefix)
{
char buf[32];
#ifdef DO_STACK_CHECK
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)expr;
p->ku.k.p2 = (void *)prefix;
return scheme_handle_stack_overflow(uncompile_k);
}
#endif
switch (SCHEME_TYPE(expr)) {
case scheme_toplevel_type:
{
expr = prefix->toplevels[SCHEME_TOPLEVEL_POS(expr)];
if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
return cons(scheme_intern_symbol("#%top"),
(Scheme_Object *)((Scheme_Bucket *)expr)->key);
} else {
Module_Variable *mv = (Module_Variable *)expr;
return cons(scheme_intern_symbol("#%top"),
cons(mv->modidx, mv->sym));
}
}
case scheme_local_type:
{
sprintf(buf, "@%d", SCHEME_LOCAL_POS(expr));
return scheme_intern_symbol(buf);
}
case scheme_local_unbox_type:
{
sprintf(buf, "@!%d", SCHEME_LOCAL_POS(expr));
return scheme_intern_symbol(buf);
}
case scheme_compiled_syntax_type:
{
return scheme_void;
}
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
int i;
expr = scheme_null;
for (i = app->num_args + 1; i--; ) {
expr = cons(scheme_uncompile_expr(app->args[i], prefix),
expr);
}
return expr;
}
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return cons(scheme_uncompile_expr(app->rator, prefix),
cons(scheme_uncompile_expr(app->rand, prefix),
scheme_null));
}
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return cons(scheme_uncompile_expr(app->rator, prefix),
cons(scheme_uncompile_expr(app->rand1, prefix),
cons(scheme_uncompile_expr(app->rand2, prefix),
scheme_null)));
}
case scheme_sequence_type:
case scheme_branch_type:
case scheme_with_cont_mark_type:
return scheme_void;
case scheme_let_value_type:
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)expr;
sprintf(buf, "@%d", lv->position);
return cons(scheme_intern_symbol("let!"),
cons(scheme_make_integer(lv->count),
cons(scheme_intern_symbol(buf),
cons(scheme_uncompile_expr(lv->value, prefix),
cons(scheme_uncompile_expr(lv->body, prefix),
scheme_null)))));
}
case scheme_let_void_type:
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)expr;
return cons(scheme_intern_symbol("let-undefined"),
cons(scheme_make_integer(lv->count),
cons(scheme_uncompile_expr(lv->body, prefix),
scheme_null)));
}
case scheme_letrec_type:
{
Scheme_Letrec *lr = (Scheme_Letrec *)expr;
int i;
expr = scheme_null;
for (i = lr->count; i--; ) {
sprintf(buf, "@%d", i);
expr = cons(cons(scheme_intern_symbol(buf),
cons(scheme_uncompile_expr(lr->procs[i], prefix),
scheme_null)),
expr);
}
return cons(scheme_intern_symbol("letrec!"),
cons(expr,
cons(scheme_uncompile_expr(lr->body, prefix),
scheme_null)));
}
case scheme_let_one_type:
{
Scheme_Let_One *lo = (Scheme_Let_One *)expr;
return cons(scheme_intern_symbol("let"),
cons(scheme_uncompile_expr(lo->value, prefix),
cons(scheme_uncompile_expr(lo->body, prefix),
scheme_null)));
}
case scheme_unclosed_procedure_type:
{
Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr;
Scheme_Object *vec;
int i;
vec = scheme_make_vector(data->closure_size, NULL);
for (i = data->closure_size; i--; ) {
SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(data->closure_map[i]);
}
return cons(scheme_intern_symbol((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? "lambda*" : "lambda"),
cons(data->name ? data->name : scheme_false,
cons(scheme_make_integer(data->num_params),
cons(vec,
cons(scheme_uncompile_expr(data->code, prefix),
scheme_null)))));
}
default:
if (SCHEME_CLOSUREP(expr)) {
return scheme_uncompile_expr((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr), prefix);
}
return cons(scheme_intern_symbol("quote"), cons(expr, scheme_null));
}
}
static Scheme_Object *
uncompile(int argc, Scheme_Object *argv[])
{
Scheme_Compilation_Top *t;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type))
scheme_wrong_type("compiled->datum", "compiled code", 0, argc, argv);
t = (Scheme_Compilation_Top *)argv[0];
return scheme_uncompile_expr(t->code, t->prefix);
}
#endif
/*========================================================================*/
/* optimize */
/*========================================================================*/
@ -1529,6 +1720,102 @@ static Scheme_Object *try_optimize_fold(Scheme_Object *f, Scheme_Object *o, Opti
return NULL;
}
static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info,
int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3)
{
Scheme_Let_Header *lh;
Scheme_Compiled_Let_Value *lv, *prev = NULL;
int i;
int *flags, flag;
if (!argc) {
info = scheme_optimize_info_add_frame(info, 0, 0, 0);
info->inline_fuel >>= 1;
p = scheme_optimize_expr(p, info);
scheme_optimize_info_done(info);
return p;
}
lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
lh->iso.so.type = scheme_compiled_let_void_type;
lh->count = argc;
lh->num_clauses = argc;
for (i = 0; i < argc; i++) {
lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
lv->so.type = scheme_compiled_let_value_type;
lv->count = 1;
lv->position = i;
if (app)
lv->value = app->args[i + 1];
else if (app3)
lv->value = (i ? app3->rand2 : app3->rand1);
else if (app2)
lv->value = app2->rand;
flag = scheme_closure_argument_flags(data, i);
flags = (int *)scheme_malloc_atomic(sizeof(int));
flags[0] = flag;
lv->flags = flags;
if (prev)
prev->body = (Scheme_Object *)lv;
else
lh->body = (Scheme_Object *)lv;
prev = lv;
}
if (prev)
prev->body = p;
else
lh->body = p;
return scheme_optimize_lets((Scheme_Object *)lh, info, 1);
}
Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc,
Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3)
{
int offset;
if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
/* Check for inling: */
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset);
} else if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_toplevel_type)) {
if (info->top_level_consts) {
int pos;
pos = SCHEME_TOPLEVEL_POS(le);
le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
if (le && !SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type))
le = NULL;
} else
le = NULL;
offset = 0;
} else {
le = NULL;
offset = 0;
}
if (le) {
Scheme_Closure_Data *data = (Scheme_Closure_Data *)le;
int sz;
if (data->num_params == argc) {
sz = scheme_closure_body_size(data, 1);
if ((sz >= 0) && (sz <= (info->inline_fuel * (argc + 2)))) {
le = scheme_optimize_clone(data->code, info, offset, argc);
if (le) {
/* fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"); */
return apply_inlined(le, data, info, argc, app, app2, app3);
}
}
}
}
return NULL;
}
static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info)
{
Scheme_Object *le;
@ -1542,6 +1829,12 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
max_let_depth = 0;
for (i = 0; i < n; i++) {
if (!i) {
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL);
if (le)
return le;
}
le = scheme_optimize_expr(app->args[i], info);
app->args[i] = le;
@ -1573,6 +1866,10 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
app = (Scheme_App2_Rec *)o;
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL);
if (le)
return le;
le = scheme_optimize_expr(app->rator, info);
app->rator = le;
@ -1604,6 +1901,10 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
app = (Scheme_App3_Rec *)o;
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app);
if (le)
return le;
le = scheme_optimize_expr(app->rator, info);
app->rator = le;
@ -1651,20 +1952,49 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info)
Scheme_Sequence *s = (Scheme_Sequence *)o;
Scheme_Object *le;
int i;
int max_let_depth = 0;
int max_let_depth = 0, drop = 0;
for (i = s->count; i--; ) {
le = scheme_optimize_expr(s->array[i], info);
s->array[i] = le;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
/* Inlining and constant propagation can expose
omittable expressions. */
if ((i + 1 != s->count)
&& scheme_omittable_expr(le, -1)) {
drop++;
s->array[i] = NULL;
} else {
s->array[i] = le;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
}
info->max_let_depth = 0;
}
info->size += 1;
info->max_let_depth = max_let_depth;
if (drop + 1 == s->count) {
return s->array[drop];
} else if (drop) {
Scheme_Sequence *s2;
int j = 0;
s2 = malloc_sequence(s->count - drop);
s2->so.type = scheme_sequence_type;
s2->count = s->count - drop;
for (i = 0; i < s->count; i++) {
if (s->array[i]) {
s2->array[j++] = s->array[i];
}
}
s = s2;
}
info->size += 1;
return (Scheme_Object *)s;
}
@ -1675,7 +2005,8 @@ int scheme_compiled_duplicate_ok(Scheme_Object *fb)
|| SCHEME_FALSEP(fb)
|| SCHEME_SYMBOLP(fb)
|| SCHEME_INTP(fb)
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type));
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type)
|| SCHEME_PRIMP(fb));
}
static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
@ -1713,6 +2044,13 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
} else
t = scheme_optimize_expr(t, info);
if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) {
if (SCHEME_FALSEP(t))
return scheme_optimize_expr(fb, info);
else
return scheme_optimize_expr(tb, info);
}
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
@ -1833,7 +2171,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
info->size += 1;
val = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr));
val = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), NULL);
if (val)
return val;
@ -1866,8 +2204,36 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
case scheme_compiled_unclosed_procedure_type:
return scheme_optimize_closure_compilation(expr, info);
case scheme_compiled_let_void_type:
return scheme_optimize_lets(expr, info);
return scheme_optimize_lets(expr, info, 0);
case scheme_compiled_toplevel_type:
if (info->top_level_consts) {
int pos;
Scheme_Object *c;
pos = SCHEME_TOPLEVEL_POS(expr);
c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
if (c) {
if (scheme_compiled_duplicate_ok(c))
return c;
/* We can't inline, but mark the top level as a constant,
so we can direct-jump and avoid null checks in JITed code: */
expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST);
} else {
/* false is mapped to a table of non-constant ready values: */
c = scheme_hash_get(info->top_level_consts, scheme_false);
if (c) {
c = scheme_hash_get((Scheme_Hash_Table *)c, scheme_make_integer(pos));
if (c) {
/* We can't inline, but mark the top level as ready,
so we can avoid null checks in JITed code: */
expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY);
}
}
}
}
scheme_optimize_info_used_top(info);
return expr;
case scheme_compiled_quote_syntax_type:
scheme_optimize_info_used_top(info);
return expr;
@ -1910,6 +2276,195 @@ Scheme_Object *scheme_optimize_list(Scheme_Object *expr, Optimize_Info *info)
return first;
}
Scheme_Object *scheme_optimize_clone(Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth)
/* Past closure_depth, need to reverse optimize to unoptimzed with respect to info;
delta is the amount to skip in info to get to the frame that bound the code */
{
int t;
t = SCHEME_TYPE(expr);
switch(t) {
case scheme_local_type:
{
int pos = SCHEME_LOCAL_POS(expr);
if (pos >= closure_depth) {
expr = scheme_optimize_reverse(info, pos + delta - closure_depth, 0);
if (closure_depth)
expr = scheme_make_local(scheme_local_type, SCHEME_LOCAL_POS(expr) + closure_depth);
}
return expr;
}
case scheme_compiled_syntax_type:
{
Scheme_Syntax_Cloner f;
f = scheme_syntax_cloners[SCHEME_PINT_VAL(expr)];
if (!f) return NULL;
return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info, delta, closure_depth);
}
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr, *app2;
app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
app2->iso.so.type = scheme_application2_type;
expr = scheme_optimize_clone(app->rator, info, delta, closure_depth);
if (!expr) return NULL;
app2->rator = expr;
expr = scheme_optimize_clone(app->rand, info, delta, closure_depth);
if (!expr) return NULL;
app2->rand = expr;
return (Scheme_Object *)app2;
}
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)expr, *app2;
int i;
app2 = scheme_malloc_application(app->num_args + 1);
for (i = app->num_args + 1; i--; ) {
expr = scheme_optimize_clone(app->args[i], info, delta, closure_depth);
if (!expr) return NULL;
app2->args[i] = expr;
}
return (Scheme_Object *)app2;
}
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr, *app2;
app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
app2->iso.so.type = scheme_application3_type;
expr = scheme_optimize_clone(app->rator, info, delta, closure_depth);
if (!expr) return NULL;
app2->rator = expr;
expr = scheme_optimize_clone(app->rand1, info, delta, closure_depth);
if (!expr) return NULL;
app2->rand1 = expr;
expr = scheme_optimize_clone(app->rand2, info, delta, closure_depth);
if (!expr) return NULL;
app2->rand2 = expr;
return (Scheme_Object *)app2;
}
case scheme_compiled_let_void_type:
{
Scheme_Let_Header *head = (Scheme_Let_Header *)expr, *head2;
Scheme_Object *body;
Scheme_Compiled_Let_Value *lv, *lv2, *prev = NULL;
int i, *flags, sz;
head2 = MALLOC_ONE_TAGGED(Scheme_Let_Header);
head2->iso.so.type = scheme_compiled_let_void_type;
head2->count = head->count;
head2->num_clauses = head->num_clauses;
SCHEME_LET_RECURSIVE(head2) = SCHEME_LET_RECURSIVE(head);
/* Build let-value change: */
body = head->body;
for (i = head->num_clauses; i--; ) {
lv = (Scheme_Compiled_Let_Value *)body;
sz = sizeof(int) * lv->count;
flags = (int *)scheme_malloc_atomic(sz);
memcpy(flags, lv->flags, sz);
lv2 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
lv2->so.type = scheme_compiled_let_value_type;
lv2->count = lv->count;
lv2->position = lv->position;
lv2->flags = flags;
expr = scheme_optimize_clone(lv->value, info, delta, closure_depth + head->count);
if (!expr) return NULL;
lv2->value = expr;
if (prev)
prev->body = (Scheme_Object *)lv2;
else
head2->body = (Scheme_Object *)lv2;
prev = lv2;
body = lv->body;
}
if (prev)
prev->body = body;
else
head2->body = body;
expr = scheme_optimize_clone(body, info, delta, closure_depth + head->count);
if (!expr) return NULL;
if (prev)
prev->body = expr;
else
head2->body = expr;
return (Scheme_Object *)head2;
}
case scheme_sequence_type:
case scheme_begin0_sequence_type:
{
Scheme_Sequence *seq = (Scheme_Sequence *)expr, *seq2;
int i;
seq2 = malloc_sequence(seq->count);
seq2->so.type = seq->so.type;
seq2->count = seq->count;
for (i = seq->count; i--; ) {
expr = scheme_optimize_clone(seq->array[i], info, delta, closure_depth);
if (!expr) return NULL;
seq2->array[i] = expr;
}
return (Scheme_Object *)seq2;
}
case scheme_branch_type:
{
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr, *b2;
b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b2->so.type = scheme_branch_type;
expr = scheme_optimize_clone(b->test, info, delta, closure_depth);
if (!expr) return NULL;
b2->test = expr;
expr = scheme_optimize_clone(b->tbranch, info, delta, closure_depth);
if (!expr) return NULL;
b2->tbranch = expr;
expr = scheme_optimize_clone(b->fbranch, info, delta, closure_depth);
if (!expr) return NULL;
b2->fbranch = expr;
return (Scheme_Object *)b2;
}
case scheme_compiled_unclosed_procedure_type:
return scheme_clone_closure_compilation(expr, info, delta, closure_depth);
case scheme_compiled_toplevel_type:
case scheme_compiled_quote_syntax_type:
return expr;
default:
if (t > _scheme_compiled_values_types_) {
if (scheme_compiled_duplicate_ok(expr))
return expr;
}
}
return NULL;
}
/*========================================================================*/
/* JIT */
/*========================================================================*/
@ -2130,7 +2685,7 @@ static Scheme_Object *jit_letrec(Scheme_Object *o)
lr2->procs = procs2;
for (i = 0; i < count; i++) {
v = scheme_jit_closure(procs[i], lr2);
v = scheme_jit_closure(procs[i], (Scheme_Object *)lr2);
procs2[i] = v;
}
@ -2442,12 +2997,13 @@ static void *compile_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *form;
int writeable, for_eval, rename;
int writeable, for_eval, rename, enforce_consts;
Scheme_Env *genv;
Scheme_Compile_Info rec, rec2;
Scheme_Object *o, *tl_queue;
Scheme_Compilation_Top *top;
Resolve_Prefix *rp;
Resolve_Info *ri;
Optimize_Info *oi;
Scheme_Object *gval, *insp;
Scheme_Comp_Env *cenv;
@ -2478,7 +3034,12 @@ static void *compile_k(void)
tl_queue = scheme_null;
insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
{
Scheme_Config *config;
config = scheme_current_config();
insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS));
}
while (1) {
rec.comp = 1;
@ -2560,12 +3121,15 @@ static void *compile_k(void)
} else
break;
}
oi = scheme_optimize_info_create();
oi = scheme_optimize_info_create(cenv);
oi->enforce_const = enforce_consts;
o = scheme_optimize_expr(o, oi);
rp = scheme_resolve_prefix(0, cenv->prefix, 1);
o = scheme_resolve_expr(o, scheme_resolve_info_create(rp));
rp = scheme_resolve_prefix(0, cenv->prefix, 1);
ri = scheme_resolve_info_create(rp);
ri->enforce_const = enforce_consts;
o = scheme_resolve_expr(o, ri);
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
top->so.type = scheme_compilation_top_type;
@ -5711,7 +6275,6 @@ compiled_p(int argc, Scheme_Object *argv[])
: scheme_false);
}
static Scheme_Object *expand(int argc, Scheme_Object **argv)
{
Scheme_Env *env;
@ -6012,6 +6575,14 @@ static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv)
-1, NULL, NULL, 1);
}
static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv)
{
return scheme_param_config("compile-enforce-module-constants",
scheme_make_integer(MZCONFIG_COMPILE_MODULE_CONSTS),
argc, argv,
-1, NULL, NULL, 1);
}
static Scheme_Object *use_jit(int argc, Scheme_Object **argv)
{
return scheme_param_config("eval-jit-enabled",
@ -6350,7 +6921,7 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, char *stack,
mzshort *map;
char *new_stack;
sz = data->max_let_depth + data->num_params;
sz = data->max_let_depth;
map = data->closure_map;
new_stack = scheme_malloc_atomic(sz);

181
src/mzscheme/src/fun.c
View File

@ -116,6 +116,7 @@ static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv);
static Scheme_Object *object_name(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
@ -383,6 +384,11 @@ scheme_init_fun (Scheme_Env *env)
"procedure-arity-includes?",
2, 2, 1),
env);
scheme_add_global_constant("procedure-closure-contents-eq?",
scheme_make_folding_prim(procedure_equal_closure_p,
"procedure-closure-contents-eq?",
2, 2, 1),
env);
scheme_add_global_constant("primitive?",
scheme_make_folding_prim(primitive_p,
@ -716,7 +722,7 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
return (Scheme_Object *)closure;
}
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Letrec *lr)
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context)
/* If lr is supplied as a letrec binding this closure, it may be used
for JIT compilation. */
{
@ -729,7 +735,7 @@ Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Letrec *lr)
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data, code, sizeof(Scheme_Closure_Data));
data->context = (Scheme_Object *)lr;
data->context = context;
ndata = scheme_generate_lambda(data, 1, NULL);
data->native_code = ndata;
@ -753,7 +759,7 @@ typedef struct {
int *local_flags;
mzshort base_closure_size; /* doesn't include top-level (if any) */
mzshort *base_closure_map;
short has_tl;
short has_tl, body_size;
} Closure_Info;
Scheme_Object *
@ -786,6 +792,10 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
cl->base_closure_map = dcm;
if (scheme_env_uses_toplevel(info))
cl->has_tl = 1;
cl->body_size = info->size;
info->size++;
info->inline_fuel++;
data->closure_size = (cl->base_closure_size
+ (cl->has_tl ? 1 : 0));
@ -800,6 +810,62 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
return (Scheme_Object *)data;
}
Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth)
{
Scheme_Closure_Data *data, *data2;
Scheme_Object *body;
Closure_Info *cl;
int *flags, sz;
data = (Scheme_Closure_Data *)_data;
body = scheme_optimize_clone(data->code, info, delta, closure_depth + data->num_params);
if (!body) return NULL;
data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data2, data, sizeof(Scheme_Closure_Data));
data2->code = body;
cl = MALLOC_ONE_RT(Closure_Info);
memcpy(cl, data->closure_map, sizeof(Closure_Info));
data2->closure_map = (mzshort *)cl;
sz = sizeof(int) * data2->num_params;
flags = (int *)scheme_malloc_atomic(sz);
memcpy(flags, cl->local_flags, sz);
cl->local_flags = flags;
return (Scheme_Object *)data2;
}
int scheme_closure_body_size(Scheme_Closure_Data *data, int check_assign)
{
int i;
Closure_Info *cl;
cl = (Closure_Info *)data->closure_map;
if (check_assign) {
/* Don't try to inline if there's a rest arg: */
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
return -1;
/* Don't try to inline if any arguments are mutated: */
for (i = data->num_params; i--; ) {
if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
return -1;
}
}
return cl->body_size;
}
int scheme_closure_argument_flags(Scheme_Closure_Data *data, int i)
{
return ((Closure_Info *)data->closure_map)->local_flags[i];
}
Scheme_Object *
scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
{
@ -2389,6 +2455,115 @@ static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[])
return scheme_get_or_check_arity(argv[0], n);
}
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *v1 = argv[0], *v2 = argv[1];
if (!SCHEME_PROCP(v1))
scheme_wrong_type("procedure-closure-contents-eq?", "procedure", 0, argc, argv);
if (!SCHEME_PROCP(v2))
scheme_wrong_type("procedure-closure-contents-eq?", "procedure", 1, argc, argv);
if (SAME_OBJ(v1, v2))
return scheme_true;
if (!SAME_TYPE(SCHEME_TYPE(v1), SCHEME_TYPE(v2)))
return scheme_false;
switch (SCHEME_TYPE(v1)) {
case scheme_prim_type:
{
Scheme_Primitive_Proc *p1 = (Scheme_Primitive_Proc *)v1;
Scheme_Primitive_Proc *p2 = (Scheme_Primitive_Proc *)v2;
if (p1->prim_val == p2->prim_val) {
if (p1->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
return scheme_false;
/* They both are closures, but we don't know how
many fields in each, except in 3m mode. So
give up. */
return scheme_false;
} else if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
return scheme_true;
}
}
break;
case scheme_closure_type:
{
Scheme_Closure *c1 = (Scheme_Closure *)v1;
Scheme_Closure *c2 = (Scheme_Closure *)v2;
if (SAME_OBJ(c1->code, c2->code)) {
int i;
for (i = c1->code->closure_size; i--; ) {
if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
return scheme_false;
}
return scheme_true;
}
}
break;
case scheme_native_closure_type:
{
Scheme_Native_Closure *c1 = (Scheme_Native_Closure *)v1;
Scheme_Native_Closure *c2 = (Scheme_Native_Closure *)v2;
if (SAME_OBJ(c1->code, c2->code)) {
int i;
i = c1->code->closure_size;
if (i < 0) {
/* A case closure */
Scheme_Native_Closure *sc1, *sc2;
int j;
i = -(i + 1);
while (i--) {
sc1 = (Scheme_Native_Closure *)c1->vals[i];
sc2 = (Scheme_Native_Closure *)c2->vals[i];
j = sc1->code->closure_size;
while (j--) {
if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
return scheme_false;
}
}
} else {
/* Normal closure: */
while (i--) {
if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
return scheme_false;
}
}
return scheme_true;
}
}
break;
case scheme_case_closure_type:
{
Scheme_Case_Lambda *c1 = (Scheme_Case_Lambda *)v1;
Scheme_Case_Lambda *c2 = (Scheme_Case_Lambda *)v2;
if (c1->count == c2->count) {
Scheme_Closure *sc1, *sc2;
int i, j;
for (i = c1->count; i--; ) {
sc1 = (Scheme_Closure *)c1->array[i];
sc2 = (Scheme_Closure *)c2->array[i];
if (!SAME_OBJ(sc1->code, sc2->code))
return scheme_false;
for (j = sc1->code->closure_size; j--; ) {
if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
return scheme_false;
}
}
return scheme_true;
}
}
break;
}
return scheme_false;
}
static Scheme_Object *
apply(int argc, Scheme_Object *argv[])
{

81
src/mzscheme/src/jit.c
View File

@ -97,7 +97,7 @@ typedef struct {
int need_set_rs;
void **retain_start;
int log_depth;
int self_pos, self_closure_size;
int self_pos, self_closure_size, self_toplevel_pos;
void *self_restart_code;
Scheme_Native_Closure *nc;
} mz_jit_state;
@ -320,6 +320,7 @@ static void *generate_one(mz_jit_state *old_jitter,
mappings[0] = 0;
jitter->max_extra_pushed = max_extra_pushed;
jitter->self_pos = 1; /* beyond end of stack */
jitter->self_toplevel_pos = -1;
ok = generate(jitter, data);
@ -1460,24 +1461,55 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
} else {
Scheme_Type t;
t = SCHEME_TYPE(rator);
if ((t == scheme_local_type) || (t > _scheme_values_types_)) {
/* We can re-order evaluation. */
if (t == scheme_local_type) {
/* We can re-order evaluation of the rator. */
reorder_ok = 1;
/* Call to known native, or even known self? */
if (SAME_TYPE(t, scheme_local_type)) {
int pos;
pos = SCHEME_LOCAL_POS(rator) - num_rands;
if (mz_is_closure(jitter, pos, num_rands)) {
direct_native = 1;
if (is_tail
&& (pos == jitter->self_pos)
&& (num_rands < MAX_SHARED_CALL_RANDS)) {
direct_self = 1;
}
}
}
} else if ((t == scheme_toplevel_type)
&& (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_CONST)) {
/* We can re-order evaluation of the rator. */
reorder_ok = 1;
if (jitter->nc) {
Scheme_Object *p;
p = extract_global(rator, jitter->nc);
p = ((Scheme_Bucket *)p)->val;
if (SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) {
if (scheme_native_arity_check(p, num_rands)
/* If it also accepts num_rands + 1, then it has a vararg,
so don't try direct_native. */
&& !scheme_native_arity_check(p, num_rands + 1)) {
direct_native = 1;
if (is_tail
&& (SCHEME_TOPLEVEL_POS(rator) == jitter->self_toplevel_pos)
&& (num_rands < MAX_SHARED_CALL_RANDS)) {
direct_self = 1;
}
}
}
}
} else if (t > _scheme_values_types_) {
/* We can re-order evaluation of the rator. */
reorder_ok = 1;
}
if (SAME_TYPE(t, scheme_local_type)) {
int pos;
pos = SCHEME_LOCAL_POS(rator) - num_rands;
if (mz_is_closure(jitter, pos, num_rands)) {
direct_native = 1;
if (is_tail
&& (pos == jitter->self_pos)
&& (num_rands < MAX_SHARED_CALL_RANDS)) {
direct_self = 1;
reorder_ok = 0;
}
}
}
if (direct_self)
reorder_ok = 0; /* superceded by direct_self */
}
if (num_rands) {
@ -2789,8 +2821,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* Extract bucket value */
jit_ldxi_p(JIT_R0, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val));
CHECK_LIMIT();
/* Is it NULL? */
(void)jit_beqi_p(unbound_global_code, JIT_R0, 0);
if (!(SCHEME_TOPLEVEL_FLAGS(obj)
& (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))) {
/* Is it NULL? */
(void)jit_beqi_p(unbound_global_code, JIT_R0, 0);
}
END_JIT_DATA(0);
return 1;
}
@ -3282,6 +3317,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
if (lv->count == 1) {
/* Expect one result: */
generate_non_tail(lv->value, jitter, 0, 1);
CHECK_LIMIT();
if (ab) {
pos = mz_remap(lv->position);
jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos));
@ -3459,6 +3495,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* No need to push mark onto value stack: */
jit_movr_p(JIT_V1, JIT_R0);
generate_non_tail(wcm->val, jitter, 0, 1);
CHECK_LIMIT();
} else {
mz_pushr_p(JIT_R0); /* !!!!!!! */
generate_non_tail(wcm->val, jitter, 0, 1);
@ -4359,7 +4396,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
/* If we have a letrec context, record arities */
if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type)) {
Scheme_Letrec *lr = (Scheme_Letrec *)data->context;
int pos, self_pos = - 1;
int pos, self_pos = -1;
for (i = data->closure_size; i--; ) {
pos = data->closure_map[i];
if (pos < lr->count) {
@ -4380,6 +4417,12 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
}
} else {
mz_runstack_pushed(jitter, cnt);
/* A define-values context? */
if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_toplevel_type)) {
jitter->self_toplevel_pos = SCHEME_TOPLEVEL_POS(data->context);
jitter->self_closure_size = data->closure_size;
}
}
LOG_IT(("PROC: %s\n", (data->name ? scheme_format_utf8("~s", 2, 1, &data->name, NULL) : "???")));

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

@ -201,11 +201,13 @@ void scheme_init_module(Scheme_Env *env)
scheme_register_syntax(MODULE_EXPD,
module_optimize,
module_resolve, module_validate,
module_execute, module_jit, -1);
module_execute, module_jit,
NULL, -1);
scheme_register_syntax(REQUIRE_EXPD,
top_level_require_optimize,
top_level_require_resolve, top_level_require_validate,
top_level_require_execute, top_level_require_jit, 2);
top_level_require_execute, top_level_require_jit,
NULL, 2);
scheme_add_global_keyword("module",
scheme_make_compiled_syntax(module_syntax,
@ -3089,15 +3091,133 @@ static Scheme_Object *
module_optimize(Scheme_Object *data, Optimize_Info *info)
{
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *e, *b;
int max_let_depth = 0;
Scheme_Object *e, *b, *vars, *start_simltaneous_b;
Scheme_Hash_Table *consts = NULL, *ready_table = NULL;
int max_let_depth = 0, cont;
start_simltaneous_b = m->body;
for (b = m->body; !SCHEME_NULLP(b); b = SCHEME_CDR(b)) {
/* Optimzie this expression: */
e = scheme_optimize_expr(SCHEME_CAR(b), info);
SCHEME_CAR(b) = e;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
if (info->enforce_const) {
/* If this expression/definition can't have any side effect
(including raising an exception), then continue the group of
simultaneous definitions: */
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_syntax_type)
&& (SCHEME_PINT_VAL(e) == DEFINE_VALUES_EXPD)) {
int n;
e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
vars = SCHEME_CAR(e);
e = SCHEME_CDR(e);
n = scheme_list_length(vars);
cont = scheme_omittable_expr(e, n);
if ((n == 1) && scheme_compiled_propagate_ok(e)) {
Scheme_Toplevel *tl;
tl = (Scheme_Toplevel *)SCHEME_CAR(vars);
if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) {
Scheme_Object *e2;
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
e2 = scheme_optimize_clone(e, info, 0, 0);
} else {
e2 = e;
}
if (e2) {
int pos;
if (!consts)
consts = scheme_make_hash_table(SCHEME_hash_ptr);
pos = tl->position;
scheme_hash_set(consts, scheme_make_integer(pos), e2);
} else {
/* At least mark it as ready */
if (!ready_table) {
ready_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!consts)
consts = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table);
}
scheme_hash_set(ready_table, scheme_make_integer(tl->position), scheme_true);
}
}
} else {
/* The binding is not inlinable/propagatable, but unless it's
set!ed, it is constant after evaluating the definition. We
map the top-level position to indicate constantness. */
Scheme_Object *l, *a;
int pos;
for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
/* Test for ISCONST to indicate no set!: */
if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) {
pos = SCHEME_TOPLEVEL_POS(a);
if (!ready_table) {
ready_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!consts)
consts = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table);
}
scheme_hash_set(ready_table, scheme_make_integer(pos), scheme_true);
}
}
}
} else {
cont = scheme_omittable_expr(e, 1);
}
if (SCHEME_NULLP(SCHEME_CDR(b)))
cont = 0;
} else
cont = 1;
if (!cont) {
/* If we have new constants, re-optimize to inline: */
if (consts) {
if (!info->top_level_consts) {
info->top_level_consts = consts;
} else {
int i;
for (i = 0; i < consts->size; i++) {
if (consts->vals[i]) {
scheme_hash_set(info->top_level_consts,
consts->keys[i],
consts->vals[i]);
}
}
}
while (1) {
/* Re-optimize this expression: */
e = scheme_optimize_expr(SCHEME_CAR(start_simltaneous_b), info);
SCHEME_CAR(start_simltaneous_b) = e;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
if (SAME_OBJ(start_simltaneous_b, b))
break;
start_simltaneous_b = SCHEME_CDR(start_simltaneous_b);
}
}
consts = NULL;
start_simltaneous_b = SCHEME_CDR(b);
}
}
m->max_let_depth = max_let_depth;
@ -3108,20 +3228,23 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
}
static Scheme_Object *
module_resolve(Scheme_Object *data, Resolve_Info *rslv)
module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
{
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *b;
Resolve_Prefix *rp;
Resolve_Info *rslv;
rp = scheme_resolve_prefix(0, m->comp_prefix, 1);
m->comp_prefix = NULL;
m->prefix = rp;
b = scheme_resolve_expr(m->dummy, rslv);
b = scheme_resolve_expr(m->dummy, old_rslv);
m->dummy = b;
rslv = scheme_resolve_info_create(rp);
rslv->enforce_const = old_rslv->enforce_const;
rslv->in_module = 1;
for (b = m->body; !SCHEME_NULLP(b); b = SCHEME_CDR(b)) {
Scheme_Object *e;
@ -4041,7 +4164,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
}
m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
oi = scheme_optimize_info_create();
oi = scheme_optimize_info_create(eenv);
m = scheme_optimize_expr(m, oi);
/* Simplify only in compile mode; it is too slow in expand mode. */

2
src/mzscheme/src/mzmark.c
View File

@ -2420,6 +2420,7 @@ static int mark_optimize_info_MARK(void *p) {
gcMARK(i->next);
gcMARK(i->use);
gcMARK(i->consts);
gcMARK(i->top_level_consts);
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
@ -2433,6 +2434,7 @@ static int mark_optimize_info_FIXUP(void *p) {
gcFIXUP(i->next);
gcFIXUP(i->use);
gcFIXUP(i->consts);
gcFIXUP(i->top_level_consts);
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));

1
src/mzscheme/src/mzmarksrc.c
View File

@ -958,6 +958,7 @@ mark_optimize_info {
gcMARK(i->next);
gcMARK(i->use);
gcMARK(i->consts);
gcMARK(i->top_level_consts);
size:
gcBYTES_TO_WORDS(sizeof(Optimize_Info));

54
src/mzscheme/src/port.c
View File

@ -3891,18 +3891,20 @@ scheme_file_position(int argc, Scheme_Object *argv[])
if (!SCHEME_OUTPORTP(argv[0]) && !SCHEME_INPORTP(argv[0]))
scheme_wrong_type("file-position", "port", 0, argc, argv);
if (argc == 2) {
int ok = 0;
if (!SCHEME_EOFP(argv[1])) {
int ok = 0;
if (SCHEME_INTP(argv[1])) {
ok = (SCHEME_INT_VAL(argv[1]) >= 0);
if (SCHEME_INTP(argv[1])) {
ok = (SCHEME_INT_VAL(argv[1]) >= 0);
}
if (SCHEME_BIGNUMP(argv[1])) {
ok = SCHEME_BIGPOS(argv[1]);
}
if (!ok)
scheme_wrong_type("file-position", "non-negative exact integer or eof", 1, argc, argv);
}
if (SCHEME_BIGNUMP(argv[1])) {
ok = SCHEME_BIGPOS(argv[1]);
}
if (!ok)
scheme_wrong_type("file-position", "non-negative exact integer", 1, argc, argv);
}
f = NULL;
@ -3972,34 +3974,45 @@ scheme_file_position(int argc, Scheme_Object *argv[])
scheme_make_provided_string(argv[0], 2, NULL));
if (argc > 1) {
long n = SCHEME_INT_VAL(argv[1]);
long n;
int whence;
if (SCHEME_INTP(argv[1])) {
n = SCHEME_INT_VAL(argv[1]);
whence = SEEK_SET;
} else {
n = 0;
whence = SEEK_END;
}
if (f) {
if (fseek(f, n, 0)) {
if (fseek(f, n, whence)) {
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
"file-position: position change failed on file (%e)",
errno);
}
#ifdef MZ_FDS
} else if (had_fd) {
long n = SCHEME_INT_VAL(argv[1]), lv;
long lv;
if (SCHEME_OUTPORTP(argv[0])) {
flush_fd((Scheme_Output_Port *)argv[0], NULL, 0, 0, 0, 0);
}
# ifdef WINDOWS_FILE_HANDLES
lv = SetFilePointer((HANDLE)fd, n, NULL, FILE_BEGIN);
lv = SetFilePointer((HANDLE)fd, n, NULL,
((whence == SEEK_SET) ? FILE_BEGIN : FILE_END));
# else
# ifdef MAC_FILE_HANDLES
{
errno = SetFPos(fd, fsFromStart, n);
{
errno = SetFPos(fd, ((whence == SEEK_SET) ? fsFromStart : fsFromLEOF), n);
if (errno == noErr)
lv = 0;
else
lv = -1;
}
# else
lv = lseek(fd, n, 0);
lv = lseek(fd, n, whence);
# endif
# endif
@ -4025,6 +4038,9 @@ scheme_file_position(int argc, Scheme_Object *argv[])
}
#endif
} else {
if (whence == SEEK_END) {
n = is->size;
}
if (wis) {
if (is->index > is->u.hot)
is->u.hot = is->index;

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 859
#define EXPECTED_PRIM_COUNT 861
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

48
src/mzscheme/src/schpriv.h
View File

@ -399,6 +399,7 @@ extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator);
#define GLOB_IS_PERMANENT 8
#define GLOB_HAS_REF_ID 16
#define GLOB_HAS_HOME_PTR 32
#define GLOB_IS_IMMUTATED 64
typedef struct {
Scheme_Bucket bucket;
@ -738,13 +739,20 @@ typedef struct Scheme_Local {
#define SCHEME_LOCAL_POS(obj) (((Scheme_Local *)(obj))->position)
typedef struct Scheme_Toplevel {
Scheme_Object so;
Scheme_Inclhash_Object iso; /* keyex used for const flag */
mzshort depth;
int position;
} Scheme_Toplevel;
#define SCHEME_TOPLEVEL_DEPTH(obj) (((Scheme_Toplevel *)(obj))->depth)
#define SCHEME_TOPLEVEL_POS(obj) (((Scheme_Toplevel *)(obj))->position)
#define SCHEME_TOPLEVEL_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Toplevel *)(obj))->iso)
#define SCHEME_TOPLEVEL_CONST 0x1
#define SCHEME_TOPLEVEL_MUTATED 0x2
#define SCHEME_TOPLEVEL_READY 0x2
/* MUTATED and READY flags are used in different contexts */
#define SCHEME_TOPLEVEL_FLAGS_MASK 0x3
typedef struct Scheme_Let_Value {
Scheme_Inclhash_Object iso; /* keyex used for autobox */
@ -1505,7 +1513,7 @@ typedef struct Resolve_Prefix
typedef struct Resolve_Info
{
MZTAG_IF_REQUIRED
int use_jit;
char use_jit, in_module, enforce_const;
int size, oldsize, count, pos;
Resolve_Prefix *prefix;
mzshort toplevel_pos; /* -1 mean consult next */
@ -1532,10 +1540,15 @@ typedef struct Optimize_Info
MZTAG_IF_REQUIRED
short flags;
struct Optimize_Info *next;
int size, max_let_depth;
int original_frame, new_frame;
Scheme_Object *consts;
/* Propagated up and down the chain: */
int size, max_let_depth;
short inline_fuel;
char letrec_not_twice, enforce_const;
Scheme_Hash_Table *top_level_consts;
char **stat_dists; /* (pos, depth) => used? */
int *sd_depths;
int used_toplevel;
@ -1543,6 +1556,7 @@ typedef struct Optimize_Info
} Optimize_Info;
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info);
typedef struct Scheme_Object *(*Scheme_Syntax_Cloner)(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
typedef struct CPort Mz_CPort;
@ -1560,7 +1574,7 @@ typedef struct Scheme_Closure_Data
mzshort num_params; /* includes collecting arg if has_rest */
mzshort max_let_depth;
mzshort closure_size;
mzshort *closure_map; /* Actually a Closure_Info* until resolved! */
mzshort *closure_map; /* actually a Closure_Info* until resolved */
Scheme_Object *code;
Scheme_Object *name;
#ifdef MZ_USE_JIT
@ -1712,18 +1726,20 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define REF_EXPD 11
#define _COUNT_EXPD_ 12
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, pa) \
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, pa) \
(scheme_syntax_optimizers[i] = fo, \
scheme_syntax_resolvers[i] = fr, \
scheme_syntax_executers[i] = fe, \
scheme_syntax_validaters[i] = fv, \
scheme_syntax_jitters[i] = fj, \
scheme_syntax_cloners[i] = cl, \
scheme_syntax_protect_afters[i] = pa)
extern Scheme_Syntax_Optimizer scheme_syntax_optimizers[_COUNT_EXPD_];
extern Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
extern Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
extern Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
extern Scheme_Syntax_Jitter scheme_syntax_jitters[_COUNT_EXPD_];
extern Scheme_Syntax_Cloner scheme_syntax_cloners[_COUNT_EXPD_];
extern int scheme_syntax_protect_afters[_COUNT_EXPD_];
Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
@ -1733,9 +1749,11 @@ Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *);
Scheme_Object *scheme_optimize_list(Scheme_Object *, Optimize_Info *);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline);
Scheme_Object *scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info);
int scheme_compiled_duplicate_ok(Scheme_Object *fb);
int scheme_compiled_duplicate_ok(Scheme_Object *o);
int scheme_compiled_propagate_ok(Scheme_Object *o);
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
@ -1753,20 +1771,28 @@ int scheme_resolve_info_flags(Resolve_Info *info, int pos);
int scheme_resolve_info_lookup(Resolve_Info *resolve, int pos, int *flags);
void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos);
Optimize_Info *scheme_optimize_info_create(void);
Optimize_Info *scheme_optimize_info_create();
void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value);
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset);
void scheme_optimize_info_used_top(Optimize_Info *info);
void scheme_optimize_mutated(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_reverse_unless_mutated(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated);
int scheme_optimize_is_used(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_clone(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
Scheme_Object *scheme_clone_closure_compilation(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth);
int scheme_closure_body_size(Scheme_Closure_Data *closure_data, int check_assign);
int scheme_closure_argument_flags(Scheme_Closure_Data *closure_data, int i);
Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags);
int scheme_optimize_info_get_shift(Optimize_Info *info, int pos);
void scheme_optimize_info_done(Optimize_Info *info);
Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags);
void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map);
int scheme_env_uses_toplevel(Optimize_Info *frame);
@ -1820,7 +1846,7 @@ Scheme_App_Rec *scheme_malloc_application(int n);
void scheme_finish_application(Scheme_App_Rec *app);
Scheme_Object *scheme_jit_expr(Scheme_Object *);
Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Letrec *lr);
Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Object *context);
Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 301
#define MZSCHEME_VERSION_MINOR 9
#define MZSCHEME_VERSION_MINOR 11
#define MZSCHEME_VERSION "301.9" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "301.11" _MZ_SPECIAL_TAG

3
src/mzscheme/src/startup.inc
View File

@ -1370,14 +1370,13 @@
"(else(loop(cdr proto-r))))))"
"(else(loop(cdr proto-r))))))"
"(-define(no-ellipses? stx)"
"(let loop((stx stx))"
"(cond"
"((stx-pair? stx)"
"(and(no-ellipses?(stx-car stx))"
"(no-ellipses?(stx-cdr stx))))"
"((identifier? stx)"
"(not(...? stx)))"
"(else #t))))"
"(else #t)))"
"(define-struct syntax-mapping(depth valvar))"
"(provide(protect make-match&env get-match-vars make-pexpand"
" make-syntax-mapping syntax-mapping?"

15
src/mzscheme/src/startup.ss
View File

@ -1641,14 +1641,13 @@
[else (loop (cdr proto-r))])))
(-define (no-ellipses? stx)
(let loop ([stx stx])
(cond
[(stx-pair? stx)
(and (no-ellipses? (stx-car stx))
(no-ellipses? (stx-cdr stx)))]
[(identifier? stx)
(not (...? stx))]
[else #t])))
(cond
[(stx-pair? stx)
(and (no-ellipses? (stx-car stx))
(no-ellipses? (stx-cdr stx)))]
[(identifier? stx)
(not (...? stx))]
[else #t]))
;; Structure for communicating first-order pattern variable information:
(define-struct syntax-mapping (depth valvar))

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

@ -818,23 +818,66 @@ static int maybe_add_chain_cache(Scheme_Stx *stx)
return 0;
}
static void set_wraps_to_skip(Scheme_Hash_Table *ht, WRAP_POS *wraps)
{
Scheme_Object *v;
v = scheme_hash_get(ht, scheme_make_integer(0));
wraps->l = v;
v = scheme_hash_get(ht, scheme_make_integer(1));
if (SCHEME_TRUEP(v)) {
wraps->pos = SCHEME_INT_VAL(v);
wraps->is_limb = 1;
wraps->a = ((Wrap_Chunk *)SCHEME_CAR(wraps->l))->a[wraps->pos];
} else {
wraps->is_limb = 0;
if (!SCHEME_NULLP(wraps->l))
wraps->a = SCHEME_CAR(wraps->l);
}
}
static void fill_chain_cache(Scheme_Object *wraps)
{
int pos;
int pos, max_depth, limit;
Scheme_Hash_Table *ht;
Scheme_Object *p, *id;
WRAP_POS awl;
ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps);
pos = ht->step;
ht->step = 0;
wraps = SCHEME_CDR(wraps);
p = scheme_hash_get(ht, scheme_make_integer(5));
if (p) {
limit = SCHEME_INT_VAL(p);
WRAP_POS_INIT(awl, wraps);
/* Extend the chain cache to deeper: */
set_wraps_to_skip(ht, &awl);
p = scheme_hash_get(ht, scheme_make_integer(2));
pos = SCHEME_INT_VAL(p);
scheme_hash_set(ht, scheme_make_integer(5), NULL);
} else {
pos = ht->step;
ht->step = 0;
wraps = SCHEME_CDR(wraps);
WRAP_POS_INIT(awl, wraps);
limit = 4;
}
/* Limit how much of the cache we build, in case we never
reuse this cache: */
max_depth = limit;
while (!WRAP_POS_END_P(awl)) {
if (!(max_depth--)) {
limit *= 2;
scheme_hash_set(ht, scheme_make_integer(5), scheme_make_integer(limit));
break;
}
p = WRAP_POS_FIRST(awl);
if (SCHEME_VECTORP(p)) {
int i, len;
@ -2769,27 +2812,17 @@ static Scheme_Object *resolve_env(Scheme_Object *a, long phase,
did_rib = NULL;
} else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) {
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps);
Scheme_Object *v;
did_rib = NULL;
if (!ht->count) {
if (!ht->count
/* Table isn't finished if 5 is mapped to a limit: */
|| scheme_hash_get(ht, scheme_make_integer(5))) {
fill_chain_cache(wraps.l);
}
if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) {
v = scheme_hash_get(ht, scheme_make_integer(0));
wraps.l = v;
v = scheme_hash_get(ht, scheme_make_integer(1));
if (SCHEME_TRUEP(v)) {
wraps.pos = SCHEME_INT_VAL(v);
wraps.is_limb = 1;
wraps.a = ((Wrap_Chunk *)SCHEME_CAR(wraps.l))->a[wraps.pos];
} else {
wraps.is_limb = 0;
if (!SCHEME_NULLP(wraps.l))
wraps.a = SCHEME_CAR(wraps.l);
}
set_wraps_to_skip(ht, &wraps);
continue; /* <<<<< ------ */
}

255
src/mzscheme/src/syntax.c
View File

@ -44,6 +44,7 @@ Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
Scheme_Syntax_Jitter scheme_syntax_jitters[_COUNT_EXPD_];
Scheme_Syntax_Cloner scheme_syntax_cloners[_COUNT_EXPD_];
int scheme_syntax_protect_afters[_COUNT_EXPD_];
/* locals */
@ -113,6 +114,9 @@ static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize
static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *begin0_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *set_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *define_values_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *ref_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *set_resolve(Scheme_Object *data, Resolve_Info *info);
@ -190,6 +194,8 @@ static void register_traversers(void);
#define max(a, b) (((a) > (b)) ? (a) : (b))
#define MAX_PROC_INLINE_SIZE 32
/**********************************************************************/
/* initialization */
/**********************************************************************/
@ -236,41 +242,51 @@ scheme_init_syntax (Scheme_Env *env)
scheme_register_syntax(DEFINE_VALUES_EXPD,
define_values_optimize,
define_values_resolve, define_values_validate,
define_values_execute, define_values_jit, 1);
define_values_execute, define_values_jit,
NULL, 1);
scheme_register_syntax(SET_EXPD,
set_optimize,
set_resolve, set_validate,
set_execute, set_jit, 2);
set_execute, set_jit,
set_clone, 2);
scheme_register_syntax(REF_EXPD,
ref_optimize,
ref_resolve, ref_validate,
ref_execute, ref_jit, 0);
ref_execute, ref_jit,
NULL, 0);
scheme_register_syntax(DEFINE_SYNTAX_EXPD,
define_syntaxes_optimize,
define_syntaxes_resolve, define_syntaxes_validate,
define_syntaxes_execute, define_syntaxes_jit, 4);
define_syntaxes_execute, define_syntaxes_jit,
NULL, 4);
scheme_register_syntax(DEFINE_FOR_SYNTAX_EXPD,
define_for_syntaxes_optimize,
define_for_syntaxes_resolve, define_for_syntaxes_validate,
define_for_syntaxes_execute, define_for_syntaxes_jit, 4);
define_for_syntaxes_execute, define_for_syntaxes_jit,
NULL, 4);
scheme_register_syntax(CASE_LAMBDA_EXPD,
case_lambda_optimize,
case_lambda_resolve, case_lambda_validate,
case_lambda_execute, case_lambda_jit, -1);
case_lambda_execute, case_lambda_jit,
NULL, -1);
scheme_register_syntax(BEGIN0_EXPD,
begin0_optimize,
begin0_resolve, begin0_validate,
begin0_execute, begin0_jit, -1);
begin0_execute, begin0_jit,
begin0_clone, -1);
scheme_register_syntax(QUOTE_SYNTAX_EXPD,
NULL, NULL, quote_syntax_validate,
quote_syntax_execute, quote_syntax_jit, 2);
quote_syntax_execute, quote_syntax_jit,
NULL, 2);
scheme_register_syntax(BOXENV_EXPD,
NULL, NULL, bangboxenv_validate,
bangboxenv_execute, NULL, 1);
bangboxenv_execute, NULL,
NULL, 1);
scheme_register_syntax(BOXVAL_EXPD,
NULL, NULL, bangboxvalue_validate,
bangboxvalue_execute, bangboxvalue_jit, 2);
bangboxvalue_execute, bangboxvalue_jit,
NULL, 2);
scheme_install_type_writer(scheme_let_value_type, write_let_value);
scheme_install_type_reader(scheme_let_value_type, read_let_value);
@ -576,26 +592,31 @@ static Scheme_Object *expand_lam(int argc, Scheme_Object **argv)
void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val,
int set_undef)
{
if (b->val || set_undef)
if ((b->val || set_undef)
&& !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_IMMUTATED))
b->val = val;
else {
if (((Scheme_Bucket_With_Home *)b)->home->module) {
const char *msg;
if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)))
msg = "%s: cannot set identifier before its definition: %S in module: %S";
msg = "%s: cannot %s: %S in module: %S";
else
msg = "%s: cannot set identifier before its definition: %S";
msg = "%s: cannot %s: %S";
scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key,
msg,
who,
(b->val
? "change identifier that is instantiated as a module constant"
: "set identifier before its definition"),
(Scheme_Object *)b->key,
((Scheme_Bucket_With_Home *)b)->home->module->modname);
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key,
"%s: cannot set undefined identifier: %S",
"%s: cannot set %s identifier: %S",
who,
b->val ? "change constant" : "set undefined",
(Scheme_Object *)b->key);
}
}
@ -663,6 +684,10 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
scheme_set_global_bucket("define-values", b, values[i], 1);
scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
if (SCHEME_TOPLEVEL_FLAGS(SCHEME_CAR(vars)) & SCHEME_TOPLEVEL_CONST) {
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
}
}
}
if (defmacro)
@ -688,6 +713,10 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
scheme_set_global_bucket("define-values", b, vals, 1);
scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
if (SCHEME_TOPLEVEL_FLAGS(SCHEME_CAR(vars)) & SCHEME_TOPLEVEL_CONST) {
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
}
if (defmacro)
scheme_pop_prefix(save_runstack);
}
@ -751,12 +780,21 @@ define_values_execute(Scheme_Object *data)
static Scheme_Object *define_values_jit(Scheme_Object *data)
{
Scheme_Object *orig = SCHEME_CDR(data), *naya;
naya = scheme_jit_expr(orig);
Scheme_Object *orig = SCHEME_CDR(data), *naya, *vars;
vars = SCHEME_CAR(data);
if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
&& SCHEME_PAIRP(vars)
&& SCHEME_NULLP(SCHEME_CDR(vars)))
naya = scheme_jit_closure(orig, SCHEME_CAR(vars));
else
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else
return scheme_make_pair(SCHEME_CAR(data), naya);
return scheme_make_pair(vars, naya);
}
static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
@ -781,13 +819,13 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
}
static Scheme_Object *
define_values_optimize(Scheme_Object *data, Optimize_Info *rslv)
define_values_optimize(Scheme_Object *data, Optimize_Info *info)
{
Scheme_Object *vars = SCHEME_CAR(data);
Scheme_Object *val = SCHEME_CDR(data);
vars = scheme_optimize_list(vars, rslv);
val = scheme_optimize_expr(val, rslv);
scheme_optimize_info_used_top(info);
val = scheme_optimize_expr(val, info);
return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(vars, val));
}
@ -795,10 +833,24 @@ define_values_optimize(Scheme_Object *data, Optimize_Info *rslv)
static Scheme_Object *
define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
Scheme_Object *vars = SCHEME_CAR(data);
Scheme_Object *vars = SCHEME_CAR(data), *l, *a;
Scheme_Object *val = SCHEME_CDR(data);
vars = scheme_resolve_list(vars, rslv);
/* If this is a module-level definition: for each variable, if the
defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then
resolve to a top-level reference with SCHEME_TOPLEVEL_CONST, so
that we know to set GLOS_IS_IMMUTATED at run time. */
for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (rslv->in_module
&& rslv->enforce_const
&& (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) {
a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST);
}
a = scheme_resolve_toplevel(rslv, a);
SCHEME_CAR(l) = a;
}
val = scheme_resolve_expr(val, rslv);
return scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, cons(vars, val));
@ -901,6 +953,8 @@ define_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_
val = scheme_compile_expr(val, env, rec, drec);
/* Note: module_optimize depends on the representation of
DEFINE_VALUES_EXPD's value. */
return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(targets, val));
}
@ -1255,12 +1309,14 @@ set_optimize(Scheme_Object *data, Optimize_Info *info)
val = SCHEME_CDR(data);
val = scheme_optimize_expr(val, info);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
int pos, delta;
pos = SCHEME_LOCAL_POS(var);
/* Register that we use this variable: */
scheme_optimize_info_lookup(info, pos);
scheme_optimize_info_lookup(info, pos, NULL);
/* Offset: */
delta = scheme_optimize_info_get_shift(info, pos);
@ -1273,6 +1329,26 @@ set_optimize(Scheme_Object *data, Optimize_Info *info)
return scheme_make_syntax_compiled(SET_EXPD, cons(set_undef, cons(var, val)));
}
static Scheme_Object *
set_clone(Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
{
Scheme_Object *var, *val, *set_undef;
set_undef = SCHEME_CAR(data);
data = SCHEME_CDR(data);
var = SCHEME_CAR(data);
val = SCHEME_CDR(data);
val = scheme_optimize_clone(val, info, delta, closure_depth);
if (!val) return NULL;
if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
var = scheme_optimize_clone(var, info, delta, closure_depth);
if (!var) return NULL;
}
return scheme_make_syntax_compiled(SET_EXPD, cons(set_undef, cons(var, val)));
}
static Scheme_Object *
set_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
@ -1373,6 +1449,7 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
}
scheme_compile_rec_done_local(rec, drec);
@ -2176,14 +2253,30 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
return 0;
}
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info)
int scheme_compiled_propagate_ok(Scheme_Object *value)
{
Optimize_Info *body_info;
if (scheme_compiled_duplicate_ok(value))
return 1;
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) {
int sz;
sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 1);
if ((sz >= 0) && (sz <= MAX_PROC_INLINE_SIZE))
return 1;
}
return 0;
}
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
{
Optimize_Info *body_info, *rhs_info;
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start;
Scheme_Object *body, *value;
int i, j, pos, is_rec, max_let_depth = 0, all_simple = 1, skipped = 0;
int size_before_opt, did_set_value;
/* Special case: (let ([x E]) x) where E is lambda, case-lambda, or
a constant. (If we allowed arbitrary E here, it would affect the
@ -2196,15 +2289,25 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info)
lhs = SCHEME_TYPE(clv->value);
if ((lhs == scheme_compiled_unclosed_procedure_type)
|| (lhs > _scheme_compiled_values_types_)) {
info = scheme_optimize_info_add_frame(info, 1, 0, 0);
body = scheme_optimize_expr(clv->value, info);
scheme_optimize_info_done(info);
return body;
if (for_inline) {
/* Just drop the inline-introduced let */
return scheme_optimize_expr(clv->value, info);
} else {
info = scheme_optimize_info_add_frame(info, 1, 0, 0);
body = scheme_optimize_expr(clv->value, info);
scheme_optimize_info_done(info);
return body;
}
}
}
}
body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
if (for_inline) {
rhs_info = scheme_optimize_info_add_frame(info, 0, head->count, 0);
body_info->inline_fuel >>= 1;
} else
rhs_info = body_info;
is_rec = SCHEME_LET_RECURSIVE(head);
if (is_rec)
@ -2228,10 +2331,19 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info)
body = head->body;
pre_body = NULL;
retry_start = NULL;
did_set_value = 0;
pos = 0;
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
value = scheme_optimize_expr(pre_body->value, body_info);
if (!retry_start)
retry_start = pre_body;
size_before_opt = body_info->size;
value = scheme_optimize_expr(pre_body->value, rhs_info);
pre_body->value = value;
if ((pre_body->count == 1)
&& !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
@ -2243,24 +2355,77 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info)
vpos = SCHEME_LOCAL_POS(value);
if ((vpos < head->count) && (vpos >= pos))
value = NULL;
else
value = scheme_optimize_reverse_unless_mutated(body_info, vpos);
else {
/* Convert value back to a pre-optimized local coordinate.
This must be done with respect to body_info, not
rhs_info, because we attach the value to body_info: */
value = scheme_optimize_reverse(body_info, vpos, 1);
}
}
if (value
&& (scheme_compiled_duplicate_ok(value)
|| (0 && SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)))) {
if (value && (scheme_compiled_propagate_ok(value))) {
scheme_optimize_propagate(body_info, pos, value);
did_set_value = 1;
}
}
if (body_info->max_let_depth > max_let_depth)
max_let_depth = body_info->max_let_depth;
body_info->max_let_depth = 0;
/* Re-optimize to inline letrec bindings? */
if (is_rec
&& !body_info->letrec_not_twice
&& ((i < 1)
|| (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1)
&& !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5)))) {
if (did_set_value) {
/* Next RHS ends a reorderable sequence.
Re-optimize from retry_start to pre_body, inclusive. */
while (1) {
value = retry_start->value;
if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) {
Scheme_Object *self_value;
self_value = scheme_optimize_clone(value, body_info, 0, 0);
if (self_value) {
/* Try optimization. */
int sz;
/* Drop old size, and remove old inline fuel: */
sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 0);
body_info->size -= (sz + 1);
/* Setting letrec_not_twice prevents inlinining
of letrec bindings in this RHS. There's a small
chance that we miss some optimizations, but we
avoid the possibility of N^2 behavior. */
body_info->letrec_not_twice = 1;
value = scheme_optimize_expr(self_value, body_info);
body_info->letrec_not_twice = 0;
retry_start->value = value;
}
}
if (retry_start == pre_body)
break;
retry_start = (Scheme_Compiled_Let_Value *)retry_start->body;
}
}
retry_start = NULL;
did_set_value = 0;
}
if (rhs_info->max_let_depth > max_let_depth)
max_let_depth = rhs_info->max_let_depth;
rhs_info->max_let_depth = 0;
pos += pre_body->count;
body = pre_body->body;
info->size += 1;
}
if (for_inline) {
body_info->size = rhs_info->size;
}
body = scheme_optimize_expr(body, body_info);
pre_body->body = body;
info->size += 1;
@ -2335,7 +2500,7 @@ scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
}
return scheme_optimize_lets(form, info);
return scheme_optimize_lets(form, info, 0);
}
Scheme_Object *
@ -3408,6 +3573,14 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info)
return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
}
static Scheme_Object *
begin0_clone(Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth)
{
obj = scheme_optimize_clone(obj, info, delta, closure_depth);
if (!obj) return NULL;
return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
}
static Scheme_Object *
begin0_resolve(Scheme_Object *obj, Resolve_Info *info)
{

1
src/mzscheme/src/thread.c
View File

@ -5883,6 +5883,7 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_HONU_MODE, scheme_false);
init_param(cells, paramz, MZCONFIG_COMPILE_MODULE_CONSTS, scheme_true);
init_param(cells, paramz, MZCONFIG_USE_JIT, scheme_startup_use_jit ? scheme_true : scheme_false);
{