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

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

db4
Slava Pestov 2009-07-15 19:02:54 -05:00
parent d03a8dff44 eba4749e5f
commit 45d466c126
57 changed files with 2402 additions and 718 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
basis/compiler/cfg/branch-folding/branch-folding-tests.factor
View File

@ -1,85 +0,0 @@
IN: compiler.cfg.branch-folding.tests
USING: compiler.cfg.branch-folding compiler.cfg.instructions
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
arrays compiler.cfg.phi-elimination compiler.cfg.dce
compiler.cfg.predecessors kernel accessors assocs
sequences classes namespaces tools.test cpu.architecture ;
V{ T{ ##branch } } 0 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
} 1 test-bb
V{
T{ ##load-immediate f V int-regs 1 1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##load-immediate f V int-regs 2 2 }
T{ ##branch }
} 3 test-bb
V{
T{ ##phi f V int-regs 3 { } }
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
[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test
[ 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
[ 2 ] [ 4 get instructions>> length ] unit-test
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{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
} 1 test-bb
V{
T{ ##copy f V int-regs 2 V int-regs 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##phi f V int-regs 3 V{ } }
T{ ##branch }
} 3 test-bb
V{
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 4 test-bb
1 get V int-regs 1 2array
2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
test-diamond
[ ] [
cfg new 0 get >>entry
compute-predecessors
fold-branches
compute-predecessors
eliminate-dead-code
drop
] unit-test
[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test

30
basis/compiler/cfg/branch-folding/branch-folding.factor
View File

@ -1,30 +0,0 @@
! 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 ;
IN: compiler.cfg.branch-folding
! Fold comparisons where both inputs are the same. Predecessors must be
! recomputed after this
: fold-branch? ( bb -- ? )
instructions>> last {
[ ##compare-branch? ]
[ [ src1>> ] [ src2>> ] bi = ]
} 1&& ;
: chosen-successor ( bb -- succ )
[ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
[ successors>> ]
bi nth ;
: fold-branch ( bb -- )
dup chosen-successor 1vector >>successors
instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
: fold-branches ( cfg -- cfg' )
dup [
dup fold-branch?
[ fold-branch ] [ drop ] if
] each-basic-block
f >>post-order ;

85
basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor Normal file
View File

@ -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

80
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -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 [
[ [
clone
dup rename-insn-defs
dup rename-insn-uses
dup fresh-insn-temps
] map
] with-variable ;
: clone-basic-block ( bb -- bb' )
! The new block gets the same RPO number as the old one.
! This is just to make 'back-edge?' work.
<basic-block> <basic-block>
swap swap
[ instructions>> [ clone ] map >>instructions ] [ instructions>> clone-instructions >>instructions ]
[ successors>> clone >>successors ] [ successors>> clone >>successors ]
bi [ number>> >>number ]
] keep tri ;
] dip
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors : new-blocks ( bb -- copies )
drop ; 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 ;
: split-branches? ( bb -- ? ) UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
: split-instructions? ( insns -- ? )
[ irrelevant? not ] count 5 <= ;
: split-branch? ( bb -- ? )
{ {
[ successors>> empty? ] [ dup successors>> [ back-edge? ] with any? not ]
[ predecessors>> length 1 > ] [ predecessors>> length 2 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-branch? [ split-branch ] [ drop ] if
] each-basic-block ] each-basic-block
f >>post-order ; cfg-changed ;

1
basis/compiler/cfg/builder/builder.factor
View File

@ -14,6 +14,7 @@ compiler.cfg.stacks
compiler.cfg.utilities compiler.cfg.utilities
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.intrinsics compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame compiler.cfg.stack-frame
compiler.cfg.instructions compiler.cfg.instructions
compiler.alien ; compiler.alien ;

36
basis/compiler/cfg/cfg.factor
View File

@ -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 )

36
basis/compiler/cfg/comparisons/comparisons.factor Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
: negate-cc ( cc -- cc' )
H{
{ cc< cc>= }
{ cc<= cc> }
{ cc> cc<= }
{ cc>= cc< }
{ cc= cc/= }
{ cc/= cc= }
} at ;
: swap-cc ( cc -- cc' )
H{
{ cc< cc> }
{ cc<= cc>= }
{ cc> cc< }
{ cc>= cc<= }
{ cc= cc= }
{ cc/= cc/= }
} at ;
: evaluate-cc ( result cc -- ? )
H{
{ cc< { +lt+ } }
{ cc<= { +lt+ +eq+ } }
{ cc= { +eq+ } }
{ cc>= { +eq+ +gt+ } }
{ cc> { +gt+ } }
{ cc/= { +lt+ +gt+ } }
} at memq? ;

38
basis/compiler/cfg/instructions/instructions.factor
View File

@ -181,44 +181,6 @@ INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ; INSN: ##phi < ##pure inputs ;
! Condition codes
SYMBOL: cc<
SYMBOL: cc<=
SYMBOL: cc=
SYMBOL: cc>
SYMBOL: cc>=
SYMBOL: cc/=
: negate-cc ( cc -- cc' )
H{
{ cc< cc>= }
{ cc<= cc> }
{ cc> cc<= }
{ cc>= cc< }
{ cc= cc/= }
{ cc/= cc= }
} at ;
: swap-cc ( cc -- cc' )
H{
{ cc< cc> }
{ cc<= cc>= }
{ cc> cc< }
{ cc>= cc<= }
{ cc= cc= }
{ cc/= cc/= }
} at ;
: evaluate-cc ( result cc -- ? )
H{
{ cc< { +lt+ } }
{ cc<= { +lt+ +eq+ } }
{ cc= { +eq+ } }
{ cc>= { +eq+ +gt+ } }
{ cc> { +gt+ } }
{ cc/= { +lt+ +gt+ } }
} at memq? ;
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ; INSN: ##compare-branch < ##conditional-branch ;

64
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -1,13 +1,14 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces USING: sequences accessors layouts kernel math namespaces
combinators fry locals combinators fry
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.hats
compiler.cfg.stacks compiler.cfg.stacks
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.utilities
compiler.cfg.registers ; compiler.cfg.registers
compiler.cfg.comparisons ;
IN: compiler.cfg.intrinsics.fixnum IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- ) : emit-both-fixnums? ( -- )
@ -20,32 +21,8 @@ IN: compiler.cfg.intrinsics.fixnum
: tag-literal ( n -- tagged ) : tag-literal ( n -- tagged )
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ; literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
: emit-fixnum-imm-op1 ( infos insn -- dst ) : emit-fixnum-op ( insn -- dst )
[ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline [ 2inputs ] dip call ds-push ; inline
: emit-fixnum-imm-op2 ( infos insn -- dst )
[ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
: (emit-fixnum-op) ( insn -- dst )
[ 2inputs ] dip call ; inline
:: emit-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
infos second value-info-small-tagged?
[ infos imm-insn emit-fixnum-imm-op2 ]
[ insn (emit-fixnum-op) ] if
ds-push
] ; inline
:: emit-commutative-fixnum-op ( node insn imm-insn -- )
[let | infos [ node node-input-infos ] |
{
{ [ infos first value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op1 ] }
{ [ infos second value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op2 ] }
[ insn (emit-fixnum-op) ]
} cond
ds-push
] ; inline
: emit-fixnum-shift-fast ( node -- ) : emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-fixnum? [ dup node-input-infos dup second value-info-small-fixnum? [
@ -65,34 +42,11 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum-log2 ( -- ) : emit-fixnum-log2 ( -- )
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ; ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
: (emit-fixnum*fast) ( -- dst ) : emit-fixnum*fast ( -- )
2inputs ^^untag-fixnum ^^mul ; 2inputs ^^untag-fixnum ^^mul ds-push ;
: (emit-fixnum*fast-imm1) ( infos -- dst ) : emit-fixnum-comparison ( cc -- )
[ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ; '[ _ ^^compare ] emit-fixnum-op ;
: (emit-fixnum*fast-imm2) ( infos -- dst )
[ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
: emit-fixnum*fast ( node -- )
node-input-infos
dup first value-info-small-fixnum? drop f
[
(emit-fixnum*fast-imm1)
] [
dup second value-info-small-fixnum?
[ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
] if
ds-push ;
: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
[ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
: emit-eq ( node -- )
cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
: emit-fixnum-comparison ( node cc -- )
(emit-fixnum-comparison) emit-fixnum-op ;
: emit-bignum>fixnum ( -- ) : emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ; ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;

25
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -8,7 +8,8 @@ compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc ; compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: kernel QUALIFIED: kernel
QUALIFIED: arrays QUALIFIED: arrays
QUALIFIED: byte-arrays QUALIFIED: byte-arrays
@ -102,20 +103,20 @@ IN: compiler.cfg.intrinsics
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] } { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] } { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] } { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] } { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] } { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] } { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] } { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] } { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ emit-eq ] } { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }

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

@ -12,6 +12,7 @@ compiler.cfg.predecessors
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.linearization compiler.cfg.linearization
compiler.cfg.debugger compiler.cfg.debugger
compiler.cfg.comparisons
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
@ -1509,6 +1510,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 +1805,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 +1861,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 +1928,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 +2486,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

1
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -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 ;

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

@ -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

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

@ -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
basis/compiler/cfg/linearization/linearization.factor
View File

@ -5,6 +5,7 @@ combinators assocs arrays locals cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.comparisons
compiler.cfg.stack-frame compiler.cfg.stack-frame
compiler.cfg.instructions ; compiler.cfg.instructions ;
IN: compiler.cfg.linearization IN: compiler.cfg.linearization

14
basis/compiler/cfg/local/local.factor
View File

@ -1,10 +1,14 @@
! 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: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ; USING: locals accessors kernel assocs namespaces
compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ;
IN: compiler.cfg.local IN: compiler.cfg.local
: optimize-basic-block ( bb init-quot insn-quot -- ) :: optimize-basic-block ( bb init-quot insn-quot -- )
[ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline bb basic-block set
bb live-in keys init-quot call
bb insn-quot change-instructions drop ; inline
: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) :: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
[ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block
cfg ; inline

17
basis/compiler/cfg/optimizer/optimizer-tests.factor
View File

@ -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

5
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -9,7 +9,6 @@ compiler.cfg.branch-splitting
compiler.cfg.alias-analysis compiler.cfg.alias-analysis
compiler.cfg.value-numbering compiler.cfg.value-numbering
compiler.cfg.dce compiler.cfg.dce
compiler.cfg.branch-folding
compiler.cfg.write-barrier compiler.cfg.write-barrier
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.rpo compiler.cfg.rpo
@ -29,15 +28,13 @@ 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
value-numbering value-numbering
fold-branches
compute-predecessors compute-predecessors
eliminate-dead-code eliminate-dead-code
eliminate-write-barriers eliminate-write-barriers

15
basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
View File

@ -1,7 +1,8 @@
IN: compiler.cfg.phi-elimination.tests IN: compiler.cfg.phi-elimination.tests
USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors compiler.cfg.comparisons compiler.cfg.debugger
sequences classes namespaces tools.test cpu.architecture arrays ; compiler.cfg.phi-elimination kernel accessors sequences classes
namespaces tools.test cpu.architecture arrays ;
V{ T{ ##branch } } 0 test-bb V{ T{ ##branch } } 0 test-bb
@ -35,6 +36,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

13
basis/compiler/cfg/phi-elimination/phi-elimination.factor
View File

@ -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 ;

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

@ -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

39
basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
View File

@ -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
H{ } clone added-instructions set
V{ } clone added-phis set
[ merge-locs locs>vregs>> keys ] { } make drop [ merge-locs locs>vregs>> keys ] { } make drop
] keep first instructions>> first class 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
V{ } clone added-phis set
[
<state> -1 >>ds-height <state> -1 >>ds-height
<state> 2array <state> 2array
[ merge-ds-heights ds-height>> ] { } make drop [ merge-ds-heights ds-height>> ] { } make drop
] keep first instructions>> first class 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

66
basis/compiler/cfg/stack-analysis/merge/merge.factor
View File

@ -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 ] }

16
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
View File

@ -91,15 +91,15 @@ IN: compiler.cfg.stack-analysis.tests
! Sync before a back-edge, not after ! Sync before a back-edge, not after
! ##peeks should be inserted before a ##loop-entry ! ##peeks should be inserted before a ##loop-entry
! Don't optimize out the constants ! Don't optimize out the constants
[ 1 t ] [ [ t ] [
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi [ ##load-immediate? ] any?
] unit-test ] unit-test
! 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

22
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -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
basis/compiler/cfg/tco/tco.factor
View File

@ -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 ;

5
basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
View File

@ -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 ;

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

@ -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 ;

25
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -1,7 +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 classes kernel math namespaces combinators USING: accessors classes kernel math namespaces combinators
compiler.cfg.instructions compiler.cfg.value-numbering.graph ; combinators.short-circuit compiler.cfg.instructions
compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions ! Referentially-transparent expressions
@ -11,15 +12,29 @@ TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ; TUPLE: commutative-expr < binary-expr ;
TUPLE: compare-expr < binary-expr cc ; TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ; TUPLE: constant-expr < expr value ;
TUPLE: reference-expr < expr value ;
: <constant> ( constant -- expr ) : <constant> ( constant -- expr )
f swap constant-expr boa ; inline f swap constant-expr boa ; inline
M: constant-expr equal? M: constant-expr equal?
over constant-expr? [ over constant-expr? [
{
[ [ value>> class ] bi@ = ]
[ [ value>> ] bi@ = ] [ [ value>> ] bi@ = ]
[ [ value>> class ] bi@ = ] 2bi } 2&&
and ] [ 2drop f ] if ;
: <reference> ( constant -- expr )
f swap reference-expr boa ; inline
M: reference-expr equal?
over reference-expr? [
[ value>> ] bi@ {
{ [ 2dup eq? ] [ 2drop t ] }
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
[ 2drop f ]
} cond
] [ 2drop f ] if ; ] [ 2drop f ] if ;
! Expressions whose values are inputs to the basic block. We ! Expressions whose values are inputs to the basic block. We
@ -39,6 +54,8 @@ GENERIC: >expr ( insn -- expr )
M: ##load-immediate >expr val>> <constant> ; M: ##load-immediate >expr val>> <constant> ;
M: ##load-reference >expr obj>> <reference> ;
M: ##unary >expr M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ; [ class ] [ src>> vreg>vn ] bi unary-expr boa ;

366
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -1,16 +1,32 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors locals combinators combinators.short-circuit arrays USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise compiler.cfg.hats compiler.cfg.instructions math.bitwise math.order classes vectors
compiler.cfg
compiler.cfg.hats
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify ; compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.rewrite IN: compiler.cfg.value-numbering.rewrite
GENERIC: rewrite ( insn -- insn' ) : vreg-small-constant? ( vreg -- ? )
vreg>expr {
[ constant-expr? ]
[ value>> small-enough? ]
} 1&& ;
M: insn rewrite ; ! Outputs f to mean no change
GENERIC: rewrite* ( insn -- insn/f )
: rewrite ( insn -- insn' )
dup [ number-values ] [ rewrite* ] bi
[ rewrite ] [ ] ?if ;
M: insn rewrite* drop f ;
: ##branch-t? ( insn -- ? ) : ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [ dup ##compare-imm-branch? [
@ -49,13 +65,16 @@ M: insn rewrite ;
[ src2>> tag-mask get bitand 0 = ] [ src2>> tag-mask get bitand 0 = ]
} 1&& ; inline } 1&& ; inline
: tagged>constant ( n -- n' )
tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) : (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ] [ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ] [ src2>> tagged>constant ]
[ cc>> ] [ cc>> ]
tri ; inline tri ; inline
GENERIC: rewrite-tagged-comparison ( insn -- insn' ) GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
M: ##compare-imm-branch rewrite-tagged-comparison M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ; (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
@ -64,41 +83,6 @@ M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi [ dst>> ] [ (rewrite-tagged-comparison) ] bi
i \ ##compare-imm new-insn ; i \ ##compare-imm new-insn ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
dup ##compare-imm-branch? [
dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
] when ;
:: >compare-imm ( insn swap? -- insn' )
insn dst>>
insn src1>>
insn src2>> swap? [ swap ] when vreg>constant
insn cc>> swap? [ swap-cc ] when
i \ ##compare-imm new-insn ; inline
! M: ##compare rewrite
! dup [ src1>> ] [ src2>> ] bi
! [ vreg>expr constant-expr? ] bi@ 2array {
! { { f t } [ f >compare-imm ] }
! { { t f } [ t >compare-imm ] }
! [ drop ]
! } case ;
:: >compare-imm-branch ( insn swap? -- insn' )
insn src1>>
insn src2>> swap? [ swap ] when vreg>constant
insn cc>> swap? [ swap-cc ] when
\ ##compare-imm-branch new-insn ; inline
! M: ##compare-branch rewrite
! dup [ src1>> ] [ src2>> ] bi
! [ vreg>expr constant-expr? ] bi@ 2array {
! { { f t } [ f >compare-imm-branch ] }
! { { t f } [ t >compare-imm-branch ] }
! [ drop ]
! } case ;
: rewrite-redundant-comparison? ( insn -- ? ) : rewrite-redundant-comparison? ( insn -- ? )
{ {
[ src1>> vreg>expr compare-expr? ] [ src1>> vreg>expr compare-expr? ]
@ -114,101 +98,253 @@ M: ##compare-imm-branch rewrite
} case } case
swap cc= eq? [ [ negate-cc ] change-cc ] when ; swap cc= eq? [ [ negate-cc ] change-cc ] when ;
M: ##compare-imm rewrite ERROR: bad-comparison ;
dup rewrite-redundant-comparison? [
rewrite-redundant-comparison
dup number-values rewrite
] when
dup ##compare-imm? [
dup rewrite-tagged-comparison? [
rewrite-tagged-comparison
dup number-values rewrite
] when
] when ;
: constant-fold ( insn -- insn' ) : (fold-compare-imm) ( insn -- ? )
dup dst>> vreg>expr dup constant-expr? [ [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
[ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn pick integer?
dup number-values [ [ <=> ] dip evaluate-cc ]
] [ [
drop 2nip {
{ cc= [ f ] }
{ cc/= [ t ] }
[ bad-comparison ]
} case
] if ; ] if ;
: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn ) : fold-compare-imm? ( insn -- ? )
[ cell-bits bits ] dip over small-enough? [ src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
new-insn dup number-values nip
] [
2drop 2drop
] if constant-fold ; inline
: new-imm-insn ( insn dst src n op -- n' op' ) : fold-branch ( ? -- insn )
2dup [ sgn ] dip 2array 0 1 ?
basic-block get [ nth 1vector ] change-successors drop
\ ##branch new-insn ;
: fold-compare-imm-branch ( insn -- insn/f )
(fold-compare-imm) fold-branch ;
M: ##compare-imm-branch rewrite*
{ {
{ { -1 ##add-imm } [ drop neg \ ##sub-imm (new-imm-insn) ] } { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
{ { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
[ drop (new-imm-insn) ] { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
} case ; inline [ drop f ]
} cond ;
: combine-imm? ( insn op -- ? ) : swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
[ src1>> vreg>expr op>> ] dip = ; [ [ swap ] dip swap-cc ] when ; inline
: (combine-imm) ( insn quot op -- insn ) : >compare-imm-branch ( insn swap? -- insn' )
[
[ src1>> ]
[ src2>> ]
[ cc>> ]
tri
] dip
swap-compare
[ vreg>constant ] dip
\ ##compare-imm-branch new-insn ; inline
: self-compare? ( insn -- ? )
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
: (rewrite-self-compare) ( insn -- ? )
cc>> { cc= cc<= cc>= } memq? ;
: rewrite-self-compare-branch ( insn -- insn' )
(rewrite-self-compare) fold-branch ;
M: ##compare-branch rewrite*
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
{ [ dup self-compare? ] [ rewrite-self-compare-branch ] }
[ drop f ]
} cond ;
: >compare-imm ( insn swap? -- insn' )
[
{
[ dst>> ]
[ src1>> ]
[ src2>> ]
[ cc>> ]
} cleave
] dip
swap-compare
[ vreg>constant ] dip
i \ ##compare-imm new-insn ; inline
: >boolean-insn ( insn ? -- insn' )
[ dst>> ] dip
{
{ t [ t \ ##load-reference new-insn ] }
{ f [ \ f tag-number \ ##load-immediate new-insn ] }
} case ;
: rewrite-self-compare ( insn -- insn' )
dup (rewrite-self-compare) >boolean-insn ;
M: ##compare rewrite*
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
{ [ dup self-compare? ] [ rewrite-self-compare ] }
[ drop f ]
} cond ;
: fold-compare-imm ( insn -- insn' )
dup (fold-compare-imm) >boolean-insn ;
M: ##compare-imm rewrite*
{
{ [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
{ [ dup fold-compare-imm? ] [ fold-compare-imm ] }
[ drop f ]
} cond ;
: constant-fold? ( insn -- ? )
src1>> vreg>expr constant-expr? ; inline
GENERIC: constant-fold* ( x y insn -- z )
M: ##add-imm constant-fold* drop + ;
M: ##sub-imm constant-fold* drop - ;
M: ##mul-imm constant-fold* drop * ;
M: ##and-imm constant-fold* drop bitand ;
M: ##or-imm constant-fold* drop bitor ;
M: ##xor-imm constant-fold* drop bitxor ;
M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
M: ##sar-imm constant-fold* drop neg shift ;
M: ##shl-imm constant-fold* drop shift ;
: constant-fold ( insn -- insn' )
[ dst>> ]
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
: reassociate? ( insn -- ? )
[ src1>> vreg>expr op>> ] [ class ] bi = ; inline
: reassociate ( insn op -- insn )
[ [
{ {
[ ]
[ dst>> ] [ dst>> ]
[ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
[ src2>> ] [ src2>> ]
} cleave
] [ call ] [ ] tri* new-imm-insn ; inline
:: combine-imm ( insn quot op -- insn )
insn op combine-imm? [
insn quot op (combine-imm)
] [
insn
] if ; inline
M: ##add-imm rewrite
{
{ [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] }
{ [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] }
[ ] [ ]
} cleave constant-fold*
] dip
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
M: ##add-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##add-imm reassociate ] }
[ drop f ]
} cond ; } cond ;
M: ##sub-imm rewrite : sub-imm>add-imm ( insn -- insn' )
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
M: ##sub-imm rewrite*
{ {
{ [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] } { [ dup constant-fold? ] [ constant-fold ] }
{ [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] } [ sub-imm>add-imm ]
[ ]
} cond ; } cond ;
M: ##mul-imm rewrite : strength-reduce-mul ( insn -- insn' )
dup src2>> dup power-of-2? [ [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
dup number-values
] [
drop [ * ] \ ##mul-imm combine-imm
] if ;
M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ; : strength-reduce-mul? ( insn -- ? )
src2>> power-of-2? ;
M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ; M: ##mul-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
{ [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ; M: ##and-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
: rewrite-add? ( insn -- ? ) M: ##or-imm rewrite*
src2>> { {
[ vreg>expr constant-expr? ] { [ dup constant-fold? ] [ constant-fold ] }
[ vreg>constant small-enough? ] { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
} 1&& ; [ drop f ]
} cond ;
M: ##add rewrite M: ##xor-imm rewrite*
dup rewrite-add? [ {
[ dst>> ] { [ dup constant-fold? ] [ constant-fold ] }
[ src1>> ] { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
[ src2>> vreg>constant ] tri \ ##add-imm new-insn [ drop f ]
dup number-values } cond ;
] when ;
M: ##sub rewrite constant-fold ; M: ##shl-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
M: ##shr-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
M: ##sar-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
: insn>imm-insn ( insn op swap? -- )
swap [
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
[ swap ] when vreg>constant
] dip new-insn ; inline
: rewrite-arithmetic ( insn op -- ? )
{
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
[ 2drop f ]
} cond ; inline
: rewrite-arithmetic-commutative ( insn op -- ? )
{
{ [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
{ [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
[ 2drop f ]
} cond ; inline
M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
: subtraction-identity? ( insn -- ? )
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
: rewrite-subtraction-identity ( insn -- insn' )
dst>> 0 \ ##load-immediate new-insn ;
M: ##sub rewrite*
{
{ [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
[ \ ##sub-imm rewrite-arithmetic ]
} cond ;
M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;

61
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -32,6 +32,8 @@ M: unary-expr simplify*
: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline : expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
: >binary-expr< ( expr -- in1 in2 ) : >binary-expr< ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
@ -44,18 +46,54 @@ M: unary-expr simplify*
: simplify-sub ( expr -- vn/expr/f ) : simplify-sub ( expr -- vn/expr/f )
>binary-expr< { >binary-expr< {
{ [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
{ [ dup expr-zero? ] [ drop ] } { [ dup expr-zero? ] [ drop ] }
[ 2drop f ] [ 2drop f ]
} cond ; inline } cond ; inline
: useless-shift? ( in1 in2 -- ? ) : simplify-mul ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-one? ] [ drop ] }
{ [ dup expr-one? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: simplify-and ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: simplify-or ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
{ [ over expr-zero? ] [ nip ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: simplify-xor ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: useless-shr? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq? over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shift ( expr -- vn/expr/f ) : simplify-shr ( expr -- vn/expr/f )
>binary-expr< >binary-expr< {
2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline { [ 2dup useless-shr? ] [ drop in1>> ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
: simplify-shl ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
M: binary-expr simplify* M: binary-expr simplify*
dup op>> { dup op>> {
@ -63,8 +101,17 @@ M: binary-expr simplify*
{ \ ##add-imm [ simplify-add ] } { \ ##add-imm [ simplify-add ] }
{ \ ##sub [ simplify-sub ] } { \ ##sub [ simplify-sub ] }
{ \ ##sub-imm [ simplify-sub ] } { \ ##sub-imm [ simplify-sub ] }
{ \ ##shr-imm [ simplify-shift ] } { \ ##mul [ simplify-mul ] }
{ \ ##sar-imm [ simplify-shift ] } { \ ##mul-imm [ simplify-mul ] }
{ \ ##and [ simplify-and ] }
{ \ ##and-imm [ simplify-and ] }
{ \ ##or [ simplify-or ] }
{ \ ##or-imm [ simplify-or ] }
{ \ ##xor [ simplify-xor ] }
{ \ ##xor-imm [ simplify-xor ] }
{ \ ##shr-imm [ simplify-shr ] }
{ \ ##sar-imm [ simplify-shr ] }
{ \ ##shl-imm [ simplify-shl ] }
[ 2drop f ] [ 2drop f ]
} case ; } case ;

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

File diff suppressed because it is too large Load Diff

9
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences fry sorting sets sequences fry
compiler.cfg
compiler.cfg.local compiler.cfg.local
compiler.cfg.liveness compiler.cfg.liveness
compiler.cfg.renaming compiler.cfg.renaming
@ -11,6 +12,8 @@ compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ; compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering IN: compiler.cfg.value-numbering
! Local value numbering. Predecessors must be recomputed after this
: number-input-values ( live-in -- ) : number-input-values ( live-in -- )
[ [ f next-input-expr simplify ] dip set-vn ] each ; [ [ f next-input-expr simplify ] dip set-vn ] each ;
@ -29,8 +32,8 @@ IN: compiler.cfg.value-numbering
] with-variable ; ] with-variable ;
: value-numbering-step ( insns -- insns' ) : value-numbering-step ( insns -- insns' )
[ [ number-values ] [ rewrite ] bi ] map [ rewrite ] map dup rename-uses ;
dup rename-uses ;
: value-numbering ( cfg -- cfg' ) : value-numbering ( cfg -- cfg' )
[ init-value-numbering ] [ value-numbering-step ] local-optimization ; [ init-value-numbering ] [ value-numbering-step ] local-optimization
cfg-changed ;

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

@ -315,3 +315,10 @@ M: cucumber equal? "The cucumber has no equal" throw ;
! Regression from Doug's value numbering changes ! Regression from Doug's value numbering changes
[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test [ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test [ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
cell 4 = [
[ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
] when
! Regression from Slava's value numbering changes
[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test

2
basis/compiler/tree/propagation/call-effect/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Daniel Ehrenberg

51
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
IN: compiler.tree.propagation.call-effect.tests
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
: optimized-quot ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
: compiled-call2 ( a quot: ( a -- b ) -- b )
call( a -- b ) ;
: compiled-execute2 ( a b word: ( a b -- c ) -- c )
execute( a b -- c ) ;
[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test
[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test
[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test
[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test
[ 1 2 { [ + ] } first compiled-call2 ] must-fail
[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test
[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test
[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test
[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test
[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test
[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test
[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test
[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test
[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test

95
basis/stack-checker/call-effect/call-effect.factor → basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations kernel kernel.private make sequences continuations quotations
stack-checker stack-checker.transforms words math ; words math stack-checker stack-checker.transforms
IN: stack-checker.call-effect compiler.tree.propagation.info slots.private ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions. ! call( and execute( have complex expansions.
@ -84,18 +85,14 @@ M: quotation cached-effect
[ drop call-effect-slow ] [ drop call-effect-slow ]
if ; inline if ; inline
\ call-effect [ : call-effect-ic ( quot effect inline-cache -- )
inline-cache new '[ 3dup nip cache-hit?
_ [ drop call-effect-unsafe ]
3dup nip cache-hit? [ [ call-effect-fast ]
drop call-effect-unsafe if ; inline
] [
call-effect-fast
] if
]
] 0 define-transform
\ call-effect t "no-compile" set-word-prop : call-effect>quot ( effect -- quot )
inline-cache new '[ drop _ _ call-effect-ic ] ;
: execute-effect-slow ( word effect -- ) : execute-effect-slow ( word effect -- )
[ '[ _ execute ] ] dip call-effect-slow ; inline [ '[ _ execute ] ] dip call-effect-slow ; inline
@ -116,8 +113,72 @@ M: quotation cached-effect
if ; inline if ; inline
: execute-effect>quot ( effect -- quot ) : execute-effect>quot ( effect -- quot )
inline-cache new '[ _ _ execute-effect-ic ] ; inline-cache new '[ drop _ _ execute-effect-ic ] ;
\ execute-effect [ execute-effect>quot ] 1 define-transform : last2 ( seq -- penultimate ultimate )
2 tail* first2 ;
\ execute-effect t "no-compile" set-word-prop : top-two ( #call -- effect value )
in-d>> last2 [ value-info ] bi@
literal>> swap ;
ERROR: uninferable ;
: remove-effect-input ( effect -- effect' )
(( -- object )) swap compose-effects ;
: (infer-value) ( value-info -- effect )
dup class>> {
{ \ quotation [
literal>> [ uninferable ] unless* cached-effect
dup +unknown+ = [ uninferable ] when
] }
{ \ curry [
slots>> third (infer-value)
remove-effect-input
] }
{ \ compose [
slots>> last2 [ (infer-value) ] bi@
compose-effects
] }
[ uninferable ]
} case ;
: infer-value ( value-info -- effect/f )
[ (infer-value) ]
[ dup uninferable? [ 2drop f ] [ rethrow ] if ]
recover ;
: (value>quot) ( value-info -- quot )
dup class>> {
{ \ quotation [ literal>> '[ drop @ ] ] }
{ \ curry [
slots>> third (value>quot)
'[ [ obj>> ] [ quot>> @ ] bi ]
] }
{ \ compose [
slots>> last2 [ (value>quot) ] bi@
'[ [ first>> @ ] [ second>> @ ] bi ]
] }
} case ;
: value>quot ( value-info -- quot: ( code effect -- ) )
(value>quot) '[ drop @ ] ;
: call-inlining ( #call -- quot/f )
top-two dup infer-value [
pick effect<=
[ nip value>quot ]
[ drop call-effect>quot ] if
] [ drop call-effect>quot ] if* ;
\ call-effect [ call-inlining ] "custom-inlining" set-word-prop
: execute-inlining ( #call -- quot/f )
top-two >literal< [
2dup swap execute-effect-unsafe?
[ nip '[ 2drop _ execute ] ]
[ drop execute-effect>quot ] if
] [ drop execute-effect>quot ] if ;
\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop

17
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -6,14 +6,15 @@ math.parser math.order layouts words sequences sequences.private
arrays assocs classes classes.algebra combinators generic.math arrays assocs classes classes.algebra combinators generic.math
splitting fry locals classes.tuple alien.accessors splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private classes.tuple.private slots.private definitions strings.private
vectors hashtables generic vectors hashtables generic quotations
stack-checker.state stack-checker.state
compiler.tree.comparisons compiler.tree.comparisons
compiler.tree.propagation.info compiler.tree.propagation.info
compiler.tree.propagation.nodes compiler.tree.propagation.nodes
compiler.tree.propagation.slots compiler.tree.propagation.slots
compiler.tree.propagation.simple compiler.tree.propagation.simple
compiler.tree.propagation.constraints ; compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect ;
IN: compiler.tree.propagation.known-words IN: compiler.tree.propagation.known-words
\ fixnum \ fixnum
@ -359,3 +360,15 @@ generic-comparison-ops [
[ swap equal? ] f ? [ swap equal? ] f ?
] [ drop f ] if ] [ drop f ] if
] "custom-inlining" set-word-prop ] "custom-inlining" set-word-prop
: inline-new ( class -- quot/f )
dup tuple-class? [
dup inlined-dependency depends-on
[ all-slots [ initial>> literalize ] map ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append [ drop ] prepend >quotation
] [ drop f ] if ;
\ new [
in-d>> first value-info literal>> inline-new
] "custom-inlining" set-word-prop

13
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -704,3 +704,16 @@ TUPLE: circle me ;
! Joe found an oversight ! Joe found an oversight
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test [ V{ integer } ] [ [ >integer ] final-classes ] unit-test
TUPLE: foo bar ;
[ t ] [ [ foo new ] { new } inlined? ] unit-test
GENERIC: whatever ( x -- y )
M: number whatever drop foo ;
[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
: that-thing ( -- class ) foo ;
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test

11
basis/cpu/x86/x86.factor
View File

@ -4,9 +4,14 @@ USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
kernel kernel.private math memory namespaces make sequences kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers compiler.constants
compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.registers
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ; compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.codegen
compiler.codegen.fixup ;
IN: cpu.x86 IN: cpu.x86
<< enable-fixnum-log2 >> << enable-fixnum-log2 >>

2
basis/math/matrices/matrices.factor
View File

@ -120,7 +120,7 @@ IN: math.matrices
PRIVATE> PRIVATE>
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ; : cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
: proj ( v u -- w ) : proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ; [ [ v. ] [ norm-sq ] bi / ] keep n*v ;

38
basis/opengl/opengl-docs.factor
View File

@ -1,5 +1,5 @@
USING: alien help.markup help.syntax io kernel math quotations USING: alien help.markup help.syntax io kernel math quotations
opengl.gl assocs vocabs.loader sequences accessors colors ; opengl.gl assocs vocabs.loader sequences accessors colors words ;
IN: opengl IN: opengl
HELP: gl-color HELP: gl-color
@ -8,7 +8,35 @@ HELP: gl-color
{ $notes "See " { $link "colors" } "." } ; { $notes "See " { $link "colors" } "." } ;
HELP: gl-error HELP: gl-error
{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ; { $description "If the most recent OpenGL call resulted in an error, throw a " { $snippet "gl-error" } " instance reporting the error." } ;
HELP: log-gl-error
{ $values { "function" word } }
{ $description "If the most recent OpenGL call resulted in an error, append it to the " { $link gl-error-log } "." }
{ $notes "Don't call this function directly. Call " { $link log-gl-errors } " to annotate every OpenGL function to automatically log errors." } ;
HELP: gl-error-log
{ $var-description "A vector of OpenGL errors logged by " { $link log-gl-errors } ". Each log entry has the following tuple slots:" }
{ $list
{ { $snippet "function" } " is the OpenGL function that raised the error." }
{ { $snippet "error" } " is the OpenGL error code." }
{ { $snippet "timestamp" } " is the time the error was logged." }
}
{ "The error log is emptied using the " { $link clear-gl-error-log } " word." } ;
HELP: clear-gl-error-log
{ $description "Empties the OpenGL error log populated by " { $link log-gl-errors } "." } ;
HELP: throw-gl-errors
{ $description "Annotate every OpenGL function to throw a " { $link gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
HELP: log-gl-errors
{ $description "Annotate every OpenGL function to log using " { $link log-gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
HELP: reset-gl-functions
{ $description "Removes any annotations from all OpenGL functions, such as those applied by " { $link throw-gl-errors } " or " { $link log-gl-errors } "." } ;
{ throw-gl-errors gl-error log-gl-errors log-gl-error clear-gl-error-log reset-gl-functions } related-words
HELP: do-enabled HELP: do-enabled
{ $values { "what" integer } { "quot" quotation } } { $values { "what" integer } { "quot" quotation } }
@ -73,6 +101,12 @@ ARTICLE: "gl-utilities" "OpenGL utility words"
$nl $nl
"The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings." "The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings."
{ $subsection "opengl-low-level" } { $subsection "opengl-low-level" }
"Error reporting:"
{ $subsection gl-error }
{ $subsection throw-gl-errors }
{ $subsection log-gl-errors }
{ $subsection clear-gl-error-log }
{ $subsection reset-gl-functions }
"Wrappers:" "Wrappers:"
{ $subsection gl-color } { $subsection gl-color }
{ $subsection gl-translate } { $subsection gl-translate }

61
basis/opengl/opengl.factor Normal file → Executable file
View File

@ -2,11 +2,13 @@
! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff. ! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros USING: alien alien.c-types ascii calendar combinators.short-circuit
namespaces math.vectors math.parser opengl.gl combinators continuations kernel libc math macros namespaces math.vectors
combinators.smart arrays sequences splitting words byte-arrays assocs math.parser opengl.gl combinators combinators.smart arrays
sequences splitting words byte-arrays assocs vocabs
colors colors.constants accessors generalizations locals fry colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ; specialized-arrays.float specialized-arrays.uint
tools.annotations tools.annotations.private compiler.units ;
IN: opengl IN: opengl
: gl-color ( color -- ) >rgba-components glColor4d ; inline : gl-color ( color -- ) >rgba-components glColor4d ; inline
@ -28,12 +30,55 @@ IN: opengl
{ HEX: 0506 "Invalid framebuffer operation" } { HEX: 0506 "Invalid framebuffer operation" }
} at "Unknown error" or ; } at "Unknown error" or ;
TUPLE: gl-error code string ; TUPLE: gl-error function code string ;
TUPLE: gl-error-log
{ function word initial: t }
{ error gl-error }
{ timestamp timestamp } ;
gl-error-log [ V{ } clone ] initialize
: <gl-error> ( function code -- gl-error )
dup error>string \ gl-error boa ; inline
: <gl-error-log> ( function code -- gl-error-log )
[ dup ] dip <gl-error> now gl-error-log boa ;
: gl-error-code ( -- code/f )
glGetError dup 0 = [ drop f ] when ; inline
: (gl-error) ( function -- )
gl-error-code [ <gl-error> throw ] [ drop ] if* ;
: gl-error ( -- ) : gl-error ( -- )
glGetError dup 0 = [ drop ] [ f (gl-error) ; inline
dup error>string \ gl-error boa throw
] if ; : log-gl-error ( function -- )
gl-error-code [ <gl-error-log> gl-error-log get push ] [ drop ] if* ;
: gl-function? ( word -- ? )
name>> { [ "glGetError" = not ] [ "gl" head? ] [ third LETTER? ] } 1&& ;
: gl-functions ( -- words )
"opengl.gl" vocab words [ gl-function? ] filter ;
: annotate-gl-functions ( quot -- )
[
[ gl-functions ] dip [ [ dup ] dip curry (annotate) ] curry each
] with-compilation-unit ;
: reset-gl-functions ( -- )
[ gl-functions [ (reset) ] each ] with-compilation-unit ;
: clear-gl-error-log ( -- )
V{ } clone gl-error-log set ;
: throw-gl-errors ( -- )
[ '[ @ _ (gl-error) ] ] annotate-gl-functions ;
: log-gl-errors ( -- )
[ '[ @ _ log-gl-error ] ] annotate-gl-functions ;
: do-enabled ( what quot -- ) : do-enabled ( what quot -- )
over glEnable dip glDisable ; inline over glEnable dip glDisable ; inline

4
basis/specialized-vectors/functor/functor.factor
View File

@ -1,6 +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: functors sequences sequences.private growable USING: accessors alien.c-types functors sequences sequences.private growable
prettyprint.custom kernel words classes math parser ; prettyprint.custom kernel words classes math parser ;
QUALIFIED: vectors.functor QUALIFIED: vectors.functor
IN: specialized-vectors.functor IN: specialized-vectors.functor
@ -21,6 +21,8 @@ V A <A> vectors.functor:define-vector
M: V contract 2drop ; M: V contract 2drop ;
M: V byte-length underlying>> byte-length ;
M: V pprint-delims drop \ V{ \ } ; M: V pprint-delims drop \ V{ \ } ;
M: V >pprint-sequence ; M: V >pprint-sequence ;

1
basis/stack-checker/call-effect/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

16
basis/stack-checker/call-effect/call-effect-tests.factor
View File

@ -1,16 +0,0 @@
USING: stack-checker.call-effect tools.test kernel math effects ;
IN: stack-checker.call-effect.tests
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test

1
basis/stack-checker/known-words/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov Slava Pestov
Daniel Ehrenberg

92
basis/stack-checker/known-words/known-words.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors alien alien.accessors arrays byte-arrays classes USING: fry accessors alien alien.accessors arrays byte-arrays classes
continuations.private effects generic hashtables continuations.private effects generic hashtables
@ -67,12 +67,18 @@ IN: stack-checker.known-words
[ length ensure-d ] keep zip [ length ensure-d ] keep zip
#declare, ; #declare, ;
\ declare [ infer-declare ] "special" set-word-prop
GENERIC: infer-call* ( value known -- ) GENERIC: infer-call* ( value known -- )
: (infer-call) ( value -- ) dup known infer-call* ; : (infer-call) ( value -- ) dup known infer-call* ;
: infer-call ( -- ) pop-d (infer-call) ; : infer-call ( -- ) pop-d (infer-call) ;
\ call [ infer-call ] "special" set-word-prop
\ (call) [ infer-call ] "special" set-word-prop
M: literal infer-call* M: literal infer-call*
[ 1array #drop, ] [ infer-literal-quot ] bi* ; [ 1array #drop, ] [ infer-literal-quot ] bi* ;
@ -103,10 +109,16 @@ M: object infer-call*
: infer-dip ( -- ) \ dip 1 infer-ndip ; : infer-dip ( -- ) \ dip 1 infer-ndip ;
\ dip [ infer-dip ] "special" set-word-prop
: infer-2dip ( -- ) \ 2dip 2 infer-ndip ; : infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
\ 2dip [ infer-2dip ] "special" set-word-prop
: infer-3dip ( -- ) \ 3dip 3 infer-ndip ; : infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
\ 3dip [ infer-3dip ] "special" set-word-prop
: infer-builder ( quot word -- ) : infer-builder ( quot word -- )
[ [
[ 2 consume-d ] dip [ 2 consume-d ] dip
@ -116,8 +128,12 @@ M: object infer-call*
: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ; : infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
\ curry [ infer-curry ] "special" set-word-prop
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ; : infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
\ compose [ infer-compose ] "special" set-word-prop
: infer-execute ( -- ) : infer-execute ( -- )
pop-literal nip pop-literal nip
dup word? [ dup word? [
@ -127,11 +143,17 @@ M: object infer-call*
"execute must be given a word" time-bomb "execute must be given a word" time-bomb
] if ; ] if ;
\ execute [ infer-execute ] "special" set-word-prop
\ (execute) [ infer-execute ] "special" set-word-prop
: infer-<tuple-boa> ( -- ) : infer-<tuple-boa> ( -- )
\ <tuple-boa> \ <tuple-boa>
peek-d literal value>> second 1+ { tuple } <effect> peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ; apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
: infer-effect-unsafe ( word -- ) : infer-effect-unsafe ( word -- )
pop-literal nip pop-literal nip
add-effect-input add-effect-input
@ -140,17 +162,30 @@ M: object infer-call*
: infer-execute-effect-unsafe ( -- ) : infer-execute-effect-unsafe ( -- )
\ (execute) infer-effect-unsafe ; \ (execute) infer-effect-unsafe ;
\ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
: infer-call-effect-unsafe ( -- ) : infer-call-effect-unsafe ( -- )
\ call infer-effect-unsafe ; \ call infer-effect-unsafe ;
\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
: infer-exit ( -- ) : infer-exit ( -- )
\ exit (( n -- * )) apply-word/effect ; \ exit (( n -- * )) apply-word/effect ;
\ exit [ infer-exit ] "special" set-word-prop
: infer-load-locals ( -- ) : infer-load-locals ( -- )
pop-literal nip pop-literal nip
consume-d dup copy-values dup output-r consume-d dup copy-values dup output-r
[ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ; [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
\ load-locals [ infer-load-locals ] "special" set-word-prop
: infer-load-local ( -- )
1 infer->r ;
\ load-local [ infer-load-local ] "special" set-word-prop
: infer-get-local ( -- ) : infer-get-local ( -- )
[let* | n [ pop-literal nip 1 swap - ] [let* | n [ pop-literal nip 1 swap - ]
in-r [ n consume-r ] in-r [ n consume-r ]
@ -163,36 +198,34 @@ M: object infer-call*
#shuffle, #shuffle,
] ; ] ;
\ get-local [ infer-get-local ] "special" set-word-prop
: infer-drop-locals ( -- ) : infer-drop-locals ( -- )
f f pop-literal nip consume-r f f #shuffle, ; f f pop-literal nip consume-r f f #shuffle, ;
\ drop-locals [ infer-drop-locals ] "special" set-word-prop
: infer-call-effect ( word -- )
1 ensure-d first literal value>>
add-effect-input add-effect-input
apply-word/effect ;
{ call-effect execute-effect } [
dup t "no-compile" set-word-prop
dup '[ _ infer-call-effect ] "special" set-word-prop
] each
\ do-primitive [ unknown-primitive-error ] "special" set-word-prop
\ if [ infer-if ] "special" set-word-prop
\ dispatch [ infer-dispatch ] "special" set-word-prop
\ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
\ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
\ alien-callback [ infer-alien-callback ] "special" set-word-prop
: infer-special ( word -- ) : infer-special ( word -- )
{ "special" word-prop call( -- ) ;
{ \ declare [ infer-declare ] }
{ \ call [ infer-call ] }
{ \ (call) [ infer-call ] }
{ \ dip [ infer-dip ] }
{ \ 2dip [ infer-2dip ] }
{ \ 3dip [ infer-3dip ] }
{ \ curry [ infer-curry ] }
{ \ compose [ infer-compose ] }
{ \ execute [ infer-execute ] }
{ \ (execute) [ infer-execute ] }
{ \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
{ \ call-effect-unsafe [ infer-call-effect-unsafe ] }
{ \ if [ infer-if ] }
{ \ dispatch [ infer-dispatch ] }
{ \ <tuple-boa> [ infer-<tuple-boa> ] }
{ \ exit [ infer-exit ] }
{ \ load-local [ 1 infer->r ] }
{ \ load-locals [ infer-load-locals ] }
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
{ \ do-primitive [ unknown-primitive-error ] }
{ \ alien-invoke [ infer-alien-invoke ] }
{ \ alien-indirect [ infer-alien-indirect ] }
{ \ alien-callback [ infer-alien-callback ] }
} case ;
: infer-local-reader ( word -- ) : infer-local-reader ( word -- )
(( -- value )) apply-word/effect ; (( -- value )) apply-word/effect ;
@ -209,10 +242,7 @@ M: object infer-call*
dispatch <tuple-boa> exit load-local load-locals get-local dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect drop-locals do-primitive alien-invoke alien-indirect
alien-callback alien-callback
} [ } [ t "no-compile" set-word-prop ] each
[ t "special" set-word-prop ]
[ t "no-compile" set-word-prop ] bi
] each
! Exceptions to the above ! Exceptions to the above
\ curry f "no-compile" set-word-prop \ curry f "no-compile" set-word-prop

6
basis/stack-checker/stack-checker-tests.factor
View File

@ -376,3 +376,9 @@ DEFER: eee'
! Found during code review ! Found during code review
[ [ [ drop [ ] ] when call ] infer ] must-fail [ [ [ drop [ ] ] when call ] infer ] must-fail
[ swap [ [ drop [ ] ] when call ] infer ] must-fail [ swap [ [ drop [ ] ] when call ] infer ] must-fail
{ 3 1 } [ call( a b -- c ) ] must-infer-as
{ 3 1 } [ execute( a b -- c ) ] must-infer-as
[ [ call-effect ] infer ] must-fail
[ [ execute-effect ] infer ] must-fail

2
basis/stack-checker/stack-checker.factor
View File

@ -15,5 +15,3 @@ M: callable infer ( quot -- effect )
: infer. ( quot -- ) : infer. ( quot -- )
#! Safe to call from inference transforms. #! Safe to call from inference transforms.
infer effect>string print ; infer effect>string print ;
"stack-checker.call-effect" require

9
basis/stack-checker/transforms/transforms.factor
View File

@ -108,15 +108,6 @@ IN: stack-checker.transforms
\ boa t "no-compile" set-word-prop \ boa t "no-compile" set-word-prop
\ new [
dup tuple-class? [
dup inlined-dependency depends-on
[ all-slots [ initial>> literalize ] map ]
[ tuple-layout '[ _ <tuple-boa> ] ]
bi append
] [ drop f ] if
] 1 define-transform
! Fast at for integer maps ! Fast at for integer maps
CONSTANT: lookup-table-at-max 256 CONSTANT: lookup-table-at-max 256

2
basis/tools/annotations/annotations-docs.factor
View File

@ -21,7 +21,7 @@ $nl
ABOUT: "tools.annotations" ABOUT: "tools.annotations"
HELP: annotate HELP: annotate
{ $values { "word" "a word" } { "quot" { $quotation "( word def -- def )" } } } { $values { "word" "a word" } { "quot" { $quotation "( old-def -- new-def )" } } }
{ $description "Changes a word definition to the result of applying a quotation to the old definition." } { $description "Changes a word definition to the result of applying a quotation to the old definition." }
{ $notes "This word is used to implement " { $link watch } "." } ; { $notes "This word is used to implement " { $link watch } "." } ;

40
basis/tools/annotations/annotations.factor
View File

@ -7,19 +7,24 @@ tools.time generic inspector fry tools.continuations
locals generalizations macros ; locals generalizations macros ;
IN: tools.annotations IN: tools.annotations
GENERIC: reset ( word -- ) <PRIVATE
M: generic reset GENERIC: (reset) ( word -- )
subwords [ reset ] each ;
M: word reset M: generic (reset)
subwords [ (reset) ] each ;
M: word (reset)
dup "unannotated-def" word-prop [ dup "unannotated-def" word-prop [
[
dup dup "unannotated-def" word-prop define dup dup "unannotated-def" word-prop define
] with-compilation-unit
f "unannotated-def" set-word-prop f "unannotated-def" set-word-prop
] [ drop ] if ; ] [ drop ] if ;
PRIVATE>
: reset ( word -- )
[ (reset) ] with-compilation-unit ;
ERROR: cannot-annotate-twice word ; ERROR: cannot-annotate-twice word ;
M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ; M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
@ -31,19 +36,20 @@ M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
cannot-annotate-twice cannot-annotate-twice
] when ; ] when ;
GENERIC# (annotate) 1 ( word quot -- )
M: generic (annotate)
[ "methods" word-prop values ] dip '[ _ (annotate) ] each ;
M: word (annotate)
[ check-annotate-twice ] dip
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip
call( old -- new ) define ;
PRIVATE> PRIVATE>
GENERIC# annotate 1 ( word quot -- ) : annotate ( word quot -- )
[ (annotate) ] with-compilation-unit ;
M: generic annotate
[ "methods" word-prop values ] dip '[ _ annotate ] each ;
M: word annotate
[ check-annotate-twice ] dip
[
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip
call( old -- new ) define
] with-compilation-unit ;
<PRIVATE <PRIVATE

2
basis/ui/gadgets/worlds/worlds.factor
View File

@ -163,9 +163,11 @@ M: world resize-world
M: world (>>dim) M: world (>>dim)
[ call-next-method ] [ call-next-method ]
[ [
dup active?>> [
dup handle>> dup handle>>
[ [ set-gl-context ] [ resize-world ] bi ] [ [ set-gl-context ] [ resize-world ] bi ]
[ drop ] if [ drop ] if
] [ drop ] if
] bi ; ] bi ;
GENERIC: draw-world* ( world -- ) GENERIC: draw-world* ( world -- )

3
core/sequences/sequences-tests.factor
View File

@ -291,3 +291,6 @@ 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

2
core/syntax/syntax-docs.factor
View File

@ -447,7 +447,7 @@ HELP: USING:
HELP: QUALIFIED: HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" } { $syntax "QUALIFIED: vocab" }
{ $description "Adds the vocabulary's words, prefixed with the vocabulary name, to the search path." } { $description "Adds the vocabulary's words, prefixed with the vocabulary name, to the search path." }
{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "finishing" } ". Then, the following will call the latter word:" { $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "fishing" } ". Then, the following will call the latter word:"
{ $code { $code
"USE: fish" "USE: fish"
"QUALIFIED: go" "QUALIFIED: go"

44
extra/bson/bson-tests.factor Normal file
View File

@ -0,0 +1,44 @@
USING: bson.reader bson.writer byte-arrays io.encodings.binary
io.streams.byte-array tools.test literals calendar kernel math ;
IN: bson.tests
: turnaround ( value -- value )
assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
[ H{ { "a list" { 1 2.234 "hello world" } } } ]
[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test
[ H{ { "a quotation" [ 1 2 + ] } } ]
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
[ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 }
{ day 11 }
{ hour 9 }
{ minute 8 }
{ second 40+77/1000 } } } }
]
[ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 }
{ day 11 }
{ hour 11 }
{ minute 8 }
{ second 40+15437/200000 }
{ gmt-offset T{ duration { hour 2 } } } } } } turnaround
] unit-test
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } }
]
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } turnaround ] unit-test