Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 13:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

adding cases in simplify to optimize let bindings over literals

Browse source 
and non-mutated identifiers.  helps a lot with the default
syntax-rules constructions - in particular reduces the number of
bytecode allocations for (chibi match) from 2397 to 1872.
This commit is contained in:
Alex Shinn 2009-12-18 11:37:37 +09:00
parent 8785e85810
commit 6b3b13dec6
5 changed files with 82 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -56,7 +56,7 @@ all: chibi-scheme$(EXE) libs
COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
lib/chibi/ast$(SO) lib/chibi/net$(SO) \
lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO)
lib/chibi/posix$(SO) lib/chibi/heap-stats$(SO)
libs: $(COMPILED_LIBS)

3
config.scm
View file

@ -187,7 +187,8 @@
open-output-file close-input-port close-output-port read read-char
peek-char eof-object? char-ready? write display newline write-char
load eval
error file-exists? string-concatenate
*current-input-port* *current-output-port* *current-error-port*
error current-error-port file-exists? string-concatenate
open-input-string open-output-string get-output-string
sc-macro-transformer rsc-macro-transformer er-macro-transformer
identifier? identifier=? identifier->symbol make-syntactic-closure

2
eval.c
View file

@ -2463,11 +2463,9 @@ sexp sexp_compile (sexp ctx, sexp x) {
if (sexp_exceptionp(ast)) {
res = ast;
} else {
#if USE_SIMPLIFY
res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS);
for ( ; sexp_pairp(res); res=sexp_cdr(res))
ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast);
#endif
free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */
generate(ctx, ast);
res = finalize_bytecode(ctx);

113
opt/simplify.c
View file

@ -1,21 +1,29 @@
#define simplify_it(it) it = simplify(ctx, it, substs, lambda)
#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;
sexp ls1, ls2, p1, p2, sv, ctx2;
sexp_gc_var4(res, substs, tmp, app);
sexp_gc_preserve4(ctx, res, substs, tmp, app);
res = ast; /* return the ast as-is by default */
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)) {
/* don't simplify the operator if it's a lambda because we
simplify that as a special case below, with the appropriate
substs list */
app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
: (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1))
sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
app = sexp_nreverse(ctx, app);
if (sexp_opcodep(sexp_car(app))) {
if (sexp_opcode_class(sexp_car(app)) == OPC_ARITHMETIC) {
for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
check = 0;
break;
@ -23,24 +31,54 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
}
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);
generate(ctx2, app);
app = finalize_bytecode(ctx2);
if (! sexp_exceptionp(app)) {
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp);
if (! sexp_exceptionp(app))
app = sexp_apply(ctx2, app, 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));
} else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
p1 = NULL;
p2 = sexp_lambda_params(sexp_car(app));
ls1 = app;
ls2 = sexp_cdr(app);
sv = sexp_lambda_sv(sexp_car(app));
for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
&& (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
|| (sexp_refp(sexp_car(ls2))
&& sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))))) {
tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
tmp = sexp_cons(ctx, sexp_car(p2), tmp);
sexp_push(ctx, substs, tmp);
sexp_cdr(ls1) = sexp_cdr(ls2);
if (p1)
sexp_cdr(p1) = sexp_cdr(p2);
else
sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
} else {
p1 = p2;
ls1 = ls2;
}
}
sexp_lambda_body(sexp_car(app))
= simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
if (sexp_nullp(sexp_cdr(app))
&& sexp_nullp(sexp_lambda_params(sexp_car(app)))
&& sexp_nullp(sexp_lambda_defs(sexp_car(app))))
app = sexp_lambda_body(sexp_car(app));
}
res = app;
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)) {
@ -53,6 +91,7 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
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))
@ -61,33 +100,29 @@ static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
break;
}
break;
case SEXP_SET:
simplify_it(sexp_set_value(res));
break;
case SEXP_SEQ:
ls1 = NULL;
app = SEXP_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_cdr(ls2))
&& (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
|| sexp_lambdap(tmp))))
sexp_push(ctx, app, tmp);
}
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");
if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
res = sexp_car(app);
else
sexp_seq_ls(res) = sexp_nreverse(ctx, app);
break;
}
sexp_gc_release3(ctx);
sexp_gc_release4(ctx);
return res;
}

6
tests/r5rs-tests.scm
View file

@ -7,7 +7,11 @@
((test expect expr)
(begin
(set! *tests-run* (+ *tests-run* 1))
(let ((str (call-with-output-string (lambda (out) (display 'expr out))))
(let ((str (call-with-output-string
(lambda (out)
(write *tests-run*)
(display ". ")
(display 'expr out))))
(res expr))
(display str)
(write-char #\space)