diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index dfbb70f7dd..9b6fce9379 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -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 diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index ad6a5c011e..aeac122832 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -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 ] diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index b6cde4d435..985d296cc6 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -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 diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 04ac2bf496..7e3db2cba8 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -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 ] keep - [ [ ^^peek ] [ base-type ] bi* unbox-parameter ] + [ [ 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 ##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 ##alien-indirect ] + params>> + { + [ caller-parameters ] + [ ##prepare-var-args alien-invoke-dlsym ##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 + ##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>> ##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 ; diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index c6d541460a..60f6f0acbf 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -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 ; diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index 83bcc0b0b1..9a4947abfb 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -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 diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index d8745c0784..a047fc4c9d 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -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 size assert= ] unit-test +[ ] [ 1 get instructions>> allocation-size 123 size assert= ] unit-test 2 \ vreg-counter set-global @@ -36,58 +112,16 @@ V{ [ first ##check-nursery-branch? ] } 1&& ; -[ t ] [ V{ } 100 gc-check? ] unit-test - -4 \ vreg-counter set-global - -[ +: gc-call? ( bb -- ? ) + instructions>> V{ T{ ##call-gc f T{ gc-map } } T{ ##branch } - } -] -[ - 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? ] 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 diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 50cd67567c..e758ec808d 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -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 -> [ 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 ; -: ( phis size -- bb ) - [ ] 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 ; -: ( -- bb ) - - [ ##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 -- ) - [ [ ] 2dip ] 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 [ + 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 ) + [ swap >>instructions ] map ; + +: ( -- bb ) + + [ ##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 [ ] 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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 39d2ab81cd..0e94ab6e6b 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 1a5287355d..ef12e8323f 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -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 ; diff --git a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor index 020d000b6a..8dd267fd44 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor @@ -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 diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index e2ccf943ad..fa37a516a7 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -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 ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 38ca9a950f..0ca2b2d11c 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -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 -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 68b01beed9..703d8126e0 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 931dccece1..f81ac8f52a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 ( -- ) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 2b82fa8117..fdcf5ca25f 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index e81e924245..308546131a 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index db3a575154..08f89e1b91 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d3adcf3960..cb48438240 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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