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

JIT opts for or and and

Browse Source 
svn: r2151
This commit is contained in:
Matthew Flatt 2006-02-07 14:48:53 +00:00
parent 040a1fbbff
commit d65b9cb407
6 changed files with 1476 additions and 1360 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
src/mzscheme/src/bool.c
View File

@ -37,6 +37,9 @@ Scheme_Object scheme_true[1];
Scheme_Object scheme_false[1];
Scheme_Object *scheme_not_prim;
Scheme_Object *scheme_eq_prim;
Scheme_Object *scheme_eqv_prim;
Scheme_Object *scheme_equal_prim;
/* locals */
static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
@ -60,6 +63,9 @@ void scheme_init_bool (Scheme_Env *env)
Scheme_Object *p;
REGISTER_SO(scheme_not_prim);
REGISTER_SO(scheme_eq_prim);
REGISTER_SO(scheme_eqv_prim);
REGISTER_SO(scheme_equal_prim);
p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
scheme_not_prim = p;
@ -75,18 +81,14 @@ void scheme_init_bool (Scheme_Env *env)
p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_eq_prim = p;
scheme_add_global_constant("eq?", p, env);
scheme_add_global_constant("eqv?",
scheme_make_folding_prim(eqv_prim,
"eqv?",
2, 2, 1),
env);
scheme_add_global_constant("equal?",
scheme_make_prim_w_arity(equal_prim,
"equal?",
2, 2),
env);
scheme_eqv_prim = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1);
scheme_add_global_constant("eqv?", scheme_eqv_prim, env);
scheme_equal_prim = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
scheme_add_global_constant("equal?", scheme_equal_prim, env);
}
static Scheme_Object *

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

File diff suppressed because it is too large Load Diff

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

@ -122,6 +122,7 @@ static int env_uid_counter;
#define ARBITRARY_USE 1
#define CONSTRAINED_USE 2
#define WAS_SET_BANGED 4
/* See also SCHEME_USE_COUNT_MASK */
typedef struct Compile_Data {
char **stat_dists; /* (pos, depth) => used? */
@ -1488,12 +1489,24 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
/* Generates a Scheme_Local record for a static distance coodinate, and also
marks the variable as used for closures. */
{
COMPILE_DATA(frame)->use[i] |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
? CONSTRAINED_USE
: ARBITRARY_USE)
| ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
? WAS_SET_BANGED
: 0));
int cnt, u;
u = COMPILE_DATA(frame)->use[i];
u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
? CONSTRAINED_USE
: ARBITRARY_USE)
| ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
? WAS_SET_BANGED
: 0));
cnt = ((u & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
if (cnt < SCHEME_USE_COUNT_INF)
cnt++;
u -= (u & SCHEME_USE_COUNT_MASK);
u |= (cnt << SCHEME_USE_COUNT_SHIFT);
COMPILE_DATA(frame)->use[i] = u;
if (!COMPILE_DATA(frame)->stat_dists) {
int k, *ia;
@ -2532,6 +2545,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
v[i] |= SCHEME_WAS_USED;
if (old & WAS_SET_BANGED)
v[i] |= SCHEME_WAS_SET_BANGED;
v[i] |= (old & SCHEME_USE_COUNT_MASK);
}
return v;

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

@ -992,6 +992,16 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *info)
return (Scheme_Object *)app;
}
static int eq_testable_constant(Scheme_Object *v)
{
if (SCHEME_SYMBOLP(v)
|| SCHEME_FALSEP(v)
|| SAME_OBJ(v, scheme_true)
|| SCHEME_VOIDP(v))
return 1;
return 0;
}
static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *info)
{
Scheme_App3_Rec *app;
@ -1011,6 +1021,15 @@ static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *info)
le = scheme_resolve_expr(app->rand2, info);
app->rand2 = le;
/* Optimize `equal?' or `eqv?' test on certain types
to `eq?'. This is especially helpful for the JIT. */
if ((SAME_OBJ(app->rator, scheme_equal_prim)
|| SAME_OBJ(app->rator, scheme_eqv_prim))
&& (eq_testable_constant(app->rand1)
|| eq_testable_constant(app->rand2))) {
app->rator = scheme_eq_prim;
}
et = scheme_get_eval_type(app->rand2);
et = et << 3;
et += scheme_get_eval_type(app->rand1);
@ -1058,7 +1077,7 @@ static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
/* Try optimize: (if (not x) y z) => (if x z y) */
/* Done here because `not' is easily recognized at this
point, and we haven't yet resolved Scheme-stack locations
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)) {
@ -1076,9 +1095,46 @@ static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info)
break;
}
t = scheme_resolve_expr(t, info);
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;
}
}
b->test = t;
b->tbranch = tb;
b->fbranch = fb;

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

@ -221,6 +221,9 @@ extern Scheme_Object *scheme_lambda_syntax;
extern Scheme_Object *scheme_begin_syntax;
extern Scheme_Object *scheme_not_prim;
extern Scheme_Object *scheme_eq_prim;
extern Scheme_Object *scheme_eqv_prim;
extern Scheme_Object *scheme_equal_prim;
extern Scheme_Object *scheme_def_exit_proc;
@ -1713,6 +1716,7 @@ 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);
@ -1784,6 +1788,10 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
#define SCHEME_WAS_USED 1
#define SCHEME_WAS_SET_BANGED 2
#define SCHEME_USE_COUNT_MASK 0x70
#define SCHEME_USE_COUNT_SHIFT 4
#define SCHEME_USE_COUNT_INF (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT)
/* flags reported by scheme_resolve_info_flags */
#define SCHEME_INFO_BOXED 1

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

@ -2343,6 +2343,43 @@ 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,