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
basis
compiler
cfg
branch-folding
branch-splitting
builder
cfg.factor
comparisons
instructions
intrinsics
linear-scan
linearization
local
optimizer
phi-elimination
renaming
stack-analysis
tco
useless-conditionals
utilities
value-numbering
tests
tree/propagation
cpu/x86
math/matrices
opengl
specialized-vectors/functor
stack-checker
tools/annotations
ui/gadgets/worlds

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

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

@ -1,37 +1,79 @@
! Copyright (C) 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math sequences
compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
USING: accessors combinators.short-circuit kernel math math.order
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
! Predecessors must be recomputed after this
: clone-renamings ( insns -- assoc )
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
: split-branch-for ( bb predecessor -- )
[
: clone-instructions ( insns -- insns' )
dup clone-renamings renamings [
[
<basic-block>
swap
[ instructions>> [ clone ] map >>instructions ]
[ successors>> clone >>successors ]
bi
] keep
] dip
[ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
drop ;
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>
swap
[ instructions>> clone-instructions >>instructions ]
[ successors>> clone >>successors ]
[ number>> >>number ]
tri ;
: new-blocks ( bb -- copies )
dup predecessors>> [
[ clone-basic-block ] dip
1vector >>predecessors
] with map ;
: update-predecessor-successor ( pred copy old-bb -- )
'[
[ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
] change-successors drop ;
: update-predecessor-successors ( copies old-bb -- )
[ predecessors>> swap ] keep
'[ _ update-predecessor-successor ] 2each ;
: update-successor-predecessor ( copies old-bb succ -- )
[
swap 1array split swap join V{ } like
] change-predecessors drop ;
: update-successor-predecessors ( copies old-bb -- )
dup successors>> [
update-successor-predecessor
] with with each ;
: split-branch ( bb -- )
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? ]
[ predecessors>> length 1 > ]
[ instructions>> [ defs-vregs ] any? not ]
[ instructions>> [ temp-vregs ] any? not ]
[ dup successors>> [ back-edge? ] with any? not ]
[ predecessors>> length 2 4 between? ]
[ instructions>> split-instructions? ]
} 1&& ;
: split-branches ( cfg -- cfg' )
dup [
dup split-branches? [ split-branch ] [ drop ] if
dup split-branch? [ split-branch ] [ drop ] if
] 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.registers
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.alien ;

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

@ -1,9 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays vectors accessors assocs sets
namespaces math make fry sequences
combinators.short-circuit
compiler.cfg.instructions ;
USING: kernel math vectors arrays accessors namespaces ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
@ -22,39 +19,12 @@ M: basic-block hashcode* nip id>> ;
V{ } clone >>predecessors
\ basic-block counter >>id ;
: empty-block? ( bb -- ? )
instructions>> {
[ length 1 = ]
[ first ##branch? ]
} 1&& ;
SYMBOL: visited
: (skip-empty-blocks) ( bb -- bb' )
dup visited get key? [
dup empty-block? [
dup visited get conjoin
successors>> first (skip-empty-blocks)
] when
] unless ;
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
building get pop
_ dip
building get push
] with-variable ; inline
: back-edge? ( from to -- ? )
[ number>> ] bi@ > ;
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr )

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 ;
! 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 ;
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.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
combinators fry
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.registers ;
compiler.cfg.registers
compiler.cfg.comparisons ;
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
@ -20,32 +21,8 @@ IN: compiler.cfg.intrinsics.fixnum
: tag-literal ( n -- tagged )
literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
: emit-fixnum-imm-op1 ( infos insn -- dst )
[ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; 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-op ( insn -- dst )
[ 2inputs ] dip call ds-push ; inline
: emit-fixnum-shift-fast ( node -- )
dup node-input-infos dup second value-info-small-fixnum? [
@ -65,34 +42,11 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum-log2 ( -- )
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
: emit-fixnum*fast ( -- )
2inputs ^^untag-fixnum ^^mul ds-push ;
: (emit-fixnum*fast-imm1) ( infos -- dst )
[ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
: (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-fixnum-comparison ( cc -- )
'[ _ ^^compare ] emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
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.float
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc ;
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: kernel
QUALIFIED: 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-sub ] 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 [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
{ \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ emit-eq ] }
{ \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
{ \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ 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.linearization
compiler.cfg.debugger
compiler.cfg.comparisons
compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
@ -1509,6 +1510,7 @@ SYMBOL: linear-scan-result
compute-liveness
dup reverse-post-order
{ { int-regs regs } } (linear-scan)
cfg-changed
flatten-cfg 1array mr.
] with-scope ;
@ -1803,7 +1805,7 @@ test-diamond
[ ] [ { 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
@ -1859,7 +1861,7 @@ V{
[ 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
@ -1926,7 +1928,7 @@ V{
[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
! 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
V{
@ -2484,7 +2486,7 @@ test-diamond
[ 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
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan
init-mapping
dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
cfg-changed
] 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
combinators.short-circuit fry kernel locals
make math sequences
compiler.cfg.utilities
compiler.cfg.instructions
compiler.cfg.linear-scan.assignment
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
] { } make ;
: fork? ( from to -- ? )
{
[ drop successors>> length 1 >= ]
[ nip predecessors>> length 1 = ]
} 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
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
mapping-instructions <simple-block>
insert-basic-block
] if ;
: resolve-edge-data-flow ( bb to -- )
[ compute-mappings ] [ perform-mappings ] 2bi ;
2dup compute-mappings perform-mappings ;
: resolve-block-data-flow ( bb -- )
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.rpo
compiler.cfg.liveness
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions ;
IN: compiler.cfg.linearization

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

@ -1,10 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! 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
: optimize-basic-block ( bb init-quot insn-quot -- )
[ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
:: optimize-basic-block ( bb init-quot insn-quot -- )
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' )
[ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
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
compiler.cfg.debugger compiler.cfg.def-use
compiler.cfg.instructions fry kernel kernel.private math
math.private sbufs sequences sequences.private sets
slots.private strings tools.test vectors layouts ;
math.partial-dispatch math.private sbufs sequences sequences.private sets
slots.private strings strings.private tools.test vectors layouts ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
@ -31,6 +31,19 @@ IN: compiler.cfg.optimizer.tests
[ [ 2 fixnum+ ] when 3 ]
[ [ 2 fixnum- ] when 3 ]
[ 10000 [ ] times ]
[
over integer? [
over dup 16 <-integer-fixnum
[ 0 >=-integer-fixnum ] [ drop f ] if [
nip dup
[ ] [ ] if
] [ 2drop f ] if
] [ 2drop f ] if
]
[
pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
set-string-nth-fast
]
} [
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each

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

@ -9,7 +9,6 @@ compiler.cfg.branch-splitting
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
compiler.cfg.branch-folding
compiler.cfg.write-barrier
compiler.cfg.liveness
compiler.cfg.rpo
@ -29,15 +28,13 @@ SYMBOL: check-optimizer?
! The passes that need this document it.
[
optimize-tail-calls
compute-predecessors
delete-useless-conditionals
split-branches
compute-predecessors
split-branches
stack-analysis
compute-liveness
alias-analysis
value-numbering
fold-branches
compute-predecessors
eliminate-dead-code
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
USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors
sequences classes namespaces tools.test cpu.architecture arrays ;
compiler.cfg.comparisons compiler.cfg.debugger
compiler.cfg.phi-elimination kernel accessors sequences classes
namespaces tools.test cpu.architecture arrays ;
V{ T{ ##branch } } 0 test-bb
@ -35,6 +36,12 @@ test-diamond
[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
[ T{ ##copy f V int-regs 3 V int-regs 1 } ]
[ 2 get successors>> first instructions>> first ]
unit-test
[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
[ 3 get successors>> first instructions>> first ]
unit-test
[ 2 ] [ 4 get instructions>> length ] unit-test

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

@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
USING: accessors assocs fry kernel sequences namespaces
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
@ -11,7 +12,11 @@ IN: compiler.cfg.phi-elimination
[ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
: eliminate-phi-step ( bb -- )
instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
H{ } clone added-instructions set
[ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ]
[ insert-basic-blocks ]
bi ;
: eliminate-phis ( cfg -- cfg' )
dup [ eliminate-phi-step ] each-basic-block ;
dup [ eliminate-phi-step ] each-basic-block
cfg-changed ;

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

@ -55,6 +55,12 @@ M: ##string-nth rename-insn-uses
[ rename-value ] change-index
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
dup call-next-method
[ rename-value ] change-obj

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

@ -1,8 +1,8 @@
IN: compiler.cfg.stack-analysis.merge.tests
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg compiler.cfg.registers compiler.cfg.debugger
cpu.architecture make assocs
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
compiler.cfg.debugger cpu.architecture make assocs namespaces
sequences kernel classes ;
[
@ -11,13 +11,15 @@ sequences kernel classes ;
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
<state> H{ { D 0 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs locs>vregs>> keys ] { } make first inputs>> values
H{ } clone added-instructions set
V{ } clone added-phis set
merge-locs locs>vregs>> keys added-phis get values first
] unit-test
[
@ -26,15 +28,16 @@ sequences kernel classes ;
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
[
<state>
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
<state>
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
[ merge-locs locs>vregs>> keys ] { } make drop
] keep first instructions>> first class
H{ } clone added-instructions set
V{ } clone added-phis set
[ merge-locs locs>vregs>> keys ] { } make drop
1 get added-instructions get at first class
] unit-test
[
@ -42,15 +45,17 @@ sequences kernel classes ;
] [
<state>
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
<basic-block> V{ T{ ##branch } } >>instructions dup 1 set
<basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
[
<state> -1 >>ds-height
<state> 2array
H{ } clone added-instructions set
V{ } clone added-phis set
[ merge-ds-heights ds-height>> ] { } make drop
] keep first instructions>> first class
<state> -1 >>ds-height
<state> 2array
[ merge-ds-heights ds-height>> ] { } make drop
1 get added-instructions get at first class
] unit-test
[
@ -63,6 +68,9 @@ sequences kernel classes ;
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
H{ } clone added-instructions set
V{ } clone added-phis set
[
<state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
<state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
@ -82,6 +90,9 @@ sequences kernel classes ;
<basic-block> V{ T{ ##branch } } >>instructions
<basic-block> V{ T{ ##branch } } >>instructions 2array
H{ } clone added-instructions set
V{ } clone added-phis set
[
<state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
<state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array

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

@ -1,12 +1,11 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping
sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.stack-analysis.state ;
USING: kernel assocs sequences accessors fry combinators grouping sets
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
IN: compiler.cfg.stack-analysis.merge
! XXX critical edges
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
[ nip first >>rs-height ]
[ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
: assoc-map-values ( assoc quot -- assoc' )
: assoc-map-keys ( assoc quot -- assoc' )
'[ _ dip ] assoc-map ; inline
: translate-locs ( assoc state -- assoc' )
'[ _ translate-loc ] assoc-map-values ;
'[ _ translate-loc ] assoc-map-keys ;
: untranslate-locs ( assoc state -- assoc' )
'[ _ untranslate-loc ] assoc-map-values ;
'[ _ untranslate-loc ] assoc-map-keys ;
: collect-locs ( loc-maps states -- assoc )
! assoc maps locs to sequences
@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
: insert-peek ( predecessor loc state -- vreg )
'[ _ _ translate-loc ^^peek ] add-instructions ;
SYMBOL: added-phis
: add-phi-later ( inputs -- vreg )
[ int-regs next-vreg dup ] dip 2array added-phis get push ;
: merge-loc ( predecessors vregs loc state -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
[ dup ] 3dip
'[ [ ] [ _ _ insert-peek ] ?if ] 2map
dup all-equal? [ nip first ] [ zip ^^phi ] if ;
dup all-equal? [ first ] [ add-phi-later ] if ;
:: merge-locs ( state predecessors states -- state )
states [ locs>vregs>> ] map states collect-locs
@ -77,30 +80,35 @@ IN: compiler.cfg.stack-analysis.merge
over translate-locs
>>changed-locs ;
ERROR: cannot-merge-poisoned states ;
:: insert-phis ( bb -- )
bb predecessors>> :> predecessors
[
added-phis get [| dst inputs |
dst predecessors inputs zip ##phi
] assoc-each
] V{ } make bb instructions>> over push-all
bb (>>instructions) ;
: multiple-predecessors ( bb states -- state )
dup [ not ] any? [
2drop <state>
:: multiple-predecessors ( bb states -- state )
states [ not ] any? [
<state>
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
] [
[ state new ] 2dip
[ predecessors>> ] dip
{
[ merge-ds-heights ]
[ merge-rs-heights ]
[ merge-locs ]
[ nip merge-actual-locs ]
[ nip merge-changed-locs ]
} 2cleave
] if
[
H{ } clone added-instructions set
V{ } clone added-phis set
bb predecessors>> :> predecessors
state new
predecessors states merge-ds-heights
predecessors states merge-rs-heights
predecessors states merge-locs
states merge-actual-locs
states merge-changed-locs
bb insert-basic-blocks
bb insert-phis
] with-scope
] if ;
: merge-states ( bb states -- state )
! If any states are poisoned, save all registers
! to the stack in each branch
dup length {
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }

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
! ##peeks should be inserted before a ##loop-entry
! Don't optimize out the constants
[ 1 t ] [
[ t ] [
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
[ ##load-immediate? ] any?
] unit-test
! Correct height tracking
[ t ] [
[ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
reverse-post-order 3 swap nth
reverse-post-order 4 swap nth
instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
2array { D 1 D 0 } set=
] unit-test
@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
stack-analysis
drop
3 get instructions>> second loc>>
3 get successors>> first instructions>> first loc>>
] unit-test
! Do inserted ##peeks reference the correct stack location if
@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
stack-analysis
drop
3 get instructions>> [ ##peek? ] find nip loc>>
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
] unit-test
! Missing ##replace
@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
! Inserted ##peeks reference the wrong stack location
[ t ] [
[ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
eliminate-dead-code reverse-post-order 3 swap nth
eliminate-dead-code reverse-post-order 4 swap nth
instructions>> [ ##peek? ] filter [ loc>> ] map
{ R 0 D 0 D 1 } set=
{ D 0 D 1 } set=
] unit-test
[ D 0 ] [
@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
stack-analysis
drop
3 get instructions>> [ ##peek? ] find nip loc>>
3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
] unit-test

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

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping
sets make combinators
sets make combinators dlists deques
compiler.cfg
compiler.cfg.copy-prop
compiler.cfg.def-use
@ -10,9 +10,14 @@ compiler.cfg.registers
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.stack-analysis.state
compiler.cfg.stack-analysis.merge ;
compiler.cfg.stack-analysis.merge
compiler.cfg.utilities ;
IN: compiler.cfg.stack-analysis
SYMBOL: work-list
: add-to-work-list ( bb -- ) work-list get push-front ;
: redundant-replace? ( vreg loc -- ? )
dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
@ -137,10 +142,21 @@ SYMBOLS: state-in state-out ;
] 2bi
] V{ } make >>instructions drop ;
: visit-successors ( bb -- )
dup successors>> [
2dup back-edge? [ 2drop ] [ nip add-to-work-list ] if
] with each ;
: process-work-list ( -- )
work-list get [ visit-block ] slurp-deque ;
: stack-analysis ( cfg -- cfg' )
[
<hashed-dlist> work-list set
H{ } clone copies set
H{ } clone state-in set
H{ } clone state-out set
dup [ visit-block ] each-basic-block
dup [ add-to-work-list ] each-basic-block
process-work-list
cfg-changed
] with-scope ;

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

@ -5,7 +5,8 @@ namespaces sequences fry combinators
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.instructions ;
compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.tco
! Tail call optimization. You must run compute-predecessors after this
@ -82,4 +83,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn
: optimize-tail-calls ( cfg -- cfg' )
dup cfg set
dup [ optimize-tail-call ] each-basic-block
f >>post-order ;
cfg-changed ;

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

@ -1,7 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences math combinators combinators.short-circuit
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities ;
IN: compiler.cfg.useless-conditionals
: delete-conditional? ( bb -- ? )
@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block
f >>post-order ;
cfg-changed ;

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.
USING: accessors kernel math layouts make sequences combinators
cpu.architecture namespaces compiler.cfg
compiler.cfg.instructions ;
USING: accessors assocs combinators combinators.short-circuit
compiler.cfg compiler.cfg.instructions cpu.architecture kernel
layouts locals make math namespaces sequences sets vectors fry ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
@ -33,7 +33,53 @@ IN: compiler.cfg.utilities
building off
basic-block off ;
: stop-iterating ( -- next ) end-basic-block f ;
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;
: back-edge? ( from to -- ? )
[ number>> ] bi@ >= ;
: empty-block? ( bb -- ? )
instructions>> {
[ length 1 = ]
[ first ##branch? ]
} 1&& ;
SYMBOL: visited
: (skip-empty-blocks) ( bb -- bb' )
dup visited get key? [
dup empty-block? [
dup visited get conjoin
successors>> first (skip-empty-blocks)
] when
] unless ;
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
! assoc mapping predecessors to sequences
SYMBOL: added-instructions
: add-instructions ( predecessor quot -- )
[
added-instructions get
[ drop V{ } clone ] cache
building
] dip with-variable ; inline
:: insert-basic-block ( from to bb -- )
bb from 1vector >>predecessors drop
bb to 1vector >>successors drop
to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
: <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 ;

27
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.
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
! Referentially-transparent expressions
@ -11,15 +12,29 @@ TUPLE: binary-expr < expr in1 in2 ;
TUPLE: commutative-expr < binary-expr ;
TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
TUPLE: reference-expr < expr value ;
: <constant> ( constant -- expr )
f swap constant-expr boa ; inline
M: constant-expr equal?
over constant-expr? [
[ [ value>> ] bi@ = ]
[ [ value>> class ] bi@ = ] 2bi
and
{
[ [ value>> class ] bi@ = ]
[ [ value>> ] bi@ = ]
} 2&&
] [ 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 ;
! 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-reference >expr obj>> <reference> ;
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;

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

@ -1,16 +1,32 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! 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
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.graph
compiler.cfg.value-numbering.simplify ;
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 -- ? )
dup ##compare-imm-branch? [
@ -49,13 +65,16 @@ M: insn rewrite ;
[ src2>> tag-mask get bitand 0 = ]
} 1&& ; inline
: tagged>constant ( n -- n' )
tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
[ src2>> tag-bits get neg shift ]
[ src2>> tagged>constant ]
[ cc>> ]
tri ; inline
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
@ -64,41 +83,6 @@ M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
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 -- ? )
{
[ src1>> vreg>expr compare-expr? ]
@ -114,101 +98,253 @@ M: ##compare-imm-branch rewrite
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
M: ##compare-imm rewrite
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 ;
ERROR: bad-comparison ;
: constant-fold ( insn -- insn' )
dup dst>> vreg>expr dup constant-expr? [
[ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn
dup number-values
] [
drop
: (fold-compare-imm) ( insn -- ? )
[ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
pick integer?
[ [ <=> ] dip evaluate-cc ]
[
2nip {
{ cc= [ f ] }
{ cc/= [ t ] }
[ bad-comparison ]
} case
] if ;
: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn )
[ cell-bits bits ] dip over small-enough? [
new-insn dup number-values nip
] [
2drop 2drop
] if constant-fold ; inline
: fold-compare-imm? ( insn -- ? )
src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
: new-imm-insn ( insn dst src n op -- n' op' )
2dup [ sgn ] dip 2array
: fold-branch ( ? -- insn )
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) ] }
{ { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] }
[ drop (new-imm-insn) ]
} case ; inline
{ [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
{ [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
[ drop f ]
} cond ;
: combine-imm? ( insn op -- ? )
[ src1>> vreg>expr op>> ] dip = ;
: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
[ [ 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>> ]
[ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
[ src2>> ]
} cleave
] [ call ] [ ] tri* new-imm-insn ; inline
[ ]
} cleave constant-fold*
] dip
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
:: combine-imm ( insn quot op -- insn )
insn op combine-imm? [
insn quot op (combine-imm)
] [
insn
] if ; inline
M: ##add-imm rewrite
M: ##add-imm rewrite*
{
{ [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] }
{ [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] }
[ ]
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##add-imm reassociate ] }
[ drop f ]
} 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 \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] }
[ ]
{ [ dup constant-fold? ] [ constant-fold ] }
[ sub-imm>add-imm ]
} cond ;
M: ##mul-imm rewrite
dup src2>> dup power-of-2? [
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
dup number-values
] [
drop [ * ] \ ##mul-imm combine-imm
] if ;
: strength-reduce-mul ( insn -- insn' )
[ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
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 -- ? )
src2>> {
[ vreg>expr constant-expr? ]
[ vreg>constant small-enough? ]
} 1&& ;
M: ##or-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##add rewrite
dup rewrite-add? [
[ dst>> ]
[ src1>> ]
[ src2>> vreg>constant ] tri \ ##add-imm new-insn
dup number-values
] when ;
M: ##xor-imm rewrite*
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
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-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
@ -44,18 +46,54 @@ M: unary-expr simplify*
: simplify-sub ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} 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?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shift ( expr -- vn/expr/f )
>binary-expr<
2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
: simplify-shr ( expr -- vn/expr/f )
>binary-expr< {
{ [ 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*
dup op>> {
@ -63,8 +101,17 @@ M: binary-expr simplify*
{ \ ##add-imm [ simplify-add ] }
{ \ ##sub [ simplify-sub ] }
{ \ ##sub-imm [ simplify-sub ] }
{ \ ##shr-imm [ simplify-shift ] }
{ \ ##sar-imm [ simplify-shift ] }
{ \ ##mul [ simplify-mul ] }
{ \ ##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 ]
} 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.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences fry
compiler.cfg
compiler.cfg.local
compiler.cfg.liveness
compiler.cfg.renaming
@ -11,6 +12,8 @@ compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
! Local value numbering. Predecessors must be recomputed after this
: number-input-values ( live-in -- )
[ [ f next-input-expr simplify ] dip set-vn ] each ;
@ -29,8 +32,8 @@ IN: compiler.cfg.value-numbering
] with-variable ;
: value-numbering-step ( insns -- insns' )
[ [ number-values ] [ rewrite ] bi ] map
dup rename-uses ;
[ rewrite ] map dup rename-uses ;
: value-numbering ( cfg -- cfg' )
[ init-value-numbering ] [ value-numbering-step ] local-optimization ;
[ init-value-numbering ] [ value-numbering-step ] local-optimization
cfg-changed ;

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

@ -314,4 +314,11 @@ M: cucumber equal? "The cucumber has no equal" throw ;
! Regression from Doug's value numbering changes
[ 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.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
stack-checker stack-checker.transforms words math ;
IN: stack-checker.call-effect
words math stack-checker stack-checker.transforms
compiler.tree.propagation.info slots.private ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
@ -84,18 +85,14 @@ M: quotation cached-effect
[ drop call-effect-slow ]
if ; inline
\ call-effect [
inline-cache new '[
_
3dup nip cache-hit? [
drop call-effect-unsafe
] [
call-effect-fast
] if
]
] 0 define-transform
: call-effect-ic ( quot effect inline-cache -- )
3dup nip cache-hit?
[ drop call-effect-unsafe ]
[ call-effect-fast ]
if ; inline
\ 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 ] ] dip call-effect-slow ; inline
@ -116,8 +113,72 @@ M: quotation cached-effect
if ; inline
: 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
splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private
vectors hashtables generic
vectors hashtables generic quotations
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.slots
compiler.tree.propagation.simple
compiler.tree.propagation.constraints ;
compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect ;
IN: compiler.tree.propagation.known-words
\ fixnum
@ -359,3 +360,15 @@ generic-comparison-ops [
[ swap equal? ] f ?
] [ drop f ] if
] "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
[ 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
kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
compiler.constants
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.codegen
compiler.codegen.fixup ;
IN: cpu.x86
<< enable-fixnum-log2 >>

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

@ -120,7 +120,7 @@ IN: math.matrices
PRIVATE>
: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
: proj ( v u -- w )
[ [ 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
opengl.gl assocs vocabs.loader sequences accessors colors ;
opengl.gl assocs vocabs.loader sequences accessors colors words ;
IN: opengl
HELP: gl-color
@ -8,7 +8,35 @@ HELP: gl-color
{ $notes "See " { $link "colors" } "." } ;
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
{ $values { "what" integer } { "quot" quotation } }
@ -73,6 +101,12 @@ ARTICLE: "gl-utilities" "OpenGL utility words"
$nl
"The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings."
{ $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:"
{ $subsection gl-color }
{ $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) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.parser opengl.gl combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
USING: alien alien.c-types ascii calendar combinators.short-circuit
continuations kernel libc math macros namespaces math.vectors
math.parser opengl.gl combinators combinators.smart arrays
sequences splitting words byte-arrays assocs vocabs
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
: gl-color ( color -- ) >rgba-components glColor4d ; inline
@ -28,12 +30,55 @@ IN: opengl
{ HEX: 0506 "Invalid framebuffer operation" }
} 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 ( -- )
glGetError dup 0 = [ drop ] [
dup error>string \ gl-error boa throw
] if ;
f (gl-error) ; inline
: 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 -- )
over glEnable dip glDisable ; inline

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

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! 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 ;
QUALIFIED: vectors.functor
IN: specialized-vectors.functor
@ -21,6 +21,8 @@ V A <A> vectors.functor:define-vector
M: V contract 2drop ;
M: V byte-length underlying>> byte-length ;
M: V pprint-delims drop \ V{ \ } ;
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
Daniel Ehrenberg

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

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

@ -375,4 +375,10 @@ DEFER: eee'
! Found during code review
[ [ [ 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 -- )
#! Safe to call from inference transforms.
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
\ 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
CONSTANT: lookup-table-at-max 256

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

@ -21,7 +21,7 @@ $nl
ABOUT: "tools.annotations"
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." }
{ $notes "This word is used to implement " { $link watch } "." } ;

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

@ -7,19 +7,24 @@ tools.time generic inspector fry tools.continuations
locals generalizations macros ;
IN: tools.annotations
GENERIC: reset ( word -- )
<PRIVATE
M: generic reset
subwords [ reset ] each ;
GENERIC: (reset) ( word -- )
M: word reset
M: generic (reset)
subwords [ (reset) ] each ;
M: word (reset)
dup "unannotated-def" word-prop [
[
dup dup "unannotated-def" word-prop define
] with-compilation-unit
dup dup "unannotated-def" word-prop define
f "unannotated-def" set-word-prop
] [ drop ] if ;
PRIVATE>
: reset ( word -- )
[ (reset) ] with-compilation-unit ;
ERROR: cannot-annotate-twice word ;
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
] 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>
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
] with-compilation-unit ;
: annotate ( word quot -- )
[ (annotate) ] with-compilation-unit ;
<PRIVATE

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

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

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

@ -290,4 +290,7 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
USE: make
[ { "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:
{ $syntax "QUALIFIED: vocab" }
{ $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
"USE: fish"
"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