From d3dccedf7d7ad9f7108bdc08df9901d607e5f25a Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 26 Jan 2021 19:01:25 -0800
Subject: 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.
---
share/txr/stdlib/compiler.tl | 10 ++++-
share/txr/stdlib/optimize.tl | 88 ++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 97 insertions(+), 1 deletion(-)
create mode 100644 share/txr/stdlib/optimize.tl
(limited to 'share')
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)
--
cgit v1.2.3