compiler: discard wrongheaded discards.

* stdlib/compiler.tl (compiler): Remove discards slot.
(compile-in-toplevel, compile-with-fresh-tregs):
Do not save and restore discards.
(compiler maybe-mov): Method removed. It doesn't
require the compiler object so it can just be a function.
(maybe-mov): New function.
(compiler alloc-discard-treg): Method removed.
(compiler free-treg): No need to do anything with discards.
(compiler maybe-alloc-treg): No need to check discards.
(compiler (comp-setq, comp-if, comp-ift, comp-switch,
comp-block, comp-catch, comp-let, comp-fbind,
comp-lambda-impl, comp-or, comp-tree-case,
comp-load-time-lit): Use maybe-mov function instead of method.
(compiler comp-progn): Use alloc-treg rather than
alloc-discard-treg, and use maybe-mov function.

1 files changed, 41 insertions, 55 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index bf6496bb..bb896344 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -224,7 +224,6 @@
     (nlev 2)
     (loop-nest 0)
     (tregs nil)
-    (discards nil)
     (dreg (hash :eql-based))
     (data (hash :eql-based))
     (sidx (hash :eql-based))
@@ -254,38 +253,32 @@
 
 (eval-only
   (defmacro compile-in-toplevel (me . body)
-    (with-gensyms (saved-tregs saved-treg-cntr saved-discards)
+    (with-gensyms (saved-tregs saved-treg-cntr)
       ^(let* ((,saved-tregs (qref ,me tregs))
-              (,saved-treg-cntr (qref ,me treg-cntr))
-              (,saved-discards (qref ,me discards)))
+              (,saved-treg-cntr (qref ,me treg-cntr)))
          (unwind-protect
            (progn
              (set (qref ,me tregs) nil
-                  (qref ,me treg-cntr) 2
-                  (qref ,me discards) nil)
+                  (qref ,me treg-cntr) 2)
              (prog1
                (progn ,*body)
                (qref ,me (check-treg-leak))))
            (set (qref ,me tregs) ,saved-tregs
-                (qref ,me treg-cntr) ,saved-treg-cntr
-                (qref ,me discards) ,saved-discards)))))
+                (qref ,me treg-cntr) ,saved-treg-cntr)))))
 
   (defmacro compile-with-fresh-tregs (me . body)
-    (with-gensyms (saved-tregs saved-treg-cntr saved-discards)
+    (with-gensyms (saved-tregs saved-treg-cntr)
       ^(let* ((,saved-tregs (qref ,me tregs))
-              (,saved-treg-cntr (qref ,me treg-cntr))
-              (,saved-discards (qref ,me discards)))
+              (,saved-treg-cntr (qref ,me treg-cntr)))
          (unwind-protect
            (progn
              (set (qref ,me tregs) nil
-                  (qref ,me treg-cntr) 2
-                  (qref ,me discards) nil)
+                  (qref ,me treg-cntr) 2)
              (prog1
                (progn ,*body)
                (qref ,me (check-treg-leak))))
            (set (qref ,me tregs) ,saved-tregs
-                (qref ,me treg-cntr) ,saved-treg-cntr
-                (qref ,me discards) ,saved-discards)))))
+                (qref ,me treg-cntr) ,saved-treg-cntr)))))
 
   (defun with-spy (me flag spy spy-expr body push-meth pop-meth)
     ^(let ((,spy (if ,flag ,spy-expr)))
@@ -393,6 +386,10 @@
 (defun null-reg (reg)
   (equal reg '(t 0)))
 
+(defun maybe-mov (to-reg from-reg)
+  (if (nequal to-reg from-reg)
+    ^((mov ,to-reg ,from-reg))))
+
 (defmeth compiler get-dreg (me obj)
   (let ((dobj (dedup obj)))
     (condlet
@@ -437,15 +434,8 @@
     ((< 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)
@@ -455,7 +445,7 @@
   (- %lev-size% me.treg-cntr))
 
 (defmeth compiler maybe-alloc-treg (me given)
-  (if (and (eq t (car given)) (not (member given me.discards)))
+  (if (eq t (car given))
     given
     me.(alloc-treg)))
 
@@ -468,10 +458,6 @@
     (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%)
@@ -605,7 +591,7 @@
       (new (frag vfrag.oreg
                  ^(,*vfrag.code
                    ,*(if bind
-                       me.(maybe-mov vloc vfrag.oreg)
+                       (maybe-mov vloc vfrag.oreg)
                        (if spec
                          ^((setv ,vfrag.oreg ,vloc))
                          ^((setlx ,vfrag.oreg ,me.(get-sidx sym))))))
@@ -693,11 +679,11 @@
                   ^(,*te-frag.code
                      (if ,te-frag.oreg ,lelse)
                      ,*th-frag.code
-                     ,*me.(maybe-mov oreg th-frag.oreg)
+                     ,*(maybe-mov oreg th-frag.oreg)
                      (jmp ,lskip)
                      ,lelse
                      ,*el-frag.code
-                     ,*me.(maybe-mov oreg el-frag.oreg)
+                     ,*(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))))))
@@ -709,10 +695,10 @@
        me.(maybe-free-treg te-oreg oreg)
        (new (frag oreg
                   ^(,*te-frag.code
-                     ,*me.(maybe-mov oreg te-frag.oreg)
+                     ,*(maybe-mov oreg te-frag.oreg)
                      (if ,te-frag.oreg ,lskip)
                      ,*th-frag.code
-                     ,*me.(maybe-mov oreg th-frag.oreg)
+                     ,*(maybe-mov oreg th-frag.oreg)
                      ,lskip)
                   (uni te-frag.fvars th-frag.fvars)
                   (uni te-frag.ffuns th-frag.ffuns)))))
@@ -752,11 +738,11 @@
                      ,*ri-frag.code
                      (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse)
                      ,*th-frag.code
-                     ,*me.(maybe-mov oreg th-frag.oreg)
+                     ,*(maybe-mov oreg th-frag.oreg)
                       (jmp ,lskip)
                      ,lelse
                      ,*el-frag.code
-                     ,*me.(maybe-mov oreg el-frag.oreg)
+                     ,*(maybe-mov oreg el-frag.oreg)
                      ,lskip)
                    (uni (uni le-frag.fvars ri-frag.fvars)
                         (uni th-frag.fvars el-frag.fvars))
@@ -799,7 +785,7 @@
                                     ^(,lb
                                        ,*cfrag.code
                                        ,*(unless shared
-                                           ^(,*me.(maybe-mov oreg cfrag.oreg)
+                                           ^(,*(maybe-mov oreg cfrag.oreg)
                                               ,*(unless (= i ncases)
                                                   ^((jmp ,lend))))))
                                     cfrag.fvars cfrag.ffuns)))))))
@@ -809,7 +795,7 @@
                    (swtch ,ifrag.oreg ,*(list-vec clabels))
                    ,*(mappend .code cfrags)
                    ,*(when (and shared last-cfrag)
-                       me.(maybe-mov oreg last-cfrag.oreg))
+                       (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]))))))
@@ -864,7 +850,7 @@
                    ^(,*(if nfrag nfrag.code)
                       (block ,oreg ,nreg ,lskip)
                       ,*bfrag.code
-                      ,*me.(maybe-mov oreg bfrag.oreg)
+                      ,*(maybe-mov oreg bfrag.oreg)
                       (end ,oreg)
                       ,lskip)
                    bfrag.fvars
@@ -934,7 +920,7 @@
                                           ((and have-one-symbol
                                                 (exception-subtype-p one-symbol sym))
                                            ^(,*cfrag.code
-                                              ,*me.(maybe-mov oreg cfrag.oreg)
+                                              ,*(maybe-mov oreg cfrag.oreg)
                                               ,*(unless (eql i nclauses)
                                                   ^((jmp ,lhend)))))
                                           (have-one-symbol
@@ -947,7 +933,7 @@
                                                       ,me.(get-dreg sym))
                                                (if ,treg ,lskip)
                                                ,*cfrag.code
-                                               ,*me.(maybe-mov oreg cfrag.oreg)
+                                               ,*(maybe-mov oreg cfrag.oreg)
                                                ,*(unless (eql i nclauses)
                                                    ^((jmp ,lhend)))
                                                ,lskip)))
@@ -960,7 +946,7 @@
                        (catch ,esvb.loc ,eavb.loc
                               ,me.(get-dreg symbols) ,dfrag.oreg ,lhand)
                        ,*tfrag.code
-                       ,*me.(maybe-mov oreg tfrag.oreg)
+                       ,*(maybe-mov oreg tfrag.oreg)
                        (jmp ,lhend)
                        ,lhand
                        ,*(mappend .code cfrags)
@@ -1053,7 +1039,7 @@
                                    nenv.(extend-var* sym loc))
                                  (pend frag.code)
                                  (unless (null-reg frag.oreg)
-                                   (pend me.(maybe-mov loc frag.oreg)))
+                                   (pend (maybe-mov loc frag.oreg)))
                                  (set ffuns (uni ffuns frag.ffuns)
                                       fvars (uni fvars
                                                  (if seq
@@ -1064,7 +1050,7 @@
                (bfrag me.(comp-progn oreg nenv body))
                (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))
                (code (append code bfrag.code
-                             me.(maybe-mov boreg bfrag.oreg)
+                             (maybe-mov boreg bfrag.oreg)
                              ^((end ,boreg)))))
           (when (and cspy (null cspy.cap-vars))
             (set code me.(eliminate-frame [code 1..-1] nenv)))
@@ -1097,7 +1083,7 @@
                            (list bind
                                  (new (frag frag.oreg
                                             (append frag.code
-                                                    me.(maybe-mov bind.loc frag.oreg))
+                                                    (maybe-mov bind.loc frag.oreg))
                                             frag.fvars
                                             frag.ffuns)))))))
              (bfrag me.(comp-progn oreg nenv body))
@@ -1112,7 +1098,7 @@
                    (append ^((frame ,nenv.lev ,frsize))
                            (mappend .code ffrags)
                            bfrag.code
-                           me.(maybe-mov boreg bfrag.oreg)
+                           (maybe-mov boreg bfrag.oreg)
                            ^((end ,boreg)))
                    (uni fvars bfrag.fvars)
                    (uni (diff bfrag.ffuns lexfuns)
@@ -1179,7 +1165,7 @@
                                           ,*(if have-sym
                                               ^((mov ,have-bind.loc nil)))
                                           ,*ifrg.code
-                                          ,*me.(maybe-mov vbind.loc ifrg.oreg)
+                                          ,*(maybe-mov vbind.loc ifrg.oreg)
                                           ,lskip
                                           ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
                                               (set specials [remq var-sym specials cdr])
@@ -1213,7 +1199,7 @@
                                ,*bfrag.code
                                ,*(if need-dframe
                                    ^((end ,boreg)))
-                               ,*me.(maybe-mov boreg bfrag.oreg)
+                               ,*(maybe-mov boreg bfrag.oreg)
                                (jend ,boreg)
                                ,lskip)))
                   me.(free-treg btreg)
@@ -1264,7 +1250,7 @@
          (forms (append eff-lead-forms last-form))
          (nargs (len forms))
          lastfrag
-         (oreg-discard me.(alloc-discard-treg))
+         (oreg-discard me.(alloc-treg))
          (code (build
                  (each ((form forms)
                         (n (range 1)))
@@ -1294,7 +1280,7 @@
                       (let ((islast (eql n nargs)))
                         (let ((frag me.(compile treg env form)))
                           (pend frag.code
-                                me.(maybe-mov treg frag.oreg))
+                                (maybe-mov treg frag.oreg))
                           (unless islast
                             (add ^(ifq ,treg (t 0) ,lout)))
                           (set fvars (uni fvars frag.fvars))
@@ -1302,12 +1288,12 @@
        me.(maybe-free-treg treg oreg)
        (new (frag oreg
                   (append code ^(,lout
-                                 ,*me.(maybe-mov oreg treg)))
+                                 ,*(maybe-mov oreg treg)))
                   fvars ffuns))))))
 
 (defmeth compiler comp-prog1 (me oreg env form)
   (tree-case form
-    ((t fi . re) (let* ((igreg me.(alloc-discard-treg))
+    ((t fi . re) (let* ((igreg me.(alloc-treg))
                         (fireg me.(maybe-alloc-treg oreg))
                         (fi-frag me.(compile fireg env fi))
                         (re-frag me.(comp-progn igreg env
@@ -1316,7 +1302,7 @@
                    me.(free-treg igreg)
                    (new (frag fireg
                               (append fi-frag.code
-                                      me.(maybe-mov fireg fi-frag.oreg)
+                                      (maybe-mov fireg fi-frag.oreg)
                                       re-frag.code)
                               (uni fi-frag.fvars re-frag.fvars)
                               (uni fi-frag.ffuns re-frag.ffuns)))))
@@ -1615,7 +1601,7 @@
                               (cfrag me.(compile treg nenv src)))
                          (new (frag treg
                                     ^(,*cfrag.code
-                                       ,*me.(maybe-mov treg cfrag.oreg)
+                                       ,*(maybe-mov treg cfrag.oreg)
                                        (ifq ,treg ,me.(get-dreg :) ,lout))
                                     cfrag.fvars
                                     cfrag.ffuns))))))
@@ -1624,11 +1610,11 @@
       (new (frag oreg
                  ^(,*objfrag.code
                    (frame ,nenv.lev ,nenv.v-cntr)
-                   ,*me.(maybe-mov obj-immut-var.loc objfrag.oreg)
+                   ,*(maybe-mov obj-immut-var.loc objfrag.oreg)
                    ,*(mappend .code cfrags)
                    (mov ,treg nil)
                    ,lout
-                   ,*me.(maybe-mov oreg treg)
+                   ,*(maybe-mov oreg treg)
                    (end ,oreg))
                  [reduce-left uni allfrags nil .fvars]
                  [reduce-left uni allfrags nil .ffuns])))))
@@ -1706,7 +1692,7 @@
                   (exp me.(compile dreg (new env co me) exp))
                   (lt-frag (new (frag dreg
                                       ^(,*exp.code
-                                         ,*me.(maybe-mov dreg exp.oreg))
+                                         ,*(maybe-mov dreg exp.oreg))
                                       exp.fvars
                                       exp.ffuns
                                       exp.pars))))