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

301.9

Browse Source 
svn: r2382
This commit is contained in:
Matthew Flatt 2006-03-07 15:50:58 +00:00
parent f017ead78c
commit b2f0e051a8
12 changed files with 3575 additions and 2615 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

File diff suppressed because it is too large Load Diff

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

@ -125,9 +125,6 @@ static int env_uid_counter;
/* See also SCHEME_USE_COUNT_MASK */
typedef struct Compile_Data {
char **stat_dists; /* (pos, depth) => used? */
int *sd_depths;
int used_toplevel;
int num_const;
Scheme_Object **const_names;
Scheme_Object **const_vals;
@ -1068,8 +1065,6 @@ static void init_compile_data(Scheme_Comp_Env *env)
data = COMPILE_DATA(env);
data->stat_dists = NULL;
data->sd_depths = NULL;
data->use = use;
for (i = 0; i < c; i++) {
use[i] = 0;
@ -1351,7 +1346,6 @@ static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved)
Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec)
{
Scheme_Comp_Env *frame;
Comp_Prefix *cp = env->prefix;
Scheme_Hash_Table *ht;
Scheme_Object *o;
@ -1361,16 +1355,6 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
return make_toplevel(0, 0, 0);
}
/* Register use at lambda, if any: */
frame = env;
while (frame) {
if (frame->flags & SCHEME_LAMBDA_FRAME) {
COMPILE_DATA(frame)->used_toplevel = 1;
break;
}
frame = frame->next;
}
ht = cp->toplevels;
if (!ht) {
ht = scheme_make_hash_table(SCHEME_hash_ptr);
@ -1423,15 +1407,6 @@ Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env
scheme_hash_set(cp->stxes, var, o);
/* Register use at lambda, if any: */
while (env) {
if (env->flags & SCHEME_LAMBDA_FRAME) {
COMPILE_DATA(env)->used_toplevel = 1;
break;
}
env = env->next;
}
return o;
}
@ -1507,37 +1482,6 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
u |= (cnt << SCHEME_USE_COUNT_SHIFT);
COMPILE_DATA(frame)->use[i] = u;
if (!COMPILE_DATA(frame)->stat_dists) {
int k, *ia;
char **ca;
ca = MALLOC_N(char*, frame->num_bindings);
COMPILE_DATA(frame)->stat_dists = ca;
ia = MALLOC_N_ATOMIC(int, frame->num_bindings);
COMPILE_DATA(frame)->sd_depths = ia;
for (k = frame->num_bindings; k--; ) {
COMPILE_DATA(frame)->sd_depths[k] = 0;
}
}
if (COMPILE_DATA(frame)->sd_depths[i] <= j) {
char *naya, *a;
int k;
naya = MALLOC_N_ATOMIC(char, (j + 1));
for (k = j + 1; k--; ) {
naya[k] = 0;
}
a = COMPILE_DATA(frame)->stat_dists[i];
for (k = COMPILE_DATA(frame)->sd_depths[i]; k--; ) {
naya[k] = a[k];
}
COMPILE_DATA(frame)->stat_dists[i] = naya;
COMPILE_DATA(frame)->sd_depths[i] = j + 1;
}
COMPILE_DATA(frame)->stat_dists[i][j] = 1;
return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i);
}
@ -2449,87 +2393,6 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return (Scheme_Object *)b;
}
void scheme_env_make_closure_map(Scheme_Comp_Env *env, mzshort *_size, mzshort **_map)
{
/* A closure map lists the captured variables for a closure; the
indices are resolved two new indicies in the second phase of
compilation. */
Compile_Data *data;
Scheme_Comp_Env *frame;
int i, j, pos = 0, lpos = 0;
mzshort *map, size;
/* Count vars used by this closure (skip args): */
j = 1;
for (frame = env->next; frame; frame = frame->next) {
data = COMPILE_DATA(frame);
if (frame->flags & SCHEME_LAMBDA_FRAME)
j++;
if (data->stat_dists) {
for (i = 0; i < frame->num_bindings; i++) {
if (data->sd_depths[i] > j) {
if (data->stat_dists[i][j]) {
pos++;
}
}
}
}
}
data = NULL; /* Clear unaligned pointer */
size = pos;
*_size = size;
map = MALLOC_N_ATOMIC(mzshort, size);
*_map = map;
/* Build map, unmarking locals and marking deeper in parent prame */
j = 1; pos = 0;
for (frame = env->next; frame; frame = frame->next) {
data = COMPILE_DATA(frame);
if (frame->flags & SCHEME_LAMBDA_FRAME)
j++;
if (data->stat_dists) {
for (i = 0; i < frame->num_bindings; i++) {
if (data->sd_depths[i] > j) {
if (data->stat_dists[i][j]) {
map[pos++] = lpos;
data->stat_dists[i][j] = 0; /* This closure's done with these vars... */
data->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */
}
}
lpos++;
}
} else
lpos += frame->num_bindings;
}
}
int scheme_env_uses_toplevel(Scheme_Comp_Env *frame)
{
int used;
used = COMPILE_DATA(frame)->used_toplevel;
if (used) {
/* Propagate use to an enclosing lambda, if any: */
frame = frame->next;
while (frame) {
if (frame->flags & SCHEME_LAMBDA_FRAME) {
COMPILE_DATA(frame)->used_toplevel = 1;
break;
}
frame = frame->next;
}
}
return used;
}
int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
{
int *v, i;
@ -2622,12 +2485,300 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok
if (SAME_OBJ(mod, scheme_undefined))
return 1;
}
return 0;
}
/*========================================================================*/
/* compile-time env for phase 2 ("resolve") */
/* compile-time env for optimization */
/*========================================================================*/
Optimize_Info *scheme_optimize_info_create(void)
{
Optimize_Info *info;
info = MALLOC_ONE_RT(Optimize_Info);
#ifdef MZTAG_REQUIRED
info->type = scheme_rt_optimize_info;
#endif
return info;
}
static void register_stat_dist(Optimize_Info *info, int i, int j)
{
if (!info->stat_dists) {
int k, *ia;
char **ca;
ca = MALLOC_N(char*, info->new_frame);
info->stat_dists = ca;
ia = MALLOC_N_ATOMIC(int, info->new_frame);
info->sd_depths = ia;
for (k = info->new_frame; k--; ) {
info->sd_depths[k] = 0;
}
}
if (info->sd_depths[i] <= j) {
char *naya, *a;
int k;
naya = MALLOC_N_ATOMIC(char, (j + 1));
for (k = j + 1; k--; ) {
naya[k] = 0;
}
a = info->stat_dists[i];
for (k = info->sd_depths[i]; k--; ) {
naya[k] = a[k];
}
info->stat_dists[i] = naya;
info->sd_depths[i] = j + 1;
}
info->stat_dists[i][j] = 1;
}
void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **_map)
{
/* A closure map lists the captured variables for a closure; the
indices are resolved two new indicies in the second phase of
compilation. */
Optimize_Info *frame;
int i, j, pos = 0, lpos = 0;
mzshort *map, size;
/* Count vars used by this closure (skip args): */
j = 1;
for (frame = info->next; frame; frame = frame->next) {
if (frame->flags & SCHEME_LAMBDA_FRAME)
j++;
if (frame->stat_dists) {
for (i = 0; i < frame->new_frame; i++) {
if (frame->sd_depths[i] > j) {
if (frame->stat_dists[i][j]) {
pos++;
}
}
}
}
}
size = pos;
*_size = size;
map = MALLOC_N_ATOMIC(mzshort, size);
*_map = map;
/* Build map, unmarking locals and marking deeper in parent frame */
j = 1; pos = 0;
for (frame = info->next; frame; frame = frame->next) {
if (frame->flags & SCHEME_LAMBDA_FRAME)
j++;
if (frame->stat_dists) {
for (i = 0; i < frame->new_frame; i++) {
if (frame->sd_depths[i] > j) {
if (frame->stat_dists[i][j]) {
map[pos++] = lpos;
frame->stat_dists[i][j] = 0; /* This closure's done with these vars... */
frame->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */
}
}
lpos++;
}
} else
lpos += frame->new_frame;
}
}
int scheme_env_uses_toplevel(Optimize_Info *frame)
{
int used;
used = frame->used_toplevel;
if (used) {
/* Propagate use to an enclosing lambda, if any: */
frame = frame->next;
while (frame) {
if (frame->flags & SCHEME_LAMBDA_FRAME) {
frame->used_toplevel = 1;
break;
}
frame = frame->next;
}
}
return used;
}
void scheme_optimize_info_used_top(Optimize_Info *info)
{
while (info) {
if (info->flags & SCHEME_LAMBDA_FRAME) {
info->used_toplevel = 1;
break;
}
info = info->next;
}
}
void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value)
{
Scheme_Object *p;
p = scheme_make_vector(3, NULL);
SCHEME_VEC_ELS(p)[0] = info->consts;
SCHEME_VEC_ELS(p)[1] = scheme_make_integer(pos);
SCHEME_VEC_ELS(p)[2] = value;
info->consts = p;
}
void scheme_optimize_mutated(Optimize_Info *info, int pos)
/* pos must be in immediate frame */
{
if (!info->use) {
char *use;
use = (char *)scheme_malloc_atomic(info->new_frame);
memset(use, 0, info->new_frame);
info->use = use;
}
info->use[pos] = 1;
}
Scheme_Object *scheme_optimize_reverse_unless_mutated(Optimize_Info *info, int pos)
/* 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) {
if (pos < info->new_frame)
break;
pos -= info->new_frame;
delta += info->original_frame;
info = info->next;
}
if (info->use && info->use[pos])
return NULL;
return scheme_make_local(scheme_local_type, pos + delta);
}
int scheme_optimize_is_used(Optimize_Info *info, int pos)
/* pos must be in immediate frame */
{
int i;
if (info->stat_dists) {
for (i = info->sd_depths[pos]; i--; ) {
if (info->stat_dists[pos][i])
return 1;
}
}
return 0;
}
static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j)
{
Scheme_Object *p, *n;
int delta = 0;
while (info) {
if (info->flags & SCHEME_LAMBDA_FRAME)
j++;
if (pos < info->original_frame)
break;
pos -= info->original_frame;
delta += info->new_frame;
info = info->next;
}
p = info->consts;
while (p) {
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)) {
int pos;
pos = SCHEME_LOCAL_POS(n);
if (info->flags & SCHEME_LAMBDA_FRAME)
j--; /* because it will get re-added on recur */
/* Marks local as used; we don't expect to get back
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);
if (!n) {
/* Return shifted reference to other local: */
delta += scheme_optimize_info_get_shift(info, pos);
n = scheme_make_local(scheme_local_type, pos + delta);
}
}
return n;
}
p = SCHEME_VEC_ELS(p)[0];
}
register_stat_dist(info, pos, j);
return NULL;
}
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos)
{
return do_optimize_info_lookup(info, pos, 0);
}
Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags)
{
Optimize_Info *naya;
naya = scheme_optimize_info_create();
naya->flags = (short)flags;
naya->next = info;
naya->original_frame = orig;
naya->new_frame = current;
return naya;
}
int scheme_optimize_info_get_shift(Optimize_Info *info, int pos)
{
int delta = 0;
while (info) {
if (pos < info->original_frame)
break;
pos -= info->original_frame;
delta += (info->new_frame - info->original_frame);
info = info->next;
}
if (!info)
*(long *)0x0 = 1;
return delta;
}
void scheme_optimize_info_done(Optimize_Info *info)
{
info->next->max_let_depth += info->max_let_depth;
info->next->size += info->size;
}
/*========================================================================*/
/* compile-time env for resolve */
/*========================================================================*/
/* See eval.c for information about the compilation phases. */
@ -3767,6 +3918,7 @@ static void register_traversers(void)
{
GC_REG_TRAV(scheme_rt_comp_env, mark_comp_env);
GC_REG_TRAV(scheme_rt_resolve_info, mark_resolve_info);
GC_REG_TRAV(scheme_rt_optimize_info, mark_optimize_info);
}
END_XFORM_SKIP;

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

