summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-02-15 11:15:09 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-02-15 11:15:09 -0800
commite2f1066cebdc3aeb139856302a290ac2513d1615 (patch)
tree0ceb8d56c6eef7efe7b90122f1aa77cb9b769a35
parente7204bf90fa7f800edd0fae7d145e3fd6449fb6f (diff)
downloadtxr-e2f1066cebdc3aeb139856302a290ac2513d1615.tar.gz
txr-e2f1066cebdc3aeb139856302a290ac2513d1615.tar.bz2
txr-e2f1066cebdc3aeb139856302a290ac2513d1615.zip
compiler: peephole newly added blocks.
If cut-block is called during peephole optimization, it can introduce blocks that can be missed, in which there might be some opportunity for peephole reduction. Let's keep track of newly added blocks in a re-scan list. * share/txr/stdlib/optimize.tl (struct basic-blocks): New slot, rescan. (basic-blocks cut-block): Add new block's label to rescan list. (basic-blocks peephole-block): New method, formed out of the bulk of basic-blocks peephole. (basic-blocks peephole): After processing the blocks from the hash table, iterate on the rescan list.
-rw-r--r--share/txr/stdlib/optimize.tl190
1 files changed, 100 insertions, 90 deletions
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl
index a527858e..530c26d2 100644
--- a/share/txr/stdlib/optimize.tl
+++ b/share/txr/stdlib/optimize.tl
@@ -30,6 +30,7 @@
(hash (hash))
labels
list
+ rescan
(:static start (gensym "start-"))
(:static jump-ops '(jmp if ifq ifql swtch ret abscsr))
@@ -59,6 +60,7 @@
ltail))
(set [bb.hash nlabel] (cons nlabel at))
(set [bb.hash label] (ldiff insns at))
+ (push nlabel bb.rescan)
nlabel))
(:method next-block (bb label)
@@ -72,99 +74,107 @@
,*cases))
,list))
+(defmeth basic-blocks peephole-block (bb label code)
+ (rewrite-case insns code
+ ;; dead code
+ ((@(or (jmp @nil) (if (t 0) @nil)) @nil . @rest)
+ (list (car insns)))
+ ;; always taken if
+ (((if (d @reg) @jlabel) . @rest)
+ rest)
+ ;; jump threading
+ (((jmp @jlabel) . @rest)
+ (let ((jinsns [bb.hash jlabel]))
+ (match-case jinsns
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^((jmp ,jjlabel) ,*rest))
+ (@jelse insns))))
+ (((if @reg @jlabel0)
+ (jmp @(with @jlabel1
+ @(hash (@jlabel1 (@jlabel1
+ (if @reg @nil)
+ (jmp @jlabel2) . @nil)))
+ bb.hash)) . @rest)
+ ^(,(car insns) (jmp ,jlabel2) ,*rest))
+ (((if @reg @jlabel) . @rest)
+ (let ((jinsns [bb.hash jlabel]))
+ (match-case jinsns
+ ((@jlabel
+ (if @reg
+ @(and @jjlabel @(not @jlabel))) . @nil)
+ ^((if ,reg ,jjlabel) ,*rest))
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^((if ,reg ,jjlabel) ,*rest))
+ ((@jlabel
+ (ifq @reg nil @jjlabel) . @jrest)
+ (let ((xlabel (if jrest
+ bb.(cut-block jlabel jrest jinsns)
+ bb.(next-block jlabel))))
+ (if xlabel
+ ^((if ,reg ,xlabel) ,*rest)
+ insns)))
+ (@jelse insns))))
+ (((ifq @reg @creg @jlabel) . @rest)
+ (let ((jinsns [bb.hash jlabel]))
+ (match-case jinsns
+ ((@jlabel
+ (ifq @reg @creg
+ @(and @jjlabel @(not @jlabel))) . @nil)
+ ^((ifq ,reg ,creg ,jjlabel) ,*rest))
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^((ifq ,reg ,creg ,jjlabel) ,*rest))
+ (@jelse insns))))
+ (((close @reg @nargs @jlabel . @cargs) . @rest)
+ (let ((jinsns [bb.hash jlabel]))
+ (match-case jinsns
+ ((@jlabel
+ (jmp @(and @jjlabel @(not @jlabel))) . @nil)
+ ^((close ,reg ,nargs ,jjlabel ,*cargs) ,*rest))
+ (@jelse insns))))
+ ;; wasteful moves
+ (((mov @reg0 @nil) (mov @reg0 @nil) . @nil)
+ (cdr insns))
+ (((mov @reg0 @reg1) (mov reg1 @reg0) . @rest)
+ ^(,(car insns) ,*rest))
+ ;; frame reduction
+ (((@(or frame dframe) @lev @size)
+ (@(or call gcall mov)
+ . @(require @(coll (v @vlev @nil))
+ (none vlev (op eql (ppred lev)))))
+ . @rest)
+ ^(,(cadr insns) ,(car insns) ,*rest))
+ (((@(or frame dframe) . @nil)
+ (if (t @reg) @jlabel))
+ (let ((jinsns [bb.hash jlabel]))
+ (match-case jinsns
+ ((@jlabel
+ (end (t @reg)) . @jrest)
+ (let* ((xlabel (if jrest
+ bb.(cut-block jlabel jrest jinsns)
+ bb.(next-block jlabel)))
+ (ylabel bb.(next-block label))
+ (yinsns [bb.hash ylabel]))
+ (cond
+ ((and xlabel ylabel)
+ (set [bb.hash ylabel]
+ ^(,ylabel ,(car insns) ,*(cdr yinsns)))
+ ^((if (t ,reg) ,xlabel)))
+ (t insns))))
+ (@jelse insns))))
+ (@else insns)))
+
(defmeth basic-blocks peephole (bb)
(dohash (label code bb.hash)
(set [bb.hash label]
- (rewrite-case insns code
- ;; dead code
- ((@(or (jmp @nil) (if (t 0) @nil)) @nil . @rest)
- (list (car insns)))
- ;; always taken if
- (((if (d @reg) @jlabel) . @rest)
- rest)
- ;; jump threading
- (((jmp @jlabel) . @rest)
- (let ((jinsns [bb.hash jlabel]))
- (match-case jinsns
- ((@jlabel
- (jmp @(and @jjlabel @(not @jlabel))) . @nil)
- ^((jmp ,jjlabel) ,*rest))
- (@jelse insns))))
- (((if @reg @jlabel0)
- (jmp @(with @jlabel1
- @(hash (@jlabel1 (@jlabel1
- (if @reg @nil)
- (jmp @jlabel2) . @nil)))
- bb.hash)) . @rest)
- ^(,(car insns) (jmp ,jlabel2) ,*rest))
- (((if @reg @jlabel) . @rest)
- (let ((jinsns [bb.hash jlabel]))
- (match-case jinsns
- ((@jlabel
- (if @reg
- @(and @jjlabel @(not @jlabel))) . @nil)
- ^((if ,reg ,jjlabel) ,*rest))
- ((@jlabel
- (jmp @(and @jjlabel @(not @jlabel))) . @nil)
- ^((if ,reg ,jjlabel) ,*rest))
- ((@jlabel
- (ifq @reg nil @jjlabel) . @jrest)
- (let ((xlabel (if jrest
- bb.(cut-block jlabel jrest jinsns)
- bb.(next-block jlabel))))
- (if xlabel
- ^((if ,reg ,xlabel) ,*rest)
- insns)))
- (@jelse insns))))
- (((ifq @reg @creg @jlabel) . @rest)
- (let ((jinsns [bb.hash jlabel]))
- (match-case jinsns
- ((@jlabel
- (ifq @reg @creg
- @(and @jjlabel @(not @jlabel))) . @nil)
- ^((ifq ,reg ,creg ,jjlabel) ,*rest))
- ((@jlabel
- (jmp @(and @jjlabel @(not @jlabel))) . @nil)
- ^((ifq ,reg ,creg ,jjlabel) ,*rest))
- (@jelse insns))))
- (((close @reg @nargs @jlabel . @cargs) . @rest)
- (let ((jinsns [bb.hash jlabel]))
- (match-case jinsns
- ((@jlabel
- (jmp @(and @jjlabel @(not @jlabel))) . @nil)
- ^((close ,reg ,nargs ,jjlabel ,*cargs) ,*rest))
- (@jelse insns))))
- ;; wasteful moves
- (((mov @reg0 @nil) (mov @reg0 @nil) . @nil)
- (cdr insns))
- (((mov @reg0 @reg1) (mov reg1 @reg0) . @rest)
- ^(,(car insns) ,*rest))
- ;; frame reduction
- (((@(or frame dframe) @lev @size)
- (@(or call gcall mov)
- . @(require @(coll (v @vlev @nil))
- (none vlev (op eql (ppred lev)))))
- . @rest)
- ^(,(cadr insns) ,(car insns) ,*rest))
- (((@(or frame dframe) . @nil)
- (if (t @reg) @jlabel))
- (let ((jinsns [bb.hash jlabel]))
- (match-case jinsns
- ((@jlabel
- (end (t @reg)) . @jrest)
- (let* ((xlabel (if jrest
- bb.(cut-block jlabel jrest jinsns)
- bb.(next-block jlabel)))
- (ylabel bb.(next-block label))
- (yinsns [bb.hash ylabel]))
- (cond
- ((and xlabel ylabel)
- (set [bb.hash ylabel]
- ^(,ylabel ,(car insns) ,*(cdr yinsns)))
- ^((if (t ,reg) ,xlabel)))
- (t insns))))
- (@jelse insns))))
- (@else insns)))))
+ bb.(peephole-block label code)))
+ (whilet ((rescan bb.rescan))
+ (set bb.rescan nil)
+ (each ((label rescan))
+ (set [bb.hash label]
+ bb.(peephole-block label [bb.hash label])))))
(defun rewrite (fun list)
(build