From 8bfcf3d9d7514309a481d5ee34bf491b6d01705a Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 2 Mar 2021 22:47:19 -0800
Subject: compiler: merge duplicate jump blocks.

I've noticed that some duplicate short blocks are generated,
which look like this. Often they are consecutive, which
is why they are noticeable. These can become one block:

  mov t17 d3
  jmp label17
  mov t17 d3
  jmp label17
  mov t17 d3
  jmp label17

We identify identical blocks by looking for short instruction
sequences that end in an unconditional jmp, and then we group
duplicates in a hash table keyed on the instruction sequence.
We must ignore the label: the first instruction in each block
is a unique label.

We have to be careful about which ones to delete. Any block
that is entered from the top must be preserved. When these
blocks are identified, at least one block must remain that
is removable for the optimization to be able to do anything.

If all blocks are removable, we pick a leader which is
preserved. Otherwise we pick a leader from the preserved
blocks.  The non-preserved blocks are deleted, and all jumps
to them from other blocks are redirected to jumps to the
leader.

* share/txr/stdlib/compiler.tl (optimize): Call
merge-jump-thunks as the last pass.

* share/txr/stdlib/optimize.tl (basic-blocks
merge-jump-thunks): New method.
---
 share/txr/stdlib/compiler.tl |  1 +
 share/txr/stdlib/optimize.tl | 25 +++++++++++++++++++++++++
 2 files changed, 26 insertions(+)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 0c90d5ce..d6ca1f45 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1508,6 +1508,7 @@
     bb.(elim-dead-code)
     bb.(calc-liveness)
     bb.(peephole)
+    bb.(merge-jump-thunks)
     bb.(get-insns)))
 
 (defun true-const-p (arg)
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl
index e94c98a1..af684aea 100644
--- a/share/txr/stdlib/optimize.tl
+++ b/share/txr/stdlib/optimize.tl
@@ -467,6 +467,31 @@
       bb.(elim-next-jump bl)))
   bb.(join-blocks))
 
+(defmeth basic-blocks merge-jump-thunks (bb)
+  (let* ((candidates (mappend (load-time
+                                [andf [chain .links len (op eql 1)]
+                                      [chain .insns len (lop < 4)]
+                                      [chain .insns last car
+                                             [iff consp
+                                                  [chain car (op eq 'jmp)]]]
+                                      list])
+                              bb.list))
+         (hash (group-by (load-time [chain .insns cdr]) candidates)))
+    (dohash (insns bls hash)
+      (when (cdr bls)
+        (whenlet ((keep (or (keep-if (op some @1.rlinks (op eq @@1) .next) bls)
+                            (list (car bls))))
+                  (leader (car keep)))
+          (whenlet ((dupes (diff bls keep)))
+            (each ((bl dupes))
+              (each ((pbl bl.rlinks))
+                (let* ((code pbl.insns)
+                       (tail (last code))
+                       (lins (car tail))
+                       (sins (subst bl.label leader.label lins)))
+                  (set pbl.insns (append (ldiff code tail) (list sins))))))
+            (set bb.list (remove-if (lop memq dupes) bb.list))))))))
+
 (defun rewrite (fun list)
   (build
     (while* list
-- 
cgit v1.2.3