@ -1078,69 +1078,9 @@ static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
b = (Scheme_Branch_Rec *)o;
t = b->test;
tb = b->tbranch;
fb = b->fbranch;
/* Try optimize: (if (not x) y z) => (if x z y) */
/* Done here because `not' is easily recognized at this
point. Also, we haven't yet resolved Scheme-stack locations,
so it's ok to remove an application. */
while (1) {
if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
Scheme_App2_Rec *app;
app = (Scheme_App2_Rec *)t;
if (SAME_PTR(scheme_not_prim, app->rator)) {
t = tb;
tb = fb;
fb = t;
t = app->rand;
} else
break;
} else
break;
}
if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_let_void_type)) {
/* Maybe convert: (let ([x M]) (if x x N)) => (if M #t N) */
t = scheme_resolve_lets_for_test(t, info);
} else
t = scheme_resolve_expr(t, info);
tb = scheme_resolve_expr(tb, info);
fb = scheme_resolve_expr(fb, info);
/* Try optimize: (if x x #f) => x */
if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)
&& SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type)
&& (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb))
&& SCHEME_FALSEP(fb)) {
return t;
}
/* Convert: (if (if M N #f) M2 K) => (if M (if N M2 K) K)
for simple constants K. This is useful to expose simple
tests to the JIT. */
if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
&& (SCHEME_VOIDP(fb)
|| SAME_OBJ(fb, scheme_true)
|| SCHEME_FALSEP(fb)
|| SCHEME_SYMBOLP(fb)
|| SCHEME_INTP(fb)
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type))) {
Scheme_Branch_Rec *b2 = (Scheme_Branch_Rec *)t;
if (SCHEME_FALSEP(b2->fbranch)) {
Scheme_Branch_Rec *b3;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b3->so.type = scheme_branch_type;
b3->test = b2->tbranch;
b3->tbranch = tb;
b3->fbranch = fb;
t = b2->test;
tb = (Scheme_Object *)b3;
}
}
t = scheme_resolve_expr(b->test, info);
tb = scheme_resolve_expr(b->tbranch, info);
fb = scheme_resolve_expr(b->fbranch, info);
b->test = t;
b->tbranch = tb;
@ -1542,6 +1482,434 @@ Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info)
return first;
}
/*========================================================================*/
/* optimize */
/*========================================================================*/
static Scheme_Object *try_optimize_fold(Scheme_Object *f, Scheme_Object *o, Optimize_Info *info)
{
if ((SCHEME_PRIMP(f)
&& (((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_IS_FOLDING))
|| (SCHEME_CLSD_PRIMP(f)
&& (((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_IS_FOLDING))) {
Scheme_Object *args;
switch (SCHEME_TYPE(o)) {
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)o;
int i;
args = scheme_null;
for (i = app->num_args; i--; ) {
args = scheme_make_pair(app->args[i + 1], args);
}
}
break;
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
args = scheme_make_pair(app->rand, scheme_null);
}
break;
case scheme_application3_type:
default:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
args = scheme_make_pair(app->rand1,
scheme_make_pair(app->rand2,
scheme_null));
}
break;
}
return try_apply(f, args);
}
return NULL;
}
static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info)
{
Scheme_Object *le;
Scheme_App_Rec *app;
int i, n, max_let_depth = 0, all_vals = 1;
app = (Scheme_App_Rec *)o;
n = app->num_args + 1;
max_let_depth = 0;
for (i = 0; i < n; i++) {
le = scheme_optimize_expr(app->args[i], info);
app->args[i] = le;
if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
all_vals = 0;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
}
if (all_vals) {
le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info);
if (le)
return le;
}
info->size += 1;
info->max_let_depth = max_let_depth + (n - 1);
return (Scheme_Object *)app;
}
static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info)
{
Scheme_App2_Rec *app;
Scheme_Object *le;
int max_let_depth;
app = (Scheme_App2_Rec *)o;
le = scheme_optimize_expr(app->rator, info);
app->rator = le;
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
le = scheme_optimize_expr(app->rand, info);
app->rand = le;
if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
if (le)
return le;
}
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->size += 1;
info->max_let_depth = max_let_depth + 1;
return (Scheme_Object *)app;
}
static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *info)
{
Scheme_App3_Rec *app;
Scheme_Object *le;
int max_let_depth, all_vals = 1;
app = (Scheme_App3_Rec *)o;
le = scheme_optimize_expr(app->rator, info);
app->rator = le;
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
/* 1st arg */
le = scheme_optimize_expr(app->rand1, info);
app->rand1 = le;
if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
all_vals = 0;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
/* 2nd arg */
le = scheme_optimize_expr(app->rand2, info);
app->rand2 = le;
if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
all_vals = 0;
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
/* Fold or continue */
if (all_vals) {
le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
if (le)
return le;
}
info->size += 1;
info->max_let_depth = max_let_depth + 2;
return (Scheme_Object *)app;
}
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;
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;
info->max_let_depth = 0;
}
info->size += 1;
info->max_let_depth = max_let_depth;
return (Scheme_Object *)s;
}
int scheme_compiled_duplicate_ok(Scheme_Object *fb)
{
return (SCHEME_VOIDP(fb)
|| SAME_OBJ(fb, scheme_true)
|| SCHEME_FALSEP(fb)
|| SCHEME_SYMBOLP(fb)
|| SCHEME_INTP(fb)
|| SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type));
}
static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
{
Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb;
int max_let_depth;
b = (Scheme_Branch_Rec *)o;
t = b->test;
tb = b->tbranch;
fb = b->fbranch;
/* Try optimize: (if (not x) y z) => (if x z y) */
while (1) {
if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
Scheme_App2_Rec *app;
app = (Scheme_App2_Rec *)t;
if (SAME_PTR(scheme_not_prim, app->rator)) {
t = tb;
tb = fb;
fb = t;
t = app->rand;
} else
break;
} else
break;
}
if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_let_void_type)) {
/* Maybe convert: (let ([x M]) (if x x N)) => (if M #t N) */
t = scheme_optimize_lets_for_test(t, info);
} else
t = scheme_optimize_expr(t, info);
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
tb = scheme_optimize_expr(tb, info);
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
fb = scheme_optimize_expr(fb, info);
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
/* Try optimize: (if x x #f) => x */
if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)
&& SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type)
&& (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb))
&& SCHEME_FALSEP(fb)) {
return t;
}
/* Convert: (if (if M N #f) M2 K) => (if M (if N M2 K) K)
for simple constants K. This is useful to expose simple
tests to the JIT. */
if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
&& scheme_compiled_duplicate_ok(fb)) {
Scheme_Branch_Rec *b2 = (Scheme_Branch_Rec *)t;
if (SCHEME_FALSEP(b2->fbranch)) {
Scheme_Branch_Rec *b3;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b3->so.type = scheme_branch_type;
b3->test = b2->tbranch;
b3->tbranch = tb;
b3->fbranch = fb;
t = b2->test;
tb = (Scheme_Object *)b3;
}
}
b->test = t;
b->tbranch = tb;
b->fbranch = fb;
info->size += 1;
info->max_let_depth = max_let_depth;
return o;
}
static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b;
int max_let_depth;
k = scheme_optimize_expr(wcm->key, info);
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
v = scheme_optimize_expr(wcm->val, info);
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
b = scheme_optimize_expr(wcm->body, info);
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
wcm->key = k;
wcm->val = v;
wcm->body = b;
info->size += 1;
info->max_let_depth = max_let_depth;
return (Scheme_Object *)wcm;
}
static Scheme_Object *optimize_k()
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
Optimize_Info *info = (Optimize_Info *)p->ku.k.p2;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
return scheme_optimize_expr(expr, info);
}
Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
{
Scheme_Type type = SCHEME_TYPE(expr);
#ifdef DO_STACK_CHECK
# include "mzstkchk.h"
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)expr;
p->ku.k.p2 = (void *)info;
return scheme_handle_stack_overflow(optimize_k);
}
#endif
switch (type) {
case scheme_local_type:
{
Scheme_Object *val;
int pos, delta;
info->size += 1;
val = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr));
if (val)
return val;
pos = SCHEME_LOCAL_POS(expr);
delta = scheme_optimize_info_get_shift(info, pos);
if (delta)
expr = scheme_make_local(scheme_local_type, pos + delta);
return expr;
}
case scheme_compiled_syntax_type:
{
Scheme_Syntax_Optimizer f;
f = scheme_syntax_optimizers[SCHEME_PINT_VAL(expr)];
return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info);
}
case scheme_application_type:
return optimize_application(expr, info);
case scheme_application2_type:
return optimize_application2(expr, info);
case scheme_application3_type:
return optimize_application3(expr, info);
case scheme_sequence_type:
return optimize_sequence(expr, info);
case scheme_branch_type:
return optimize_branch(expr, info);
case scheme_with_cont_mark_type:
return optimize_wcm(expr, 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);
case scheme_compiled_toplevel_type:
case scheme_compiled_quote_syntax_type:
scheme_optimize_info_used_top(info);
return expr;
case scheme_variable_type:
case scheme_module_variable_type:
scheme_signal_error("got top-level in wrong place");
return 0;
default:
info->size += 1;
return expr;
}
}
Scheme_Object *scheme_optimize_list(Scheme_Object *expr, Optimize_Info *info)
{
Scheme_Object *first = scheme_null, *last = NULL;
int max_let_depth = 0;
while (SCHEME_PAIRP(expr)) {
Scheme_Object *pr;
pr = scheme_make_pair(scheme_optimize_expr(SCHEME_CAR(expr), info),
scheme_null);
if (info->max_let_depth > max_let_depth)
max_let_depth = info->max_let_depth;
info->max_let_depth = 0;
if (last)
SCHEME_CDR(last) = pr;
else
first = pr;
last = pr;
expr = SCHEME_CDR(expr);
}
info->max_let_depth = max_let_depth;
return first;
}
/*========================================================================*/
/* JIT */
/*========================================================================*/
@ -1868,7 +2236,6 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
void scheme_default_compile_rec(Scheme_Compile_Info *rec, int drec)
{
rec[drec].max_let_depth = 0;
}
void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
@ -1881,7 +2248,6 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
dest[i].type = scheme_rt_compile_info;
#endif
dest[i].comp = 1;
dest[i].max_let_depth = 0;
dest[i].dont_mark_local_use = src[drec].dont_mark_local_use;
dest[i].resolve_module_ids = src[drec].resolve_module_ids;
dest[i].value_name = scheme_false;
@ -1908,25 +2274,12 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec,
void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec,
Scheme_Compile_Info *dest, int n)
{
int i;
if (!n) {
src[drec].max_let_depth = 0;
return;
}
src[drec].max_let_depth = dest[0].max_let_depth;
for (i = 1; i < n; i++) {
if (dest[i].max_let_depth > src[drec].max_let_depth)
src[drec].max_let_depth = dest[i].max_let_depth;
}
/* Nothing to do anymore, since we moved max_let_depth to optimize phase */
}
void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec,
Scheme_Compile_Info *lam, int dlrec)
{
lam[dlrec].max_let_depth = 0;
lam[dlrec].comp = 1;
lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use;
lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids;
@ -2024,11 +2377,6 @@ static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env *
form = scheme_inner_compile_list(form, scheme_no_defines(env), rec, drec, 1);
result = make_application(form);
if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type)
|| SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type)
|| SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type))
rec[drec].max_let_depth += (len - 1);
return result;
}
@ -2100,6 +2448,7 @@ static void *compile_k(void)
Scheme_Object *o, *tl_queue;
Scheme_Compilation_Top *top;
Resolve_Prefix *rp;
Optimize_Info *oi;
Scheme_Object *gval, *insp;
Scheme_Comp_Env *cenv;
@ -2179,7 +2528,6 @@ static void *compile_k(void)
} else {
/* We want to simply compile `form', but we have to loop in case
an expression is lifted in the process of compiling: */
int max_let_depth = 0;
Scheme_Object *l, *prev_o = NULL;
while (1) {
@ -2189,9 +2537,6 @@ static void *compile_k(void)
o = scheme_compile_expr(form, cenv, &rec2, 0);
if (rec2.max_let_depth > max_let_depth)
max_let_depth = rec2.max_let_depth;
/* If we had compiled an expression in a previous iteration,
combine it in a sequence: */
if (prev_o) {
@ -2216,13 +2561,15 @@ static void *compile_k(void)
break;
}
rp = scheme_resolve_prefix(0, cenv->prefix, 1);
oi = scheme_optimize_info_create();
o = scheme_optimize_expr(o, oi);
rp = scheme_resolve_prefix(0, cenv->prefix, 1);
o = scheme_resolve_expr(o, scheme_resolve_info_create(rp));
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
top->so.type = scheme_compilation_top_type;
top->max_let_depth = max_let_depth;
top->max_let_depth = oi->max_let_depth;
top->code = o;
top->prefix = rp;
}
@ -2542,7 +2889,6 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
/* A hack for handling lifted expressions. See compile_expand_lift_to_let. */
if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_already_comp_type)) {
form = SCHEME_STX_VAL(form);
rec[drec].max_let_depth = SCHEME_PINT_VAL(form);
return SCHEME_IPTR_VAL(form);
}
@ -3114,7 +3460,6 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
o = scheme_alloc_object();
o->type = scheme_already_comp_type;
SCHEME_IPTR_VAL(o) = form;
SCHEME_PINT_VAL(o) = recs[0].max_let_depth;
} else
o = form;
for (revl = scheme_null; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {

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

@ -189,9 +189,7 @@ scheme_init_fun (Scheme_Env *env)
REGISTER_SO(cached_dv_stx);
REGISTER_SO(cached_ds_stx);
o = scheme_make_folding_prim(procedure_p,
"procedure?",
1, 1, 1);
o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("procedure?", o, env);
@ -758,6 +756,50 @@ typedef struct {
short has_tl;
} Closure_Info;
Scheme_Object *
scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
{
Scheme_Closure_Data *data;
Scheme_Object *code;
Closure_Info *cl;
mzshort dcs, *dcm;
int i;
data = (Scheme_Closure_Data *)_data;
info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params,
SCHEME_LAMBDA_FRAME);
cl = (Closure_Info *)data->closure_map;
for (i = 0; i < data->num_params; i++) {
if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED)
scheme_optimize_mutated(info, i);
}
code = scheme_optimize_expr(data->code, info);
data->code = code;
/* Remembers positions of used vars (and unsets usage for this level) */
scheme_env_make_closure_map(info, &dcs, &dcm);
cl->base_closure_size = dcs;
cl->base_closure_map = dcm;
if (scheme_env_uses_toplevel(info))
cl->has_tl = 1;
data->closure_size = (cl->base_closure_size
+ (cl->has_tl ? 1 : 0));
info->max_let_depth += data->num_params + data->closure_size;
data->max_let_depth = info->max_let_depth;
info->max_let_depth = 0; /* So it doesn't propagate outward */
scheme_optimize_info_done(info);
return (Scheme_Object *)data;
}
Scheme_Object *
scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info)
{
@ -965,10 +1007,9 @@ scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
Scheme_Closure_Data *data;
Scheme_Compile_Info lam;
Scheme_Comp_Env *frame;
Closure_Info *cl;
int i;
long num_params;
mzshort dcs, *dcm;
Closure_Info *cl;
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
@ -1033,26 +1074,13 @@ scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code,
#ifdef MZTAG_REQUIRED
cl->type = scheme_rt_closure_info;
#endif
{
int *local_flags;
local_flags = scheme_env_get_flags(frame, 0, data->num_params);
cl->local_flags = local_flags;
}
/* Remembers positions of used vars (and unsets usage for this level) */
scheme_env_make_closure_map(frame, &dcs, &dcm);
cl->base_closure_size = dcs;
cl->base_closure_map = dcm;
if (scheme_env_uses_toplevel(frame))
cl->has_tl = 1;
data->closure_size = (cl->base_closure_size
+ (cl->has_tl ? 1 : 0));
data->closure_map = (mzshort *)cl;
data->max_let_depth = lam.max_let_depth + data->num_params + data->closure_size;
return (Scheme_Object *)data;
}

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

