From 6b3b13dec63dbf85bbe6eb074d990c0596337485 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 18 Dec 2009 11:37:37 +0900 Subject: [PATCH] adding cases in simplify to optimize let bindings over literals 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. --- Makefile | 2 +- config.scm | 3 +- eval.c | 2 - opt/simplify.c | 113 ++++++++++++++++++++++++++++--------------- tests/r5rs-tests.scm | 6 ++- 5 files changed, 82 insertions(+), 44 deletions(-) diff --git a/Makefile b/Makefile index 67ffa658..e6c1d79a 100644 --- a/Makefile +++ b/Makefile @@ -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) diff --git a/config.scm b/config.scm index e670845d..141e95f3 100644 --- a/config.scm +++ b/config.scm @@ -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 diff --git a/eval.c b/eval.c index 20e27da4..8d5dc45a 100644 --- a/eval.c +++ b/eval.c @@ -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); diff --git a/opt/simplify.c b/opt/simplify.c index c2241939..4092f791 100644 --- a/opt/simplify.c +++ b/opt/simplify.c @@ -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; } diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index 5ad8b5b7..555caf85 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -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)