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= }
} test-alias-analysis
] 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
] [ 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-object ( insn -- vreg )
@ -277,22 +286,6 @@ M: ##compare analyze-aliases
analyze-aliases
] 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 ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
@ -305,6 +298,19 @@ M: insn eliminate-dead-stores drop t ;
\ ##vm-field 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' )
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]

View File

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

View File

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

View File

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

View File

@ -9,7 +9,7 @@ IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
schedule-instructions
! schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
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.predecessors compiler.cfg.rpo cpu.architecture
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
[ { } ] [
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 ( -- )
H{ } clone representations 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
[ ] [ 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
@ -36,58 +112,16 @@ V{
[ first ##check-nursery-branch? ]
} 1&& ;
[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
4 \ vreg-counter set-global
[
: gc-call? ( bb -- ? )
instructions>>
V{
T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
]
[
<gc-call> instructions>>
] unit-test
} = ;
30 \ vreg-counter set-global
4 \ vreg-counter set-global
V{
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
[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
@ -135,6 +169,8 @@ H{
[ ] [ 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
[ t ] [ 1 get successors>> first gc-check? ] unit-test
@ -187,5 +223,148 @@ H{
} representations set
[ ] [ 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
[ 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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators fry kernel layouts locals
math make namespaces sequences cpu.architecture
USING: accessors assocs combinators fry grouping kernel layouts
locals math make namespaces sequences cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
@ -12,12 +12,12 @@ compiler.cfg.instructions
compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
<PRIVATE
! Garbage collection check insertion. This pass runs after
! representation selection, since it needs to know which vregs
! can contain tagged pointers.
<PRIVATE
: insert-gc-check? ( bb -- ? )
dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
@ -25,46 +25,38 @@ IN: compiler.cfg.gc-checks
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
! A GC check for bb consists of two new basic blocks, gc-check
! and gc-call:
!
! gc-check
! / \
! | gc-call
! \ /
! bb
GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
! Any ##phi instructions at the start of bb are transplanted
! into the gc-check block.
:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
seen-allocation? [ call-index , ] when
insn-index 1 + f ;
: <gc-check> ( phis size -- bb )
[ <basic-block> ] 2dip
M: ##phi gc-check-offsets* gc-check-here ;
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.
[
[ % ]
[
cc<= int-rep next-vreg-rep int-rep next-vreg-rep
##check-nursery-branch
] bi*
] V{ } make >>instructions ;
[ 0 f ] dip
[ gc-check-offsets* ] each-index
[ , ] [ drop ] if
] { } make ;
: <gc-call> ( -- bb )
<basic-block>
[ <gc-map> ##call-gc ##branch ] V{ } make
>>instructions t >>unlikely? ;
:: insert-guard ( body check bb -- )
bb predecessors>> check predecessors<<
V{ bb body } check successors<<
V{ check } body predecessors<<
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 ;
:: split-instructions ( insns seq -- insns-seq )
! Divide a basic block into sections, where every section
! other than the first requires a GC check.
[
insns 0 seq [| insns from to |
from to insns subseq ,
insns to
] each
tail ,
] { } make ;
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 ;
: allocation-size ( bb -- n )
instructions>>
: allocation-size ( insns -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
: remove-phis ( bb -- phis )
[ [ ##phi? ] partition ] change-instructions drop ;
: add-gc-checks ( insns-seq -- )
! 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 -- )
[ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
: make-blocks ( insns-seq -- bbs )
[ <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>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
[ needs-predecessors ] dip
[ insert-gc-check ] each
[ process-block ] each
cfg-changed
] unless-empty ;

View File

@ -694,7 +694,7 @@ use: src/int-rep
literal: gc-map ;
INSN: ##alien-assembly
literal: quot ;
literal: quot gc-map ;
INSN: ##begin-callback ;
@ -812,9 +812,6 @@ literal: cc ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
INSN: ##restore-context
temp: temp1/int-rep temp2/int-rep ;
! GC checks
INSN: ##check-nursery-branch
literal: size cc
@ -858,15 +855,21 @@ UNION: conditional-branch-insn
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
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
! allocate memory
UNION: gc-map-insn
##call-gc
##alien-invoke
##alien-indirect
##box
##box-long-long
##allot-byte-array ;
##allot-byte-array
factor-call-insn ;
M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! 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.instructions compiler.cfg.registers
cpu.architecture ;
@ -24,7 +24,12 @@ GENERIC: visit-insn ( live-set insn -- live-set )
M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
: 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
[ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;

View File

@ -1,6 +1,7 @@
USING: accessors compiler.cfg.debugger
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
0 vreg-counter set-global
@ -38,3 +39,34 @@ V{
] [
0 get instructions>>
] 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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit
compiler.cfg.instructions compiler.cfg.registers
USING: accessors compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
IN: compiler.cfg.save-contexts
! Insert context saves.
: needs-save-context? ( insns -- ? )
[
{
[ ##unary-float-function? ]
[ ##binary-float-function? ]
[ ##alien-invoke? ]
[ ##alien-indirect? ]
[ ##alien-assembly? ]
} 1||
] any? ;
GENERIC: needs-save-context? ( insn -- ? )
M: ##unary-float-function needs-save-context? drop t ;
M: ##binary-float-function needs-save-context? drop t ;
M: gc-map-insn needs-save-context? drop t ;
M: insn needs-save-context? drop f ;
: bb-needs-save-context? ( insn -- ? )
instructions>> [ needs-save-context? ] 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 -- )
dup instructions>> dup needs-save-context? [
tagged-rep next-vreg-rep
tagged-rep next-vreg-rep
\ ##save-context new-insn prefix
>>instructions drop
] [ 2drop ] if ;
dup bb-needs-save-context? [
[
int-rep next-vreg-rep
int-rep next-vreg-rep
\ ##save-context new-insn
] dip
[ save-context-offset ] keep
[ insert-nth ] change-instructions drop
] [ drop ] if ;
: insert-save-contexts ( cfg -- cfg' )
dup [ insert-save-context ] each-basic-block ;

View File

@ -32,13 +32,13 @@ SYMBOL: visited
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: update-predecessors ( from to bb -- )
! Update 'to' predecessors for insertion of 'bb' between
! 'from' and 'to'.
! Whenever 'from' appears in the list of predecessors of 'to'
! replace it with 'bb'.
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
:: update-successors ( from to bb -- )
! Update 'from' successors for insertion of 'bb' between
! 'from' and 'to'.
! Whenever 'to' appears in the list of successors of 'from'
! replace it with 'bb'.
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
:: 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-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
@ -304,4 +303,5 @@ CODEGEN: ##begin-callback %begin-callback
CODEGEN: ##alien-callback %alien-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: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- )

View File

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

View File

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

View File

@ -38,15 +38,17 @@ big-endian off
! Save C callstack pointer
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
nv-reg jit-update-tib
jit-install-seh
rs-reg nv-reg context-retainstack-offset [+] MOV
ds-reg nv-reg context-datastack-offset [+] MOV
! Call into Factor code
nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
nv-reg CALL
link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
link-reg CALL
! Load VM into vm-reg; only needed on x86-32, but doesn't
! 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 %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 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace