compiler: eliminate dead calls.

The main idea in this patch is to identify calls functions
whose values are not used and which have no side effects. For
this purpose, we borrow the same set of functions that we
use as targets for constant folding: those in the compiler's
%const-foldable% hash.

A call is dead if it is a gcall or gapply instruction which
calls one of these functions, and the destination register is
dead.

To maximize the opportunities for this elimination, whenever
we eliminate such an instruction, we mark the block for
re-scanning, and we re-calculate the liveness info for that
block and then globally.

* share/txr/stdlib/compiler.tl (struct compiler): New slots,
datavec and symvec.
(compiler get-datavec): Cache the calculated datavec in the
new datavec slot.
(compiler get-symvec): Cache the calculated symvec in the
new symvec slot.
(compiler optimize): Pass the symvec to the basic-blocks BOA
constructor; it is now needed for identifying functions
that are referenced by symvec index number in the gcall and
gapply instructions.

* share/txr/stdlib/optimize.tl (struct basic-blocks): New
symvec slot, added to the the BOA parameter list also.
New slot recalc, indicating re-calculation of liveness is
needed.
(basic-blocks cut-block): Use pushnew to put bl onto the
rescan list, to prevent duplicates. Also push the new block
onto the rescan list.
(basic-blocks local-liveness): This method can now be called
again to re-calculate local liveness, so we must reset the
live slot to nil.
(basic-blocks calc-liveness): Take an optional list of blocks
to scan for local liveness, defaulting to all of them.
(basic-blocks peephole-block): Factor out some register
liveness tests to local functions. Add a pattern targetting
gcall and gapply instructions, testing for a dead register
from a call to a %const-foldable% function. Use pushnew
everywhere to add to the rescan list. Set the recalc flag when
the liveness-based reductions are applied.
(basic-blocks peephole): If there are blocks to be scanned
again, then if the recalc flag is set, recalculate local
liveness for all the blocks to be re-scanned and re-do global
liveness.

2 files changed, 98 insertions, 74 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index c7c57e3b..890e1a8a 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -183,6 +183,8 @@
     (data (hash :eql-based))
     (sidx (hash :eql-based))
     (stab (hash :eql-based))
+    datavec
+    symvec
     lt-frags
     last-form
     var-spies
@@ -361,10 +363,12 @@
       (set [me.sidx atom] sidx))))
 
 (defmeth compiler get-datavec (me)
-  (vec-list [mapcar me.data (range* 0 me.dreg-cntr)]))
+  (or me.datavec
+      (set me.datavec (vec-list [mapcar me.data (range* 0 me.dreg-cntr)]))))
 
 (defmeth compiler get-symvec (me)
-  (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)]))
+  (or me.symvec
+      (set me.symvec (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)]))))
 
 (defmeth compiler alloc-treg (me)
   (cond
@@ -1564,7 +1568,7 @@
   (let ((olev *opt-level*))
     (if (>= olev 4)
       (let* ((lt-dregs (mapcar .oreg me.lt-frags))
-             (bb (new (basic-blocks insns lt-dregs))))
+             (bb (new (basic-blocks insns lt-dregs me.(get-symvec)))))
         (when (>= olev 4)
           bb.(thread-jumps)
           bb.(elim-dead-code))
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl
index babf7bce..8f166a6f 100644
--- a/share/txr/stdlib/optimize.tl
+++ b/share/txr/stdlib/optimize.tl
@@ -47,14 +47,16 @@
                             rlinks ,(mapcar .label bl.rlinks)
                             next ,bl.next) stream)))
 
