compiler: jump-threading optimization.

* share/txr/stdlib/compiler.tl: Load the new optimize module.
(compiler optimize): New method.
(compile-toplevel): Pass code through optimize method.

* share/txr/stdlib/optimize.tl: New file.

2 files changed, 97 insertions, 1 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index ff769a0f..6d5dce38 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -25,6 +25,7 @@
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 (load "vm-param")
+(load "optimize")
 
 (compile-only
   (load-for (struct sys:param-parser-base "param")))
@@ -1270,6 +1271,11 @@
              (push lt-frag me.lt-frags)
              (new (frag dreg nil))))))))
 
+(defmeth compiler optimize (me insns)
+  (let* ((bb (new (basic-blocks insns))))
+    bb.(thread-jumps)
+    bb.(get-insns)))
+
 (defun maybe-mov (to-reg from-reg)
   (if (nequal to-reg from-reg)
     ^((mov ,to-reg ,from-reg))))
@@ -1669,7 +1675,9 @@
            (frag co.(compile oreg (new env co co) xexp)))
       co.(free-treg oreg)
       co.(check-treg-leak)
-      as.(asm ^(,*(mappend .code (nreverse co.lt-frags)) ,*frag.code (end ,frag.oreg)))
+      as.(asm co.(optimize ^(,*(mappend .code (nreverse co.lt-frags))
+                             ,*frag.code
+                             (end ,frag.oreg))))
       (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec)))))
 
 (defun compiler-emit-warnings ()
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl
new file mode 100644
index 00000000..5cd05095
--- /dev/null
+++ b/share/txr/stdlib/optimize.tl
@@ -0,0 +1,88 @@
+;; Copyright 2021
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice, this
+;;    list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(compile-only
+  (defstruct (basic-blocks insns) nil
+    insns
+    (hash (hash))
+    labels
+    list
+    (:static start (gensym "start-"))
+
+    (:postinit (bb)
+      (set bb.list (partition (dedup-labels (cons bb.start bb.insns))
+                              (op where symbolp)))
+      (set bb.labels [mapcar car bb.list])
+      (mapdo (do set [bb.hash (car @1)] @1) bb.list))
+
+    (:method get-insns (bb)
+      [mappend bb.hash bb.labels])))
+
+(defmeth basic-blocks thread-jumps (bb)
+  (dohash (label code bb.hash)
+    (set [bb.hash label]
+         (rewrite (lambda (insns)
+                    (match-case insns
+                      (((jmp @jlabel) . @rest)
+                       (let ((jinsns [bb.hash jlabel]))
+                         (match-case jinsns
+                           ((@(op eq jlabel) (jmp @(require @jjlabel (neq jjlabel jlabel))) . @nil)
+                            ^((jmp ,jjlabel) ,*rest))
+                           (@jelse insns))))
+                      (((if @reg @jlabel) . @rest)
+                       (let ((jinsns [bb.hash jlabel]))
+                         (match-case jinsns
+                           ((@(op eq jlabel) (if @(op eq reg) @(require @jjlabel (neq jjlabel jlabel))) . @nil)
+                            ^((if ,reg ,jjlabel) ,*rest))
+                           ((@(op eq jlabel) (jmp @(require @jjlabel (neq jjlabel jlabel))) . @nil)
+                            ^((if ,reg ,jjlabel) ,*rest))
+                           (@jelse insns))))
+                      (@else insns)))
+                  code))))
+
+(defun rewrite (fun list)
+  (build
+    (while* list
+      (let ((nlist [fun list]))
+        (if (eq list nlist)
+          (if list (add (pop list)))
+          (set list nlist))))))
+
+(defun subst (x y list)
+  (mapcar (lambda (item)
+            (if (equal item x) y item))
+          list))
+
+(defun dedup-labels (insns)
+  (rewrite (lambda (tail)
+              (match-case tail
+                ((@(symbolp label0) @(symbolp label1) . @rest)
+                 (set insns (mapcar [iffi listp (op subst label1 label0)]
+                                    (remq label1 insns)))
+                 (list* label0 rest))
+                (@else tail)))
+            insns)
+  insns)