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

@@ -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)
 

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

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);

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 ls1, ls2, p1, p2, sv, ctx2;
-  sexp_gc_var3(res, substs, tmp);
+  sexp_gc_var4(res, substs, tmp, app);
-  sexp_gc_preserve3(ctx, res, substs, tmp);
+  sexp_gc_preserve4(ctx, res, substs, tmp, app);
-  res = ast;
+  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))
+    /* don't simplify the operator if it's a lambda because we
-      simplify_it(sexp_car(ls1));
+       simplify that as a special case below, with the appropriate
-    if (sexp_opcodep(sexp_car(res))) {
+       substs list */
-      if (sexp_opcode_class(sexp_car(res)) == OPC_ARITHMETIC) {
+    app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
-        for (check=1, ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
+                     : (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);
+          generate(ctx2, app);
-          res = finalize_bytecode(ctx2);
+          app = finalize_bytecode(ctx2);
+          if (! sexp_exceptionp(app)) {
             tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
-          res = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, res, tmp);
+            app = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, app, tmp);
-          if (! sexp_exceptionp(res))
+            if (! sexp_exceptionp(app))
-            res = sexp_apply(ctx2, res, SEXP_NULL);
+              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))
+      if (! (sexp_pairp(sexp_cdr(ls2))
              && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
-              || sexp_lambdap(tmp))) {
+                 || sexp_lambdap(tmp))))
-        if (ls1)
+        sexp_push(ctx, app, tmp);
-          sexp_cdr(ls1) = sexp_cdr(ls2);
+    }
+    if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
+      res = sexp_car(app);
     else
-          sexp_seq_ls(res) = sexp_cdr(ls2);
+      sexp_seq_ls(res) = sexp_nreverse(ctx, app);
-      } 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);
+
+  sexp_gc_release4(ctx);
   return res;
 }
 

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)