-  (defstruct (basic-blocks insns lt-dregs) nil
+  (defstruct (basic-blocks insns lt-dregs symvec) nil
     insns
     lt-dregs
+    symvec
     root
     (hash (hash))
     (li-hash (hash :eq-based))
     list
     rescan
+    recalc
     (:static start (gensym "start-"))
     (:static jump-ops '(jmp if ifq ifql close swtch ret abscsr
                         uwprot catch block jend))
@@ -88,7 +90,8 @@
         (set bb.list (append (ldiff bb.list ltail) (list nbl) ltail))
         (set bl.insns (ldiff insns at))
         (set [bb.hash nlabel] nbl)
-        (push bl bb.rescan)
+        (pushnew bl bb.rescan)
+        (pushnew nbl bb.rescan)
         nbl))
 
     (:method next-block (bb bl)
@@ -148,6 +151,7 @@
         (pushnew bl nxbl.rlinks)))))
 
 (defmeth basic-blocks local-liveness (bb bl)
+  (set bl.live nil)
   (labels ((regnum (reg)
              (when-match (t @num) reg num))
            (regnums (regs)
@@ -233,8 +237,8 @@
       (set bl.used li.used
            bl.defined li.defined))))
 
-(defmeth basic-blocks calc-liveness (bb)
-  (each ((bl bb.list))
+(defmeth basic-blocks calc-liveness (bb : (blist bb.list))
+  (each ((bl blist))
     bb.(local-liveness bl))
   (let (changed)
     (while* changed
@@ -342,79 +346,95 @@
       (t (set [bb.li-hash sub] li) sub))))
 
 (defmeth basic-blocks peephole-block (bb bl code)
-  (rewrite-case insns code
-    ;; dead t-reg
-    (@(require ((mov (t @n) . @nil) . @nil)
-               (let ((li [bb.li-hash (car insns)]))
-                 (and li (not (bit li.used n)))))
-      (cdr insns))
-    ;; unnecessary copying t-reg
-    (@(require ((mov @(as dst (t @n)) @src) . @rest)
-               (let ((li [bb.li-hash (car insns)]))
-                 (and li (bit li.used n) (not (bit bl.live n))))
-               (or (neq (car src) 'v)
-                   (none rest [andf [chain car (op eq 'end)]
-                                    [chain bb.li-hash .used (lop bit n)]]))
-               (not (find dst rest : [chain bb.li-hash .def]))
-               (not (find src rest : [chain bb.li-hash .def])))
-      (labels ((rename (insns n dst src)
-                 (tree-case insns
-                   ((fi . re)
-                    (cons (subst-preserve dst src bb [bb.li-hash fi] fi)
-                          (rename (cdr insns) n dst src)))
-                   (else else))))
-        (rename (cdr insns) n dst src)))
-    ;; wasteful moves
-    (((mov @reg0 @nil) (mov @reg0 @nil) . @nil)
-     (cdr insns))
-    (((mov @reg0 @reg1) (mov reg1 @reg0) . @rest)
-     ^(,(car insns) ,*rest))
-    ;; frame reduction
-    (((@(or frame dframe) @lev @size)
-      (@(or call gcall mov)
-        . @(require @(coll (v @vlev @nil))
-                    (none vlev (op eql (ppred lev)))))
-      . @rest)
-     ^(,(cadr insns) ,(car insns) ,*rest))
-    (((@(or frame dframe) . @nil)
-      (if (t @reg) @jlabel))
-     (let ((jinsns [bb.hash jlabel].insns))
-       (match-case jinsns
-         ((@jlabel
-            (end (t @reg)) . @jrest)
-          (let* ((xbl (if jrest
-                         bb.(cut-block [bb.hash jlabel] jrest jinsns)
-                         bb.(next-block [bb.hash jlabel])))
-                 (ybl bb.(next-block bl))
-                 (yinsns ybl.insns))
-            (cond
-              ((and xbl ybl)
-               (set ybl.insns ^(,ybl.label ,(car insns) ,*(cdr yinsns)))
-               (push ybl bb.rescan)
-               ^((if (t ,reg) ,xbl.label)))
-              (t insns))))
-         (@jelse insns))))
-    (@(require ((if @(as reg (d @dn)) @jlabel) . @nil)
-               (not (memqual reg bb.lt-dregs)))
-      nil)
-    (@(require ((ifq @(as reg (d @dn)) (t 0) @jlabel) . @nil)
-               (not (memqual reg bb.lt-dregs)))
-      ^((jmp ,jlabel)))
-    (((jmp @jlabel) . @rest)
-     (let ((jinsns (cdr [bb.hash jlabel].insns)))
-       (match-case jinsns
-         (((jend @nil) . @nil)
-          ^(,(car jinsns) ,*rest))
-         ((@nil (jend @nil) . @nil)
-          ^(,(car jinsns) ,(cadr jinsns) ,*rest))
-         (@else insns))))
-    (@else insns)))
+  (labels ((dead-treg (insn n)
+             (let ((li [bb.li-hash insn]))
+               (and li (not (bit li.used n)))))
+           (only-locally-used-treg (insn n)
+             (let ((li [bb.li-hash insn]))
+               (and li (bit li.used n) (not (bit bl.live n))))))
+    (rewrite-case insns code
+      ;; dead t-reg
+      (@(require ((mov (t @n) . @nil) . @nil)
+                 (dead-treg (car insns) n))
+        (pushnew bl bb.rescan)
+        (set bb.recalc t)
+        (cdr insns))
+      (@(require ((@(or gcall gapply) (t @n) @idx . @nil) . @nil)
+                 (dead-treg (car insns) n)
+                 [%const-foldable% [bb.symvec idx]])
+        (pushnew bl bb.rescan)
+        (set bb.recalc t)
+        (cdr insns))
+      ;; unnecessary copying t-reg
+      (@(require ((mov @(as dst (t @n)) @src) . @rest)
+                 (only-locally-used-treg (car insns) n)
+                 (or (neq (car src) 'v)
+                     (none rest [andf [chain car (op eq 'end)]
+                                      [chain bb.li-hash .used (lop bit n)]]))
+                 (not (find dst rest : [chain bb.li-hash .def]))
+                 (not (find src rest : [chain bb.li-hash .def])))
+        (pushnew bl bb.rescan)
+        (labels ((rename (insns n dst src)
+                   (tree-case insns
+                     ((fi . re)
+                      (cons (subst-preserve dst src bb [bb.li-hash fi] fi)
+                            (rename (cdr insns) n dst src)))
+                     (else else))))
+          (rename (cdr insns) n dst src)))
+      ;; wasteful moves
+      (((mov @reg0 @nil) (mov @reg0 @nil) . @nil)
+       (cdr insns))
+      (((mov @reg0 @reg1) (mov reg1 @reg0) . @rest)
+       ^(,(car insns) ,*rest))
+      ;; frame reduction
+      (((@(or frame dframe) @lev @size)
+        (@(or call gcall mov)
+          . @(require @(coll (v @vlev @nil))
+                      (none vlev (op eql (ppred lev)))))
+        . @rest)
+       ^(,(cadr insns) ,(car insns) ,*rest))
+      (((@(or frame dframe) . @nil)
+        (if (t @reg) @jlabel))
+       (let ((jinsns [bb.hash jlabel].insns))
+         (match-case jinsns
+           ((@jlabel
+              (end (t @reg)) . @jrest)
+            (let* ((xbl (if jrest
+                           bb.(cut-block [bb.hash jlabel] jrest jinsns)
+                           bb.(next-block [bb.hash jlabel])))
+                   (ybl bb.(next-block bl))
+                   (yinsns ybl.insns))
+              (cond
+                ((and xbl ybl)
+                 (set ybl.insns ^(,ybl.label ,(car insns) ,*(cdr yinsns)))
+                 (pushnew ybl bb.rescan)
+                 ^((if (t ,reg) ,xbl.label)))
+                (t insns))))
+           (@jelse insns))))
+      (@(require ((if @(as reg (d @dn)) @jlabel) . @nil)
+                 (not (memqual reg bb.lt-dregs)))
+        nil)
+      (@(require ((ifq @(as reg (d @dn)) (t 0) @jlabel) . @nil)
+                 (not (memqual reg bb.lt-dregs)))
+        ^((jmp ,jlabel)))
+      (((jmp @jlabel) . @rest)
+       (let ((jinsns (cdr [bb.hash jlabel].insns)))
+         (match-case jinsns
+           (((jend @nil) . @nil)
+            ^(,(car jinsns) ,*rest))
+           ((@nil (jend @nil) . @nil)
+            ^(,(car jinsns) ,(cadr jinsns) ,*rest))
+           (@else insns))))
+      (@else insns))))
 
 (defmeth basic-blocks peephole (bb)
   (each ((bl bb.list))
     (set bl.insns bb.(peephole-block bl bl.insns)))
   (whilet ((rescan bb.rescan))
     (set bb.rescan nil)
+    (when bb.recalc
+      bb.(calc-liveness rescan)
+      (set bb.recalc nil))
     (each ((bl rescan))
       (set bl.insns bb.(peephole-block bl bl.insns)))))