compiler: optimize away discard register.

When compiling the procedural special forms prog and prog1,
there are subforms whose values are discarded.  The
compilation of those forms still requires an output register,
which is passed down.  In certain cases, wasteful moves of data
into that register are generated, which we can eliminate.

* share/txr/stdlib/compiler.tl (struct compiler): New slot,
discards. Holds t-registers that are marked as discard.
(compiler alloc-discard-treg): New method.
(compiler free-treg): Remove freed treg from discard list.
(compiler maybe-alloc-treg): If the given register is a
discard, we must allocate.
(compiler maybe-mov): New method, replacing maybe-mov function.
(compiler comp-if): Replace maybe-mov function calls with method.
In the (if test then) case, avoid referencing oreg register
after a maybe-mov since it may be a discard such that the
maybe-mov produced no code; reference the original register.
(comp-progn): Allocate oreg-discard with alloc-discard-treg
method instead of alloc-treg.
(comp-prog1): Same thing with igreg.
(comp-for): For compiling the test expression, use the same
output register as what was used for the init block. Do not
borrow oreg for this, which may be a discard that will be
removed by the maybe-mov.
(compiler (comp-setq, comp-ift, comp-switch, comp-block,
comp-catch, comp-let, comp-fbind, comp-lambda-impl, comp-or,
comp-tree-case, comp-load-time-lit): Replace maybe-mov
function calls with method.
(maybe-mov): Function removed, replaced by method.

1 files changed, 41 insertions, 33 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 08dc2c13..e858ade1 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -145,6 +145,7 @@
     (sidx-cntr 0)
     (nlev 2)
     (tregs nil)
+    (discards nil)
     (dreg (hash :eql-based))
     (data (hash :eql-based))
     (sidx (hash :eql-based))
@@ -250,15 +251,22 @@
     ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr)))
     (t (compile-error me.last-form "code too complex: out of registers"))))
 
+(defmeth compiler alloc-discard-treg (me)
+  (let ((treg me.(alloc-treg)))
+    (push treg me.discards)
+    treg))
+
 (defmeth compiler free-treg (me treg)
   (when (and (eq t (car treg)) (neq 0 (cadr treg)))
+    (when me.discards
+      (set me.discards (remqual treg me.discards)))
     (push treg me.tregs)))
 
 (defmeth compiler free-tregs (me tregs)
   (mapdo (meth me free-treg) tregs))
 
 (defmeth compiler maybe-alloc-treg (me given)
-  (if (eq t (car given))
+  (if (and (eq t (car given)) (not (member given me.discards)))
     given
     me.(alloc-treg)))
 
@@ -271,6 +279,10 @@
     (unless (zerop balance)
       (error "t-register leak in compiler: ~s outstanding" balance))))
 
+(defmeth compiler maybe-mov (me to-reg from-reg)
+  (if (and (nequal to-reg from-reg) (not (member to-reg me.discards)))
+    ^((mov ,to-reg ,from-reg))))
+
 (defmeth compiler new-env (me env)
   (when (>= env.lev me.nlev)
     (unless (<= env.lev %max-lev%)
@@ -373,7 +385,7 @@
       (new (frag vfrag.oreg
                  ^(,*vfrag.code
                    ,*(if bind
-                       (maybe-mov vloc vfrag.oreg)
+                       me.(maybe-mov vloc vfrag.oreg)
                        (if spec
                          ^((setv ,vfrag.oreg ,vloc))
                          ^((setlx ,vfrag.oreg ,me.(get-sidx sym))))))
@@ -448,11 +460,11 @@
                       ^(,*te-frag.code
                          (if ,te-frag.oreg ,lelse)
                          ,*th-frag.code
-                         ,*(maybe-mov oreg th-frag.oreg)
+                         ,*me.(maybe-mov oreg th-frag.oreg)
                          (jmp ,lskip)
                          ,lelse
                          ,*el-frag.code
-                         ,*(maybe-mov oreg el-frag.oreg)
+                         ,*me.(maybe-mov oreg el-frag.oreg)
                          ,lskip)
                       (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars))
                       (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns))))))))
@@ -471,10 +483,10 @@
             me.(maybe-free-treg te-oreg oreg)
             (new (frag oreg
                        ^(,*te-frag.code
-                          ,*(maybe-mov oreg te-frag.oreg)
-                          (if ,oreg ,lskip)
+                          ,*me.(maybe-mov oreg te-frag.oreg)
+                          (if ,te-frag.oreg ,lskip)
                           ,*th-frag.code
-                          ,*(maybe-mov oreg th-frag.oreg)
+                          ,*me.(maybe-mov oreg th-frag.oreg)
                           ,lskip)
                        (uni te-frag.fvars th-frag.fvars)
                        (uni te-frag.ffuns th-frag.ffuns)))))))
