Merge branch 'master' of git://factorcode.org/git/factor
commit
f6f44ede5a
|
@ -40,7 +40,10 @@ test-diamond
|
||||||
[ 1 ] [ 1 get successors>> length ] unit-test
|
[ 1 ] [ 1 get successors>> length ] unit-test
|
||||||
[ t ] [ 1 get successors>> first 3 get eq? ] 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
|
[ 2 ] [ 4 get instructions>> length ] unit-test
|
||||||
|
|
||||||
V{
|
V{
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors combinators.short-circuit kernel sequences vectors
|
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
|
IN: compiler.cfg.branch-folding
|
||||||
|
|
||||||
! Fold comparisons where both inputs are the same. Predecessors must be
|
! Fold comparisons where both inputs are the same. Predecessors must be
|
||||||
|
@ -27,4 +27,4 @@ IN: compiler.cfg.branch-folding
|
||||||
dup fold-branch?
|
dup fold-branch?
|
||||||
[ fold-branch ] [ drop ] if
|
[ fold-branch ] [ drop ] if
|
||||||
] each-basic-block
|
] each-basic-block
|
||||||
f >>post-order ;
|
cfg-changed ;
|
|
@ -0,0 +1,85 @@
|
||||||
|
USING: accessors assocs compiler.cfg
|
||||||
|
compiler.cfg.branch-splitting compiler.cfg.debugger
|
||||||
|
compiler.cfg.predecessors compiler.cfg.rpo fry kernel
|
||||||
|
tools.test namespaces sequences vectors ;
|
||||||
|
IN: compiler.cfg.branch-splitting.tests
|
||||||
|
|
||||||
|
: get-predecessors ( cfg -- assoc )
|
||||||
|
H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ;
|
||||||
|
|
||||||
|
: check-predecessors ( cfg -- )
|
||||||
|
[ get-predecessors ]
|
||||||
|
[ compute-predecessors drop ]
|
||||||
|
[ get-predecessors ] tri assert= ;
|
||||||
|
|
||||||
|
: check-branch-splitting ( cfg -- )
|
||||||
|
compute-predecessors
|
||||||
|
split-branches
|
||||||
|
check-predecessors ;
|
||||||
|
|
||||||
|
: test-branch-splitting ( -- )
|
||||||
|
cfg new 0 get >>entry check-branch-splitting ;
|
||||||
|
|
||||||
|
V{ } 0 test-bb
|
||||||
|
|
||||||
|
V{ } 1 test-bb
|
||||||
|
|
||||||
|
V{ } 2 test-bb
|
||||||
|
|
||||||
|
V{ } 3 test-bb
|
||||||
|
|
||||||
|
V{ } 4 test-bb
|
||||||
|
|
||||||
|
test-diamond
|
||||||
|
|
||||||
|
[ ] [ test-branch-splitting ] unit-test
|
||||||
|
|
||||||
|
V{ } 0 test-bb
|
||||||
|
|
||||||
|
V{ } 1 test-bb
|
||||||
|
|
||||||
|
V{ } 2 test-bb
|
||||||
|
|
||||||
|
V{ } 3 test-bb
|
||||||
|
|
||||||
|
V{ } 4 test-bb
|
||||||
|
|
||||||
|
V{ } 5 test-bb
|
||||||
|
|
||||||
|
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||||
|
|
||||||
|
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||||
|
|
||||||
|
2 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||||
|
|
||||||
|
[ ] [ test-branch-splitting ] unit-test
|
||||||
|
|
||||||
|
V{ } 0 test-bb
|
||||||
|
|
||||||
|
V{ } 1 test-bb
|
||||||
|
|
||||||
|
V{ } 2 test-bb
|
||||||
|
|
||||||
|
V{ } 3 test-bb
|
||||||
|
|
||||||
|
V{ } 4 test-bb
|
||||||
|
|
||||||
|
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||||
|
|
||||||
|
1 get 3 get 4 get V{ } 2sequence >>successors drop
|
||||||
|
|
||||||
|
2 get 4 get 1vector >>successors drop
|
||||||
|
|
||||||
|
[ ] [ test-branch-splitting ] unit-test
|
||||||
|
|
||||||
|
V{ } 0 test-bb
|
||||||
|
|
||||||
|
V{ } 1 test-bb
|
||||||
|
|
||||||
|
V{ } 2 test-bb
|
||||||
|
|
||||||
|
0 get 1 get 2 get V{ } 2sequence >>successors drop
|
||||||
|
|
||||||
|
1 get 2 get 1vector >>successors drop
|
||||||
|
|
||||||
|
[ ] [ test-branch-splitting ] unit-test
|
|
@ -1,37 +1,79 @@
|
||||||
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
|
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors combinators.short-circuit kernel math sequences
|
USING: accessors combinators.short-circuit kernel math math.order
|
||||||
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
|
sequences assocs namespaces vectors fry arrays splitting
|
||||||
|
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
|
||||||
|
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
|
||||||
IN: compiler.cfg.branch-splitting
|
IN: compiler.cfg.branch-splitting
|
||||||
|
|
||||||
! Predecessors must be recomputed after this
|
: clone-renamings ( insns -- assoc )
|
||||||
|
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
|
||||||
|
|
||||||
: split-branch-for ( bb predecessor -- )
|
: clone-instructions ( insns -- insns' )
|
||||||
[
|
dup clone-renamings renamings [
|
||||||
[
|
[
|
||||||
<basic-block>
|
clone
|
||||||
swap
|
dup rename-insn-defs
|
||||||
[ instructions>> [ clone ] map >>instructions ]
|
dup rename-insn-uses
|
||||||
[ successors>> clone >>successors ]
|
dup fresh-insn-temps
|
||||||
bi
|
] map
|
||||||
] keep
|
] with-variable ;
|
||||||
] dip
|
|
||||||
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
|
: clone-basic-block ( bb -- bb' )
|
||||||
drop ;
|
! The new block gets the same RPO number as the old one.
|
||||||
|
! This is just to make 'back-edge?' work.
|
||||||
|
<basic-block>
|
||||||
|
swap
|
||||||
|
[ instructions>> clone-instructions >>instructions ]
|
||||||
|
[ successors>> clone >>successors ]
|
||||||
|
[ number>> >>number ]
|
||||||
|
tri ;
|
||||||
|
|
||||||
|
: new-blocks ( bb -- copies )
|
||||||
|
dup predecessors>> [
|
||||||
|
[ clone-basic-block ] dip
|
||||||
|
1vector >>predecessors
|
||||||
|
] with map ;
|
||||||
|
|
||||||
|
: update-predecessor-successor ( pred copy old-bb -- )
|
||||||
|
'[
|
||||||
|
[ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
|
||||||
|
] change-successors drop ;
|
||||||
|
|
||||||
|
: update-predecessor-successors ( copies old-bb -- )
|
||||||
|
[ predecessors>> swap ] keep
|
||||||
|
'[ _ update-predecessor-successor ] 2each ;
|
||||||
|
|
||||||
|
: update-successor-predecessor ( copies old-bb succ -- )
|
||||||
|
[
|
||||||
|
swap 1array split swap join V{ } like
|
||||||
|
] change-predecessors drop ;
|
||||||
|
|
||||||
|
: update-successor-predecessors ( copies old-bb -- )
|
||||||
|
dup successors>> [
|
||||||
|
update-successor-predecessor
|
||||||
|
] with with each ;
|
||||||
|
|
||||||
: split-branch ( bb -- )
|
: split-branch ( bb -- )
|
||||||
dup predecessors>> [ split-branch-for ] with each ;
|
[ new-blocks ] keep
|
||||||
|
[ update-predecessor-successors ]
|
||||||
|
[ update-successor-predecessors ]
|
||||||
|
2bi ;
|
||||||
|
|
||||||
|
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
|
||||||
|
|
||||||
|
: split-instructions? ( insns -- ? )
|
||||||
|
[ irrelevant? not ] count 5 <= ;
|
||||||
|
|
||||||
: split-branches? ( bb -- ? )
|
: split-branches? ( bb -- ? )
|
||||||
{
|
{
|
||||||
[ successors>> empty? ]
|
[ dup successors>> [ back-edge? ] with any? not ]
|
||||||
[ predecessors>> length 1 > ]
|
[ predecessors>> length 1 4 between? ]
|
||||||
[ instructions>> [ defs-vregs ] any? not ]
|
[ instructions>> split-instructions? ]
|
||||||
[ instructions>> [ temp-vregs ] any? not ]
|
|
||||||
} 1&& ;
|
} 1&& ;
|
||||||
|
|
||||||
: split-branches ( cfg -- cfg' )
|
: split-branches ( cfg -- cfg' )
|
||||||
dup [
|
dup [
|
||||||
dup split-branches? [ split-branch ] [ drop ] if
|
dup split-branches? [ split-branch ] [ drop ] if
|
||||||
] each-basic-block
|
] each-basic-block
|
||||||
f >>post-order ;
|
cfg-changed ;
|
||||||
|
|
|
@ -1,9 +1,6 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel arrays vectors accessors assocs sets
|
USING: kernel math vectors arrays accessors namespaces ;
|
||||||
namespaces math make fry sequences
|
|
||||||
combinators.short-circuit
|
|
||||||
compiler.cfg.instructions ;
|
|
||||||
IN: compiler.cfg
|
IN: compiler.cfg
|
||||||
|
|
||||||
TUPLE: basic-block < identity-tuple
|
TUPLE: basic-block < identity-tuple
|
||||||
|
@ -22,39 +19,12 @@ M: basic-block hashcode* nip id>> ;
|
||||||
V{ } clone >>predecessors
|
V{ } clone >>predecessors
|
||||||
\ basic-block counter >>id ;
|
\ 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 ;
|
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
|
||||||
|
|
||||||
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
|
||||||
|
|
||||||
|
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
|
||||||
|
|
||||||
TUPLE: mr { instructions array } word label ;
|
TUPLE: mr { instructions array } word label ;
|
||||||
|
|
||||||
: <mr> ( instructions word label -- mr )
|
: <mr> ( instructions word label -- mr )
|
||||||
|
|
|
@ -1509,6 +1509,7 @@ SYMBOL: linear-scan-result
|
||||||
compute-liveness
|
compute-liveness
|
||||||
dup reverse-post-order
|
dup reverse-post-order
|
||||||
{ { int-regs regs } } (linear-scan)
|
{ { int-regs regs } } (linear-scan)
|
||||||
|
cfg-changed
|
||||||
flatten-cfg 1array mr.
|
flatten-cfg 1array mr.
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
|
@ -1803,7 +1804,7 @@ test-diamond
|
||||||
|
|
||||||
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
|
||||||
|
|
||||||
[ _spill ] [ 2 get instructions>> first class ] unit-test
|
[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
|
||||||
|
|
||||||
[ _spill ] [ 3 get instructions>> second class ] unit-test
|
[ _spill ] [ 3 get instructions>> second class ] unit-test
|
||||||
|
|
||||||
|
@ -1859,7 +1860,7 @@ V{
|
||||||
|
|
||||||
[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
|
[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
|
||||||
|
|
||||||
[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
|
[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
|
||||||
|
|
||||||
[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
|
[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
|
||||||
|
|
||||||
|
@ -1926,7 +1927,7 @@ V{
|
||||||
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
|
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
|
||||||
|
|
||||||
! Resolve pass should insert this
|
! Resolve pass should insert this
|
||||||
[ _reload ] [ 5 get instructions>> first class ] unit-test
|
[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
|
||||||
|
|
||||||
! Some random bug
|
! Some random bug
|
||||||
V{
|
V{
|
||||||
|
@ -2484,7 +2485,7 @@ test-diamond
|
||||||
|
|
||||||
[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
|
[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
|
||||||
|
|
||||||
[ 1 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
|
[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
|
||||||
|
|
||||||
[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
|
[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan
|
||||||
init-mapping
|
init-mapping
|
||||||
dup reverse-post-order machine-registers (linear-scan)
|
dup reverse-post-order machine-registers (linear-scan)
|
||||||
spill-counts get >>spill-counts
|
spill-counts get >>spill-counts
|
||||||
|
cfg-changed
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
|
@ -1,7 +0,0 @@
|
||||||
USING: arrays compiler.cfg.linear-scan.resolve kernel
|
|
||||||
tools.test ;
|
|
||||||
IN: compiler.cfg.linear-scan.resolve.tests
|
|
||||||
|
|
||||||
[ { 1 2 3 4 5 6 } ] [
|
|
||||||
{ 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
|
|
||||||
] unit-test
|
|
|
@ -3,6 +3,7 @@
|
||||||
USING: accessors arrays assocs combinators
|
USING: accessors arrays assocs combinators
|
||||||
combinators.short-circuit fry kernel locals
|
combinators.short-circuit fry kernel locals
|
||||||
make math sequences
|
make math sequences
|
||||||
|
compiler.cfg.utilities
|
||||||
compiler.cfg.instructions
|
compiler.cfg.instructions
|
||||||
compiler.cfg.linear-scan.assignment
|
compiler.cfg.linear-scan.assignment
|
||||||
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
|
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
|
||||||
|
@ -30,42 +31,14 @@ IN: compiler.cfg.linear-scan.resolve
|
||||||
[ resolve-value-data-flow ] with with each
|
[ resolve-value-data-flow ] with with each
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
: fork? ( from to -- ? )
|
: perform-mappings ( bb to mappings -- )
|
||||||
{
|
dup empty? [ 3drop ] [
|
||||||
[ drop successors>> length 1 >= ]
|
mapping-instructions <simple-block>
|
||||||
[ nip predecessors>> length 1 = ]
|
insert-basic-block
|
||||||
} 2&& ; inline
|
|
||||||
|
|
||||||
: insert-position/fork ( from to -- before after )
|
|
||||||
nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
|
|
||||||
|
|
||||||
: join? ( from to -- ? )
|
|
||||||
{
|
|
||||||
[ drop successors>> length 1 = ]
|
|
||||||
[ nip predecessors>> length 1 >= ]
|
|
||||||
} 2&& ; inline
|
|
||||||
|
|
||||||
: insert-position/join ( from to -- before after )
|
|
||||||
drop instructions>> dup pop 1array ;
|
|
||||||
|
|
||||||
: insert-position ( bb to -- before after )
|
|
||||||
{
|
|
||||||
{ [ 2dup fork? ] [ insert-position/fork ] }
|
|
||||||
{ [ 2dup join? ] [ insert-position/join ] }
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
: 3append-here ( seq2 seq1 seq3 -- )
|
|
||||||
#! Mutate seq1
|
|
||||||
swap '[ _ push-all ] bi@ ;
|
|
||||||
|
|
||||||
: perform-mappings ( mappings bb to -- )
|
|
||||||
pick empty? [ 3drop ] [
|
|
||||||
[ mapping-instructions ] 2dip
|
|
||||||
insert-position 3append-here
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: resolve-edge-data-flow ( bb to -- )
|
: resolve-edge-data-flow ( bb to -- )
|
||||||
[ compute-mappings ] [ perform-mappings ] 2bi ;
|
2dup compute-mappings perform-mappings ;
|
||||||
|
|
||||||
: resolve-block-data-flow ( bb -- )
|
: resolve-block-data-flow ( bb -- )
|
||||||
dup successors>> [ resolve-edge-data-flow ] with each ;
|
dup successors>> [ resolve-edge-data-flow ] with each ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
USING: accessors arrays compiler.cfg.checker
|
USING: accessors arrays compiler.cfg.checker
|
||||||
compiler.cfg.debugger compiler.cfg.def-use
|
compiler.cfg.debugger compiler.cfg.def-use
|
||||||
compiler.cfg.instructions fry kernel kernel.private math
|
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 ;
|
slots.private strings strings.private tools.test vectors layouts ;
|
||||||
IN: compiler.cfg.optimizer.tests
|
IN: compiler.cfg.optimizer.tests
|
||||||
|
|
||||||
! Miscellaneous tests
|
! Miscellaneous tests
|
||||||
|
@ -31,6 +31,19 @@ IN: compiler.cfg.optimizer.tests
|
||||||
[ [ 2 fixnum+ ] when 3 ]
|
[ [ 2 fixnum+ ] when 3 ]
|
||||||
[ [ 2 fixnum- ] when 3 ]
|
[ [ 2 fixnum- ] when 3 ]
|
||||||
[ 10000 [ ] times ]
|
[ 10000 [ ] times ]
|
||||||
|
[
|
||||||
|
over integer? [
|
||||||
|
over dup 16 <-integer-fixnum
|
||||||
|
[ 0 >=-integer-fixnum ] [ drop f ] if [
|
||||||
|
nip dup
|
||||||
|
[ ] [ ] if
|
||||||
|
] [ 2drop f ] if
|
||||||
|
] [ 2drop f ] if
|
||||||
|
]
|
||||||
|
[
|
||||||
|
pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
|
||||||
|
set-string-nth-fast
|
||||||
|
]
|
||||||
} [
|
} [
|
||||||
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
|
||||||
] each
|
] each
|
||||||
|
|
|
@ -29,10 +29,9 @@ SYMBOL: check-optimizer?
|
||||||
! The passes that need this document it.
|
! The passes that need this document it.
|
||||||
[
|
[
|
||||||
optimize-tail-calls
|
optimize-tail-calls
|
||||||
compute-predecessors
|
|
||||||
delete-useless-conditionals
|
delete-useless-conditionals
|
||||||
split-branches
|
|
||||||
compute-predecessors
|
compute-predecessors
|
||||||
|
split-branches
|
||||||
stack-analysis
|
stack-analysis
|
||||||
compute-liveness
|
compute-liveness
|
||||||
alias-analysis
|
alias-analysis
|
||||||
|
|
|
@ -35,6 +35,12 @@ test-diamond
|
||||||
|
|
||||||
[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
|
[ ] [ 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 1 } ]
|
||||||
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
|
[ 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
|
[ 2 ] [ 4 get instructions>> length ] unit-test
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs fry kernel sequences
|
USING: accessors assocs fry kernel sequences namespaces
|
||||||
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
|
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
|
||||||
|
compiler.cfg.utilities ;
|
||||||
IN: compiler.cfg.phi-elimination
|
IN: compiler.cfg.phi-elimination
|
||||||
|
|
||||||
: insert-copy ( predecessor input output -- )
|
: insert-copy ( predecessor input output -- )
|
||||||
|
@ -11,7 +12,11 @@ IN: compiler.cfg.phi-elimination
|
||||||
[ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
|
[ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
|
||||||
|
|
||||||
: eliminate-phi-step ( bb -- )
|
: 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' )
|
: eliminate-phis ( cfg -- cfg' )
|
||||||
dup [ eliminate-phi-step ] each-basic-block ;
|
dup [ eliminate-phi-step ] each-basic-block
|
||||||
|
cfg-changed ;
|
|
@ -55,6 +55,12 @@ M: ##string-nth rename-insn-uses
|
||||||
[ rename-value ] change-index
|
[ rename-value ] change-index
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
|
M: ##set-string-nth-fast rename-insn-uses
|
||||||
|
dup call-next-method
|
||||||
|
[ rename-value ] change-obj
|
||||||
|
[ rename-value ] change-index
|
||||||
|
drop ;
|
||||||
|
|
||||||
M: ##set-slot-imm rename-insn-uses
|
M: ##set-slot-imm rename-insn-uses
|
||||||
dup call-next-method
|
dup call-next-method
|
||||||
[ rename-value ] change-obj
|
[ rename-value ] change-obj
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
IN: compiler.cfg.stack-analysis.merge.tests
|
IN: compiler.cfg.stack-analysis.merge.tests
|
||||||
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
|
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
|
||||||
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||||
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
|
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
|
||||||
cpu.architecture make assocs
|
compiler.cfg.debugger cpu.architecture make assocs namespaces
|
||||||
sequences kernel classes ;
|
sequences kernel classes ;
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -11,13 +11,15 @@ sequences kernel classes ;
|
||||||
] [
|
] [
|
||||||
<state>
|
<state>
|
||||||
|
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions
|
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
<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 0 } } >>locs>vregs
|
||||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
<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
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -26,15 +28,16 @@ sequences kernel classes ;
|
||||||
] [
|
] [
|
||||||
<state>
|
<state>
|
||||||
|
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions
|
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||||
|
|
||||||
[
|
<state>
|
||||||
<state>
|
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
||||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
|
||||||
|
|
||||||
[ merge-locs locs>vregs>> keys ] { } make drop
|
H{ } clone added-instructions set
|
||||||
] keep first instructions>> first class
|
V{ } clone added-phis set
|
||||||
|
[ merge-locs locs>vregs>> keys ] { } make drop
|
||||||
|
1 get added-instructions get at first class
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -42,15 +45,17 @@ sequences kernel classes ;
|
||||||
] [
|
] [
|
||||||
<state>
|
<state>
|
||||||
|
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions
|
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
|
||||||
|
|
||||||
[
|
H{ } clone added-instructions set
|
||||||
<state> -1 >>ds-height
|
V{ } clone added-phis set
|
||||||
<state> 2array
|
|
||||||
|
|
||||||
[ merge-ds-heights ds-height>> ] { } make drop
|
<state> -1 >>ds-height
|
||||||
] keep first instructions>> first class
|
<state> 2array
|
||||||
|
|
||||||
|
[ merge-ds-heights ds-height>> ] { } make drop
|
||||||
|
1 get added-instructions get at first class
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -63,6 +68,9 @@ sequences kernel classes ;
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions
|
<basic-block> V{ T{ ##branch } } >>instructions
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
<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 0 } } >>locs>vregs
|
||||||
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
|
<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
|
||||||
<basic-block> V{ T{ ##branch } } >>instructions 2array
|
<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 0 } } >>locs>vregs
|
||||||
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
|
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel assocs sequences accessors fry combinators grouping
|
USING: kernel assocs sequences accessors fry combinators grouping sets
|
||||||
sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
|
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
|
||||||
compiler.cfg.stack-analysis.state ;
|
compiler.cfg.instructions compiler.cfg.stack-analysis.state
|
||||||
|
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
|
||||||
IN: compiler.cfg.stack-analysis.merge
|
IN: compiler.cfg.stack-analysis.merge
|
||||||
|
|
||||||
! XXX critical edges
|
|
||||||
|
|
||||||
: initial-state ( bb states -- state ) 2drop <state> ;
|
: initial-state ( bb states -- state ) 2drop <state> ;
|
||||||
|
|
||||||
: single-predecessor ( bb states -- state ) nip first clone ;
|
: single-predecessor ( bb states -- state ) nip first clone ;
|
||||||
|
@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
|
||||||
[ nip first >>rs-height ]
|
[ nip first >>rs-height ]
|
||||||
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
|
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
|
||||||
|
|
||||||
: assoc-map-values ( assoc quot -- assoc' )
|
: assoc-map-keys ( assoc quot -- assoc' )
|
||||||
'[ _ dip ] assoc-map ; inline
|
'[ _ dip ] assoc-map ; inline
|
||||||
|
|
||||||
: translate-locs ( assoc state -- assoc' )
|
: translate-locs ( assoc state -- assoc' )
|
||||||
'[ _ translate-loc ] assoc-map-values ;
|
'[ _ translate-loc ] assoc-map-keys ;
|
||||||
|
|
||||||
: untranslate-locs ( assoc state -- assoc' )
|
: untranslate-locs ( assoc state -- assoc' )
|
||||||
'[ _ untranslate-loc ] assoc-map-values ;
|
'[ _ untranslate-loc ] assoc-map-keys ;
|
||||||
|
|
||||||
: collect-locs ( loc-maps states -- assoc )
|
: collect-locs ( loc-maps states -- assoc )
|
||||||
! assoc maps locs to sequences
|
! assoc maps locs to sequences
|
||||||
|
@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
|
||||||
: insert-peek ( predecessor loc state -- vreg )
|
: insert-peek ( predecessor loc state -- vreg )
|
||||||
'[ _ _ translate-loc ^^peek ] add-instructions ;
|
'[ _ _ 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 )
|
: merge-loc ( predecessors vregs loc state -- vreg )
|
||||||
! Insert a ##phi in the current block where the input
|
! Insert a ##phi in the current block where the input
|
||||||
! is the vreg storing loc from each predecessor block
|
! is the vreg storing loc from each predecessor block
|
||||||
[ dup ] 3dip
|
|
||||||
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
|
'[ [ ] [ _ _ 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 )
|
:: merge-locs ( state predecessors states -- state )
|
||||||
states [ locs>vregs>> ] map states collect-locs
|
states [ locs>vregs>> ] map states collect-locs
|
||||||
|
@ -77,30 +80,35 @@ IN: compiler.cfg.stack-analysis.merge
|
||||||
over translate-locs
|
over translate-locs
|
||||||
>>changed-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 )
|
:: multiple-predecessors ( bb states -- state )
|
||||||
dup [ not ] any? [
|
states [ not ] any? [
|
||||||
2drop <state>
|
<state>
|
||||||
] [
|
] [
|
||||||
dup [ poisoned?>> ] any? [
|
[
|
||||||
cannot-merge-poisoned
|
H{ } clone added-instructions set
|
||||||
] [
|
V{ } clone added-phis set
|
||||||
[ state new ] 2dip
|
bb predecessors>> :> predecessors
|
||||||
[ predecessors>> ] dip
|
state new
|
||||||
{
|
predecessors states merge-ds-heights
|
||||||
[ merge-ds-heights ]
|
predecessors states merge-rs-heights
|
||||||
[ merge-rs-heights ]
|
predecessors states merge-locs
|
||||||
[ merge-locs ]
|
states merge-actual-locs
|
||||||
[ nip merge-actual-locs ]
|
states merge-changed-locs
|
||||||
[ nip merge-changed-locs ]
|
bb insert-basic-blocks
|
||||||
} 2cleave
|
bb insert-phis
|
||||||
] if
|
] with-scope
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: merge-states ( bb states -- state )
|
: merge-states ( bb states -- state )
|
||||||
! If any states are poisoned, save all registers
|
|
||||||
! to the stack in each branch
|
|
||||||
dup length {
|
dup length {
|
||||||
{ 0 [ initial-state ] }
|
{ 0 [ initial-state ] }
|
||||||
{ 1 [ single-predecessor ] }
|
{ 1 [ single-predecessor ] }
|
||||||
|
|
|
@ -99,7 +99,7 @@ IN: compiler.cfg.stack-analysis.tests
|
||||||
! Correct height tracking
|
! Correct height tracking
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
|
[ 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*
|
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
|
||||||
2array { D 1 D 0 } set=
|
2array { D 1 D 0 } set=
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
|
||||||
stack-analysis
|
stack-analysis
|
||||||
drop
|
drop
|
||||||
|
|
||||||
3 get instructions>> second loc>>
|
3 get successors>> first instructions>> first loc>>
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Do inserted ##peeks reference the correct stack location if
|
! Do inserted ##peeks reference the correct stack location if
|
||||||
|
@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
|
||||||
stack-analysis
|
stack-analysis
|
||||||
drop
|
drop
|
||||||
|
|
||||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
! Missing ##replace
|
! Missing ##replace
|
||||||
|
@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
|
||||||
! Inserted ##peeks reference the wrong stack location
|
! Inserted ##peeks reference the wrong stack location
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
|
[ [ "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
|
instructions>> [ ##peek? ] filter [ loc>> ] map
|
||||||
{ R 0 D 0 D 1 } set=
|
{ D 0 D 1 } set=
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ D 0 ] [
|
[ D 0 ] [
|
||||||
|
@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
|
||||||
stack-analysis
|
stack-analysis
|
||||||
drop
|
drop
|
||||||
|
|
||||||
3 get instructions>> [ ##peek? ] find nip loc>>
|
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
|
||||||
] unit-test
|
] unit-test
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2009 Slava Pestov.
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs kernel namespaces math sequences fry grouping
|
USING: accessors assocs kernel namespaces math sequences fry grouping
|
||||||
sets make combinators
|
sets make combinators dlists deques
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
compiler.cfg.copy-prop
|
compiler.cfg.copy-prop
|
||||||
compiler.cfg.def-use
|
compiler.cfg.def-use
|
||||||
|
@ -10,9 +10,14 @@ compiler.cfg.registers
|
||||||
compiler.cfg.rpo
|
compiler.cfg.rpo
|
||||||
compiler.cfg.hats
|
compiler.cfg.hats
|
||||||
compiler.cfg.stack-analysis.state
|
compiler.cfg.stack-analysis.state
|
||||||
compiler.cfg.stack-analysis.merge ;
|
compiler.cfg.stack-analysis.merge
|
||||||
|
compiler.cfg.utilities ;
|
||||||
IN: compiler.cfg.stack-analysis
|
IN: compiler.cfg.stack-analysis
|
||||||
|
|
||||||
|
SYMBOL: work-list
|
||||||
|
|
||||||
|
: add-to-work-list ( bb -- ) work-list get push-front ;
|
||||||
|
|
||||||
: redundant-replace? ( vreg loc -- ? )
|
: redundant-replace? ( vreg loc -- ? )
|
||||||
dup state get untranslate-loc n>> 0 <
|
dup state get untranslate-loc n>> 0 <
|
||||||
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
|
||||||
|
@ -137,10 +142,21 @@ SYMBOLS: state-in state-out ;
|
||||||
] 2bi
|
] 2bi
|
||||||
] V{ } make >>instructions drop ;
|
] 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' )
|
: stack-analysis ( cfg -- cfg' )
|
||||||
[
|
[
|
||||||
|
<hashed-dlist> work-list set
|
||||||
H{ } clone copies set
|
H{ } clone copies set
|
||||||
H{ } clone state-in set
|
H{ } clone state-in set
|
||||||
H{ } clone state-out 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 ;
|
] with-scope ;
|
||||||
|
|
|
@ -5,7 +5,8 @@ namespaces sequences fry combinators
|
||||||
compiler.cfg
|
compiler.cfg
|
||||||
compiler.cfg.rpo
|
compiler.cfg.rpo
|
||||||
compiler.cfg.hats
|
compiler.cfg.hats
|
||||||
compiler.cfg.instructions ;
|
compiler.cfg.instructions
|
||||||
|
compiler.cfg.utilities ;
|
||||||
IN: compiler.cfg.tco
|
IN: compiler.cfg.tco
|
||||||
|
|
||||||
! Tail call optimization. You must run compute-predecessors after this
|
! 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' )
|
: optimize-tail-calls ( cfg -- cfg' )
|
||||||
dup cfg set
|
dup cfg set
|
||||||
dup [ optimize-tail-call ] each-basic-block
|
dup [ optimize-tail-call ] each-basic-block
|
||||||
f >>post-order ;
|
cfg-changed ;
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors sequences math combinators combinators.short-circuit
|
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
|
IN: compiler.cfg.useless-conditionals
|
||||||
|
|
||||||
: delete-conditional? ( bb -- ? )
|
: delete-conditional? ( bb -- ? )
|
||||||
|
@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
|
||||||
dup [
|
dup [
|
||||||
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
dup delete-conditional? [ delete-conditional ] [ drop ] if
|
||||||
] each-basic-block
|
] 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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel math layouts make sequences combinators
|
USING: accessors assocs combinators combinators.short-circuit
|
||||||
cpu.architecture namespaces compiler.cfg
|
compiler.cfg compiler.cfg.instructions cpu.architecture kernel
|
||||||
compiler.cfg.instructions ;
|
layouts locals make math namespaces sequences sets vectors fry ;
|
||||||
IN: compiler.cfg.utilities
|
IN: compiler.cfg.utilities
|
||||||
|
|
||||||
: value-info-small-fixnum? ( value-info -- ? )
|
: value-info-small-fixnum? ( value-info -- ? )
|
||||||
|
@ -33,7 +33,53 @@ IN: compiler.cfg.utilities
|
||||||
building off
|
building off
|
||||||
basic-block off ;
|
basic-block off ;
|
||||||
|
|
||||||
: stop-iterating ( -- next ) end-basic-block f ;
|
|
||||||
|
|
||||||
: emit-primitive ( node -- )
|
: emit-primitive ( node -- )
|
||||||
word>> ##call ##branch begin-basic-block ;
|
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 ;
|
||||||
|
|
||||||
|
: <simple-block> ( insns -- bb )
|
||||||
|
<basic-block>
|
||||||
|
swap >vector
|
||||||
|
\ ##branch new-insn over push
|
||||||
|
>>instructions ;
|
||||||
|
|
||||||
|
: insert-basic-blocks ( bb -- )
|
||||||
|
[ added-instructions get ] dip
|
||||||
|
'[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
|
||||||
|
|
|
@ -77,13 +77,19 @@ M: ##compare-imm-branch rewrite
|
||||||
insn cc>> swap? [ swap-cc ] when
|
insn cc>> swap? [ swap-cc ] when
|
||||||
i \ ##compare-imm new-insn ; inline
|
i \ ##compare-imm new-insn ; inline
|
||||||
|
|
||||||
! M: ##compare rewrite
|
: vreg-small-constant? ( vreg -- ? )
|
||||||
! dup [ src1>> ] [ src2>> ] bi
|
vreg>expr {
|
||||||
! [ vreg>expr constant-expr? ] bi@ 2array {
|
[ constant-expr? ]
|
||||||
! { { f t } [ f >compare-imm ] }
|
[ value>> small-enough? ]
|
||||||
! { { t f } [ t >compare-imm ] }
|
} 1&& ;
|
||||||
! [ drop ]
|
|
||||||
! } case ;
|
M: ##compare rewrite
|
||||||
|
dup [ src1>> ] [ src2>> ] bi
|
||||||
|
[ vreg-small-constant? ] bi@ 2array {
|
||||||
|
{ { f t } [ f >compare-imm ] }
|
||||||
|
{ { t f } [ t >compare-imm ] }
|
||||||
|
[ drop ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
:: >compare-imm-branch ( insn swap? -- insn' )
|
:: >compare-imm-branch ( insn swap? -- insn' )
|
||||||
insn src1>>
|
insn src1>>
|
||||||
|
@ -91,13 +97,13 @@ M: ##compare-imm-branch rewrite
|
||||||
insn cc>> swap? [ swap-cc ] when
|
insn cc>> swap? [ swap-cc ] when
|
||||||
\ ##compare-imm-branch new-insn ; inline
|
\ ##compare-imm-branch new-insn ; inline
|
||||||
|
|
||||||
! M: ##compare-branch rewrite
|
M: ##compare-branch rewrite
|
||||||
! dup [ src1>> ] [ src2>> ] bi
|
dup [ src1>> ] [ src2>> ] bi
|
||||||
! [ vreg>expr constant-expr? ] bi@ 2array {
|
[ vreg-small-constant? ] bi@ 2array {
|
||||||
! { { f t } [ f >compare-imm-branch ] }
|
{ { f t } [ f >compare-imm-branch ] }
|
||||||
! { { t f } [ t >compare-imm-branch ] }
|
{ { t f } [ t >compare-imm-branch ] }
|
||||||
! [ drop ]
|
[ drop ]
|
||||||
! } case ;
|
} case ;
|
||||||
|
|
||||||
: rewrite-redundant-comparison? ( insn -- ? )
|
: rewrite-redundant-comparison? ( insn -- ? )
|
||||||
{
|
{
|
||||||
|
@ -198,10 +204,7 @@ M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
|
||||||
M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
|
M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
|
||||||
|
|
||||||
: rewrite-add? ( insn -- ? )
|
: rewrite-add? ( insn -- ? )
|
||||||
src2>> {
|
src2>> vreg-small-constant? ;
|
||||||
[ vreg>expr constant-expr? ]
|
|
||||||
[ vreg>constant small-enough? ]
|
|
||||||
} 1&& ;
|
|
||||||
|
|
||||||
M: ##add rewrite
|
M: ##add rewrite
|
||||||
dup rewrite-add? [
|
dup rewrite-add? [
|
||||||
|
|
|
@ -26,7 +26,7 @@ HELP: assoc>query
|
||||||
"USING: io urls.encoding ;"
|
"USING: io urls.encoding ;"
|
||||||
"{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
|
"{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
|
||||||
"assoc>query print"
|
"assoc>query print"
|
||||||
"from=Lead&to=Gold%2c%20please"
|
"from=Lead&to=Gold%2C%20please"
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
|
@ -290,4 +290,7 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
|
||||||
USE: make
|
USE: make
|
||||||
|
|
||||||
[ { "a" 1 "b" 1 "c" } ]
|
[ { "a" 1 "b" 1 "c" } ]
|
||||||
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
|
[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ 0 array-capacity? ] unit-test
|
||||||
|
[ f ] [ -1 array-capacity? ] unit-test
|
|
@ -76,7 +76,7 @@ HELP: count
|
||||||
|
|
||||||
HELP: create-collection
|
HELP: create-collection
|
||||||
{ $values
|
{ $values
|
||||||
{ "name" "collection name" }
|
{ "name/collection" "collection name" }
|
||||||
}
|
}
|
||||||
{ $description "Creates a new collection with the given name." } ;
|
{ $description "Creates a new collection with the given name." } ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue