compiler: compact D registers.

We now have some constant folding in the optimizer too, not
just in the front end compiler pass. This is leaving behind
dead D registers that are not referenced in the code.
Let's compact the D register table to close the gap.

* stdlib/compiler.tl (compiler get-dreg): In this function
we no longer check that we have allocated too many D
registers.  We let the counter blow past %lev-size%.
Because this creates the fighting chance that the compaction
of D regs will reduce their number to %lev-size% or less.
By doing this, we allow code to be compilable that otherwise
would not be: code that allocates too many D regs which
are then optimized away.
(compiler compact-dregs): New function. Does all the work.
(compiler optimize): Compact the D regs at optimization
level 5 or higher.
(compile-toplevel): Check for an overflowing D reg count
here, after optimization.

* stdlib/optimize.tl (basic-blocks null-unused-data):
Here, we no longer have to do anything with the D registers.

2 files changed, 34 insertions, 16 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index fd855f67..bce409f6 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -377,12 +377,11 @@
     (condlet
       ((((null dobj))) '(t 0))
       (((dreg [me.dreg dobj])) dreg)
-      ((((< me.dreg-cntr %lev-size%)))
-       (let ((dreg ^(d ,(pinc me.dreg-cntr))))
-         (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")))))
+      (t
+        (let ((dreg ^(d ,(pinc me.dreg-cntr))))
+          (set me.datavec nil
+               [me.data (cadr dreg)] dobj
+               [me.dreg dobj] dreg))))))
 
 (defmeth compiler alloc-dreg (me)
   (if (< me.dreg-cntr %lev-size%)
@@ -1745,6 +1744,24 @@
              (push lt-frag me.lt-frags)
              (new (frag dreg nil nil nil exp.pars))))))))
 
+(defmeth compiler compact-dregs (me insns)
+  (let ((map (hash))
+        (i 0))
+    (each ((insn insns))
+      (if-match @(coll @(as dr (d @nil))) insn
+        (each ((d dr))
+          (unless (inhash map d)
+            (set [map d] ^(d ,(pinc i)))))))
+    (let ((data (hash :eql-based)))
+      (dohash (from-dreg to-dreg map)
+        (set [data (cadr to-dreg)] [me.data (cadr from-dreg)]))
+      (set me.data data))
+    (each ((cell me.dreg))
+      (upd (cdr cell) map))
+    (set me.datavec nil
+         me.dreg-cntr i)
+    (mapcar [iffi consp (op mapcar [orf map use])] insns)))
+
 (defmeth compiler optimize (me insns)
   (let ((olev *opt-level*))
     (if (>= olev 4)
@@ -1767,8 +1784,10 @@
           ((>= olev 7)
            bb.(merge-jump-thunks)
            bb.(compact-tregs)
-           bb.(late-peephole bb.(get-insns)))
-          (t bb.(get-insns))))
+           bb.(late-peephole me.(compact-dregs bb.(get-insns))))
+          ((>= olev 5)
+           me.(compact-dregs bb.(get-insns)))
+          (t  bb.(get-insns))))
       insns)))
 
 (defun true-const-p (arg)
@@ -2326,9 +2345,12 @@
         (eval-cache-emit-warnings))
       co.(free-treg oreg)
       co.(check-treg-leak)
-      as.(asm co.(optimize ^(,*(mappend .code (nreverse co.lt-frags))
-                             ,*frag.code
-                             (jend ,frag.oreg))))
+      (let ((insns co.(optimize ^(,*(mappend .code (nreverse co.lt-frags))
+                                   ,*frag.code
+                                   (jend ,frag.oreg)))))
+        (unless (< co.dreg-cntr %lev-size%)
+          (compile-error co.last-form "code too complex: too many literals"))
+        as.(asm insns))
       (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec)))))
 
 (defun get-param-info (sym)
diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl
index ee9257ac..49a8259e 100644
--- a/stdlib/optimize.tl
+++ b/stdlib/optimize.tl
@@ -798,16 +798,12 @@
           cl.(apply-treg-compacting-map map))))))
 
 (defmeth basic-blocks null-unused-data (bb)
-  (let ((used-dregs 0)
-        (used-funs 0)
+  (let ((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)