steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-08-02 10:39:59 -05:00
parent de5a42c9f7 ba55633b19
commit 5f6eb8f068
40 changed files with 520 additions and 621 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/bootstrap/compiler/compiler.factor
View File

@ -94,6 +94,7 @@ nl
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
like clone-like
} compile-unoptimized
"." write flush

16
basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
View File

@ -46,11 +46,11 @@ V{ T{ ##branch } } 4 test-bb
V{ T{ ##branch } } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
0 { 1 2 } edges
1 get 3 get 4 get V{ } 2sequence >>successors drop
1 { 3 4 } edges
2 get 3 get 4 get V{ } 2sequence >>successors drop
2 { 3 4 } edges
[ ] [ test-branch-splitting ] unit-test
@ -64,11 +64,11 @@ V{ T{ ##branch } } 3 test-bb
V{ T{ ##branch } } 4 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
0 { 1 2 } edges
1 get 3 get 4 get V{ } 2sequence >>successors drop
1 { 3 4 } edges
2 get 4 get 1vector >>successors drop
2 4 edge
[ ] [ test-branch-splitting ] unit-test
@ -78,8 +78,8 @@ V{ T{ ##branch } } 1 test-bb
V{ T{ ##branch } } 2 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
0 { 1 2 } edges
1 get 2 get 1vector >>successors drop
1 2 edge
[ ] [ test-branch-splitting ] unit-test

37
basis/compiler/cfg/critical-edges/critical-edges-tests.factor Normal file
View File

@ -0,0 +1,37 @@
USING: accessors assocs compiler.cfg
compiler.cfg.critical-edges compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.predecessors
compiler.cfg.registers cpu.architecture kernel namespaces
sequences tools.test compiler.cfg.utilities ;
IN: compiler.cfg.critical-edges.tests
! Make sure we update phi nodes when splitting critical edges
: test-critical-edges ( -- )
cfg new 0 get >>entry
compute-predecessors
split-critical-edges ;
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 1 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##phi f V int-regs 2 H{ { 0 V int-regs 0 } { 1 V int-regs 1 } } }
T{ ##return }
} 2 test-bb
0 { 1 2 } edges
1 2 edge
[ ] [ test-critical-edges ] unit-test
[ t ] [ 0 get successors>> second successors>> first 2 get eq? ] unit-test
[ V int-regs 0 ] [ 2 get instructions>> first inputs>> 0 get successors>> second swap at ] unit-test

12
basis/compiler/cfg/critical-edges/critical-edges.factor
View File

@ -1,14 +1,22 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences
USING: kernel math accessors sequences locals assocs fry
compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
IN: compiler.cfg.critical-edges
: critical-edge? ( from to -- ? )
[ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
: new-key ( new-key old-key assoc -- )
[ delete-at* ] keep '[ swap _ set-at ] [ 2drop ] if ;
:: update-phis ( from to bb -- )
! Any phi nodes in 'to' which reference 'from'
! should now reference 'bb'.
to [ [ bb from ] dip inputs>> new-key ] each-phi ;
: split-critical-edge ( from to -- )
f <simple-block> insert-basic-block ;
f <simple-block> [ insert-basic-block ] [ update-phis ] 3bi ;
: split-critical-edges ( cfg -- )
dup [

28
basis/compiler/cfg/debugger/debugger.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config
classes.tuple accessors prettyprint prettyprint.config assocs
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer
compiler.cfg.mr compiler.cfg ;
compiler.cfg.optimizer compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -52,11 +52,23 @@ M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;
: resolve-phis ( bb -- )
[
[ [ [ get ] dip ] assoc-map ] change-inputs drop
] each-phi ;
: test-bb ( insns n -- )
[ <basic-block> swap >>number swap >>instructions ] keep set ;
[ <basic-block> swap >>number swap >>instructions dup ] keep set
resolve-phis ;
: edge ( from to -- )
[ get ] bi@ 1vector >>successors drop ;
: edges ( from tos -- )
[ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
: test-diamond ( -- )
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
4 get 1vector 2 get (>>successors)
4 get 1vector 3 get (>>successors) ;
0 1 edge
1 { 2 3 } edges
2 4 edge
3 4 edge ;

32
basis/compiler/cfg/dominance/dominance-tests.factor
View File

@ -16,11 +16,11 @@ 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 1vector >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
0 { 1 2 } edges
1 3 edge
2 4 edge
3 4 edge
4 5 edge
[ ] [ test-dominance ] unit-test
@ -46,11 +46,11 @@ 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 1vector >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 3 get 1vector >>successors drop
0 { 1 2 } edges
1 3 edge
2 4 edge
3 4 edge
4 3 edge
[ ] [ test-dominance ] unit-test
@ -64,12 +64,12 @@ V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 5 get 1vector >>successors drop
2 get 4 get 3 get V{ } 2sequence >>successors drop
5 get 4 get 1vector >>successors drop
4 get 5 get 3 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
0 { 1 2 } edges
1 5 edge
2 { 4 3 } edges
5 4 edge
4 { 5 3 } edges
3 4 edge
[ ] [ test-dominance ] unit-test

2
basis/compiler/cfg/gc-checks/gc-checks-tests.factor
View File

@ -19,7 +19,7 @@ V{
T{ ##box-float f V int-regs 0 V int-regs 1 }
} 1 test-bb
0 get 1 get 1vector >>successors drop
0 1 edge
[ ] [ test-gc-checks ] unit-test

64
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -1549,9 +1549,9 @@ V{
T{ ##return }
} 3 test-bb
1 get 1vector 0 get (>>successors)
2 get 3 get V{ } 2sequence 1 get (>>successors)
3 get 1vector 2 get (>>successors)
0 1 edge
1 { 2 3 } edges
2 3 edge
SYMBOL: linear-scan-result
@ -1564,9 +1564,7 @@ SYMBOL: linear-scan-result
flatten-cfg 1array mr.
] with-scope ;
! This test has a critical edge -- do we care about these?
! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
@ -1896,11 +1894,11 @@ V{
T{ ##return }
} 6 test-bb
0 get 1 get V{ } 1sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get V{ } 1sequence >>successors drop
3 get 4 get V{ } 1sequence >>successors drop
4 get 5 get 6 get V{ } 2sequence >>successors drop
0 1 edge
1 { 2 3 } edges
2 4 edge
3 4 edge
4 { 5 6 } edges
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
@ -1956,14 +1954,14 @@ V{
T{ ##return }
} 9 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 7 get V{ } 2sequence >>successors drop
7 get 8 get 1vector >>successors drop
8 get 9 get 1vector >>successors drop
2 get 3 get 5 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
4 get 9 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
0 1 edge
1 { 2 7 } edges
7 8 edge
8 9 edge
2 { 3 5 } edges
3 4 edge
4 9 edge
5 6 edge
[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
@ -2139,11 +2137,11 @@ V{
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 4 get V{ } 2sequence >>successors drop
2 get 3 get 1vector >>successors drop
3 get 5 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
0 1 edge
1 { 2 4 } edges
2 3 edge
3 5 edge
4 5 edge
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
@ -2286,12 +2284,12 @@ V{
T{ ##return }
} 6 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 5 get V{ } 2sequence >>successors drop
2 get 3 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
0 1 edge
1 { 2 5 } edges
2 3 edge
3 4 edge
4 6 edge
5 6 edge
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
@ -2419,8 +2417,8 @@ V{
T{ ##return }
} 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
0 1 edge
1 2 edge
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
@ -2444,7 +2442,7 @@ V{
T{ ##return }
} 2 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
0 { 1 2 } edges
[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test

7
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -26,10 +26,9 @@ SYMBOL: spill-temps
2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
[
dup live-in keys
[ resolve-value-data-flow ] with with each
] { } make ;
dup live-in dup assoc-empty? [ 3drop f ] [
[ keys [ resolve-value-data-flow ] with with each ] { } make
] if ;
: memory->register ( from to -- )
swap [ first2 ] [ first n>> ] bi* _reload ;

4
basis/compiler/cfg/liveness/liveness-tests.factor
View File

@ -29,7 +29,7 @@ V{
T{ ##return }
} 3 test-bb
1 get 2 get 3 get V{ } 2sequence >>successors drop
1 { 2 3 } edges
test-liveness
@ -55,7 +55,7 @@ V{
T{ ##return }
} 2 test-bb
1 get 2 get 1vector >>successors drop
1 2 edge
test-liveness

10
basis/compiler/cfg/liveness/ssa/ssa.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo compiler.cfg.liveness ;
compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities ;
IN: compiler.cfg.liveness.ssa
! TODO: merge with compiler.cfg.liveness
@ -22,11 +22,9 @@ SYMBOL: work-list
[ live-out ] keep instructions>> transfer-liveness ;
: compute-phi-live-in ( basic-block -- phi-live-in )
instructions>> [ ##phi? ] filter [ f ] [
H{ } clone [
'[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
] keep
] if-empty ;
H{ } clone [
'[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
] keep ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]

6
basis/compiler/cfg/predecessors/predecessors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
compiler.cfg.instructions ;
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.predecessors
: update-predecessors ( bb -- )
@ -14,9 +14,7 @@ IN: compiler.cfg.predecessors
] change-inputs drop ;
: update-phis ( bb -- )
dup instructions>> [
dup ##phi? [ update-phi ] [ 2drop ] if
] with each ;
dup [ update-phi ] with each-phi ;
: compute-predecessors ( cfg -- cfg' )
{

18
basis/compiler/cfg/ssa/construction/construction-tests.factor
View File

@ -34,9 +34,9 @@ V{
T{ ##return }
} 3 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
0 { 1 2 } edges
1 3 edge
2 3 edge
: test-ssa ( -- )
cfg new 0 get >>entry
@ -93,12 +93,12 @@ V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
0 get 1 get 5 get V{ } 2sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
0 { 1 5 } edges
1 { 2 3 } edges
2 4 edge
3 4 edge
4 6 edge
5 6 edge
[ ] [ test-ssa ] unit-test

36
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor
View File

@ -17,11 +17,11 @@ 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 1vector >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
0 { 1 2 } edges
1 3 edge
2 4 edge
3 4 edge
4 5 edge
[ ] [ test-tdmsc ] unit-test
@ -38,12 +38,12 @@ V{ } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
0 get 1 get 5 get V{ } 2sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
0 { 1 5 } edges
1 { 2 3 } edges
2 4 edge
3 4 edge
4 6 edge
5 6 edge
[ ] [ test-tdmsc ] unit-test
@ -61,13 +61,13 @@ V{ } 5 test-bb
V{ } 6 test-bb
V{ } 7 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
2 get 3 get 6 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
6 get 7 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
5 get 2 get 1vector >>successors drop
0 1 edge
1 2 edge
2 { 3 6 } edges
3 4 edge
6 7 edge
4 5 edge
5 2 edge
[ ] [ test-tdmsc ] unit-test

21
basis/compiler/cfg/ssa/cssa/cssa.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel locals
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.utilities
compiler.cfg.instructions ;
IN: compiler.cfg.ssa.cssa
! Convert SSA to conventional SSA.
:: insert-copy ( bb src -- bb dst )
i :> dst
bb [ dst src ##copy ] add-instructions
bb dst ;
: convert-phi ( ##phi -- )
[ [ insert-copy ] assoc-map ] change-inputs drop ;
: construct-cssa ( cfg -- )
[ [ convert-phi ] each-phi ] each-basic-block ;

28
basis/compiler/cfg/ssa/destruction/copies/copies.factor
View File

@ -1,28 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs hashtables fry kernel make namespaces sets
sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
IN: compiler.cfg.ssa.destruction.copies
ERROR: bad-copy ;
: compute-copies ( assoc -- assoc' )
dup assoc-size <hashtable> [
'[
prune [
2dup eq? [ 2drop ] [
_ 2dup key?
[ bad-copy ] [ set-at ] if
] if
] with each
] assoc-each
] keep ;
: insert-copies ( -- )
waiting get [
[ instructions>> building ] dip '[
building get pop
_ compute-copies parallel-copy
,
] with-variable
] assoc-each ;

129
basis/compiler/cfg/ssa/destruction/destruction.factor
View File

@ -1,63 +1,104 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel locals math math.order
sequences namespaces sets
USING: accessors arrays assocs fry kernel namespaces
sequences sequences.deep
sets vectors
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.renaming
compiler.cfg.dominance
compiler.cfg.instructions
compiler.cfg.liveness.ssa
compiler.cfg.critical-edges
compiler.cfg.ssa.destruction.state
compiler.cfg.ssa.destruction.forest
compiler.cfg.ssa.destruction.copies
compiler.cfg.ssa.destruction.renaming
compiler.cfg.ssa.destruction.live-ranges
compiler.cfg.ssa.destruction.process-blocks ;
compiler.cfg.ssa.cssa
compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges
compiler.utilities ;
IN: compiler.cfg.ssa.destruction
! Based on "Fast Copy Coalescing and Live-Range Identification"
! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
! Maps vregs to leaders.
SYMBOL: leader-map
! Dominance, liveness and def-use need to be computed
: leader ( vreg -- vreg' ) leader-map get compress-path ;
: process-blocks ( cfg -- )
[ [ process-block ] if-has-phis ] each-basic-block ;
! Maps leaders to equivalence class elements.
SYMBOL: class-element-map
SYMBOL: seen
: class-elements ( vreg -- elts ) class-element-map get at ;
:: visit-renaming ( dst assoc src bb -- )
src seen get key? [
src dst bb add-waiting
src assoc delete-at
] [ src seen get conjoin ] if ;
! Sequence of vreg pairs
SYMBOL: copies
:: break-interferences ( -- )
V{ } clone seen set
renaming-sets get [| dst assoc |
assoc [| src bb |
dst assoc src bb visit-renaming
] assoc-each
: init-coalescing ( -- )
H{ } clone leader-map set
H{ } clone class-element-map set
V{ } clone copies set ;
: classes-interfere? ( vreg1 vreg2 -- ? )
[ leader ] bi@ 2dup eq? [ 2drop f ] [
[ class-elements flatten ] bi@ sets-interfere?
] if ;
: update-leaders ( vreg1 vreg2 -- )
swap leader-map get set-at ;
: merge-classes ( vreg1 vreg2 -- )
[ [ class-elements ] bi@ push ]
[ drop class-element-map get delete-at ] 2bi ;
: eliminate-copy ( vreg1 vreg2 -- )
[ leader ] bi@
2dup eq? [ 2drop ] [
[ update-leaders ] [ merge-classes ] 2bi
] if ;
: introduce-vreg ( vreg -- )
[ leader-map get conjoin ]
[ [ 1vector ] keep class-element-map get set-at ] bi ;
GENERIC: prepare-insn ( insn -- )
M: ##copy prepare-insn
[ dst>> ] [ src>> ] bi 2array copies get push ;
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ eliminate-copy ] with each ;
M: insn prepare-insn drop ;
: prepare-block ( bb -- )
instructions>> [ prepare-insn ] each ;
: prepare-coalescing ( cfg -- )
init-coalescing
defs get keys [ introduce-vreg ] each
[ prepare-block ] each-basic-block ;
: process-copies ( -- )
copies get [
2dup classes-interfere?
[ 2drop ] [ eliminate-copy ] if
] assoc-each ;
: remove-phis-from-block ( bb -- )
instructions>> [ ##phi? not ] filter-here ;
: useless-copy? ( ##copy -- ? )
dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
: remove-phis ( cfg -- )
[ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
: perform-renaming ( cfg -- )
leader-map get keys [ dup leader ] H{ } map>assoc renamings set
[
instructions>> [
[ rename-insn-defs ]
[ rename-insn-uses ]
[ [ useless-copy? ] [ ##phi? ] bi or not ] tri
] filter-here
] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
dup cfg-has-phis? [
init-coalescing
compute-ssa-live-sets
dup split-critical-edges
dup compute-def-use
dup compute-dominance
dup compute-live-ranges
dup process-blocks
break-interferences
dup perform-renaming
insert-copies
dup remove-phis
] when ;
dup construct-cssa
compute-ssa-live-sets
dup compute-defs
dup compute-dominance
dup compute-live-ranges
dup prepare-coalescing
process-copies
dup perform-renaming ;

86
basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor
View File

@ -1,86 +0,0 @@
USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest
compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
cpu.architecture kernel namespaces sequences tools.test vectors sorting
math.order ;
IN: compiler.cfg.ssa.destruction.forest.tests
V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
2 get 3 get 4 get V{ } 2sequence >>successors drop
3 get 5 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
1 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
: clean-up-forest ( forest -- forest' )
[ [ vreg>> n>> ] compare ] sort
[
[ clean-up-forest ] change-children
[ number>> ] change-bb
] V{ } map-as ;
: test-dom-forest ( vregs -- forest )
cfg new 0 get >>entry
compute-predecessors
dup compute-dominance
compute-def-use
compute-dom-forest
clean-up-forest ;
[ V{ } ] [ { } test-dom-forest ] unit-test
[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
[ { V int-regs 0 } test-dom-forest ]
unit-test
[
V{
T{ dom-forest-node
f
V int-regs 0
0
V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
}
}
]
[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
unit-test
[
V{
T{ dom-forest-node
f
V int-regs 1
1
V{ }
}
T{ dom-forest-node
f
V int-regs 2
2
V{
T{ dom-forest-node f V int-regs 3 3 V{ } }
T{ dom-forest-node f V int-regs 4 4 V{ } }
T{ dom-forest-node f V int-regs 5 5 V{ } }
}
}
T{ dom-forest-node
f
V int-regs 6
6
V{ }
}
}
]
[
{ V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
test-dom-forest
] unit-test

38
basis/compiler/cfg/ssa/destruction/forest/forest.factor
View File

@ -1,38 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel math math.order
namespaces sequences sorting vectors compiler.cfg.def-use
compiler.cfg.dominance compiler.cfg.registers ;
IN: compiler.cfg.ssa.destruction.forest
TUPLE: dom-forest-node vreg bb children ;
<PRIVATE
: sort-vregs-by-bb ( vregs -- alist )
defs get
'[ dup _ at ] { } map>assoc
[ [ second pre-of ] compare ] sort ;
: <dom-forest-node> ( vreg bb parent -- node )
[ V{ } clone dom-forest-node boa dup ] dip children>> push ;
: <virtual-root> ( -- node )
f f V{ } clone dom-forest-node boa ;
: find-parent ( pre stack -- parent )
2dup last vreg>> def-of maxpre-of > [
dup pop* find-parent
] [ nip last ] if ;
: (compute-dom-forest) ( vreg bb stack -- )
[ dup pre-of ] dip [ find-parent <dom-forest-node> ] keep push ;
PRIVATE>
: compute-dom-forest ( vregs -- forest )
<virtual-root> [
1vector
[ sort-vregs-by-bb ] dip
'[ _ (compute-dom-forest) ] assoc-each
] keep children>> ;

44
basis/compiler/cfg/ssa/destruction/interference/interference.factor
View File

@ -1,44 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
kernel math namespaces sequences locals compiler.cfg.def-use
compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ;
IN: compiler.cfg.ssa.destruction.interference
<PRIVATE
: kill-after-def? ( vreg1 vreg2 bb -- ? )
! If first register is used after second one is defined, they interfere.
! If they are used in the same instruction, no interference. If the
! instruction is a def-is-use-insn, then there will be a use at +1
! (instructions are 2 apart) and so outputs will interfere with
! inputs.
[ kill-index ] [ def-index ] bi-curry bi* > ;
: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
! If both are defined in the same basic block, they interfere if their
! local live ranges intersect.
drop
{ [ kill-after-def? ] [ swapd kill-after-def? ] } 3|| ;
: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
! If vreg1 dominates vreg2, then they interfere if vreg2's definition
! occurs before vreg1 is killed.
nip
kill-after-def? ;
: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
! If vreg2 dominates vreg1, then they interfere if vreg1's definition
! occurs before vreg2 is killed.
drop
swapd kill-after-def? ;
PRIVATE>
: interferes? ( vreg1 vreg2 -- ? )
2dup [ def-of ] bi@ {
{ [ 2dup eq? ] [ interferes-same-block? ] }
{ [ 2dup dominates? ] [ interferes-first-dominates? ] }
{ [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
[ 2drop 2drop f ]
} cond ;

138
basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor
View File

@ -1,138 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel locals math math.order arrays
namespaces sequences sorting sets combinators combinators.short-circuit make
compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.liveness.ssa
compiler.cfg.dominance
compiler.cfg.ssa.destruction.state
compiler.cfg.ssa.destruction.forest
compiler.cfg.ssa.destruction.interference ;
IN: compiler.cfg.ssa.destruction.process-blocks
! phi-union maps a vreg to the predecessor block
! that carries it to the phi node's block
! unioned-blocks is a set of bb's which defined
! the source vregs above
SYMBOLS: phi-union unioned-blocks ;
: operand-live-into-phi-node's-block? ( src dst -- ? )
def-of live-in? ;
: phi-node-is-live-out-of-operand's-block? ( src dst -- ? )
swap def-of live-out? ;
: operand-is-phi-node-and-live-into-operand's-block? ( src dst -- ? )
drop { [ insn-of ##phi? ] [ dup def-of live-in? ] } 1&& ;
: operand-being-renamed? ( src dst -- ? )
drop processed-names get key? ;
: two-operands-in-same-block? ( src dst -- ? )
drop def-of unioned-blocks get key? ;
: trivial-interference? ( src dst -- ? )
{
[ operand-live-into-phi-node's-block? ]
[ phi-node-is-live-out-of-operand's-block? ]
[ operand-is-phi-node-and-live-into-operand's-block? ]
[ operand-being-renamed? ]
[ two-operands-in-same-block? ]
} 2|| ;
: don't-coalesce ( bb src dst -- )
2nip processed-name ;
:: trivial-interference ( bb src dst -- )
dst src bb add-waiting
src used-by-another get push ;
:: add-to-renaming-set ( bb src dst -- )
bb src phi-union get set-at
src def-of unioned-blocks get conjoin ;
: process-phi-operand ( bb src dst -- )
{
{ [ 2dup eq? ] [ don't-coalesce ] }
{ [ 2dup trivial-interference? ] [ trivial-interference ] }
[ add-to-renaming-set ]
} cond ;
: node-is-live-in-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> ] bi* live-in? ;
: node-is-live-out-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> ] bi* live-out? ;
:: insert-copy ( bb src dst -- )
bb src dst trivial-interference
src phi-union get delete-at ;
:: insert-copy-for-parent ( bb src dst node -- )
src node vreg>> eq? [ bb src dst insert-copy ] when ;
: insert-copies-for-parent ( ##phi node child -- )
drop
[ [ inputs>> ] [ dst>> ] bi ] dip
'[ _ _ insert-copy-for-parent ] assoc-each ;
: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
: add-interference ( ##phi node child -- )
[ vreg>> ] bi@ 2array , drop ;
: process-df-child ( ##phi node child -- )
{
{ [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
{ [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
{ [ 2dup defined-in-same-block? ] [ add-interference ] }
[ 3drop ]
} cond ;
: process-df-node ( ##phi node -- )
dup children>>
[ [ process-df-child ] with with each ]
[ nip [ process-df-node ] with each ]
3bi ;
: process-phi-union ( ##phi dom-forest -- )
[ process-df-node ] with each ;
: add-local-interferences ( ##phi -- )
[ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
: compute-local-interferences ( ##phi -- pairs )
[
[ phi-union get keys compute-dom-forest process-phi-union ]
[ add-local-interferences ]
bi
] { } make ;
:: insert-copies-for-interference ( ##phi src -- )
##phi inputs>> [| bb src' |
src src' eq? [ bb src ##phi dst>> insert-copy ] when
] assoc-each ;
: process-local-interferences ( ##phi pairs -- )
[
first2 2dup interferes?
[ drop insert-copies-for-interference ] [ 3drop ] if
] with each ;
: add-renaming-set ( ##phi -- )
[ phi-union get ] dip dst>> renaming-sets get set-at
phi-union get [ drop processed-name ] assoc-each ;
: process-phi ( ##phi -- )
H{ } clone phi-union set
H{ } clone unioned-blocks set
[ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
[ dup compute-local-interferences process-local-interferences ]
[ add-renaming-set ]
tri ;
: process-block ( bb -- )
instructions>>
[ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;

47
basis/compiler/cfg/ssa/destruction/renaming/renaming.factor
View File

@ -1,47 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences
compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo
disjoint-sets ;
IN: compiler.cfg.ssa.destruction.renaming
: build-disjoint-set ( assoc -- disjoint-set )
<disjoint-set> dup [
'[
[ _ add-atom ]
[ [ drop _ add-atom ] assoc-each ]
bi*
] assoc-each
] keep ;
: update-congruence-class ( dst assoc disjoint-set -- )
[ keys swap ] dip equate-all-with ;
: build-congruence-classes ( -- disjoint-set )
renaming-sets get
dup build-disjoint-set
[ '[ _ update-congruence-class ] assoc-each ] keep ;
: compute-renaming ( disjoint-set -- assoc )
[ parents>> ] keep
'[ drop dup _ representative ] assoc-map ;
: rename-blocks ( cfg -- )
[
instructions>> [
[ rename-insn-defs ]
[ rename-insn-uses ] bi
] each
] each-basic-block ;
: rename-copies ( -- )
waiting renamings get '[
[
[ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map
] assoc-map
] change ;
: perform-renaming ( cfg -- )
build-congruence-classes compute-renaming renamings set
rename-blocks
rename-copies ;

18
basis/compiler/cfg/ssa/destruction/state/state.factor
View File

@ -1,18 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sets kernel assocs ;
IN: compiler.cfg.ssa.destruction.state
SYMBOLS: processed-names waiting used-by-another renaming-sets ;
: init-coalescing ( -- )
H{ } clone renaming-sets set
H{ } clone processed-names set
H{ } clone waiting set
V{ } clone used-by-another set ;
: processed-name ( vreg -- ) processed-names get conjoin ;
: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
: add-waiting ( dst src bb -- ) waiting-for push-at ;

52
basis/compiler/cfg/ssa/interference/interference-tests.factor Normal file
View File

@ -0,0 +1,52 @@
USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.def-use compiler.cfg.dominance
compiler.cfg.instructions compiler.cfg.liveness.ssa
compiler.cfg.registers compiler.cfg.predecessors
compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges cpu.architecture
kernel namespaces tools.test ;
IN: compiler.cfg.ssa.interference.tests
: test-interference ( -- )
cfg new 0 get >>entry
compute-ssa-live-sets
compute-predecessors
dup compute-defs
dup compute-dominance
compute-live-ranges ;
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 2 D 0 }
T{ ##copy f V int-regs 1 V int-regs 0 }
T{ ##copy f V int-regs 3 V int-regs 2 }
T{ ##branch }
} 0 test-bb
V{
T{ ##peek f V int-regs 4 D 0 }
T{ ##peek f V int-regs 5 D 0 }
T{ ##replace f V int-regs 3 D 0 }
T{ ##peek f V int-regs 6 D 0 }
T{ ##replace f V int-regs 5 D 0 }
T{ ##return }
} 1 test-bb
0 1 edge
[ ] [ test-interference ] unit-test
[ f ] [ V int-regs 0 V int-regs 1 vregs-interfere? ] unit-test
[ f ] [ V int-regs 1 V int-regs 0 vregs-interfere? ] unit-test
[ f ] [ V int-regs 2 V int-regs 3 vregs-interfere? ] unit-test
[ f ] [ V int-regs 3 V int-regs 2 vregs-interfere? ] unit-test
[ t ] [ V int-regs 0 V int-regs 2 vregs-interfere? ] unit-test
[ t ] [ V int-regs 2 V int-regs 0 vregs-interfere? ] unit-test
[ f ] [ V int-regs 1 V int-regs 3 vregs-interfere? ] unit-test
[ f ] [ V int-regs 3 V int-regs 1 vregs-interfere? ] unit-test
[ t ] [ V int-regs 3 V int-regs 4 vregs-interfere? ] unit-test
[ t ] [ V int-regs 4 V int-regs 3 vregs-interfere? ] unit-test
[ t ] [ V int-regs 3 V int-regs 5 vregs-interfere? ] unit-test
[ t ] [ V int-regs 5 V int-regs 3 vregs-interfere? ] unit-test
[ f ] [ V int-regs 3 V int-regs 6 vregs-interfere? ] unit-test
[ f ] [ V int-regs 6 V int-regs 3 vregs-interfere? ] unit-test

86
basis/compiler/cfg/ssa/interference/interference.factor Normal file
View File

@ -0,0 +1,86 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit fry
kernel math math.order sorting namespaces sequences locals
compiler.cfg.def-use compiler.cfg.dominance
compiler.cfg.ssa.interference.live-ranges ;
IN: compiler.cfg.ssa.interference
<PRIVATE
:: kill-after-def? ( vreg1 vreg2 bb -- ? )
! If first register is used after second one is defined, they interfere.
! If they are used in the same instruction, no interference. If the
! instruction is a def-is-use-insn, then there will be a use at +1
! (instructions are 2 apart) and so outputs will interfere with
! inputs.
vreg1 bb kill-index
vreg2 bb def-index > ;
:: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
! If both are defined in the same basic block, they interfere if their
! local live ranges intersect.
vreg1 bb1 def-index
vreg2 bb1 def-index <
[ vreg1 vreg2 ] [ vreg2 vreg1 ] if
bb1 kill-after-def? ;
: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
! If vreg1 dominates vreg2, then they interfere if vreg2's definition
! occurs before vreg1 is killed.
nip
kill-after-def? ;
: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
! If vreg2 dominates vreg1, then they interfere if vreg1's definition
! occurs before vreg2 is killed.
drop
swapd kill-after-def? ;
PRIVATE>
: vregs-interfere? ( vreg1 vreg2 -- ? )
2dup [ def-of ] bi@ {
{ [ 2dup eq? ] [ interferes-same-block? ] }
{ [ 2dup dominates? ] [ interferes-first-dominates? ] }
{ [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
[ 2drop 2drop f ]
} cond ;
! Debug this stuff later
<PRIVATE
: quadratic-test? ( seq1 seq2 -- ? ) [ length ] bi@ + 10 < ;
: quadratic-test ( seq1 seq2 -- ? )
'[ _ [ vregs-interfere? ] with any? ] any? ;
: sort-vregs-by-bb ( vregs -- alist )
defs get
'[ dup _ at ] { } map>assoc
[ [ second pre-of ] compare ] sort ;
: ?last ( seq -- elt/f ) [ f ] [ last ] if-empty ; inline
: find-parent ( dom current -- parent )
over empty? [ 2drop f ] [
over last over dominates? [ drop last ] [
over pop* find-parent
] if
] if ;
:: linear-test ( seq1 seq2 -- ? )
! Instead of sorting, SSA destruction should keep equivalence
! classes sorted by merging them on append
V{ } clone :> dom
seq1 seq2 append sort-vregs-by-bb [| pair |
pair first :> current
dom current find-parent
dup [ current vregs-interfere? ] when
[ t ] [ current dom push f ] if
] any? ;
PRIVATE>
: sets-interfere? ( seq1 seq2 -- ? )
quadratic-test ;

2
basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor → basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor
View File

@ -3,7 +3,7 @@
USING: accessors assocs fry kernel namespaces sequences math
arrays compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.liveness.ssa compiler.cfg.rpo ;
IN: compiler.cfg.ssa.destruction.live-ranges
IN: compiler.cfg.ssa.interference.live-ranges
! Live ranges for interference testing

22
basis/compiler/cfg/ssa/liveness/liveness-tests.factor
View File

@ -31,7 +31,7 @@ V{
T{ ##replace f V int-regs 3 D 0 }
} 3 test-bb
1 get 2 get 3 get V{ } 2sequence >>successors drop
1 { 2 3 } edges
cfg new 1 get >>entry 4 set
@ -132,35 +132,35 @@ cfg new 1 get >>entry 5 set
! This is the CFG in Figure 3 from the paper
V{ } 1 test-bb
V{ } 2 test-bb
1 get 2 get 1vector >>successors drop
1 2 edge
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 0 }
T{ ##peek f V int-regs 2 D 0 }
} 3 test-bb
V{ } 11 test-bb
2 get 3 get 11 get V{ } 2sequence >>successors drop
2 { 3 11 } edges
V{
T{ ##replace f V int-regs 0 D 0 }
} 4 test-bb
V{ } 8 test-bb
3 get 8 get 4 get V{ } 2sequence >>successors drop
3 { 8 4 } edges
V{
T{ ##replace f V int-regs 1 D 0 }
} 9 test-bb
8 get 9 get 1vector >>successors drop
8 9 edge
V{
T{ ##replace f V int-regs 2 D 0 }
} 5 test-bb
4 get 5 get 1vector >>successors drop
4 5 edge
V{ } 10 test-bb
V{ } 6 test-bb
5 get 6 get 1vector >>successors drop
9 get 6 get 10 get V{ } 2sequence >>successors drop
5 6 edge
9 { 6 10 } edges
V{ } 7 test-bb
6 get 5 get 7 get V{ } 2sequence >>successors drop
10 get 8 get 1vector >>successors drop
7 get 2 get 1vector >>successors drop
6 { 5 7 } edges
10 8 edge
7 2 edge
cfg new 1 get >>entry 0 set
[ ] [ 0 get compute-predecessors drop ] unit-test

8
basis/compiler/cfg/stacks/finalize/finalize.factor
View File

@ -30,8 +30,12 @@ ERROR: bad-peek dst loc ;
[ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
: visit-edge ( from to -- )
2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
! If both blocks are subroutine calls, don't bother
! computing anything.
2dup [ kill-block? ] both? [ 2drop ] [
2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
[ 2drop ] [ <simple-block> insert-basic-block ] if-empty
] if ;
: visit-block ( bb -- )
[ predecessors>> ] keep '[ _ visit-edge ] each ;

10
basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor
View File

@ -25,8 +25,8 @@ V{
T{ ##inc-d f 1 }
} 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
0 1 edge
1 2 edge
[ ] [ test-uninitialized ] unit-test
@ -52,9 +52,9 @@ V{
T{ ##return }
} 3 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 3 get 1vector >>successors drop
0 { 1 2 } edges
1 3 edge
2 3 edge
[ ] [ test-uninitialized ] unit-test

13
basis/compiler/cfg/two-operand/two-operand-tests.factor
View File

@ -27,19 +27,12 @@ compiler.cfg.registers cpu.architecture namespaces tools.test ;
[
V{
T{ ##copy f V int-regs 4 V int-regs 2 }
T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 }
T{ ##copy f V int-regs 1 V int-regs 4 }
T{ ##copy f V int-regs 4 V int-regs 1 }
T{ ##copy f V int-regs 1 V int-regs 2 }
T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 4 }
}
] [
{
T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
} (convert-two-operand)
] unit-test
! This should never come up after coalescing
[
V{
T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 }
} (convert-two-operand)
] must-fail

16
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -65,15 +65,11 @@ GENERIC: convert-two-operand* ( insn -- )
: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline
ERROR: bad-case-2 insn ;
: case-2 ( insn -- )
! This can't work with a ##fixnum-overflow since it branches
dup ##fixnum-overflow? [ bad-case-2 ] when
dup dst>> reg-class>> next-vreg
[ swap src1>> emit-copy ]
[ [ >>src1 ] [ >>dst ] bi , ]
[ [ src2>> ] dip emit-copy ]
[ swap src2>> emit-copy ]
[ drop [ src2>> ] [ src1>> ] bi emit-copy ]
[ >>src2 dup dst>> >>src1 , ]
2tri ; inline
: case-3 ( insn -- )
@ -97,8 +93,10 @@ M: ##not convert-two-operand*
M: insn convert-two-operand* , ;
: (convert-two-operand) ( cfg -- cfg' )
[ [ convert-two-operand* ] each ] V{ } make ;
: (convert-two-operand) ( insns -- insns' )
dup first kill-vreg-insn? [
[ [ convert-two-operand* ] each ] V{ } make
] unless ;
: convert-two-operand ( cfg -- cfg' )
two-operand? [ [ (convert-two-operand) ] local-optimization ] when ;

11
basis/compiler/cfg/utilities/utilities.factor
View File

@ -43,6 +43,13 @@ SYMBOL: visited
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
@
,
] with-variable ; inline
: <simple-block> ( insns -- bb )
<basic-block>
swap >vector
@ -58,6 +65,10 @@ SYMBOL: visited
: if-has-phis ( bb quot: ( bb -- ) -- )
[ dup has-phis? ] dip [ drop ] if ; inline
: each-phi ( bb quot: ( ##phi -- ) -- )
[ instructions>> ] dip
'[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
: predecessor ( bb -- pred )
predecessors>> first ; inline

15
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1175,16 +1175,11 @@ V{
} 3 test-bb
V{
T{ ##phi f V int-regs 3 { } }
T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 4 test-bb
4 get instructions>> first
2 get V int-regs 1 2array
3 get V int-regs 2 2array 2array
>>inputs drop
test-diamond
[ ] [
@ -1296,10 +1291,10 @@ V{
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 4 get V{ } 2sequence >>successors drop
2 get 3 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
0 1 edge
1 { 2 4 } edges
2 3 edge
4 5 edge
[ ] [
cfg new 0 get >>entry

30
basis/compiler/tests/codegen.factor
View File

@ -2,7 +2,8 @@ USING: generalizations accessors arrays compiler kernel kernel.private
math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit ;
combinators vectors grouping make alien.c-types combinators.short-circuit
math.order ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@ -366,4 +367,29 @@ cell 4 = [
fixnum+fast 2 fixnum*fast 2 fixnum-fast 2 fixnum*fast 2 fixnum+fast ;
[ 10 ] [ 1 coalescing-bug-2 ] unit-test
[ 86 ] [ 11 coalescing-bug-2 ] unit-test
[ 86 ] [ 11 coalescing-bug-2 ] unit-test
! Regression in suffix-arrays code
: coalescing-bug-3 ( from/f to/f seq -- slice )
[
[ drop 0 or ] [ length or ] bi-curry bi*
[ min ] keep
] keep <slice> ;
[ T{ slice f 0 5 "hello" } ] [ f f "hello" coalescing-bug-3 ] unit-test
[ T{ slice f 1 5 "hello" } ] [ 1 f "hello" coalescing-bug-3 ] unit-test
[ T{ slice f 0 3 "hello" } ] [ f 3 "hello" coalescing-bug-3 ] unit-test
[ T{ slice f 1 3 "hello" } ] [ 1 3 "hello" coalescing-bug-3 ] unit-test
[ T{ slice f 3 3 "hello" } ] [ 4 3 "hello" coalescing-bug-3 ] unit-test
[ T{ slice f 5 5 "hello" } ] [ 6 f "hello" coalescing-bug-3 ] unit-test
! Reduction
: coalescing-bug-4 ( a b c -- a b c )
[ [ min ] keep ] dip vector? [ 1 ] [ 2 ] if ;
[ 2 3 2 ] [ 2 3 "" coalescing-bug-4 ] unit-test
[ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
[ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
[ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
[ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
[ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test

4
basis/compiler/tests/low-level-ir.factor
View File

@ -27,8 +27,8 @@ IN: compiler.tests.low-level-ir
T{ ##epilogue }
T{ ##return }
} [ clone ] map 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
0 1 edge
1 2 edge
compile-test-cfg
execute( -- result ) ;

15
basis/compiler/tree/propagation/copy/copy.factor
View File

@ -5,7 +5,8 @@ combinators sets locals columns grouping
stack-checker.branches
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
compiler.tree.combinators
compiler.utilities ;
IN: compiler.tree.propagation.copy
! Two values are copy-equivalent if they are always identical
@ -15,18 +16,6 @@ IN: compiler.tree.propagation.copy
! Mapping from values to their canonical leader
SYMBOL: copies
:: compress-path ( source assoc -- destination )
[let | destination [ source assoc at ] |
source destination = [ source ] [
[let | destination' [ destination assoc compress-path ] |
destination' destination = [
destination' source assoc set-at
] unless
destination'
]
] if
] ;
: resolve-copy ( copy -- val ) copies get compress-path ;
: is-copy-of ( val copy -- ) copies get set-at ;

14
basis/compiler/utilities/utilities.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private arrays vectors fry
math math.order namespaces assocs ;
math math.order namespaces assocs locals ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
@ -30,3 +30,15 @@ yield-hook [ [ ] ] initialize
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
:: compress-path ( source assoc -- destination )
[let | destination [ source assoc at ] |
source destination = [ source ] [
[let | destination' [ destination assoc compress-path ] |
destination' destination = [
destination' source assoc set-at
] unless
destination'
]
] if
] ;

16
core/combinators/combinators-docs.factor
View File

@ -354,6 +354,22 @@ HELP: spread
{ bi* tri* spread } related-words
HELP: to-fixed-point
{ $values { "object" object } { "quot" { $quotation "( object(n) -- object(n+1) )" } } { "object(n)" object } }
{ $description "Applies the quotation repeatedly with " { $snippet "object" } " as the initial input until the output of the quotation equals the input." }
{ $examples
{ $example
"USING: combinators kernel math prettyprint sequences ;"
"IN: scratchpad"
": flatten ( sequence -- sequence' )"
" \"flatten\" over index"
" [ [ 1 + swap nth ] [ nip dup 2 + ] [ drop ] 2tri replace-slice ] when* ;"
""
"{ \"flatten\" { 1 { 2 3 } \"flatten\" { 4 5 } { 6 } } } [ flatten ] to-fixed-point ."
"{ 1 { 2 3 } 4 5 { 6 } }"
}
} ;
HELP: alist>quot
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
{ $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }

3
core/combinators/combinators.factor
View File

@ -180,3 +180,6 @@ M: hashtable hashcode*
dup assoc-size 1 eq?
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) )
[ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive

2
core/make/make.factor
View File

@ -8,7 +8,7 @@ SYMBOL: building
: make ( quot exemplar -- seq )
[
[
1024 swap new-resizable [
100 swap new-resizable [
building set call
] keep
] keep like