FFI rewrite part 6: deconcatenatize

db4
Slava Pestov 2010-07-02 15:44:12 -04:00
parent 3f13fc7099
commit a55c8ee671
19 changed files with 579 additions and 258 deletions

View File

@ -287,3 +287,75 @@ IN: compiler.cfg.alias-analysis.tests
T{ ##compare f 6 5 1 cc= } T{ ##compare f 6 5 1 cc= }
} test-alias-analysis } test-alias-analysis
] unit-test ] unit-test
! We can't make any assumptions about heap-ac between alien
! calls, since they might callback into Factor code
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 2 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##peek f 1 D 1 }
T{ ##peek f 2 D 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 2 0 1 0 }
} test-alias-analysis
] unit-test
[
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 1 0 1 0 }
}
] [
V{
T{ ##peek f 0 D 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f "free" }
T{ ##set-slot-imm f 1 0 1 0 }
} test-alias-analysis
] unit-test

View File

@ -186,6 +186,15 @@ SYMBOL: heap-ac
slot# vreg kill-constant-set-slot slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ; ] [ vreg kill-computed-set-slot ] if ;
: init-alias-analysis ( -- )
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
H{ } clone recent-stores set
HS{ } clone dead-stores set
0 ac-counter set ;
GENERIC: insn-slot# ( insn -- slot#/f ) GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg ) GENERIC: insn-object ( insn -- vreg )
@ -277,22 +286,6 @@ M: ##compare analyze-aliases
analyze-aliases analyze-aliases
] when ; ] when ;
GENERIC: eliminate-dead-stores ( insn -- ? )
M: ##set-slot-imm eliminate-dead-stores
insn#>> dead-stores get in? not ;
M: insn eliminate-dead-stores drop t ;
: init-alias-analysis ( -- )
H{ } clone vregs>acs set
H{ } clone acs>vregs set
H{ } clone live-slots set
H{ } clone copies set
H{ } clone recent-stores set
HS{ } clone dead-stores set
0 ac-counter set ;
: reset-alias-analysis ( -- ) : reset-alias-analysis ( -- )
recent-stores get clear-assoc recent-stores get clear-assoc
vregs>acs get clear-assoc vregs>acs get clear-assoc
@ -305,6 +298,19 @@ M: insn eliminate-dead-stores drop t ;
\ ##vm-field set-new-ac \ ##vm-field set-new-ac
\ ##alien-global set-new-ac ; \ ##alien-global set-new-ac ;
M: factor-call-insn analyze-aliases
heap-ac get ac>vregs [
[ live-slots get at clear-assoc ]
[ recent-stores get at clear-assoc ] bi
] each ;
GENERIC: eliminate-dead-stores ( insn -- ? )
M: ##set-slot-imm eliminate-dead-stores
insn#>> dead-stores get in? not ;
M: insn eliminate-dead-stores drop t ;
: alias-analysis-step ( insns -- insns' ) : alias-analysis-step ( insns -- insns' )
reset-alias-analysis reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ] [ local-live-in [ set-heap-ac ] each ]

View File

@ -1,9 +1,9 @@
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov. ! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit kernel USING: accessors combinators combinators.short-circuit kernel
math math.order sequences assocs namespaces vectors fry arrays locals math math.order sequences assocs namespaces vectors fry
splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo arrays splitting compiler.cfg.def-use compiler.cfg
compiler.cfg.predecessors compiler.cfg.renaming compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ; compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting IN: compiler.cfg.branch-splitting
@ -29,24 +29,18 @@ IN: compiler.cfg.branch-splitting
1vector >>predecessors 1vector >>predecessors
] with map ; ] 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 -- ) : update-predecessor-successors ( copies old-bb -- )
[ predecessors>> swap ] keep [ predecessors>> swap ] keep
'[ _ update-predecessor-successor ] 2each ; '[ [ _ ] 2dip update-predecessors ] 2each ;
: update-successor-predecessor ( copies old-bb succ -- ) :: update-successor-predecessor ( copies old-bb succ -- )
[ succ
swap 1array split swap join V{ } like [ { old-bb } split copies join V{ } like ] change-predecessors
] change-predecessors drop ; drop ;
: update-successor-predecessors ( copies old-bb -- ) : update-successor-predecessors ( copies old-bb -- )
dup successors>> [ dup successors>>
update-successor-predecessor [ update-successor-predecessor ] with with each ;
] with with each ;
: split-branch ( bb -- ) : split-branch ( bb -- )
[ new-blocks ] keep [ new-blocks ] keep

