mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
adding initial optimization pass
this includes constant folding, dead-code elimination, and empty let reduction
This commit is contained in:
Alex Shinn
parent
3861a5b599
commit
2baae2cc3b
4 changed files with 110 additions and 2 deletions
2
Makefile
2
Makefile
|
|
@ -86,7 +86,7 @@ include/chibi/install.h: Makefile
|
|||
sexp.o: sexp.c gc.c opt/bignum.c $(INCLUDES) Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c opcodes.c opt/debug.c $(INCLUDES) include/chibi/eval.h Makefile
|
||||
eval.o: eval.c opcodes.c opt/debug.c opt/simplify.c $(INCLUDES) include/chibi/eval.h Makefile
|
||||
$(CC) -c $(XCPPFLAGS) $(XCFLAGS) $(CLIBFLAGS) -o $@ $<
|
||||
|
||||
main.o: main.c $(INCLUDES) include/chibi/eval.h Makefile
|
||||
|
|
|
|||
3
TODO
3
TODO
|
|
@ -16,7 +16,8 @@
|
|||
you, (chibi loop)).
|
||||
|
||||
* compiler optimizations
|
||||
** TODO constant folding
|
||||
** DONE constant folding
|
||||
- State "DONE" [2009-12-16 Wed 23:25]
|
||||
** TODO simplification pass, dead-code elimination
|
||||
This is important in particular for the output generated by
|
||||
syntax-rules.
|
||||
|
|
|
|||
10
eval.c
10
eval.c
|
|
@ -2200,6 +2200,10 @@ static sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) {
|
|||
return res;
|
||||
}
|
||||
|
||||
#if USE_SIMPLIFY
|
||||
#include "opt/simplify.c"
|
||||
#endif
|
||||
|
||||
/*********************** standard environment *************************/
|
||||
|
||||
static struct sexp_struct core_forms[] = {
|
||||
|
|
@ -2386,6 +2390,12 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi"));
|
||||
sexp_env_define(ctx, e, sexp_intern(ctx, "*features*"), tmp);
|
||||
sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL;
|
||||
#if USE_SIMPLIFY
|
||||
op = sexp_make_foreign(ctx, "simplify", 1, 0,
|
||||
(sexp_proc1)sexp_simplify, SEXP_VOID);
|
||||
tmp = sexp_cons(ctx, sexp_make_fixnum(500), op);
|
||||
sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), tmp);
|
||||
#endif
|
||||
sexp_gc_release4(ctx);
|
||||
return e;
|
||||
}
|
||||
|
|
|
|||
97
opt/simplify.c
Normal file
97
opt/simplify.c
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
|
||||
#define simplify_it(it) it = simplify(ctx, it, substs, lambda)
|
||||
|
||||
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
|
||||
int check;
|
||||
sexp ls1, ls2, ctx2;
|
||||
sexp_gc_var3(res, substs, tmp);
|
||||
sexp_gc_preserve3(ctx, res, substs, tmp);
|
||||
res = ast;
|
||||
substs = init_substs;
|
||||
loop:
|
||||
switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) {
|
||||
case SEXP_PAIR:
|
||||
for (ls1=res; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
|
||||
simplify_it(sexp_car(ls1));
|
||||
if (sexp_opcodep(sexp_car(res))) {
|
||||
if (sexp_opcode_class(sexp_car(res)) == OPC_ARITHMETIC) {
|
||||
for (check=1, ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
|
||||
if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
|
||||
check = 0;
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (check) {
|
||||
ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx));
|
||||
generate(ctx2, res);
|
||||
res = finalize_bytecode(ctx2);
|
||||
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
|
||||
res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, tmp);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_apply(ctx2, res, SEXP_NULL);
|
||||
}
|
||||
}
|
||||
} else if (lambda && sexp_lambdap(sexp_car(res))) { /* let */
|
||||
if (sexp_nullp(sexp_cdr(res))
|
||||
&& sexp_nullp(sexp_lambda_params(sexp_car(res)))
|
||||
&& sexp_nullp(sexp_lambda_defs(sexp_car(res))))
|
||||
res = sexp_lambda_body(sexp_car(res));
|
||||
}
|
||||
break;
|
||||
case SEXP_LAMBDA:
|
||||
sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
|
||||
break;
|
||||
case SEXP_CND:
|
||||
tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
|
||||
if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
|
||||
res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
|
||||
? sexp_cnd_fail(res) : sexp_cnd_pass(res);
|
||||
goto loop;
|
||||
} else {
|
||||
sexp_cnd_test(res) = tmp;
|
||||
simplify_it(sexp_cnd_pass(res));
|
||||
simplify_it(sexp_cnd_fail(res));
|
||||
}
|
||||
break;
|
||||
case SEXP_REF:
|
||||
tmp = sexp_ref_name(res);
|
||||
for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
|
||||
if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
|
||||
res = sexp_cddar(ls1);
|
||||
break;
|
||||
}
|
||||
break;
|
||||
case SEXP_SET:
|
||||
simplify_it(sexp_set_value(res));
|
||||
break;
|
||||
case SEXP_SEQ:
|
||||
ls1 = NULL;
|
||||
for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
|
||||
tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
|
||||
if (sexp_pairp(sexp_cdr(ls2))
|
||||
&& (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
|
||||
|| sexp_lambdap(tmp))) {
|
||||
if (ls1)
|
||||
sexp_cdr(ls1) = sexp_cdr(ls2);
|
||||
else
|
||||
sexp_seq_ls(res) = sexp_cdr(ls2);
|
||||
} else {
|
||||
sexp_car(ls2) = tmp;
|
||||
ls1 = ls2;
|
||||
}
|
||||
}
|
||||
if (sexp_pairp(sexp_seq_ls(res)) && sexp_nullp(sexp_cdr(sexp_seq_ls(res))))
|
||||
res = sexp_car(sexp_seq_ls(res));
|
||||
break;
|
||||
case SEXP_SYMBOL:
|
||||
fprintf(stderr, "WARNING: raw symbol\n");
|
||||
break;
|
||||
}
|
||||
sexp_gc_release3(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_simplify (sexp ctx, sexp ast) {
|
||||
return simplify(ctx, ast, SEXP_NULL, NULL);
|
||||
}
|
||||
|
||||
Loading…
Add table
Reference in a new issue