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
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 )
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
\ ##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 ]
! 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
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
! 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? [
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 -- ? )
[ 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-assembly emit-node
+M: #alien-indirect emit-node ( node -- )
+ params>>
[
- {
- [ caller-parameters ]
- [ quot>> ##alien-assembly ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
+ ds-pop ^^unbox-any-c-ptr
+ [ caller-parameters ] dip
+ <gc-map> ##alien-indirect
+ ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ tri ;
+
+M: #alien-assembly emit-node
+ 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
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
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 ;
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 ;
: finalize-cfg ( cfg -- cfg' )
select-representations
- schedule-instructions
+ ! schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
insert-save-contexts
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 ;
[ 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
[ 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
-
-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
+4 \ vreg-counter set-global
-[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
[ ] [ 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
} 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
! 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
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 ;
: 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
-
-! Any ##phi instructions at the start of bb are transplanted
-! into the gc-check block.
-
-: <gc-check> ( phis size -- bb )
- [ <basic-block> ] 2dip
- [
- [ % ]
- [
- cc<= int-rep next-vreg-rep int-rep next-vreg-rep
- ##check-nursery-branch
- ] bi*
- ] V{ } make >>instructions ;
-
-: <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<<
+GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
- V{ check body } bb predecessors<<
+:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
+ seen-allocation? [ call-index , ] when
+ insn-index 1 + f ;
- check predecessors>> [ bb check update-successors ] each ;
+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 ;
-: (insert-gc-check) ( phis size bb -- )
- [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+: 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
+ [ , ] [ drop ] if
+ ] { } make ;
+
+:: 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 )
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 ;
+
+: make-blocks ( insns-seq -- bbs )
+ [ <basic-block> swap >>instructions ] map ;
-: insert-gc-check ( bb -- )
- [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
+: <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 ;
literal: gc-map ;
INSN: ##alien-assembly
-literal: quot ;
+literal: quot gc-map ;
INSN: ##begin-callback ;
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
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 ;
! 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 ;
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 ;
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
] [
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
! 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 ;
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 -- )
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
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 ;
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 ( -- )
: 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 ;
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
: 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 ;
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
! 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
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
projects / factor.git / commitdiff