FFI rewrite part 6: deconcatenatize
Slava Pestov
parent
3f13fc7099
commit
a55c8ee671
basis
compiler
cfg
alias-analysis
branch-splitting
builder
finalization
instructions
liveness
save-contexts
utilities
codegen
cpu
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue