diff options
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 1 | ||||
| -rw-r--r-- | share/txr/stdlib/optimize.tl | 115 |
2 files changed, 65 insertions, 51 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index d034ab21..b283a0c8 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1418,6 +1418,7 @@ (defmeth compiler optimize (me insns) (let* ((bb (new (basic-blocks insns)))) bb.(peephole) + bb.(thread-jumps) bb.(get-insns))) (defun true-const-p (arg) diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl index b0363755..aee0dac8 100644 --- a/share/txr/stdlib/optimize.tl +++ b/share/txr/stdlib/optimize.tl @@ -74,59 +74,67 @@ ,*cases)) ,list)) +(defmeth basic-blocks thread-jumps-block (bb label code) + (let* ((tail (last code)) + (oinsn (car tail)) + (insn oinsn) + (ninsn oinsn)) + (while* (nequal ninsn insn) + (pset insn ninsn + ninsn (match-case insn + ((if (d @reg) @jlabel) nil) + ((jmp @jlabel) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(jmp ,jjlabel)) + (@jelse insn)))) + ((if @reg @jlabel) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@jlabel + (if @reg + @(and @jjlabel @(not @jlabel))) . @nil) + ^(if ,reg ,jjlabel)) + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(if ,reg ,jjlabel)) + ((@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) + insn))) + (@jelse insn)))) + ((ifq @reg @creg @jlabel) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@jlabel + (ifq @reg @creg + @(and @jjlabel @(not @jlabel))) . @nil) + ^(ifq ,reg ,creg ,jjlabel)) + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(ifq ,reg ,creg ,jjlabel)) + (@jelse insn)))) + ((close @reg @nargs @jlabel . @cargs) + (let ((jinsns [bb.hash jlabel])) + (match-case jinsns + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(close ,reg ,nargs ,jjlabel ,*cargs)) + (@jelse insn)))) + (@else else)))) + (cond + ((null ninsn) (ldiff code tail)) + ((nequal ninsn oinsn) (append (ldiff code tail) (list ninsn))) + (t code)))) + (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 @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)) @@ -170,6 +178,11 @@ (set [bb.hash label] bb.(peephole-block label [bb.hash label]))))) +(defmeth basic-blocks thread-jumps (bb) + (dohash (label code bb.hash) + (set [bb.hash label] + bb.(thread-jumps-block label code)))) + (defun rewrite (fun list) (build (while* list |