Optimize quasiquote code generation.

The surface motive here is to get better code than
forms like (append (list 'a) (list 'b) ...).

The ulterior motive is to suppress the memory
explosion when heavily nested forms like ^^^^^^^^^^^x
are expanded. This problem was uncovered by
AFL (fast).

* eval.c (optimize_qquote_form, optimize_qquote_args,
optimize_qquote): New static functions.
(expand_qquote_rec): New function.
(expand_qquote): Contents moved into expand_qquote_rec.
This function now optimizes the results of calling
expand_qquote_rec.

1 files changed, 98 insertions, 9 deletions

diff --git a/eval.c b/eval.c
index e01cf413..0379eabf 100644
--- a/eval.c
+++ b/eval.c
@@ -2616,8 +2616,89 @@ static val expand_cond_pairs(val form, val menv)
   }
 }
 
+static val optimize_qquote_form(val form)
+{
+  if (atom(form)) {
+    return form;
+  } else {
+    val sym = car(form);
+    val args = cdr(form);
+
+    if (sym == append_s) {
+      val eq_to_list = curry_12_1(eq_f, list_s);
+
+      if (all_satisfy(args, andf(func_n1(consp),
+                                 chain(car_f, eq_to_list, nao),
+                                 nao),
+                      nil))
+      {
+        sym = list_s;
+        args = mapcar(func_n1(second), args);
+      } else {
+        val blargs = butlast(args);
+
+        if (all_satisfy(blargs, andf(func_n1(consp),
+                                     chain(car_f, eq_to_list, nao),
+                                     nao),
+                        nil))
+          return rlcp_tree(cons(list_star_s, nappend2(mapcar(func_n1(second), blargs),
+                                                      last(args))), form);
+      }
+    }
+
+    if (sym == list_s) {
+      if (all_satisfy(args, andf(func_n1(consp),
+                                 chain(car_f, curry_12_1(eq_f, quote_s), nao),
+                                 nao),
+                      nil))
+        return rlcp_tree(cons(quote_s, cons(mapcar(func_n1(second), args), nil)), form);
+      return rlcp_tree(cons(list_s, args), form);
+    }
+
+    return form;
+  }
+}
+
+static val optimize_qquote_args(val form)
+{
+  if (atom(form)) {
+    return form;
+  } else {
+    val sym = car(form);
+    val args = cdr(form);
+
+    if (sym == list_s || sym == append_s || sym == list_star_s) {
+      val consp_f = func_n1(consp);
+      val cons_f = func_n2(cons);
+      val if_fun = andf(consp_f,
+                        chain(car_f, curry_12_1(eq_f, list_s), nao),
+                        chain(cdr_f, consp_f, nao),
+                        chain(cdr_f, cdr_f, null_f, nao),
+                        chain(cdr_f, car_f, consp_f, nao),
+                        chain(cdr_f, car_f, car_f, curry_12_1(eq_f, quote_s), nao),
+                        nao);
+      val xform_fun = chain(cdr_f, car_f, cdr_f,
+                            curry_12_1(cons_f, nil),
+                            curry_12_2(cons_f, quote_s),
+                            nao);
+      val xform = iffi(if_fun, xform_fun, nil);
+      return rlcp_tree(cons(sym, mapcar(xform, args)), form);
+    }
+
+    return form;
+  }
+}
+
+static val optimize_qquote(val form)
+{
+  return optimize_qquote_args(optimize_qquote_form(form));
+}
+
 static val expand_qquote(val qquoted_form, val menv,
-                         val qq, val unq, val spl)
+                         val qq, val unq, val spl);
+
+static val expand_qquote_rec(val qquoted_form, val menv,
+                             val qq, val unq, val spl)
 {
   if (nilp(qquoted_form)) {
     return nil;
@@ -2637,9 +2718,9 @@ static val expand_qquote(val qquoted_form, val menv,
     } else if (sym == unq) {
       return rlcp(expand(second(qquoted_form), menv), qquoted_form);
     } else if (sym == qq) {
-      return rlcp(expand_qquote(expand_qquote(second(qquoted_form),
-                                              menv, qq, unq, spl),
-                                menv, qq, unq, spl),
+      return rlcp(expand_qquote_rec(expand_qquote(second(qquoted_form),
+                                                  menv, qq, unq, spl),
+                                    menv, qq, unq, spl),
                   qquoted_form);
     } else if (sym == hash_lit_s) {
       val args = expand_qquote(second(qquoted_form), menv, qq, unq, spl);
@@ -2652,7 +2733,7 @@ static val expand_qquote(val qquoted_form, val menv,
       val f = sym;
       val r = cdr(qquoted_form);
       val f_ex;
-      val r_ex = expand_qquote(r, menv, qq, unq, spl);
+      val r_ex = expand_qquote_rec(r, menv, qq, unq, spl);
 
       if (consp(f)) {
         val qsym = car(f);
@@ -2661,10 +2742,10 @@ static val expand_qquote(val qquoted_form, val menv,
         } else if (qsym == unq) {
           f_ex = cons(list_s, cons(expand(second(f), menv), nil));
         } else if (qsym == qq) {
-          f_ex = cons(list_s, cons(expand_qquote(expand_qquote(second(f),
-                                                               menv, qq,
-                                                               unq, spl),
-                                                 menv, qq, unq, spl), nil));
+          f_ex = cons(list_s, cons(expand_qquote_rec(expand_qquote(second(f),
+                                                                   menv, qq,
+                                                                   unq, spl),
+                                                     menv, qq, unq, spl), nil));
         } else {
           f_ex = cons(list_s, cons(expand_qquote(f, menv, qq, unq, spl), nil));
         }
@@ -2690,6 +2771,14 @@ static val expand_qquote(val qquoted_form, val menv,
   abort();
 }
 
+static val expand_qquote(val qquoted_form, val menv,
+                         val qq, val unq, val spl)
+{
+  val exp = expand_qquote_rec(qquoted_form, menv, qq, unq, spl);
+  return optimize_qquote(exp);
+}
+
+
 static val me_qquote(val form, val menv)
 {
   if (first(form) == sys_qquote_s)