View File

@ -1,25 +1,26 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays layouts math math.order math.parser USING: accessors assocs arrays layouts math math.order
combinators combinators.short-circuit fry make sequences math.parser combinators combinators.short-circuit fry make
sequences.generalizations alien alien.private alien.strings sequences sequences.generalizations alien alien.private
alien.c-types alien.libraries classes.struct namespaces kernel alien.strings alien.c-types alien.libraries classes.struct
strings libc locals quotations words cpu.architecture namespaces kernel strings libc locals quotations words
compiler.utilities compiler.tree compiler.cfg cpu.architecture compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ; compiler.cfg.stacks compiler.cfg.stacks.local
compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ; FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien IN: compiler.cfg.builder.alien
: unbox-parameters ( parameters -- vregs reps ) : unbox-parameters ( parameters -- vregs reps )
[ [
[ length iota <reversed> ] keep [ length iota <reversed> ] keep
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ] [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@ 2 2 mnmap [ concat ] bi@
] ]
[ length neg ##inc-d ] bi ; [ length neg inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f ) : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [ dup large-struct? [
@ -54,7 +55,7 @@ IN: compiler.cfg.builder.alien
struct-return-area set ; struct-return-area set ;
: box-return* ( node -- ) : box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; return>> [ ] [ base-type box-return ds-push ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
@ -83,49 +84,38 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
[ library>> load-library ] [ library>> load-library ]
bi 2dup check-dlsym ; bi 2dup check-dlsym ;
: alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
: emit-alien-block ( node quot: ( params -- ) -- )
'[
make-kill-block
params>>
_ [ alien-node-height ] bi
] emit-trivial-block ; inline
: emit-stack-frame ( stack-size params -- ) : emit-stack-frame ( stack-size params -- )
[ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ] [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
[ drop ##stack-frame ] [ drop ##stack-frame ]
2bi ; 2bi ;
M: #alien-invoke emit-node M: #alien-invoke emit-node
[ params>>
{ {
[ caller-parameters ] [ caller-parameters ]
[ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ] [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
} cleave
] emit-alien-block ;
M:: #alien-indirect emit-node ( node -- )
node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
[ caller-parameters src <gc-map> ##alien-indirect ]
[ emit-stack-frame ] [ emit-stack-frame ]
[ box-return* ] [ box-return* ]
tri } cleave ;
] emit-alien-block ;
M: #alien-indirect emit-node ( node -- )
params>>
[
ds-pop ^^unbox-any-c-ptr
[ caller-parameters ] dip
<gc-map> ##alien-indirect
]
[ emit-stack-frame ]
[ box-return* ]
tri ;
M: #alien-assembly emit-node M: #alien-assembly emit-node
[ params>> {
{ [ caller-parameters ]
[ caller-parameters ] [ quot>> <gc-map> ##alien-assembly ]
[ quot>> ##alien-assembly ] [ emit-stack-frame ]
[ emit-stack-frame ] [ box-return* ]
[ box-return* ] } cleave ;
} cleave
] emit-alien-block ;
: callee-parameter ( rep on-stack? -- dst insn ) : callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip [ next-vreg dup ] 2dip
@ -148,13 +138,7 @@ M: #alien-assembly emit-node
bi ; bi ;
: box-parameters ( vregs reps params -- ) : box-parameters ( vregs reps params -- )
##begin-callback ##begin-callback [ box-parameter ds-push ] 3each ;
next-vreg next-vreg ##restore-context
[
next-vreg next-vreg ##save-context
box-parameter
1 ##inc-d D 0 ##replace
] 3each ;
: callee-parameters ( params -- stack-size ) : callee-parameters ( params -- stack-size )
[ abi>> ] [ return>> ] [ parameters>> ] tri [ abi>> ] [ return>> ] [ parameters>> ] tri
@ -174,25 +158,29 @@ M: #alien-assembly emit-node
cfg get t >>frame-pointer? drop ; cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node M: #alien-callback emit-node
dup params>> xt>> dup params>> dup xt>> dup
[ [
needs-frame-pointer needs-frame-pointer
##prologue begin-word
[
{ {
[ callee-parameters ] [ callee-parameters ]
[ quot>> ##alien-callback ] [
[ [
return>> [ ##end-callback ] [ make-kill-block
[ D 0 ^^peek ] dip quot>> ##alien-callback
##end-callback ] emit-trivial-block
base-type unbox-return ]
] if-void [
] return>> [ ##end-callback ] [
[ callback-stack-cleanup ] [ ds-pop ] dip
} cleave ##end-callback
] emit-alien-block base-type unbox-return
##epilogue ] if-void
##return ]
[ callback-stack-cleanup ]
} cleave
end-word
] with-cfg-builder ; ] with-cfg-builder ;

View File

@ -198,17 +198,17 @@ M: #shuffle emit-node
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ; dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return ! #return
: emit-return ( -- ) : end-word ( -- )
##branch ##branch
begin-basic-block begin-basic-block
make-kill-block make-kill-block
##epilogue ##epilogue
##return ; ##return ;
M: #return emit-node drop emit-return ; M: #return emit-node drop end-word ;
M: #return-recursive emit-node M: #return-recursive emit-node
label>> id>> loops get key? [ emit-return ] unless ; label>> id>> loops get key? [ end-word ] unless ;
! #terminate ! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ; M: #terminate emit-node drop ##no-tco end-basic-block ;

View File

@ -9,7 +9,7 @@ IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' ) : finalize-cfg ( cfg -- cfg' )
select-representations select-representations
schedule-instructions ! schedule-instructions
insert-gc-checks insert-gc-checks
dup compute-uninitialized-sets dup compute-uninitialized-sets
insert-save-contexts insert-save-contexts

View File

@ -3,9 +3,85 @@ compiler.cfg.gc-checks.private compiler.cfg.debugger
compiler.cfg.registers compiler.cfg.instructions compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
tools.test kernel vectors namespaces accessors sequences alien tools.test kernel vectors namespaces accessors sequences alien
memory classes make combinators.short-circuit byte-arrays ; memory classes make combinators.short-circuit byte-arrays
compiler.cfg.comparisons ;
IN: compiler.cfg.gc-checks.tests IN: compiler.cfg.gc-checks.tests
[ { } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##alien-invoke }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 0 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##allot }
T{ ##alien-invoke }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 0 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##allot }
T{ ##allot }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 0 4 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##allot }
T{ ##alien-invoke }
T{ ##allot }
T{ ##add }
T{ ##sub }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { 3 } ] [
V{
T{ ##inc-d }
T{ ##peek }
T{ ##alien-invoke }
T{ ##allot }
T{ ##add }
T{ ##branch }
} gc-check-offsets
] unit-test
[ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
[ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
[ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
[ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
[ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
: test-gc-checks ( -- ) : test-gc-checks ( -- )
H{ } clone representations set H{ } clone representations set
cfg new 0 get >>entry cfg set ; cfg new 0 get >>entry cfg set ;
@ -25,7 +101,7 @@ V{
[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test [ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test [ ] [ 1 get instructions>> allocation-size 123 <alien> size assert= ] unit-test
2 \ vreg-counter set-global 2 \ vreg-counter set-global
@ -36,58 +112,16 @@ V{
[ first ##check-nursery-branch? ] [ first ##check-nursery-branch? ]
} 1&& ; } 1&& ;
[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test : gc-call? ( bb -- ? )
instructions>>
4 \ vreg-counter set-global
[
V{ V{
T{ ##call-gc f T{ gc-map } } T{ ##call-gc f T{ gc-map } }
T{ ##branch } T{ ##branch }
} } = ;
]
[
<gc-call> instructions>>
] unit-test
30 \ vreg-counter set-global 4 \ vreg-counter set-global
V{ [ t ] [ <gc-call> gc-call? ] unit-test
T{ ##branch }
} 0 test-bb
V{
T{ ##branch }
} 1 test-bb
V{
T{ ##branch }
} 2 test-bb
V{
T{ ##branch }
} 3 test-bb
V{
T{ ##branch }
} 4 test-bb
0 { 1 2 } edges
1 3 edge
2 3 edge
3 4 edge
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get needs-predecessors drop ] unit-test
[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
[ t ] [ 2 get successors>> first gc-check? ] unit-test
[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
30 \ vreg-counter set-global 30 \ vreg-counter set-global
@ -135,6 +169,8 @@ H{
[ ] [ cfg get insert-gc-checks drop ] unit-test [ ] [ cfg get insert-gc-checks drop ] unit-test
[ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
[ 2 ] [ 2 get predecessors>> length ] unit-test [ 2 ] [ 2 get predecessors>> length ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test [ t ] [ 1 get successors>> first gc-check? ] unit-test
@ -187,5 +223,148 @@ H{
} representations set } representations set
[ ] [ cfg get insert-gc-checks drop ] unit-test [ ] [ cfg get insert-gc-checks drop ] unit-test
[ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test [ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
[ 2 ] [ 3 get instructions>> length ] unit-test [ 2 ] [ 3 get instructions>> length ] unit-test
! GC check in a block that is its own successor
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##allot f 1 64 byte-array }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 { 1 2 } edges
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get insert-gc-checks drop ] unit-test
[ ] [
0 get successors>> first predecessors>>
[ first 0 get assert= ]
[ second 1 get [ instructions>> ] bi@ assert= ] bi
] unit-test
[ ] [
0 get successors>> first successors>>
[ first 1 get [ instructions>> ] bi@ assert= ]
[ second gc-call? t assert= ] bi
] unit-test
[ ] [
2 get predecessors>> first predecessors>>
[ first gc-check? t assert= ]
[ second gc-call? t assert= ] bi
] unit-test
! Brave new world of calls in the middle of BBs
! call then allot
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##allot f 1 64 byte-array }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 2 edge
2 \ vreg-counter set-global
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get insert-gc-checks drop ] unit-test
! The GC check should come after the alien-invoke
[
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 3 4 }
}
] [ 0 get successors>> first instructions>> ] unit-test
! call then allot then call then allot
V{
T{ ##prologue }
T{ ##branch }
} 0 test-bb
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##allot f 1 64 byte-array }
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##allot f 2 64 byte-array }
T{ ##branch }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 1 edge
1 2 edge
2 \ vreg-counter set-global
[ ] [ test-gc-checks ] unit-test
[ ] [ cfg get insert-gc-checks drop ] unit-test
[
V{
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 3 4 }
}
] [
0 get
successors>> first
instructions>>
] unit-test
[
V{
T{ ##allot f 1 64 byte-array }
T{ ##alien-invoke f "malloc" f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 5 6 }
}
] [
0 get
successors>> first
successors>> first
instructions>>
] unit-test
[
V{
T{ ##allot f 2 64 byte-array }
T{ ##branch }
}
] [
0 get
successors>> first
successors>> first
successors>> first
instructions>>
] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators fry kernel layouts locals USING: accessors assocs combinators fry grouping kernel layouts
math make namespaces sequences cpu.architecture locals math make namespaces sequences cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.hats compiler.cfg.hats
@ -12,12 +12,12 @@ compiler.cfg.instructions
compiler.cfg.predecessors ; compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks IN: compiler.cfg.gc-checks
<PRIVATE
! Garbage collection check insertion. This pass runs after ! Garbage collection check insertion. This pass runs after
! representation selection, since it needs to know which vregs ! representation selection, since it needs to know which vregs
! can contain tagged pointers. ! can contain tagged pointers.
<PRIVATE
: insert-gc-check? ( bb -- ? ) : insert-gc-check? ( bb -- ? )
dup kill-block?>> dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ; [ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
@ -25,46 +25,38 @@ IN: compiler.cfg.gc-checks
: blocks-with-gc ( cfg -- bbs ) : blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ; post-order [ insert-gc-check? ] filter ;
! A GC check for bb consists of two new basic blocks, gc-check GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
! and gc-call:
!
! gc-check
! / \
! | gc-call
! \ /
! bb
! Any ##phi instructions at the start of bb are transplanted :: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
! into the gc-check block. seen-allocation? [ call-index , ] when
insn-index 1 + f ;
: <gc-check> ( phis size -- bb ) M: ##phi gc-check-offsets* gc-check-here ;
[ <basic-block> ] 2dip M: gc-map-insn gc-check-offsets* gc-check-here ;
M: ##allocation gc-check-offsets* 3drop t ;
M: insn gc-check-offsets* 2drop ;
: gc-check-offsets ( insns -- seq )
! A basic block is divided into sections by call and phi
! instructions. For every section with at least one
! allocation, record the offset of its first instruction
! in a sequence.
[ [
[ % ] [ 0 f ] dip
[ [ gc-check-offsets* ] each-index
cc<= int-rep next-vreg-rep int-rep next-vreg-rep [ , ] [ drop ] if
##check-nursery-branch ] { } make ;
] bi*
] V{ } make >>instructions ;
: <gc-call> ( -- bb ) :: split-instructions ( insns seq -- insns-seq )
<basic-block> ! Divide a basic block into sections, where every section
[ <gc-map> ##call-gc ##branch ] V{ } make ! other than the first requires a GC check.
>>instructions t >>unlikely? ; [
insns 0 seq [| insns from to |
:: insert-guard ( body check bb -- ) from to insns subseq ,
bb predecessors>> check predecessors<< insns to
V{ bb body } check successors<< ] each
tail ,
V{ check } body predecessors<< ] { } make ;
V{ bb } body successors<<
V{ check body } bb predecessors<<
check predecessors>> [ bb check update-successors ] each ;
: (insert-gc-check) ( phis size bb -- )
[ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
GENERIC: allocation-size* ( insn -- n ) GENERIC: allocation-size* ( insn -- n )
@ -74,22 +66,75 @@ M: ##box-alien allocation-size* drop 5 cells ;
M: ##box-displaced-alien allocation-size* drop 5 cells ; M: ##box-displaced-alien allocation-size* drop 5 cells ;
: allocation-size ( bb -- n ) : allocation-size ( insns -- n )
instructions>>
[ ##allocation? ] filter [ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ; [ allocation-size* data-alignment get align ] map-sum ;
: remove-phis ( bb -- phis ) : add-gc-checks ( insns-seq -- )
[ [ ##phi? ] partition ] change-instructions drop ; ! Insert a GC check at the end of every chunk but the last
! one. This ensures that every section other than the first
! has a GC check in the section immediately preceeding it.
2 <clumps> [
first2 allocation-size
cc<= int-rep next-vreg-rep int-rep next-vreg-rep
\ ##check-nursery-branch new-insn
swap push
] each ;
: insert-gc-check ( bb -- ) : make-blocks ( insns-seq -- bbs )
[ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ; [ <basic-block> swap >>instructions ] map ;
: <gc-call> ( -- bb )
<basic-block>
[ <gc-map> ##call-gc ##branch ] V{ } make
>>instructions t >>unlikely? ;
:: connect-gc-checks ( bbs -- )
! Every basic block but the last has two successors:
! the next block, and a GC call.
! Every basic block but the first has two predecessors:
! the previous block, and the previous block's GC call.
bbs length 1 - :> len
len [ <gc-call> ] replicate :> gc-calls
len [| n |
n bbs nth :> bb
n 1 + bbs nth :> next-bb
n gc-calls nth :> gc-call
V{ next-bb gc-call } bb successors<<
V{ next-bb } gc-call successors<<
V{ bb } gc-call predecessors<<
V{ bb gc-call } next-bb predecessors<<
] each-integer ;
:: update-predecessor-phis ( from to bb -- )
to [
[
[
[ dup from eq? [ drop bb ] when ] dip
] assoc-map
] change-inputs drop
] each-phi ;
:: (insert-gc-checks) ( bb bbs -- )
bb predecessors>> bbs first predecessors<<
bb successors>> bbs last successors<<
bb predecessors>> [ bb bbs first update-successors ] each
bb successors>> [
[ bb ] dip bbs last
[ update-predecessors ]
[ update-predecessor-phis ] 3bi
] each ;
: process-block ( bb -- )
dup instructions>> dup gc-check-offsets split-instructions
[ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
(insert-gc-checks) ;
PRIVATE> PRIVATE>
: insert-gc-checks ( cfg -- cfg' ) : insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [ dup blocks-with-gc [
[ needs-predecessors ] dip [ needs-predecessors ] dip
[ insert-gc-check ] each [ process-block ] each
cfg-changed cfg-changed
] unless-empty ; ] unless-empty ;

View File

@ -694,7 +694,7 @@ use: src/int-rep
literal: gc-map ; literal: gc-map ;
INSN: ##alien-assembly INSN: ##alien-assembly
literal: quot ; literal: quot gc-map ;
INSN: ##begin-callback ; INSN: ##begin-callback ;
@ -812,9 +812,6 @@ literal: cc ;
INSN: ##save-context INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ; temp: temp1/int-rep temp2/int-rep ;
INSN: ##restore-context
temp: temp1/int-rep temp2/int-rep ;
! GC checks ! GC checks
INSN: ##check-nursery-branch INSN: ##check-nursery-branch
literal: size cc literal: size cc
@ -858,15 +855,21 @@ UNION: conditional-branch-insn
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that contain subroutine calls to functions which
! can callback arbitrary Factor code
UNION: factor-call-insn
##alien-invoke
##alien-indirect
##alien-assembly ;
! Instructions that contain subroutine calls to functions which ! Instructions that contain subroutine calls to functions which
! allocate memory ! allocate memory
UNION: gc-map-insn UNION: gc-map-insn
##call-gc ##call-gc
##alien-invoke
##alien-indirect
##box ##box
##box-long-long ##box-long-long
##allot-byte-array ; ##allot-byte-array
factor-call-insn ;
M: gc-map-insn clone call-next-method [ clone ] change-gc-map ; M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs sequences sets USING: kernel accessors assocs namespaces sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis compiler.cfg.def-use compiler.cfg.dataflow-analysis
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.instructions compiler.cfg.registers
cpu.architecture ; cpu.architecture ;
@ -24,7 +24,12 @@ GENERIC: visit-insn ( live-set insn -- live-set )
M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ; M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
: fill-gc-map ( live-set insn -- live-set ) : fill-gc-map ( live-set insn -- live-set )
gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ; representations get [
gc-map>> over keys
[ rep-of tagged-rep? ] filter
>>gc-roots
] when
drop ;
M: gc-map-insn visit-insn M: gc-map-insn visit-insn
[ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ; [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;

View File

@ -1,6 +1,7 @@
USING: accessors compiler.cfg.debugger USING: accessors compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.save-contexts kernel namespaces tools.test ; compiler.cfg.save-contexts kernel namespaces tools.test
cpu.x86.assembler.operands cpu.architecture ;
IN: compiler.cfg.save-contexts.tests IN: compiler.cfg.save-contexts.tests
0 vreg-counter set-global 0 vreg-counter set-global
@ -38,3 +39,34 @@ V{
] [ ] [
0 get instructions>> 0 get instructions>>
] unit-test ] unit-test
4 vreg-counter set-global
V{
T{ ##inc-d f 3 }
T{ ##load-reg-param f 0 RCX int-rep }
T{ ##load-reg-param f 1 RDX int-rep }
T{ ##load-reg-param f 2 R8 int-rep }
T{ ##begin-callback }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
}
} 0 test-bb
0 get insert-save-context
[
V{
T{ ##inc-d f 3 }
T{ ##load-reg-param f 0 RCX int-rep }
T{ ##load-reg-param f 1 RDX int-rep }
T{ ##load-reg-param f 2 R8 int-rep }
T{ ##save-context f 5 6 }
T{ ##begin-callback }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
}
}
] [
0 get instructions>>
] unit-test

View File

@ -1,30 +1,44 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit USING: accessors compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.rpo cpu.architecture kernel sequences vectors ; compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
IN: compiler.cfg.save-contexts IN: compiler.cfg.save-contexts
! Insert context saves. ! Insert context saves.
: needs-save-context? ( insns -- ? ) GENERIC: needs-save-context? ( insn -- ? )
[
{ M: ##unary-float-function needs-save-context? drop t ;
[ ##unary-float-function? ] M: ##binary-float-function needs-save-context? drop t ;
[ ##binary-float-function? ] M: gc-map-insn needs-save-context? drop t ;
[ ##alien-invoke? ] M: insn needs-save-context? drop f ;
[ ##alien-indirect? ]
[ ##alien-assembly? ] : bb-needs-save-context? ( insn -- ? )
} 1|| instructions>> [ needs-save-context? ] any? ;
] any? ;
GENERIC: modifies-context? ( insn -- ? )
M: ##inc-d modifies-context? drop t ;
M: ##inc-r modifies-context? drop t ;
M: ##load-reg-param modifies-context? drop t ;
M: insn modifies-context? drop f ;
: save-context-offset ( bb -- n )
! ##save-context must be placed after instructions that
! modify the context, or instructions that read parameter
! registers.
instructions>> [ modifies-context? not ] find drop ;
: insert-save-context ( bb -- ) : insert-save-context ( bb -- )
dup instructions>> dup needs-save-context? [ dup bb-needs-save-context? [
tagged-rep next-vreg-rep [
tagged-rep next-vreg-rep int-rep next-vreg-rep
\ ##save-context new-insn prefix int-rep next-vreg-rep
>>instructions drop \ ##save-context new-insn
] [ 2drop ] if ; ] dip
[ save-context-offset ] keep
[ insert-nth ] change-instructions drop
] [ drop ] if ;
: insert-save-contexts ( cfg -- cfg' ) : insert-save-contexts ( cfg -- cfg' )
dup [ insert-save-context ] each-basic-block ; dup [ insert-save-context ] each-basic-block ;

View File

@ -32,13 +32,13 @@ SYMBOL: visited
H{ } clone visited [ (skip-empty-blocks) ] with-variable ; H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: update-predecessors ( from to bb -- ) :: update-predecessors ( from to bb -- )
! Update 'to' predecessors for insertion of 'bb' between ! Whenever 'from' appears in the list of predecessors of 'to'
! 'from' and 'to'. ! replace it with 'bb'.
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ; to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
:: update-successors ( from to bb -- ) :: update-successors ( from to bb -- )
! Update 'from' successors for insertion of 'bb' between ! Whenever 'to' appears in the list of successors of 'from'
! 'from' and 'to'. ! replace it with 'bb'.
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ; from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
:: insert-basic-block ( from to insns -- ) :: insert-basic-block ( from to insns -- )

View File

@ -254,7 +254,6 @@ CODEGEN: ##compare-integer-imm %compare-integer-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context CODEGEN: ##save-context %save-context
CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global CODEGEN: ##alien-global %alien-global
@ -304,4 +303,5 @@ CODEGEN: ##begin-callback %begin-callback
CODEGEN: ##alien-callback %alien-callback CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback CODEGEN: ##end-callback %end-callback
M: ##alien-assembly generate-insn quot>> call( -- ) ; M: ##alien-assembly generate-insn
[ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;

View File

@ -602,8 +602,6 @@ HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
HOOK: %allot-byte-array cpu ( dst size gc-map -- ) HOOK: %allot-byte-array cpu ( dst size gc-map -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- ) HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- ) HOOK: %prepare-var-args cpu ( -- )

View File

@ -25,6 +25,7 @@ IN: bootstrap.x86
: nv-reg ( -- reg ) ESI ; : nv-reg ( -- reg ) ESI ;
: ds-reg ( -- reg ) ESI ; : ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ; : rs-reg ( -- reg ) EDI ;
: link-reg ( -- reg ) EBX ;
: fixnum>slot@ ( -- ) temp0 2 SAR ; : fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ; : rex-length ( -- n ) 0 ;
@ -90,15 +91,9 @@ IN: bootstrap.x86
ESP 4 [+] EAX MOV ESP 4 [+] EAX MOV
"begin_callback" jit-call "begin_callback" jit-call
jit-load-vm
jit-load-context
jit-restore-context
jit-call-quot jit-call-quot
jit-load-vm jit-load-vm
jit-save-context
ESP [] vm-reg MOV ESP [] vm-reg MOV
"end_callback" jit-call "end_callback" jit-call
] \ c-to-factor define-sub-primitive ] \ c-to-factor define-sub-primitive

View File

@ -20,6 +20,7 @@ IN: bootstrap.x86
: nv-reg ( -- reg ) RBX ; : nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ; : stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ; : frame-reg ( -- reg ) RBP ;
: link-reg ( -- reg ) R11 ;
: ctx-reg ( -- reg ) R12 ; : ctx-reg ( -- reg ) R12 ;
: vm-reg ( -- reg ) R13 ; : vm-reg ( -- reg ) R13 ;
: ds-reg ( -- reg ) R14 ; : ds-reg ( -- reg ) R14 ;
@ -84,15 +85,10 @@ IN: bootstrap.x86
arg1 vm-reg MOV arg1 vm-reg MOV
"begin_callback" jit-call "begin_callback" jit-call
jit-load-context
jit-restore-context
! call the quotation ! call the quotation
arg1 return-reg MOV arg1 return-reg MOV
jit-call-quot jit-call-quot
jit-save-context
arg1 vm-reg MOV arg1 vm-reg MOV
"end_callback" jit-call "end_callback" jit-call
] \ c-to-factor define-sub-primitive ] \ c-to-factor define-sub-primitive

View File

@ -38,15 +38,17 @@ big-endian off
! Save C callstack pointer ! Save C callstack pointer
nv-reg context-callstack-save-offset [+] stack-reg MOV nv-reg context-callstack-save-offset [+] stack-reg MOV
! Load Factor callstack pointer ! Load Factor stack pointers
stack-reg nv-reg context-callstack-bottom-offset [+] MOV stack-reg nv-reg context-callstack-bottom-offset [+] MOV
nv-reg jit-update-tib nv-reg jit-update-tib
jit-install-seh jit-install-seh
rs-reg nv-reg context-retainstack-offset [+] MOV
ds-reg nv-reg context-datastack-offset [+] MOV
! Call into Factor code ! Call into Factor code
nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
nv-reg CALL link-reg CALL
! Load VM into vm-reg; only needed on x86-32, but doesn't ! Load VM into vm-reg; only needed on x86-32, but doesn't
! hurt on x86-64 ! hurt on x86-64

View File

@ -614,14 +614,6 @@ M: x86 %alien-indirect ( src gc-map -- )
M: x86 %loop-entry 16 alignment [ NOP ] times ; M: x86 %loop-entry 16 alignment [ NOP ] times ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV
ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
M:: x86 %save-context ( temp1 temp2 -- ) M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace