compiler.cfg: Some code cleanups, update stack-analysis and phi-insertion to work on CFGs with critical edges
parent
1cf6bb7f99
commit
608fb054f2
|
@ -40,7 +40,10 @@ test-diamond
|
|||
[ 1 ] [ 1 get successors>> length ] unit-test
|
||||
[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
|
||||
[ 3 get successors>> first instructions>> first ]
|
||||
unit-test
|
||||
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
||||
|
||||
V{
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit kernel sequences vectors
|
||||
compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
compiler.cfg.instructions compiler.cfg.rpo compiler.cfg ;
|
||||
IN: compiler.cfg.branch-folding
|
||||
|
||||
! Fold comparisons where both inputs are the same. Predecessors must be
|
||||
|
@ -27,4 +27,4 @@ IN: compiler.cfg.branch-folding
|
|||
dup fold-branch?
|
||||
[ fold-branch ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
|
@ -1,9 +1,6 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays vectors accessors assocs sets
|
||||
namespaces math make fry sequences
|
||||
combinators.short-circuit
|
||||
compiler.cfg.instructions ;
|
||||
USING: kernel math vectors arrays accessors namespaces ;
|
||||
IN: compiler.cfg
|
||||
|
||||
TUPLE: basic-block < identity-tuple
|
||||
|
@ -22,39 +19,12 @@ M: basic-block hashcode* nip id>> ;
|
|||
V{ } clone >>predecessors
|
||||
\ basic-block counter >>id ;
|
||||
|
||||
: empty-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 1 = ]
|
||||
[ first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: (skip-empty-blocks) ( bb -- bb' )
|
||||
dup visited get key? [
|
||||
dup empty-block? [
|
||||
dup visited get conjoin
|
||||
successors>> first (skip-empty-blocks)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: skip-empty-blocks ( bb -- bb' )
|
||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||
|
||||
: add-instructions ( bb quot -- )
|
||||
[ instructions>> building ] dip '[
|
||||
building get pop
|
||||
_ dip
|
||||
building get push
|
||||
] with-variable ; inline
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ > ;
|
||||
|
||||
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
|
||||
|
||||
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
||||
|
||||
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
|
||||
|
||||
TUPLE: mr { instructions array } word label ;
|
||||
|
||||
: <mr> ( instructions word label -- mr )
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors arrays compiler.cfg.checker
|
||||
compiler.cfg.debugger compiler.cfg.def-use
|
||||
compiler.cfg.instructions fry kernel kernel.private math
|
||||
math.private sbufs sequences sequences.private sets
|
||||
math.partial-dispatch math.private sbufs sequences sequences.private sets
|
||||
slots.private strings tools.test vectors layouts ;
|
||||
IN: compiler.cfg.optimizer.tests
|
||||
|
||||
|
@ -31,6 +31,15 @@ IN: compiler.cfg.optimizer.tests
|
|||
[ [ 2 fixnum+ ] when 3 ]
|
||||
[ [ 2 fixnum- ] when 3 ]
|
||||
[ 10000 [ ] times ]
|
||||
[
|
||||
over integer? [
|
||||
over dup 16 <-integer-fixnum
|
||||
[ 0 >=-integer-fixnum ] [ drop f ] if [
|
||||
nip dup
|
||||
[ ] [ ] if
|
||||
] [ 2drop f ] if
|
||||
] [ 2drop f ] if
|
||||
]
|
||||
} [
|
||||
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
||||
] each
|
||||
|
|
|
@ -35,6 +35,12 @@ test-diamond
|
|||
|
||||
[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 1 } ]
|
||||
[ 2 get successors>> first instructions>> first ]
|
||||
unit-test
|
||||
|
||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
|
||||
[ 3 get successors>> first instructions>> first ]
|
||||
unit-test
|
||||
|
||||
[ 2 ] [ 4 get instructions>> length ] unit-test
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs fry kernel sequences
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
USING: accessors assocs fry kernel sequences namespaces
|
||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.phi-elimination
|
||||
|
||||
: insert-copy ( predecessor input output -- )
|
||||
|
@ -11,7 +12,11 @@ IN: compiler.cfg.phi-elimination
|
|||
[ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
|
||||
|
||||
: eliminate-phi-step ( bb -- )
|
||||
instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
|
||||
H{ } clone added-instructions set
|
||||
[ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ]
|
||||
[ insert-basic-blocks ]
|
||||
bi ;
|
||||
|
||||
: eliminate-phis ( cfg -- cfg' )
|
||||
dup [ eliminate-phi-step ] each-basic-block ;
|
||||
dup [ eliminate-phi-step ] each-basic-block
|
||||
cfg-changed ;
|
|
@ -2,7 +2,7 @@ IN: compiler.cfg.stack-analysis.merge.tests
|
|||
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
|
||||
cpu.architecture make assocs
|
||||
cpu.architecture make assocs namespaces
|
||||
sequences kernel classes ;
|
||||
|
||||
[
|
||||
|
@ -11,13 +11,15 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
[ merge-locs locs>vregs>> keys ] { } make first inputs>> values
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
merge-locs locs>vregs>> keys added-phis get values first
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -26,15 +28,16 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
[
|
||||
<state>
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
<state>
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||
] keep first instructions>> first class
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -42,15 +45,17 @@ sequences kernel classes ;
|
|||
] [
|
||||
<state>
|
||||
|
||||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
] keep first instructions>> first class
|
||||
<state> -1 >>ds-height
|
||||
<state> 2array
|
||||
|
||||
[ merge-ds-heights ds-height>> ] { } make drop
|
||||
1 get added-instructions get at first class
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
@ -63,6 +68,9 @@ sequences kernel classes ;
|
|||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
|
||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
@ -82,6 +90,9 @@ sequences kernel classes ;
|
|||
<basic-block> V{ T{ ##branch } } >>instructions
|
||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
||||
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
|
||||
[
|
||||
<state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
|
||||
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs sequences accessors fry combinators grouping
|
||||
sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.stack-analysis.state ;
|
||||
USING: kernel assocs sequences accessors fry combinators grouping sets
|
||||
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
|
||||
IN: compiler.cfg.stack-analysis.merge
|
||||
|
||||
! XXX critical edges
|
||||
|
||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||
|
||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||
|
@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
[ nip first >>rs-height ]
|
||||
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
|
||||
|
||||
: assoc-map-values ( assoc quot -- assoc' )
|
||||
: assoc-map-keys ( assoc quot -- assoc' )
|
||||
'[ _ dip ] assoc-map ; inline
|
||||
|
||||
: translate-locs ( assoc state -- assoc' )
|
||||
'[ _ translate-loc ] assoc-map-values ;
|
||||
'[ _ translate-loc ] assoc-map-keys ;
|
||||
|
||||
: untranslate-locs ( assoc state -- assoc' )
|
||||
'[ _ untranslate-loc ] assoc-map-values ;
|
||||
'[ _ untranslate-loc ] assoc-map-keys ;
|
||||
|
||||
: collect-locs ( loc-maps states -- assoc )
|
||||
! assoc maps locs to sequences
|
||||
|
@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
: insert-peek ( predecessor loc state -- vreg )
|
||||
'[ _ _ translate-loc ^^peek ] add-instructions ;
|
||||
|
||||
SYMBOL: added-phis
|
||||
|
||||
: add-phi-later ( inputs -- vreg )
|
||||
[ int-regs next-vreg dup ] dip 2array added-phis get push ;
|
||||
|
||||
: merge-loc ( predecessors vregs loc state -- vreg )
|
||||
! Insert a ##phi in the current block where the input
|
||||
! is the vreg storing loc from each predecessor block
|
||||
[ dup ] 3dip
|
||||
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
|
||||
dup all-equal? [ nip first ] [ zip ^^phi ] if ;
|
||||
dup all-equal? [ first ] [ add-phi-later ] if ;
|
||||
|
||||
:: merge-locs ( state predecessors states -- state )
|
||||
states [ locs>vregs>> ] map states collect-locs
|
||||
|
@ -77,30 +80,35 @@ IN: compiler.cfg.stack-analysis.merge
|
|||
over translate-locs
|
||||
>>changed-locs ;
|
||||
|
||||
ERROR: cannot-merge-poisoned states ;
|
||||
:: insert-phis ( bb -- )
|
||||
bb predecessors>> :> predecessors
|
||||
[
|
||||
added-phis get [| dst inputs |
|
||||
dst predecessors inputs zip ##phi
|
||||
] assoc-each
|
||||
] V{ } make bb instructions>> over push-all
|
||||
bb (>>instructions) ;
|
||||
|
||||
: multiple-predecessors ( bb states -- state )
|
||||
dup [ not ] any? [
|
||||
2drop <state>
|
||||
:: multiple-predecessors ( bb states -- state )
|
||||
states [ not ] any? [
|
||||
<state>
|
||||
] [
|
||||
dup [ poisoned?>> ] any? [
|
||||
cannot-merge-poisoned
|
||||
] [
|
||||
[ state new ] 2dip
|
||||
[ predecessors>> ] dip
|
||||
{
|
||||
[ merge-ds-heights ]
|
||||
[ merge-rs-heights ]
|
||||
[ merge-locs ]
|
||||
[ nip merge-actual-locs ]
|
||||
[ nip merge-changed-locs ]
|
||||
} 2cleave
|
||||
] if
|
||||
[
|
||||
H{ } clone added-instructions set
|
||||
V{ } clone added-phis set
|
||||
bb predecessors>> :> predecessors
|
||||
state new
|
||||
predecessors states merge-ds-heights
|
||||
predecessors states merge-rs-heights
|
||||
predecessors states merge-locs
|
||||
states merge-actual-locs
|
||||
states merge-changed-locs
|
||||
bb insert-basic-blocks
|
||||
bb insert-phis
|
||||
] with-scope
|
||||
] if ;
|
||||
|
||||
: merge-states ( bb states -- state )
|
||||
! If any states are poisoned, save all registers
|
||||
! to the stack in each branch
|
||||
dup length {
|
||||
{ 0 [ initial-state ] }
|
||||
{ 1 [ single-predecessor ] }
|
||||
|
|
|
@ -99,7 +99,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
! Correct height tracking
|
||||
[ t ] [
|
||||
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
|
||||
reverse-post-order 3 swap nth
|
||||
reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
|
||||
2array { D 1 D 0 } set=
|
||||
] unit-test
|
||||
|
@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> second loc>>
|
||||
3 get successors>> first instructions>> first loc>>
|
||||
] unit-test
|
||||
|
||||
! Do inserted ##peeks reference the correct stack location if
|
||||
|
@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
||||
|
||||
! Missing ##replace
|
||||
|
@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
! Inserted ##peeks reference the wrong stack location
|
||||
[ t ] [
|
||||
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
|
||||
eliminate-dead-code reverse-post-order 3 swap nth
|
||||
eliminate-dead-code reverse-post-order 4 swap nth
|
||||
instructions>> [ ##peek? ] filter [ loc>> ] map
|
||||
{ R 0 D 0 D 1 } set=
|
||||
{ D 0 D 1 } set=
|
||||
] unit-test
|
||||
|
||||
[ D 0 ] [
|
||||
|
@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
|
|||
stack-analysis
|
||||
drop
|
||||
|
||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
||||
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||
] unit-test
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||
sets make combinators
|
||||
sets make combinators dlists deques
|
||||
compiler.cfg
|
||||
compiler.cfg.copy-prop
|
||||
compiler.cfg.def-use
|
||||
|
@ -10,9 +10,14 @@ compiler.cfg.registers
|
|||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.stack-analysis.state
|
||||
compiler.cfg.stack-analysis.merge ;
|
||||
compiler.cfg.stack-analysis.merge
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.stack-analysis
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: add-to-work-list ( bb -- ) work-list get push-front ;
|
||||
|
||||
: redundant-replace? ( vreg loc -- ? )
|
||||
dup state get untranslate-loc n>> 0 <
|
||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||
|
@ -137,10 +142,21 @@ SYMBOLS: state-in state-out ;
|
|||
] 2bi
|
||||
] V{ } make >>instructions drop ;
|
||||
|
||||
: visit-successors ( bb -- )
|
||||
dup successors>> [
|
||||
2dup back-edge? [ 2drop ] [ nip add-to-work-list ] if
|
||||
] with each ;
|
||||
|
||||
: process-work-list ( -- )
|
||||
work-list get [ visit-block ] slurp-deque ;
|
||||
|
||||
: stack-analysis ( cfg -- cfg' )
|
||||
[
|
||||
<hashed-dlist> work-list set
|
||||
H{ } clone copies set
|
||||
H{ } clone state-in set
|
||||
H{ } clone state-out set
|
||||
dup [ visit-block ] each-basic-block
|
||||
dup [ add-to-work-list ] each-basic-block
|
||||
process-work-list
|
||||
cfg-changed
|
||||
] with-scope ;
|
||||
|
|
|
@ -5,7 +5,8 @@ namespaces sequences fry combinators
|
|||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.instructions ;
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.tco
|
||||
|
||||
! Tail call optimization. You must run compute-predecessors after this
|
||||
|
@ -82,4 +83,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn
|
|||
: optimize-tail-calls ( cfg -- cfg' )
|
||||
dup cfg set
|
||||
dup [ optimize-tail-call ] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences math combinators combinators.short-circuit
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
||||
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||
compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.useless-conditionals
|
||||
|
||||
: delete-conditional? ( bb -- ? )
|
||||
|
@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
|
|||
dup [
|
||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||
] each-basic-block
|
||||
f >>post-order ;
|
||||
cfg-changed ;
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math layouts make sequences combinators
|
||||
cpu.architecture namespaces compiler.cfg
|
||||
compiler.cfg.instructions ;
|
||||
USING: accessors assocs combinators combinators.short-circuit
|
||||
compiler.cfg compiler.cfg.instructions cpu.architecture kernel
|
||||
layouts locals make math namespaces sequences sets vectors ;
|
||||
IN: compiler.cfg.utilities
|
||||
|
||||
: value-info-small-fixnum? ( value-info -- ? )
|
||||
|
@ -33,7 +33,53 @@ IN: compiler.cfg.utilities
|
|||
building off
|
||||
basic-block off ;
|
||||
|
||||
: stop-iterating ( -- next ) end-basic-block f ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##call ##branch begin-basic-block ;
|
||||
|
||||
: back-edge? ( from to -- ? )
|
||||
[ number>> ] bi@ >= ;
|
||||
|
||||
: empty-block? ( bb -- ? )
|
||||
instructions>> {
|
||||
[ length 1 = ]
|
||||
[ first ##branch? ]
|
||||
} 1&& ;
|
||||
|
||||
SYMBOL: visited
|
||||
|
||||
: (skip-empty-blocks) ( bb -- bb' )
|
||||
dup visited get key? [
|
||||
dup empty-block? [
|
||||
dup visited get conjoin
|
||||
successors>> first (skip-empty-blocks)
|
||||
] when
|
||||
] unless ;
|
||||
|
||||
: skip-empty-blocks ( bb -- bb' )
|
||||
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
|
||||
|
||||
! assoc mapping predecessors to sequences
|
||||
SYMBOL: added-instructions
|
||||
|
||||
: add-instructions ( predecessor quot -- )
|
||||
[
|
||||
added-instructions get
|
||||
[ drop V{ } clone ] cache
|
||||
building
|
||||
] dip with-variable ; inline
|
||||
|
||||
:: insert-basic-block ( from to bb -- )
|
||||
bb from 1vector >>predecessors drop
|
||||
bb to 1vector >>successors drop
|
||||
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
|
||||
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
|
||||
|
||||
:: insert-basic-blocks ( bb -- )
|
||||
added-instructions get
|
||||
[| predecessor instructions |
|
||||
\ ##branch new-insn instructions push
|
||||
predecessor bb
|
||||
<basic-block> instructions >>instructions
|
||||
insert-basic-block
|
||||
] assoc-each ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue