From 2baae2cc3b5ac520cb98bee7be9ebd1dcb89e119 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Thu, 17 Dec 2009 16:41:49 +0900
Subject: [PATCH] adding initial optimization pass

this includes constant folding, dead-code elimination,
and empty let reduction
---
 Makefile       |  2 +-
 TODO           |  3 +-
 eval.c         | 10 ++++++
 opt/simplify.c | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 110 insertions(+), 2 deletions(-)
 create mode 100644 opt/simplify.c

diff --git a/Makefile b/Makefile
index a2ca3826..67ffa658 100644
--- a/Makefile
+++ b/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
diff --git a/TODO b/TODO
index 57f7c861..4fd8e131 100644
--- a/TODO
+++ b/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.
diff --git a/eval.c b/eval.c
index 6958b9ee..20e27da4 100644
--- a/eval.c
+++ b/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;
 }
diff --git a/opt/simplify.c b/opt/simplify.c
new file mode 100644
index 00000000..c2241939
--- /dev/null
+++ b/opt/simplify.c
@@ -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);
+}
+