@@ -515,11 +527,11 @@
                      ,*ri-frag.code
                      (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse)
                      ,*th-frag.code
-                     ,*(maybe-mov oreg th-frag.oreg)
+                     ,*me.(maybe-mov oreg th-frag.oreg)
                       (jmp ,lskip)
                      ,lelse
                      ,*el-frag.code
-                     ,*(maybe-mov oreg el-frag.oreg)
+                     ,*me.(maybe-mov oreg el-frag.oreg)
                      ,lskip)
                    (uni (uni le-frag.fvars ri-frag.fvars)
                         (uni th-frag.fvars el-frag.fvars))
@@ -562,7 +574,7 @@
                                     ^(,lb
                                        ,*cfrag.code
                                        ,*(unless shared
-                                           ^(,*(maybe-mov oreg cfrag.oreg)
+                                           ^(,*me.(maybe-mov oreg cfrag.oreg)
                                               ,*(unless (= i ncases)
                                                   ^((jmp ,lend))))))
                                     cfrag.fvars cfrag.ffuns)))))))
@@ -572,7 +584,7 @@
                    (swtch ,ifrag.oreg ,*(list-vec clabels))
                    ,*(mappend .code cfrags)
                    ,*(when (and shared last-cfrag)
-                       (maybe-mov oreg last-cfrag.oreg))
+                       me.(maybe-mov oreg last-cfrag.oreg))
                    ,lend)
                  (uni ifrag.fvars [reduce-left uni cfrags nil .fvars])
                  (uni ifrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))
@@ -624,7 +636,7 @@
                    ^(,*(if nfrag nfrag.code)
                       (block ,oreg ,nreg ,lskip)
                       ,*bfrag.code
-                      ,*(maybe-mov oreg bfrag.oreg)
+                      ,*me.(maybe-mov oreg bfrag.oreg)
                       (end ,oreg)
                       ,lskip)
                    bfrag.fvars
@@ -689,7 +701,7 @@
                                                ,me.(get-dreg sym))
                                         (if ,treg ,lskip)
                                         ,*cfrag.code
-                                        ,*(maybe-mov tfrag.oreg cfrag.oreg)
+                                        ,*me.(maybe-mov tfrag.oreg cfrag.oreg)
                                         ,*(unless (eql i nclauses)
                                             ^((jmp ,lhend)))
                                         ,lskip)
@@ -755,7 +767,7 @@
                                  fenv.(rename-var tmp sym))
                                (pend frag.code)
                                (unless (null-reg frag.oreg)
-                                 (pend (maybe-mov bind.loc frag.oreg)))
+                                 (pend me.(maybe-mov bind.loc frag.oreg)))
                                (set ffuns (uni ffuns frag.ffuns)
                                     fvars (uni fvars
                                                (if seq
@@ -769,7 +781,7 @@
           me.(free-treg treg))
         (new (frag boreg
                    (append code bfrag.code
-                           (maybe-mov boreg bfrag.oreg)
+                           me.(maybe-mov boreg bfrag.oreg)
                            ^((end ,boreg)))
                    (uni (diff bfrag.fvars allsyms) fvars)
                    (uni ffuns bfrag.ffuns)))))))
@@ -794,7 +806,7 @@
                            (list bind
                                  (new (frag frag.oreg
                                             (append frag.code
-                                                    (maybe-mov bind.loc frag.oreg))
+                                                    me.(maybe-mov bind.loc frag.oreg))
                                             frag.fvars
                                             frag.ffuns)))))))
              (bfrag me.(comp-progn oreg nenv body))
@@ -809,7 +821,7 @@
                    (append ^((frame ,nenv.lev ,frsize))
                            (mappend .code ffrags)
                            bfrag.code
-                           (maybe-mov boreg bfrag.oreg)
+                           me.(maybe-mov boreg bfrag.oreg)
                            ^((end ,boreg)))
                    (uni fvars bfrag.fvars)
                    (uni (diff bfrag.ffuns lexfuns)
@@ -870,7 +882,7 @@
                                     ,*(if have-sym
                                         ^((mov ,have-bind.loc nil)))
                                     ,*ifrg.code
-                                    ,*(maybe-mov vbind.loc ifrg.oreg)
+                                    ,*me.(maybe-mov vbind.loc ifrg.oreg)
                                     ,lskip
                                     ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
                                         (set specials [remq var-sym specials cdr])
@@ -906,7 +918,7 @@
                          ,*bfrag.code
                          ,*(if need-dframe
                              ^((end ,boreg)))
-                         ,*(maybe-mov boreg bfrag.oreg)
+                         ,*me.(maybe-mov boreg bfrag.oreg)
                          (end ,boreg)
                          ,lskip)
                        (uni fvars (diff bfrag.fvars lexsyms))
@@ -945,7 +957,7 @@
          (forms (append eff-lead-forms last-form))
          (nargs (len forms))
          lastfrag
-         (oreg-discard me.(alloc-treg))
+         (oreg-discard me.(alloc-discard-treg))
          (code (build
                  (each ((form forms)
                         (n (range 1)))
@@ -978,7 +990,7 @@
                           (when islast
                             (set lastfrag frag))
                           (pend frag.code
-                                (maybe-mov treg frag.oreg))
+                                me.(maybe-mov treg frag.oreg))
                           (unless islast
                             (add ^(ifq ,treg ,nil ,lout)))
                           (set fvars (uni fvars frag.fvars))
@@ -986,12 +998,12 @@
        me.(maybe-free-treg treg oreg)
        (new (frag oreg
                   (append code ^(,lout
-                                 ,*(maybe-mov oreg treg)))
+                                 ,*me.(maybe-mov oreg treg)))
                   fvars ffuns))))))
 
 (defmeth compiler comp-prog1 (me oreg env form)
   (tree-case form
-    ((prog1 fi . re) (let* ((igreg me.(alloc-treg))
+    ((prog1 fi . re) (let* ((igreg me.(alloc-discard-treg))
                             (fireg me.(maybe-alloc-treg oreg))
                             (fi-frag me.(compile fireg env fi))
                             (re-frag me.(comp-progn igreg env
@@ -1000,7 +1012,7 @@
                        me.(free-treg igreg)
                        (new (frag fireg
                                   (append fi-frag.code
-                                          (maybe-mov fireg fi-frag.oreg)
+                                          me.(maybe-mov fireg fi-frag.oreg)
                                           re-frag.code)
                                   (uni fi-frag.fvars re-frag.fvars)
                                   (uni fi-frag.ffuns re-frag.ffuns)))))
@@ -1099,7 +1111,7 @@
     (let* ((treg me.(alloc-treg))
            (ifrag me.(comp-progn treg env inits))
            (*load-time* nil)
-           (tfrag (if test-p me.(compile oreg env test)))
+           (tfrag (if test-p me.(compile treg env test)))
            (rfrag me.(comp-progn oreg env rets))
            (nfrag me.(comp-progn treg env incs))
            (bfrag me.(comp-progn treg env body))
@@ -1175,7 +1187,7 @@
                               (cfrag me.(compile treg nenv src)))
                          (new (frag treg
                                     ^(,*cfrag.code
-                                       ,*(maybe-mov treg cfrag.oreg)
+                                       ,*me.(maybe-mov treg cfrag.oreg)
                                        (ifq ,treg ,me.(get-dreg :) ,lout))
                                     cfrag.fvars
                                     cfrag.ffuns))))))
@@ -1184,11 +1196,11 @@
       (new (frag oreg
                  ^(,*objfrag.code
                    (frame ,nenv.lev ,nenv.v-cntr)
-                   ,*(maybe-mov obj-immut-var.loc objfrag.oreg)
+                   ,*me.(maybe-mov obj-immut-var.loc objfrag.oreg)
                    ,*(mappend .code cfrags)
                    (mov ,treg nil)
                    ,lout
-                   ,*(maybe-mov oreg treg)
+                   ,*me.(maybe-mov oreg treg)
                    (end ,oreg))
                  [reduce-left uni allfrags nil .fvars]
                  [reduce-left uni allfrags nil .ffuns])))))
@@ -1263,7 +1275,7 @@
                   (exp me.(compile dreg (new env co me) exp))
                   (lt-frag (new (frag dreg
                                       ^(,*exp.code
-                                         ,*(maybe-mov dreg exp.oreg))
+                                         ,*me.(maybe-mov dreg exp.oreg))
                                       exp.fvars
                                       exp.ffuns))))
              (misleading-ref-check exp env form)
@@ -1275,10 +1287,6 @@
     bb.(peephole)
     bb.(get-insns)))
 
-(defun maybe-mov (to-reg from-reg)
-  (if (nequal to-reg from-reg)
-    ^((mov ,to-reg ,from-reg))))
-
 (defun true-const-p (arg)
   (and arg (constantp arg)))