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

db4
Daniel Ehrenberg 2009-07-16 22:42:39 -05:00
commit 3ca5665ad6
42 changed files with 300 additions and 461 deletions

View File

@ -0,0 +1,43 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel sequences math
compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities ;
IN: compiler.cfg.block-joining
! Joining blocks that are not calls and are connected by a single CFG edge.
! Predecessors must be recomputed after this. Also this pass does not
! update ##phi nodes and should therefore only run before stack analysis.
: kill-vreg-block? ( bb -- ? )
instructions>> {
[ length 2 >= ]
[ penultimate kill-vreg-insn? ]
} 1&& ;
: predecessor ( bb -- pred )
predecessors>> first ; inline
: join-block? ( bb -- ? )
{
[ predecessors>> length 1 = ]
[ predecessor kill-vreg-block? not ]
[ predecessor successors>> length 1 = ]
[ [ predecessor ] keep back-edge? not ]
} 1&& ;
: join-instructions ( bb pred -- )
[ instructions>> ] bi@ dup pop* push-all ;
: update-successors ( bb pred -- )
[ successors>> ] dip (>>successors) ;
: join-block ( bb pred -- )
[ join-instructions ] [ update-successors ] 2bi ;
: join-blocks ( cfg -- cfg' )
dup post-order [
dup join-block?
[ dup predecessor join-block ] [ drop ] if
] each
cfg-changed ;

View File

@ -1,6 +1,6 @@
USING: accessors assocs compiler.cfg
compiler.cfg.branch-splitting compiler.cfg.debugger
compiler.cfg.predecessors compiler.cfg.rpo fry kernel
compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel
tools.test namespaces sequences vectors ;
IN: compiler.cfg.branch-splitting.tests
@ -20,31 +20,31 @@ IN: compiler.cfg.branch-splitting.tests
: test-branch-splitting ( -- )
cfg new 0 get >>entry check-branch-splitting ;
V{ } 0 test-bb
V{ T{ ##branch } } 0 test-bb
V{ } 1 test-bb
V{ T{ ##branch } } 1 test-bb
V{ } 2 test-bb
V{ T{ ##branch } } 2 test-bb
V{ } 3 test-bb
V{ T{ ##branch } } 3 test-bb
V{ } 4 test-bb
V{ T{ ##branch } } 4 test-bb
test-diamond
[ ] [ test-branch-splitting ] unit-test
V{ } 0 test-bb
V{ T{ ##branch } } 0 test-bb
V{ } 1 test-bb
V{ T{ ##branch } } 1 test-bb
V{ } 2 test-bb
V{ T{ ##branch } } 2 test-bb
V{ } 3 test-bb
V{ T{ ##branch } } 3 test-bb
V{ } 4 test-bb
V{ T{ ##branch } } 4 test-bb
V{ } 5 test-bb
V{ T{ ##branch } } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
@ -54,15 +54,15 @@ V{ } 5 test-bb
[ ] [ test-branch-splitting ] unit-test
V{ } 0 test-bb
V{ T{ ##branch } } 0 test-bb
V{ } 1 test-bb
V{ T{ ##branch } } 1 test-bb
V{ } 2 test-bb
V{ T{ ##branch } } 2 test-bb
V{ } 3 test-bb
V{ T{ ##branch } } 3 test-bb
V{ } 4 test-bb
V{ T{ ##branch } } 4 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
@ -72,11 +72,11 @@ V{ } 4 test-bb
[ ] [ test-branch-splitting ] unit-test
V{ } 0 test-bb
V{ T{ ##branch } } 0 test-bb
V{ } 1 test-bb
V{ T{ ##branch } } 1 test-bb
V{ } 2 test-bb
V{ T{ ##branch } } 2 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop

View File

@ -63,7 +63,9 @@ IN: compiler.cfg.branch-splitting
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
: split-instructions? ( insns -- ? )
[ irrelevant? not ] count 5 <= ;
[ [ irrelevant? not ] count 5 <= ]
[ last ##fixnum-overflow? not ]
bi and ;
: split-branch? ( bb -- ? )
{

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
@ -36,12 +36,6 @@ M: insn compute-stack-frame*
] when ;
\ _spill t frame-required? set-word-prop
\ ##fixnum-add t frame-required? set-word-prop
\ ##fixnum-sub t frame-required? set-word-prop
\ ##fixnum-mul t frame-required? set-word-prop
\ ##fixnum-add-tail f frame-required? set-word-prop
\ ##fixnum-sub-tail f frame-required? set-word-prop
\ ##fixnum-mul-tail f frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off

View File

@ -98,17 +98,10 @@ M: #recursive emit-node
! #if
: emit-branch ( obj -- final-bb )
[
begin-basic-block
emit-nodes
basic-block get dup [ ##branch ] when
] with-scope ;
[ emit-nodes ] with-branch ;
: emit-if ( node -- )
children>> [ emit-branch ] map
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
children>> [ emit-branch ] map emit-conditional ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;

View File

@ -16,9 +16,9 @@ ERROR: last-insn-not-a-jump insn ;
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
[ ##fixnum-add-tail? ]
[ ##fixnum-sub-tail? ]
[ ##fixnum-mul-tail? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;

View File

@ -8,6 +8,7 @@ GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ;
M: ##fixnum-overflow defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
@ -21,8 +22,6 @@ M: ##set-string-nth-fast temp-vregs temp>> 1array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;

View File

@ -73,5 +73,7 @@ IN: compiler.cfg.hats
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline

View File

@ -92,15 +92,6 @@ INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ;
INSN: ##log2 < ##unary ;
! Overflowing arithmetic
TUPLE: ##fixnum-overflow < insn src1 src2 ;
INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
@ -181,6 +172,7 @@ INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Conditionals
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
@ -192,6 +184,12 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
! Overflowing arithmetic
TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ;
INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow ;
INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
! Instructions used by machine IR only.
@ -212,6 +210,12 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ;
! Overflowing arithmetic
TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ;
INSN: _fixnum-add < _fixnum-overflow ;
INSN: _fixnum-sub < _fixnum-overflow ;
INSN: _fixnum-mul < _fixnum-overflow ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
@ -223,3 +227,19 @@ INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
! Instructions that poison the stack state
UNION: poison-insn
##jump
##return
##callback-return ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
poison-insn
##stack-frame
##call
##prologue
##epilogue
##alien-invoke
##alien-indirect
##alien-callback ;

View File

@ -1,7 +1,7 @@
! 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
combinators fry arrays
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
@ -54,6 +54,28 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-fixnum-overflow-op ( quot -- next )
[ 2inputs 1 ##inc-d ] dip call ##branch
begin-basic-block ; inline
: emit-no-overflow-case ( dst -- final-bb )
[ -2 ##inc-d ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb )
[ ##call ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
[ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
: emit-fixnum+ ( -- )
[ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
: emit-fixnum- ( -- )
[ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
: emit-fixnum* ( -- )
[ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;

View File

@ -100,9 +100,9 @@ IN: compiler.cfg.intrinsics
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ kernel.private:getenv [ emit-getenv ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ \ 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+ [ drop emit-fixnum+ ] }
{ \ math.private:fixnum- [ drop emit-fixnum- ] }
{ \ math.private:fixnum* [ drop emit-fixnum* ] }
{ \ 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 ] }

View File

@ -2159,12 +2159,7 @@ V{
T{ ##replace { src V int-regs 85 } { loc D 1 } }
T{ ##replace { src V int-regs 89 } { loc D 4 } }
T{ ##replace { src V int-regs 96 } { loc R 0 } }
T{ ##fixnum-mul
{ src1 V int-regs 128 }
{ src2 V int-regs 129 }
{ temp1 V int-regs 132 }
{ temp2 V int-regs 133 }
}
T{ ##replace { src V int-regs 129 } { loc R 0 } }
T{ ##branch }
} 2 test-bb
@ -2255,206 +2250,6 @@ V{
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
! Another push-all reduction to demonstrate numbering anamoly
V{ T{ ##prologue } T{ ##branch } }
0 test-bb
V{
T{ ##peek { dst V int-regs 1 } { loc D 0 } }
T{ ##slot-imm
{ dst V int-regs 5 }
{ obj V int-regs 1 }
{ slot 3 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 7 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 12 }
{ obj V int-regs 7 }
{ slot 1 }
{ tag 6 }
}
T{ ##add
{ dst V int-regs 25 }
{ src1 V int-regs 5 }
{ src2 V int-regs 12 }
}
T{ ##compare-branch
{ src1 V int-regs 25 }
{ src2 V int-regs 5 }
{ cc cc> }
}
}
1 test-bb
V{
T{ ##slot-imm
{ dst V int-regs 41 }
{ obj V int-regs 1 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
{ dst V int-regs 44 }
{ obj V int-regs 41 }
{ slot 1 }
{ tag 6 }
}
T{ ##compare-branch
{ src1 V int-regs 25 }
{ src2 V int-regs 44 }
{ cc cc> }
}
}
2 test-bb
V{
T{ ##add-imm
{ dst V int-regs 54 }
{ src1 V int-regs 25 }
{ src2 8 }
}
T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 25 } { loc D 2 } }
T{ ##replace { src V int-regs 1 } { loc D 3 } }
T{ ##replace { src V int-regs 5 } { loc D 4 } }
T{ ##replace { src V int-regs 1 } { loc D 1 } }
T{ ##replace { src V int-regs 54 } { loc D 0 } }
T{ ##replace { src V int-regs 12 } { loc R 0 } }
T{ ##fixnum-mul
{ src1 V int-regs 54 }
{ src2 V int-regs 55 }
{ temp1 V int-regs 58 }
{ temp2 V int-regs 59 }
}
T{ ##branch }
}
3 test-bb
V{
T{ ##peek { dst V int-regs 60 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 66 }
{ obj V int-regs 60 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 66 } { loc D 0 } }
T{ ##replace { src V int-regs 60 } { loc R 0 } }
T{ ##call { word resize-string } }
T{ ##branch }
}
4 test-bb
V{
T{ ##peek { dst V int-regs 67 } { loc R 0 } }
T{ ##peek { dst V int-regs 68 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 68 }
{ obj V int-regs 67 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
{ src V int-regs 67 }
{ card# V int-regs 75 }
{ table V int-regs 76 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
T{ ##peek { dst V int-regs 94 } { loc D 0 } }
T{ ##peek { dst V int-regs 96 } { loc D 1 } }
T{ ##peek { dst V int-regs 98 } { loc D 2 } }
T{ ##peek { dst V int-regs 100 } { loc D 3 } }
T{ ##peek { dst V int-regs 102 } { loc D 4 } }
T{ ##peek { dst V int-regs 106 } { loc R 0 } }
T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
T{ ##branch }
}
5 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
T{ ##branch }
}
6 test-bb
V{
T{ ##load-immediate
{ dst V int-regs 78 }
{ val 4611686018427387896 }
}
T{ ##and
{ dst V int-regs 81 }
{ src1 V int-regs 97 }
{ src2 V int-regs 78 }
}
T{ ##set-slot-imm
{ src V int-regs 81 }
{ obj V int-regs 95 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n -2 } }
T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
T{ ##branch }
}
7 test-bb
V{
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
T{ ##branch }
}
8 test-bb
V{
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
T{ ##replace { src V int-regs 117 } { loc D 0 } }
T{ ##replace { src V int-regs 110 } { loc D 1 } }
T{ ##replace { src V int-regs 111 } { loc D 2 } }
T{ ##replace { src V int-regs 112 } { loc D 3 } }
T{ ##epilogue }
T{ ##return }
}
9 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 8 get V{ } 2sequence >>successors drop
2 get 3 get 6 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
5 get 7 get 1vector >>successors drop
6 get 7 get 1vector >>successors drop
7 get 9 get 1vector >>successors drop
8 get 9 get 1vector >>successors drop
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
! Fencepost error in assignment pass
V{ T{ ##branch } } 0 test-bb

View File

@ -122,10 +122,10 @@ M: ##copy-float compute-live-intervals*
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
: check-start/end ( live-interval -- )
[ [ start>> ] [ uses>> first ] bi assert= ]
[ [ end>> ] [ uses>> last ] bi assert= ]
bi ;
ERROR: bad-live-interval live-interval ;
: check-start ( live-interval -- )
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
: finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have
@ -135,7 +135,7 @@ M: ##copy-float compute-live-intervals*
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
[ check-start/end ]
[ check-start ]
} cleave
] each ;

View File

@ -31,8 +31,10 @@ M: insn linearize-insn , drop ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
: successors ( bb -- first second ) successors>> first2 ; inline
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
[ dup successors>> first2 ]
[ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
@ -52,6 +54,19 @@ M: ##compare-imm-branch linearize-insn
M: ##compare-float-branch linearize-insn
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
[ dup successors number>> ]
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
M: ##fixnum-add linearize-insn
[ overflow-conditional _fixnum-add ] with-regs emit-branch ;
M: ##fixnum-sub linearize-insn
[ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
M: ##fixnum-mul linearize-insn
[ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
M: ##dispatch linearize-insn
swap
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]

View File

@ -6,6 +6,7 @@ compiler.cfg.predecessors
compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
compiler.cfg.branch-splitting
compiler.cfg.block-joining
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
@ -31,6 +32,8 @@ SYMBOL: check-optimizer?
delete-useless-conditionals
compute-predecessors
split-branches
join-blocks
compute-predecessors
stack-analysis
compute-liveness
alias-analysis

View File

@ -136,16 +136,6 @@ M: ##compare-imm fresh-insn-temps
M: ##compare-float fresh-insn-temps
[ fresh-vreg ] change-temp drop ;
M: ##fixnum-mul fresh-insn-temps
[ fresh-vreg ] change-temp1
[ fresh-vreg ] change-temp2
drop ;
M: ##fixnum-mul-tail fresh-insn-temps
[ fresh-vreg ] change-temp1
[ fresh-vreg ] change-temp2
drop ;
M: ##gc fresh-insn-temps
[ fresh-vreg ] change-temp1
[ fresh-vreg ] change-temp2

View File

@ -92,6 +92,7 @@ SYMBOL: added-phis
:: multiple-predecessors ( bb states -- state )
states [ not ] any? [
<state>
bb add-to-work-list
] [
[
H{ } clone added-instructions set

View File

@ -14,9 +14,7 @@ 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 ;
SYMBOL: global-optimization?
: redundant-replace? ( vreg loc -- ? )
dup state get untranslate-loc n>> 0 <
@ -63,14 +61,16 @@ UNION: sync-if-back-edge
##conditional-branch
##compare-imm-branch
##dispatch
##loop-entry ;
##loop-entry
##fixnum-overflow ;
: sync-state? ( -- ? )
basic-block get successors>>
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
sync-state? [ sync-state ] when , ;
global-optimization? get [ sync-state? [ sync-state ] when ] unless
, ;
: eliminate-peek ( dst src -- )
! the requested stack location is already in 'src'
@ -87,31 +87,8 @@ M: ##replace visit
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
! Instructions that poison the stack state
UNION: poison-insn
##jump
##return
##callback-return
##fixnum-mul-tail
##fixnum-add-tail
##fixnum-sub-tail ;
M: poison-insn visit call-next-method poison-state ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
poison-insn
##stack-frame
##call
##prologue
##epilogue
##fixnum-mul
##fixnum-add
##fixnum-sub
##alien-invoke
##alien-indirect
##alien-callback ;
M: kill-vreg-insn visit sync-state , ;
! Maps basic-blocks to states
@ -142,21 +119,13 @@ 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 [ add-to-work-list ] each-basic-block
process-work-list
dup [ visit-block ] each-basic-block
global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
cfg-changed
] with-scope ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets math
USING: kernel accessors namespaces assocs sets math deques
compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state
@ -47,3 +47,7 @@ M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
GENERIC# untranslate-loc 1 ( loc state -- loc' )
M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
SYMBOL: work-list
: add-to-work-list ( bb -- ) work-list get push-front ;

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit kernel math
namespaces sequences fry combinators
compiler.utilities
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
@ -19,8 +20,6 @@ IN: compiler.cfg.tco
[ second ##return? ]
} 1&& ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
: tail-call? ( bb -- ? )
{
[ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
@ -54,28 +53,11 @@ IN: compiler.cfg.tco
[ [ cfg get entry>> successors>> first ] dip successors>> push ]
tri ;
: fixnum-tail-call? ( bb -- ? )
instructions>> penultimate
{ [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
: convert-fixnum-tail-call ( bb -- )
[
[ src1>> ] [ src2>> ] [ ] tri
convert-fixnum-tail-call*
] convert-tail-call ;
: optimize-tail-call ( bb -- )
dup tail-call? [
{
{ [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
{ [ dup word-tail-call? ] [ convert-word-tail-call ] }
{ [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
[ drop ]
} cond
] [ drop ] if ;

View File

@ -44,6 +44,8 @@ M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ;
M: ##add-float convert-two-operand* convert-two-operand/float ;
M: ##sub-float convert-two-operand* convert-two-operand/float ;
M: ##mul-float convert-two-operand* convert-two-operand/float ;

View File

@ -36,6 +36,18 @@ IN: compiler.cfg.utilities
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;
: with-branch ( quot -- final-bb )
[
begin-basic-block
call
basic-block get dup [ ##branch ] when
] with-scope ; inline
: emit-conditional ( branches -- )
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
: back-edge? ( from to -- ? )
[ number>> ] bi@ >= ;

View File

@ -171,18 +171,12 @@ M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##not generate-insn dst/src %not ;
M: ##log2 generate-insn dst/src %log2 ;
: src1/src2 ( insn -- src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline
: label/dst/src1/src2 ( insn -- label dst src1 src2 )
[ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
[ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline

View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
@ -15,7 +15,9 @@ compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker ;
compiler.tree.checker
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
RENAME: _ match => __
IN: compiler.tree.debugger
@ -201,8 +203,15 @@ SYMBOL: node-count
: cleaned-up-tree ( quot -- nodes )
[
check-optimizer? on
build-tree optimize-tree
build-tree
analyze-recursive
normalize
propagate
cleanup
compute-def-use
remove-dead-code
compute-def-use
optimize-modular-arithmetic
] with-scope ;
: inlined? ( quot seq/word -- ? )

View File

@ -46,6 +46,9 @@ M: predicate finalize-word
[ drop ]
} cond ;
M: math-partial finalize-word
dup primitive? [ drop ] [ nip cached-expansion ] if ;
M: word finalize-word drop ;
M: #call finalize*

View File

@ -4,12 +4,12 @@ IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences strings sbufs
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.normalization
compiler.tree.debugger
alien.accessors layouts combinators byte-arrays ;
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
cleaned-up-tree nodes>quot ;
[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test

View File

@ -27,4 +27,6 @@ SYMBOL: yield-hook
yield-hook [ [ ] ] initialize
: alist-max ( alist -- pair )
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;

View File

@ -82,12 +82,9 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
HOOK: %fixnum-add cpu ( src1 src2 -- )
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
HOOK: %fixnum-sub cpu ( src1 src2 -- )
HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )

View File

@ -51,8 +51,6 @@ M: x86.32 reserved-area-size 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]

View File

@ -167,11 +167,6 @@ M: x86.64 %alien-invoke
rc-absolute-cell rel-dlsym
R11 CALL ;
M: x86.64 %alien-invoke-tail
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 JMP ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
RBP RAX MOV ;

View File

@ -129,83 +129,18 @@ M: x86 %log2 BSR ;
: ?MOV ( dst src -- )
2dup = [ 2drop ] [ MOV ] if ; inline
:: move>args ( src1 src2 -- )
{
{ [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] }
{ [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] }
{ [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] }
{ [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] }
[
param-reg-1 src1 MOV
param-reg-2 src2 MOV
]
} cond ;
HOOK: %alien-invoke-tail cpu ( func dll -- )
:: overflow-template ( src1 src2 insn inverse func -- )
<label> "no-overflow" set
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
ds-reg [] src1 MOV
"no-overflow" get JNO
src1 src2 inverse call
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke
"no-overflow" resolve-label ; inline
label JO ; inline
:: overflow-template-tail ( src1 src2 insn inverse func -- )
<label> "no-overflow" set
src1 src2 insn call
"no-overflow" get JNO
src1 src2 inverse call
src1 src2 move>args
%prepare-alien-invoke
func f %alien-invoke-tail
"no-overflow" resolve-label
ds-reg [] src1 MOV
0 RET ; inline
M: x86 %fixnum-add ( label dst src1 src2 -- )
[ ADD ] overflow-template ;
M: x86 %fixnum-add ( src1 src2 -- )
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template ;
M: x86 %fixnum-sub ( label dst src1 src2 -- )
[ SUB ] overflow-template ;
M: x86 %fixnum-add-tail ( src1 src2 -- )
[ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template-tail ;
M: x86 %fixnum-sub ( src1 src2 -- )
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template ;
M: x86 %fixnum-sub-tail ( src1 src2 -- )
[ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
"no-overflow" define-label
temp1 src1 MOV
temp1 tag-bits get SAR
src2 temp1 IMUL2
ds-reg [] temp1 MOV
"no-overflow" get JNO
src1 src2 move>args
param-reg-1 tag-bits get SAR
param-reg-2 tag-bits get SAR
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke
"no-overflow" resolve-label ;
M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
"overflow" define-label
temp1 src1 MOV
temp1 tag-bits get SAR
src2 temp1 IMUL2
"overflow" get JO
ds-reg [] temp1 MOV
0 RET
"overflow" resolve-label
src1 src2 move>args
param-reg-1 tag-bits get SAR
param-reg-2 tag-bits get SAR
%prepare-alien-invoke
"overflow_fixnum_multiply" f %alien-invoke-tail ;
M: x86 %fixnum-mul ( label dst src1 src2 -- )
[ swap IMUL2 ] overflow-template ;
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline

View File

@ -143,7 +143,7 @@ SYMBOL: vocab-articles
swap '[
_ elements [
rest { { } { "" } } member?
[ "Empty description" throw ] when
[ "Empty $description" simple-lint-error ] when
] each
] each ;

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1,36 @@
! (c)2009 Joe Groff bsd license
USING: help.markup help.syntax multiline tools.continuations ;
IN: opengl.debug
HELP: G
{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." }
{ $examples { $code <" USING: opengl.debug ui ;
[ drop t ] find-window G-world set
G 0.0 0.0 1.0 1.0 glClearColor
G GL_COLOR_BUFFER_BIT glClear
"> } } ;
HELP: F
{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ;
HELP: G-world
{ $var-description "The world whose OpenGL context is made active by " { $link G } "." } ;
HELP: GB
{ $description "A shorthand for " { $link gl-break } "." } ;
HELP: gl-break
{ $description "Suspends the current thread and activates the walker like " { $link break } ", but also preserves the current OpenGL context, saves it to " { $link G-world } " for interactive use through " { $link G } ", and restores the current context when the suspended thread is continued. The shorthand word " { $link POSTPONE: GB } " can also be used." } ;
{ G F G-world POSTPONE: GB gl-break } related-words
ARTICLE: "opengl.debug" "Interactive debugging of OpenGL applications"
"The " { $vocab-link "opengl.debug" } " vocabulary provides words to assist with interactive debugging of OpenGL applications in the Factor UI."
{ $subsection G-world }
{ $subsection G }
{ $subsection F }
{ $subsection GB }
{ $subsection gl-break } ;
ABOUT: "opengl.debug"

View File

@ -0,0 +1,23 @@
! (c)2009 Joe Groff bsd license
USING: accessors kernel namespaces parser tools.continuations
ui.backend ui.gadgets.worlds words ;
IN: opengl.debug
SYMBOL: G-world
: G ( -- )
G-world get set-gl-context ;
: F ( -- )
G-world get handle>> flush-gl-context ;
: gl-break ( -- )
world get dup G-world set-global
[ break ] dip
set-gl-context ;
<< \ gl-break t "break?" set-word-prop >>
SYNTAX: GB
\ gl-break parsed ;

View File

@ -0,0 +1 @@
Helper words for breaking and interactively manipulating OpenGL applications

View File

@ -29,9 +29,6 @@ HELP: set-title
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
HELP: context-world
{ $var-description "Holds the " { $link world } " whose OpenGL context was most recently made active by " { $link set-gl-context } "." } ;
HELP: set-gl-context
{ $values { "world" world } }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;

View File

@ -78,13 +78,11 @@ TUPLE: world-attributes
'[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
] [ 2drop ] if ;
SYMBOL: context-world
: window-resource ( resource -- resource )
dup context-world get-global window-resources>> push ;
dup world get-global window-resources>> push ;
: set-gl-context ( world -- )
[ context-world set-global ]
[ world set-global ]
[ handle>> select-gl-context ] bi ;
: with-gl-context ( world quot -- )

View File

@ -18,7 +18,7 @@ HELP: C-FUNCTION:
{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
{ $examples
{ $example
"USING: alien.inline prettyprint ;"
"USING: alien.inline.syntax prettyprint ;"
"IN: cmath.ffi"
""
"C-LIBRARY: cmathlib"
@ -44,7 +44,7 @@ HELP: C-LIBRARY:
{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
{ $examples
{ $example
"USING: alien.inline ;"
"USING: alien.inline.syntax ;"
"IN: rectangle.ffi"
""
"C-LIBRARY: rectlib"

View File

@ -12,7 +12,7 @@ HELP: CM-FUNCTION:
}
{ $examples
{ $example
"USING: alien.inline alien.marshall.syntax prettyprint ;"
"USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
"IN: example"
""
"C-LIBRARY: exlib"
@ -28,10 +28,8 @@ HELP: CM-FUNCTION:
""
";C-LIBRARY"
""
"8 5 0 0 sum_diff .s"
"\"sum 13, diff 3\""
"13"
"3"
"8 5 0 0 sum_diff . . ."
"3\n13\n\"sum 13, diff 3\""
}
}
{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Jeremy Hughes.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.inline alien.marshall.syntax destructors
USING: alien.inline.syntax alien.marshall.syntax destructors
tools.test accessors kernel ;
IN: alien.marshall.syntax.tests

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger math namespaces memory ;
continuations debugger math namespaces memory fry ;
IN: benchmark
<PRIVATE
@ -12,9 +12,12 @@ SYMBOL: errors
PRIVATE>
: (run-benchmark) ( vocab -- time )
[ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
: run-benchmark ( vocab -- )
[ "=== " write print flush ] [
[ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ [ require ] [ (run-benchmark) ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
@ -24,6 +27,7 @@ PRIVATE>
V{ } clone timings set
V{ } clone errors set
"benchmark" child-vocab-names
[ find-vocab-root ] filter
[ run-benchmark ] each
timings get
errors get