@ -304,7 +304,7 @@ static void *generate_one(mz_jit_state *old_jitter,
ndata->retained = jitter->retain_start;
ndata->retain_count = num_retained;
SCHEME_BOX_VAL(fnl_obj) = scheme_make_integer(size_pre_retained);
GC_set_finalizer(fnl_obj, 1, 1,
GC_set_finalizer(fnl_obj, 1, 2,
release_native_code, buffer,
NULL, NULL);
}
@ -677,6 +677,33 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity)
# define mz_epilog_without_jmp() /* empty */
# define mz_push_locals() /* empty */
# define mz_pop_locals() /* empty */
static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg)
{
/* This must be consistent with _jit_prolog in many ways: */
int frame_size;
int ofs;
int first_saved_reg = JIT_AUX - n;
int num_saved_regs = 32 - first_saved_reg;
frame_size = 24 + 32 + 12 + num_saved_regs * 4; /* r27..r31 + args */
frame_size += 15; /* the stack must be quad-word */
frame_size &= ~15; /* aligned */
STWUrm(1, -frame_size, 1); /* stwu r1, -x(r1) */
/* We actually only need to save V0-V2, which are at
the end of the saved area: */
first_saved_reg = 29;
num_saved_regs = 3;
ofs = frame_size - num_saved_regs * 4;
STMWrm(first_saved_reg, ofs, 1); /* stmw rI, ofs(r1) */
#ifdef _CALL_DARWIN
STWrm(ret_addr_reg, frame_size + 8, 1); /* stw r0, x+8(r1) */
#else
STWrm(ret_addr_reg, frame_size + 4, 1); /* stw r0, x+4(r1) */
#endif
}
#else
# define JIT_LOCAL1 -16
# define JIT_LOCAL2 -20
@ -703,6 +730,7 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity)
# endif
# define mz_push_locals() SUBLir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP)
# define mz_pop_locals() ADDLir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP)
#define _jit_prolog_again(jitter, n, ret_addr_reg) (PUSHLr(ret_addr_reg), PUSHLr(_EBP), MOVLrr(_ESP, _EBP), PUSHLr(_EBX), PUSHLr(_ESI), PUSHLr(_EDI))
#endif
#ifdef MZ_USE_JIT_PPC
@ -1151,7 +1179,7 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
#endif
/* Fast inlined-native jump ok (proc will check argc); */
/* extract function and data: */
#if 0
mz_prepare(3);
jit_pusharg_p(JIT_RUNSTACK);
jit_movi_i(JIT_R1, num_rands);
@ -1162,6 +1190,28 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
} else {
(void)mz_finish(jump_to_native_arity_code);
}
#else
{
jit_insn *refr;
refr = jit_movi_p(JIT_R0, jit_forward());
_jit_prolog_again(jitter, 3, JIT_R0); /* saves V registers */
jit_movr_p(JIT_R0, JIT_V1); /* closure */
jit_movi_i(JIT_R1, num_rands); /* argc */
jit_movr_p(JIT_R2, JIT_RUNSTACK); /* argv */
jit_movr_p(JIT_RUNSTACK_BASE, JIT_RUNSTACK);
CHECK_LIMIT();
mz_push_locals();
mz_set_local_p(JIT_RUNSTACK, JIT_LOCAL1);
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Native_Closure *)0x0)->code);
if (direct_native) {
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->u.tail_code);
} else {
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Native_Closure_Data *)0x0)->arity_code);
}
jit_jmpr(JIT_V1);
jit_patch_movi(refr, (_jit.x.pc));
}
#endif
CHECK_LIMIT();
jit_retval(JIT_R0);
if (!multi_ok) {
@ -4141,7 +4191,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
/* A tail call starts here. Caller must ensure that the
stack is big enough, right number of arguments, closure
is in R0. */
is in R0. If the closure has a rest arg, also ensure
argc in R1 and argv in R2. */
tail_code = jit_get_ip().ptr;
/* 0 params and has_rest => (lambda args E) where args is not in E,

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

@ -73,7 +73,9 @@ static Scheme_Object *top_level_require_execute(Scheme_Object *data);
static Scheme_Object *module_jit(Scheme_Object *data);
static Scheme_Object *top_level_require_jit(Scheme_Object *data);
static Scheme_Object *module_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *module_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *top_level_require_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_Info *info);
static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack, int depth, int letlimit, int delta,
@ -197,9 +199,11 @@ void scheme_init_module(Scheme_Env *env)
Scheme_Object *o;
scheme_register_syntax(MODULE_EXPD,
module_optimize,
module_resolve, module_validate,
module_execute, module_jit, -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);
@ -3081,6 +3085,28 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
/* FIXME: validate exp-time code */
}
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;
for (b = m->body; !SCHEME_NULLP(b); b = SCHEME_CDR(b)) {
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;
}
m->max_let_depth = max_let_depth;
/* Exp-time body was optimized during compilation */
return scheme_make_syntax_compiled(MODULE_EXPD, data);
}
static Scheme_Object *
module_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
@ -3651,7 +3677,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
char *exps;
int excount, exvcount, exicount;
int reprovide_kernel;
int max_let_depth;
int all_simple_renames = 1, et_all_simple_renames = 1, tt_all_simple_renames = 1;
Scheme_Object *redef_modname;
@ -3932,6 +3957,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Resolve_Prefix *rp;
Resolve_Info *ri;
Scheme_Comp_Env *oenv, *eenv;
Optimize_Info *oi;
int count = 0;
int for_stx;
@ -4014,6 +4040,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
}
m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
oi = scheme_optimize_info_create();
m = scheme_optimize_expr(m, oi);
/* Simplify only in compile mode; it is too slow in expand mode. */
rp = scheme_resolve_prefix(1, eenv->prefix, rec[drec].comp);
@ -4024,7 +4053,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
vec = scheme_make_vector(5, NULL);
SCHEME_VEC_ELS(vec)[0] = names;
SCHEME_VEC_ELS(vec)[1] = m;
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(mrec.max_let_depth);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(oi->max_let_depth);
SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false);
exp_body = scheme_make_pair(vec, exp_body);
@ -4032,7 +4061,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
if (ri->use_jit)
m = scheme_jit_expr(m);
eval_defmacro(names, count, m, eenv->genv, rhs_env, rp, mrec.max_let_depth, 0,
eval_defmacro(names, count, m, eenv->genv, rhs_env, rp, oi->max_let_depth, 0,
(for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,
rec[drec].certs);
@ -4383,10 +4412,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Module manages its own prefix. That's how we get
multiple instantiation of a module with "dynamic linking". */
cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
rec[drec].max_let_depth = 0; /* since module executer takes care of it */
} else
cenv = scheme_extend_as_toplevel(env);
max_let_depth = 0;
lift_data = scheme_make_vector(3, NULL);
SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv;
@ -4409,8 +4436,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_init_compile_recs(rec, drec, &crec1, 1);
crec1.resolve_module_ids = 0;
e = scheme_compile_expr(e, cenv, &crec1, 0);
if (crec1.max_let_depth > max_let_depth)
max_let_depth = crec1.max_let_depth;
} else {
Scheme_Expand_Info erec1;
scheme_init_expand_recs(rec, drec, &erec1, 1);
@ -4943,7 +4968,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
env->genv->module->num_indirect_provides = exicount;
env->genv->module->comp_prefix = cenv->prefix;
env->genv->module->max_let_depth = max_let_depth;
if (all_simple_renames && (env->genv->marked_names->count == 0)) {
env->genv->module->rn_stx = scheme_true;
@ -5542,6 +5566,12 @@ static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, char
{
}
static Scheme_Object *
top_level_require_optimize(Scheme_Object *data, Optimize_Info *info)
{
return scheme_make_syntax_compiled(REQUIRE_EXPD, data);
}
static Scheme_Object *
top_level_require_resolve(Scheme_Object *data, Resolve_Info *rslv)
{

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

@ -2329,8 +2329,6 @@ static int mark_comp_env_MARK(void *p) {
gcMARK(e->base.in_modidx);
gcMARK(e->base.skip_table);
gcMARK(e->data.stat_dists);
gcMARK(e->data.sd_depths);
gcMARK(e->data.const_names);
gcMARK(e->data.const_vals);
gcMARK(e->data.const_uids);
@ -2358,8 +2356,6 @@ static int mark_comp_env_FIXUP(void *p) {
gcFIXUP(e->base.in_modidx);
gcFIXUP(e->base.skip_table);
gcFIXUP(e->data.stat_dists);
gcFIXUP(e->data.sd_depths);
gcFIXUP(e->data.const_names);
gcFIXUP(e->data.const_vals);
gcFIXUP(e->data.const_uids);
@ -2411,6 +2407,41 @@ static int mark_resolve_info_FIXUP(void *p) {
#define mark_resolve_info_IS_CONST_SIZE 1
static int mark_optimize_info_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
}
static int mark_optimize_info_MARK(void *p) {
Optimize_Info *i = (Optimize_Info *)p;
gcMARK(i->stat_dists);
gcMARK(i->sd_depths);
gcMARK(i->next);
gcMARK(i->use);
gcMARK(i->consts);
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
}
static int mark_optimize_info_FIXUP(void *p) {
Optimize_Info *i = (Optimize_Info *)p;
gcFIXUP(i->stat_dists);
gcFIXUP(i->sd_depths);
gcFIXUP(i->next);
gcFIXUP(i->use);
gcFIXUP(i->consts);
return
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
}
#define mark_optimize_info_IS_ATOMIC 0
#define mark_optimize_info_IS_CONST_SIZE 1
#endif /* ENV */

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

@ -924,8 +924,6 @@ mark_comp_env {
gcMARK(e->base.in_modidx);
gcMARK(e->base.skip_table);
gcMARK(e->data.stat_dists);
gcMARK(e->data.sd_depths);
gcMARK(e->data.const_names);
gcMARK(e->data.const_vals);
gcMARK(e->data.const_uids);
@ -951,6 +949,20 @@ mark_resolve_info {
gcBYTES_TO_WORDS(sizeof(Resolve_Info));
}
mark_optimize_info {
mark:
Optimize_Info *i = (Optimize_Info *)p;
gcMARK(i->stat_dists);
gcMARK(i->sd_depths);
gcMARK(i->next);
gcMARK(i->use);
gcMARK(i->consts);
size:
gcBYTES_TO_WORDS(sizeof(Optimize_Info));
}
END env;

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

@ -1486,7 +1486,6 @@ typedef struct Scheme_Compile_Expand_Info
int comp;
Scheme_Object *value_name;
Scheme_Object *certs;
int max_let_depth;
char dont_mark_local_use;
char resolve_module_ids;
int depth;
@ -1528,6 +1527,23 @@ typedef struct Scheme_Object *
typedef struct Scheme_Object *(*Scheme_Syntax_Resolver)(Scheme_Object *data, Resolve_Info *info);
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;
char **stat_dists; /* (pos, depth) => used? */
int *sd_depths;
int used_toplevel;
char *use;
} Optimize_Info;
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info);
typedef struct CPort Mz_CPort;
typedef void (*Scheme_Syntax_Validater)(Scheme_Object *data, Mz_CPort *port,
@ -1576,7 +1592,7 @@ typedef struct Scheme_Native_Closure_Data {
mzshort *arities; /* For case-lambda */
} u;
void *arity_code;
mzshort max_let_depth;
mzshort max_let_depth; /* In bytes instead of words */
mzshort closure_size;
union {
struct Scheme_Closure_Data *orig_code; /* For not-yet-JITted non-case-lambda */
@ -1657,9 +1673,6 @@ void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env);
void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,
Scheme_Comp_Env *env);
void scheme_env_make_closure_map(Scheme_Comp_Env *frame, mzshort *size, mzshort **map);
int scheme_env_uses_toplevel(Scheme_Comp_Env *frame);
Scheme_Object *scheme_make_closure(Scheme_Thread *p,
Scheme_Object *compiled_code,
int close);
@ -1699,12 +1712,14 @@ 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, fr, fv, fe, fj, pa) \
(scheme_syntax_resolvers[i] = fr, \
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, 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_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_];
@ -1716,13 +1731,18 @@ Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
Scheme_Object *scheme_make_syntax_resolved(int idx, Scheme_Object *data);
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_for_test(Scheme_Object *form, Optimize_Info *info);
int scheme_compiled_duplicate_ok(Scheme_Object *fb);
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed);
Scheme_Object *scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info);
Scheme_Object *scheme_resolve_lets_for_test(Scheme_Object *form, Resolve_Info *info);
Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify);
@ -1733,6 +1753,23 @@ 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);
void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value);
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos);
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);
int scheme_optimize_is_used(Optimize_Info *info, int pos);
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);
void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map);
int scheme_env_uses_toplevel(Optimize_Info *frame);
int scheme_resolve_toplevel_pos(Resolve_Info *info);
int scheme_resolve_quote_syntax_pos(Resolve_Info *info);
Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr);
@ -1776,6 +1813,7 @@ Scheme_Object *scheme_make_closure_compilation(Scheme_Comp_Env *env,
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list,
int strip_values);
Scheme_Object *scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info);
Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info);
Scheme_App_Rec *scheme_malloc_application(int n);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 301
#define MZSCHEME_VERSION_MINOR 8
#define MZSCHEME_VERSION_MINOR 9
#define MZSCHEME_VERSION "301.8" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "301.9" _MZ_SPECIAL_TAG

111
src/mzscheme/src/stypes.h
View File

@ -157,61 +157,62 @@ enum {
scheme_rt_comp_env, /* 136 */
scheme_rt_constant_binding, /* 137 */
scheme_rt_resolve_info, /* 138 */
scheme_rt_compile_info, /* 139 */
scheme_rt_cont_mark, /* 140 */
scheme_rt_saved_stack, /* 141 */
scheme_rt_reply_item, /* 142 */
scheme_rt_closure_info, /* 143 */
scheme_rt_overflow, /* 144 */
scheme_rt_dyn_wind_cell, /* 145 */
scheme_rt_dyn_wind_info, /* 146 */
scheme_rt_dyn_wind, /* 147 */
scheme_rt_dup_check, /* 148 */
scheme_rt_thread_memory, /* 149 */
scheme_rt_input_file, /* 150 */
scheme_rt_input_fd, /* 151 */
scheme_rt_oskit_console_input, /* 152 */
scheme_rt_tested_input_file, /* 153 */
scheme_rt_tested_output_file, /* 154 */
scheme_rt_indexed_string, /* 155 */
scheme_rt_output_file, /* 156 */
scheme_rt_load_handler_data, /* 157 */
scheme_rt_pipe, /* 158 */
scheme_rt_beos_process, /* 159 */
scheme_rt_system_child, /* 160 */
scheme_rt_tcp, /* 161 */
scheme_rt_write_data, /* 162 */
scheme_rt_tcp_select_info, /* 163 */
scheme_rt_namespace_option, /* 164 */
scheme_rt_param_data, /* 165 */
scheme_rt_will, /* 166 */
scheme_rt_will_registration, /* 167 */
scheme_rt_struct_proc_info, /* 168 */
scheme_rt_linker_name, /* 169 */
scheme_rt_param_map, /* 170 */
scheme_rt_finalization, /* 171 */
scheme_rt_finalizations, /* 172 */
scheme_rt_cpp_object, /* 173 */
scheme_rt_cpp_array_object, /* 174 */
scheme_rt_stack_object, /* 175 */
scheme_rt_preallocated_object, /* 176 */
scheme_thread_hop_type, /* 177 */
scheme_rt_srcloc, /* 178 */
scheme_rt_evt, /* 179 */
scheme_rt_syncing, /* 180 */
scheme_rt_comp_prefix, /* 181 */
scheme_rt_user_input, /* 182 */
scheme_rt_user_output, /* 183 */
scheme_rt_compact_port, /* 184 */
scheme_rt_read_special_dw, /* 185 */
scheme_rt_regwork, /* 186 */
scheme_rt_buf_holder, /* 187 */
scheme_rt_parameterization, /* 188 */
scheme_rt_print_params, /* 189 */
scheme_rt_read_params, /* 190 */
scheme_rt_native_code, /* 191 */
scheme_rt_native_code_plus_case, /* 192 */
scheme_rt_jitter_data, /* 193 */
scheme_rt_optimize_info, /* 139 */
scheme_rt_compile_info, /* 140 */
scheme_rt_cont_mark, /* 141 */
scheme_rt_saved_stack, /* 142 */
scheme_rt_reply_item, /* 143 */
scheme_rt_closure_info, /* 144 */
scheme_rt_overflow, /* 145 */
scheme_rt_dyn_wind_cell, /* 146 */
scheme_rt_dyn_wind_info, /* 147 */
scheme_rt_dyn_wind, /* 148 */
scheme_rt_dup_check, /* 149 */
scheme_rt_thread_memory, /* 150 */
scheme_rt_input_file, /* 151 */
scheme_rt_input_fd, /* 152 */
scheme_rt_oskit_console_input, /* 153 */
scheme_rt_tested_input_file, /* 154 */
scheme_rt_tested_output_file, /* 155 */
scheme_rt_indexed_string, /* 156 */
scheme_rt_output_file, /* 157 */
scheme_rt_load_handler_data, /* 158 */
scheme_rt_pipe, /* 159 */
scheme_rt_beos_process, /* 160 */
scheme_rt_system_child, /* 161 */
scheme_rt_tcp, /* 162 */
scheme_rt_write_data, /* 163 */
scheme_rt_tcp_select_info, /* 164 */
scheme_rt_namespace_option, /* 165 */
scheme_rt_param_data, /* 166 */
scheme_rt_will, /* 167 */
scheme_rt_will_registration, /* 168 */
scheme_rt_struct_proc_info, /* 169 */
scheme_rt_linker_name, /* 170 */
scheme_rt_param_map, /* 171 */
scheme_rt_finalization, /* 172 */
scheme_rt_finalizations, /* 173 */
scheme_rt_cpp_object, /* 174 */
scheme_rt_cpp_array_object, /* 175 */
scheme_rt_stack_object, /* 176 */
scheme_rt_preallocated_object, /* 177 */
scheme_thread_hop_type, /* 178 */
scheme_rt_srcloc, /* 179 */
scheme_rt_evt, /* 180 */
scheme_rt_syncing, /* 181 */
scheme_rt_comp_prefix, /* 182 */
scheme_rt_user_input, /* 183 */
scheme_rt_user_output, /* 184 */
scheme_rt_compact_port, /* 185 */
scheme_rt_read_special_dw, /* 186 */
scheme_rt_regwork, /* 187 */
scheme_rt_buf_holder, /* 188 */
scheme_rt_parameterization, /* 189 */
scheme_rt_print_params, /* 190 */
scheme_rt_read_params, /* 191 */
scheme_rt_native_code, /* 192 */
scheme_rt_native_code_plus_case, /* 193 */
scheme_rt_jitter_data, /* 194 */
#endif
_scheme_last_type_

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

@ -39,6 +39,7 @@ Scheme_Object *scheme_lambda_syntax;
Scheme_Object *scheme_compiled_void_code;
Scheme_Object scheme_undefined[1];
Scheme_Syntax_Optimizer scheme_syntax_optimizers[_COUNT_EXPD_];
Scheme_Syntax_Resolver scheme_syntax_resolvers[_COUNT_EXPD_];
Scheme_Syntax_Validater scheme_syntax_validaters[_COUNT_EXPD_];
Scheme_Syntax_Executer scheme_syntax_executers[_COUNT_EXPD_];
@ -104,6 +105,14 @@ static Scheme_Object *quote_syntax_execute(Scheme_Object *data);
static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
static Scheme_Object *define_values_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *ref_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *set_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *define_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
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 *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);
@ -225,35 +234,42 @@ scheme_init_syntax (Scheme_Env *env)
disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding");
scheme_register_syntax(DEFINE_VALUES_EXPD,
define_values_optimize,
define_values_resolve, define_values_validate,
define_values_execute, define_values_jit, 1);
scheme_register_syntax(SET_EXPD,
set_optimize,
set_resolve, set_validate,
set_execute, set_jit, 2);
scheme_register_syntax(REF_EXPD,
ref_optimize,
ref_resolve, ref_validate,
ref_execute, ref_jit, 0);
scheme_register_syntax(DEFINE_SYNTAX_EXPD,
define_syntaxes_optimize,
define_syntaxes_resolve, define_syntaxes_validate,
define_syntaxes_execute, define_syntaxes_jit, 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);
scheme_register_syntax(CASE_LAMBDA_EXPD,
case_lambda_optimize,
case_lambda_resolve, case_lambda_validate,
case_lambda_execute, case_lambda_jit, -1);
scheme_register_syntax(BEGIN0_EXPD,
begin0_optimize,
begin0_resolve, begin0_validate,
begin0_execute, begin0_jit, -1);
scheme_register_syntax(QUOTE_SYNTAX_EXPD,
NULL, quote_syntax_validate,
NULL, NULL, quote_syntax_validate,
quote_syntax_execute, quote_syntax_jit, 2);
scheme_register_syntax(BOXENV_EXPD,
NULL, bangboxenv_validate,
NULL, NULL, bangboxenv_validate,
bangboxenv_execute, NULL, 1);
scheme_register_syntax(BOXVAL_EXPD,
NULL, bangboxvalue_validate,
NULL, NULL, bangboxvalue_validate,
bangboxvalue_execute, bangboxvalue_jit, 2);
scheme_install_type_writer(scheme_let_value_type, write_let_value);
@ -764,6 +780,18 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_expr(port, val, stack, depth, letlimit, delta, num_toplevels, num_stxes);
}
static Scheme_Object *
define_values_optimize(Scheme_Object *data, Optimize_Info *rslv)
{
Scheme_Object *vars = SCHEME_CAR(data);
Scheme_Object *val = SCHEME_CDR(data);
vars = scheme_optimize_list(vars, rslv);
val = scheme_optimize_expr(val, rslv);
return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(vars, val));
}
static Scheme_Object *
define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
@ -1216,6 +1244,35 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
scheme_validate_toplevel(tl, port, stack, depth, delta, num_toplevels, num_stxes);
}
static Scheme_Object *
set_optimize(Scheme_Object *data, Optimize_Info *info)
{
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_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);
/* Offset: */
delta = scheme_optimize_info_get_shift(info, pos);
if (delta)
var = scheme_make_local(scheme_local_type, pos + delta);
} else {
scheme_optimize_info_used_top(info);
}
return scheme_make_syntax_compiled(SET_EXPD, cons(set_undef, cons(var, val)));
}
static Scheme_Object *
set_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
@ -1449,6 +1506,12 @@ static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
scheme_validate_toplevel(tl, port, stack, depth, delta, num_toplevels, num_stxes);
}
static Scheme_Object *
ref_optimize(Scheme_Object *tl, Optimize_Info *rslv)
{
return scheme_make_syntax_compiled(REF_EXPD, tl);
}
static Scheme_Object *
ref_resolve(Scheme_Object *tl, Resolve_Info *rslv)
{
@ -1699,7 +1762,6 @@ case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv)
for (i = 0; i < seq->count; i++) {
Scheme_Object *le;
le = seq->array[i];
((Scheme_Closure_Data *)le)->name = scheme_false; /* inidcates that it's a case */
le = scheme_resolve_expr(le, rslv);
seq->array[i] = le;
if (!SCHEME_PROCP(le))
@ -1714,6 +1776,22 @@ case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv)
return scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, expr);
}
static Scheme_Object *
case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info)
{
Scheme_Object *le;
int i;
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
for (i = 0; i < seq->count; i++) {
le = seq->array[i];
le = scheme_optimize_expr(le, info);
seq->array[i] = le;
}
return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr);
}
Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int jit)
{
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr;
@ -2045,6 +2123,221 @@ static void bangboxvalue_validate(Scheme_Object *data, Mz_CPort *port,
/* let, let-values, letrec, etc. */
/**********************************************************************/
static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
{
Scheme_Type t = SCHEME_TYPE(o);
switch (t) {
case scheme_compiled_toplevel_type:
return 1;
case scheme_local_type:
if (SCHEME_LOCAL_POS(o) > bind_count)
return 1;
break;
case scheme_branch_type:
if (fuel) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o;
if (is_liftable(b->test, bind_count, fuel - 1)
&& is_liftable(b->tbranch, bind_count, fuel - 1)
&& is_liftable(b->fbranch, bind_count, fuel - 1))
return 1;
}
break;
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)o;
int i;
for (i = app->num_args + 1; i--; ) {
if (!is_liftable(app->args[i], bind_count + app->num_args, fuel - 1))
return 0;
}
return 1;
}
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
if (is_liftable(app->rator, bind_count + 1, fuel - 1)
&& is_liftable(app->rand, bind_count + 1, fuel - 1))
return 1;
}
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
if (is_liftable(app->rator, bind_count + 2, fuel - 1)
&& is_liftable(app->rand1, bind_count + 2, fuel - 1)
&& is_liftable(app->rand2, bind_count + 2, fuel - 1))
return 1;
}
default:
if (t > _scheme_compiled_values_types_)
return 1;
}
return 0;
}
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info)
{
Optimize_Info *body_info;
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body;
Scheme_Object *body, *value;
int i, j, pos, is_rec, max_let_depth = 0, all_simple = 1, skipped = 0;
/* 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
tailness of E.) */
if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
&& (((Scheme_Local *)clv->body)->position == 0)) {
Scheme_Type lhs;
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;
}
}
}
body_info = scheme_optimize_info_add_frame(info, head->count, head->count, 0);
is_rec = SCHEME_LET_RECURSIVE(head);
if (is_rec)
all_simple = 0;
body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
if (pre_body->count != 1)
all_simple = 0;
for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) {
scheme_optimize_mutated(body_info, pos + j);
all_simple = 0;
}
}
pos += pre_body->count;
body = pre_body->body;
}
body = head->body;
pre_body = NULL;
pos = 0;
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
value = scheme_optimize_expr(pre_body->value, body_info);
pre_body->value = value;
if ((pre_body->count == 1)
&& !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) {
if (SAME_TYPE(SCHEME_TYPE(value), scheme_local_type)) {
/* Don't optimize reference to a local binding
that's not available yet, or that mutable. */
int vpos;
vpos = SCHEME_LOCAL_POS(value);
if ((vpos < head->count) && (vpos >= pos))
value = NULL;
else
value = scheme_optimize_reverse_unless_mutated(body_info, vpos);
}
if (value
&& (scheme_compiled_duplicate_ok(value)
|| (0 && SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)))) {
scheme_optimize_propagate(body_info, pos, value);
}
}
if (body_info->max_let_depth > max_let_depth)
max_let_depth = body_info->max_let_depth;
body_info->max_let_depth = 0;
pos += pre_body->count;
body = pre_body->body;
info->size += 1;
}
body = scheme_optimize_expr(body, body_info);
pre_body->body = body;
info->size += 1;
/* Clear used flags where possible */
if (all_simple) {
body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
if (!scheme_optimize_is_used(body_info, pos)
&& scheme_omittable_expr(pre_body->value, 1)) {
skipped++;
if (pre_body->flags[0] & SCHEME_WAS_USED) {
pre_body->flags[0] -= SCHEME_WAS_USED;
}
} else {
pre_body->flags[0] |= SCHEME_WAS_USED;
}
pos += pre_body->count;
body = pre_body->body;
}
}
if (body_info->max_let_depth > max_let_depth)
max_let_depth = body_info->max_let_depth;
body_info->max_let_depth = (max_let_depth + head->count - skipped);
scheme_optimize_info_done(body_info);
return form;
}
Scheme_Object *
scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
/* Special case for when the `let' expression appears in an `if' test */
{
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
/* Special case: (let ([x M]) (if x x N)), where x is not in N,
to (if M #t #f), since we're in a test position. */
if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
Scheme_Compiled_Let_Value *clv;
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
&& (((clv->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT)
== 2)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)clv->body;
if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_local_type)
&& SAME_TYPE(SCHEME_TYPE(b->tbranch), scheme_local_type)
&& !SCHEME_LOCAL_POS(b->test)
&& !SCHEME_LOCAL_POS(b->tbranch)) {
Scheme_Branch_Rec *b3;
Optimize_Info *sub_info;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b3->so.type = scheme_branch_type;
b3->test = clv->value;
b3->tbranch = scheme_true;
b3->fbranch = b->fbranch;
sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0);
form = scheme_optimize_expr((Scheme_Object *)b3, sub_info);
scheme_optimize_info_done(sub_info);
return form;
}
}
}
return scheme_optimize_lets(form, info);
}
Scheme_Object *
scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
{
@ -2057,23 +2350,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
mzshort *skips, skips_fast[5];
int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc;
/* Special case: (let ([x E]) x) where E is lambda, case-lambda,
etc. (If we allowed arbitrary E here, it would affect the
tailness of E.) */
if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
&& (((Scheme_Local *)clv->body)->position == 0)) {
Scheme_Type lhs;
lhs = SCHEME_TYPE(clv->value);
if ((lhs == scheme_compiled_unclosed_procedure_type)
|| (lhs == scheme_case_lambda_sequence_type)) {
linfo = scheme_resolve_info_extend(info, 0, 1, 0);
return scheme_resolve_expr(clv->value, linfo);
}
}
}
/* Find body: */
body = head->body;
pre_body = NULL;
@ -2087,26 +2363,34 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
/* Do we need to box vars in a letrec? */
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
int is_proc;
int is_proc, is_lift;
is_proc = scheme_is_compiled_procedure(clv->value, 1);
if (is_proc)
is_lift = 0;
else
is_lift = is_liftable(clv->value, head->count, 5);
if (!(is_proc || (SCHEME_TYPE(clv->value) > _scheme_compiled_values_types_))) {
if (!is_proc && !is_lift) {
recbox = 1;
break;
} else {
int j;
if (!is_lift) {
/* is_proc must be true ... */
int j;
for (j = 0; j < clv->count; j++) {
if (clv->flags[j] & SCHEME_WAS_SET_BANGED) {
recbox = 1;
break;
for (j = 0; j < clv->count; j++) {
if (clv->flags[j] & SCHEME_WAS_SET_BANGED) {
recbox = 1;
break;
}
}
}
if (recbox)
break;
if (recbox)
break;
if (scheme_is_compiled_procedure(clv->value, 0))
num_rec_procs++;
if (scheme_is_compiled_procedure(clv->value, 0))
num_rec_procs++;
}
}
}
@ -2126,18 +2410,27 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
int skip_count = 0, frame_size;
int j, k;
clv = (Scheme_Compiled_Let_Value *)head->body;
j = head->num_clauses;
if (j <= 5)
skips = skips_fast;
else
skips = MALLOC_N_ATOMIC(mzshort, j);
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) {
if (!(clv->flags[0] & SCHEME_WAS_USED))
skips[i] = 1;
else
skips[i] = 0;
}
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = 0; i < head->num_clauses; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) {
Scheme_Object *le;
skips[i] = 0;
if (!(clv->flags[0] & SCHEME_WAS_USED)) {
skip_count++;
}
/* First `i+1' bindings now exist "at runtime", except those skipped. */
/* The mapping is complicated because we now push in the order of
@ -2146,30 +2439,15 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1);
for (j = i, k = 0; j >= 0; j--) {
if (skips[j])
scheme_resolve_info_add_mapping(linfo, j,
((skips[j] < 0)
? (k - skips[j] - 1)
: (skips[j] - 1 + frame_size)),
0);
scheme_resolve_info_add_mapping(linfo, j, 0, 0);
else
scheme_resolve_info_add_mapping(linfo, j, k++, 0);
}
le = scheme_resolve_expr(clv->value, linfo);
if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
/* This binding is like (let ([x y]) ...) where y is not
global and never set!ed, so replace all uses of x with
uses of y. In the skips array, if the position is
outside this frame, put 1 + offset relative
the start of the binding group. If this position is
inside this frame, put -pos in the array. */
j = SCHEME_LOCAL_POS(le);
if (j < frame_size)
skips[i] = -j;
else
skips[i] = (j - frame_size) + 1;
skip_count++;
if (!(clv->flags[0] & SCHEME_WAS_USED)) {
/* Unused binding, so drop it. */
} else {
Scheme_Let_One *lo;
int et;
@ -2244,27 +2522,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
extra_alloc = 0;
val_linfo = linfo;
/* We used to try to collapse let_void, here. But collapsing
potentially changes the maxiumum stack depth of the expression,
since collapsing make variables from the body get allocated
before the RHSes are executed. Also, this optimization was
arbitrary, in that it didn't recursively collapse. For both of
these reasons, it's now disabled. */
#if 0
if (!num_rec_procs) {
if (SAME_TYPE(SCHEME_TYPE(body), scheme_let_void_type)) {
Scheme_Let_Void *lvd = (Scheme_Let_Void *)body;
if (!!SCHEME_LET_AUTOBOX(lvd) == !!recbox) {
/* Do collapse: */
extra_alloc = lvd->count;
body = lvd->body;
val_linfo = scheme_resolve_info_extend(linfo, extra_alloc, 0, 0);
}
}
}
#endif
if (num_rec_procs) {
Scheme_Object **sa;
letrec = MALLOC_ONE_TAGGED(Scheme_Letrec);
@ -2346,43 +2603,6 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
return first;
}
Scheme_Object *
scheme_resolve_lets_for_test(Scheme_Object *form, Resolve_Info *info)
/* Special case for when the `let' expression appears in an `if' test */
{
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
/* Special case: (let ([x M]) (if x x N)), where x is not in N,
to (if M #t #f), since we're in a test position. */
if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
Scheme_Compiled_Let_Value *clv;
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
&& (((clv->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT)
== 2)) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)clv->body;
if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_local_type)
&& SAME_TYPE(SCHEME_TYPE(b->tbranch), scheme_local_type)
&& !SCHEME_LOCAL_POS(b->test)
&& !SCHEME_LOCAL_POS(b->tbranch)) {
Scheme_Branch_Rec *b3;
b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b3->so.type = scheme_branch_type;
b3->test = clv->value;
b3->tbranch = scheme_true;
b3->fbranch = b->fbranch;
info = scheme_resolve_info_extend(info, 0, 1, 0);
return scheme_resolve_expr((Scheme_Object *)b3, info);
}
}
}
return scheme_resolve_lets(form, info);
}
static Scheme_Object *
gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec,
@ -2609,8 +2829,6 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1);
rec[drec].max_let_depth += num_bindings;
return first;
}
@ -3174,6 +3392,22 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port, char *stack,
}
}
static Scheme_Object *
begin0_optimize(Scheme_Object *obj, Optimize_Info *info)
{
int i;
i = ((Scheme_Sequence *)obj)->count;
while (i--) {
Scheme_Object *le;
le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info);
((Scheme_Sequence *)obj)->array[i] = le;
}
return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
}
static Scheme_Object *
begin0_resolve(Scheme_Object *obj, Resolve_Info *info)
{
@ -3632,6 +3866,42 @@ static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
do_define_syntaxes_validate(data, port, stack, depth, letlimit, delta, num_toplevels, num_stxes, 1);
}
static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int for_stx)
{
Scheme_Object *cp, *names, *val, *base_stack_depth, *dummy;
Optimize_Info *einfo;
cp = SCHEME_CAR(data);
data = SCHEME_CDDR(data);
dummy = SCHEME_CAR(data);
data = SCHEME_CDR(data);
names = SCHEME_CAR(data);
val = SCHEME_CDR(data);
einfo = scheme_optimize_info_create();
val = scheme_optimize_expr(val, einfo);
base_stack_depth = scheme_make_integer(einfo->max_let_depth);
return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD),
cons(cp,
cons(base_stack_depth,
cons(dummy,
cons(names, val)))));
}
static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info)
{
return do_define_syntaxes_optimize(data, info, 0);
}
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info)
{
return do_define_syntaxes_optimize(data, info, 1);
}
static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info, int for_stx)
{
Comp_Prefix *cp;
@ -3721,7 +3991,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD),
cons((Scheme_Object *)exp_env->prefix,
cons(scheme_make_integer(rec1.max_let_depth),
cons(scheme_make_integer(0),
cons(dummy,
cons(names, val)))));
}
@ -3865,6 +4135,7 @@ Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Sch
Scheme_Comp_Env *eenv;
Resolve_Prefix *rp;
Resolve_Info *ri;
Optimize_Info *oi;
int vc, nc, j, i;
Scheme_Compile_Info mrec;
@ -3884,16 +4155,18 @@ Scheme_Object *scheme_bind_syntaxes(const char *where, Scheme_Object *names, Sch
For letrec-syntaxes+values, don't simplify because it's too expensive. */
rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, 0);
oi = scheme_optimize_info_create();
a = scheme_optimize_expr(a, oi);
ri = scheme_resolve_info_create(rp);
a = scheme_resolve_expr(a, ri);
/* To JIT:
if (ri->use_jit) a = scheme_jit_expr(a);
but it's not likely that a let-syntax-bound macro is going
to run lots of times, so JITting is probably not worth it. */
a = eval_letmacro_rhs(a, rhs_env, mrec.max_let_depth, rp, eenv->genv->phase, certs);
a = eval_letmacro_rhs(a, rhs_env, oi->max_let_depth, rp, eenv->genv->phase, certs);
if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES))
vc = scheme_current_thread->ku.multiple.count;