compiler: constant folding in optimizer.

The compiler handles trivial constant folding over the
source code, as a source to source transformation.
However, there are more opportunities for constant folding
after data flow optimizations of the VM code.
Early constant folding will not fold, for instance,

  (let ((a 2) (b 3)) (* a b))

but we can reduce this to an end instruction that returns
the value of a D register that holds 6. Data flow optimizations
will propagate the D registers for 2 and 3 into the gcall
instruction. We can then recognize that we have a gcall with
nothing but D register operands, calling a constant-foldable
function. We can allocate a new D register to hold the result
of that calculation and just move that D register's value
into the target register of the original gcall.

* stdlib/compiler.tl (compiler get-dreg): When allocating
a new D reg, we must invalidate the datavec slot which is
calculated from the data hash. This didn't matter before,
because until now, get-datavec was called after compilation,
at which point no new D regs will exist. That is changing;
the optimizer can allocate D regs.
(compiler null-dregs, compiler null-stab): New methods.
(compiler optimize): Pass self to constructor for basic-blocks.
basic-blocks now references back to the compiler.
At optimization level 5 or higher, constant folding can
now happen, so we call the new method in the optimizer to
null the unused data. This overwrites unused D registers
and unused parts of the symbol vector with nil.

* stdlib/optimize (basic-blocks): Boa constructor now takes
a new leftmost param, the compiler.
(basic-blocks do-peephole-block): New optimization case:
gcall instruction invoking const-foldable function, with
all arguments being dregs.
(basic-blocks null-unused-data): New method.

2 files changed, 43 insertions, 5 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index e48a2403..8e8ba3c0 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -409,8 +409,9 @@
       (((dreg [me.dreg dobj])) dreg)
       ((((< me.dreg-cntr %lev-size%)))
        (let ((dreg ^(d ,(pinc me.dreg-cntr))))
-        (set [me.data (cadr dreg)] dobj)
-        (set [me.dreg dobj] dreg)))
+        (set me.datavec nil
+             [me.data (cadr dreg)] dobj
+             [me.dreg dobj] dreg)))
       (t (compile-error me.last-form "code too complex: too many literals")))))
 
 (defmeth compiler alloc-dreg (me)
@@ -420,6 +421,12 @@
       dreg)
     (compile-error me.last-form "code too complex: too many literals")))
 
+(defmeth compiler null-dregs (me used-dreg)
+  (each ((n 0..me.dreg-cntr))
+    (unless (bit used-dreg n)
+      (set [me.data n] nil
+           me.datavec nil))))
+
 (defmeth compiler get-sidx (me atom)
   (iflet ((sidx [me.sidx atom]))
     sidx
@@ -427,6 +434,12 @@
       (set [me.stab sidx] atom)
       (set [me.sidx atom] sidx))))
 
+(defmeth compiler null-stab (me used-sidx)
+  (each ((n 0..me.sidx-cntr))
+    (unless (bit used-sidx n)
+      (set [me.stab n] nil
+           me.symvec nil))))
+
 (defmeth compiler get-datavec (me)
   (or me.datavec
       (set me.datavec (vec-list [mapcar me.data (range* 0 me.dreg-cntr)]))))
@@ -1766,7 +1779,7 @@
   (let ((olev *opt-level*))
     (if (>= olev 4)
       (let* ((lt-dregs (mapcar .oreg me.lt-frags))
-             (bb (new (basic-blocks insns lt-dregs me.(get-symvec)))))
+             (bb (new (basic-blocks me insns lt-dregs me.(get-symvec)))))
         (when (>= olev 4)
           bb.(thread-jumps)
           bb.(elim-dead-code))
@@ -1778,7 +1791,8 @@
               bb.(peephole)
               bb.(link-graph)
               bb.(thread-jumps)
-              bb.(elim-dead-code))))
+              bb.(elim-dead-code))
+            bb.(null-unused-data)))
         (cond
           ((>= olev 7)
            bb.(merge-jump-thunks)
diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl
index 9950d934..b6cbbb10 100644
--- a/stdlib/optimize.tl
+++ b/stdlib/optimize.tl
@@ -52,7 +52,8 @@
                            rlinks ,(mapcar .label bl.rlinks)
                            next ,bl.next.?label) stream)))
 
-  (defstruct (basic-blocks insns lt-dregs symvec) nil
+  (defstruct (basic-blocks compiler insns lt-dregs symvec) nil
+    compiler
     insns
     lt-dregs
     symvec
@@ -524,6 +525,16 @@
              (set bb.recalc t)
              (cons (car insns) ren))
             (t insns))))
+      ;; constant folding
+      (@(require ((gcall @tgt @idx . @(all (d @dn))) . @rest)
+                 [%const-foldable% [bb.symvec idx]])
+        (let* ((co bb.compiler)
+               (dvec co.(get-datavec))
+               (fun [bb.symvec idx])
+               (args [mapcar dvec dn])
+               (val (apply fun args))
+               (dreg co.(get-dreg val)))
+          ^((mov ,tgt ,dreg) ,*rest)))
       (@nil insns))))
 
 (defmeth basic-blocks peephole (bb)
@@ -764,6 +775,19 @@
         (each ((cl clist))
           cl.(apply-treg-compacting-map map))))))
 
+(defmeth basic-blocks null-unused-data (bb)
+  (let ((used-dregs 0)
+        (used-funs 0)
+        (co bb.compiler))
+    (each ((bl bb.list))
+      (each ((insn bl.insns))
+        (if-match @(coll (d @dn)) insn
+          (set-mask used-dregs (mask . dn)))
+        (if-match (@(or gcall gapply getf getlx setlx) @nil @fn . @nil) insn
+          (set-mask used-funs (mask fn)))))
+    co.(null-dregs used-dregs)
+    co.(null-stab used-funs)))
+
 (defun rewrite (fun list)
   (build
     (while* list