diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-02-15 09:38:37 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-02-15 09:38:37 -0800 |
commit | e7204bf90fa7f800edd0fae7d145e3fd6449fb6f (patch) | |
tree | d7d7165caa1b43820b27042a2a64f7a019c596cb | |
parent | abe744ceb522434907094dc3d946d12177d51fce (diff) | |
download | txr-e7204bf90fa7f800edd0fae7d145e3fd6449fb6f.tar.gz txr-e7204bf90fa7f800edd0fae7d145e3fd6449fb6f.tar.bz2 txr-e7204bf90fa7f800edd0fae7d145e3fd6449fb6f.zip |
compiler: basic blocks replace extended basic blocks.
* share/txr/stdlib/optimize.tl (struct basic-blocks):
jump-ops, new static member.
(basic-blocks :postinit): Cut the code into basic blocks
rather than extended basic blocks. This means that the
insruction which follows every jumping instructions is now a
block leader. Every block needs a label, so we add them.
(basic-blocks peephole): The optimization which slides a frame
instruction past a jump must be refactored to move the frame
instruction into the next block. Firstly, moving anything
past a jump instruction is no longer allowed, because the
result is no longer a basic block. Secondly, doing so prevents
further frame movements, because the block no longer has any
instructions after the jump over which the frame can be moved.
-rw-r--r-- | share/txr/stdlib/optimize.tl | 39 |
1 files changed, 27 insertions, 12 deletions
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl index 9acbbe5d..a527858e 100644 --- a/share/txr/stdlib/optimize.tl +++ b/share/txr/stdlib/optimize.tl @@ -31,12 +31,22 @@ labels list (:static start (gensym "start-")) + (:static jump-ops '(jmp if ifq ifql swtch ret abscsr)) (: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)) + (let* ((insns (dedup-labels (cons bb.start bb.insns))) + (cuts (merge [where symbolp insns] + [where [andf consp + (op memq (car @1) bb.jump-ops)] + (cons nil insns)])) + (parts (partition insns cuts)) + (lparts (mapcar [iff [chain car symbolp] + use + (op cons (gensym))] + parts))) + (set bb.list lparts) + (set bb.labels [mapcar car lparts]) + (mapdo (do set [bb.hash (car @1)] @1) lparts))) (:method get-insns (bb) [mappend bb.hash bb.labels]) @@ -137,17 +147,22 @@ . @rest) ^(,(cadr insns) ,(car insns) ,*rest)) (((@(or frame dframe) . @nil) - (if (t @reg) @jlabel) . @rest) + (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)))) - (if xlabel - ^((if (t ,reg) ,xlabel) ,(car insns) ,*rest) - insns))) + (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))))) |