USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo ;
+compiler.cfg.rpo arrays ;
IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-:: insert-basic-block ( from to bb -- )
- bb from 1vector >>predecessors drop
+:: insert-basic-block ( froms to bb -- )
+ bb froms V{ } like >>predecessors drop
bb to 1vector >>successors drop
- to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
- from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+ to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
+ froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
\ ##branch new-insn over push
>>instructions ;
+: insert-simple-basic-block ( from to insns -- )
+ [ 1vector ] 2dip <simple-block> insert-basic-block ;
+
: has-phis? ( bb -- ? )
instructions>> first ##phi? ;
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences
-fry combinators.short-circuit locals
+fry combinators.short-circuit locals make arrays
compiler.cfg
compiler.cfg.dominance
compiler.cfg.predecessors
! Anticipation of this and set-slot would help too, maybe later
FORWARD-ANALYSIS: slot
+UNION: access ##read ##write ;
+
M: slot-analysis transfer-set
drop [ H{ } assoc-clone-like ] dip
instructions>> over '[
- dup ##read? [
+ dup access? [
obj>> _ conjoin
] [ drop ] if
] each ;
: slot-available? ( vreg bb -- ? )
slot-in key? ;
-: make-barriers ( vregs bb -- )
- [ [ next-vreg next-vreg ##write-barrier ] each ] add-instructions ;
+: make-barriers ( vregs -- bb )
+ [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
-: emit-barriers ( vregs bb -- )
- predecessors>> [ make-barriers ] with each ;
+: emit-barriers ( vregs loop -- )
+ swap [
+ [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
+ [ header>> ] bi
+ ] [ make-barriers ] bi*
+ insert-basic-block ;
: write-barriers ( bbs -- bb=>barriers )
[
: dominant-write-barriers ( loop -- vregs )
[ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
-: insert-extra-barriers ( -- )
- loops get values [| loop |
+: safe-loops ( -- loops )
+ loops get values
+ [ blocks>> keys [ has-allocation? not ] all? ] filter ;
+
+:: insert-extra-barriers ( cfg -- )
+ safe-loops [| loop |
+ cfg needs-dominance needs-predecessors drop
loop dominant-write-barriers
loop header>> '[ _ slot-available? ] filter
- [ loop header>> emit-barriers ] unless-empty
+ [ loop emit-barriers cfg cfg-changed drop ] unless-empty
] each ;
: contains-write-barrier? ( cfg -- ? )
: eliminate-write-barriers ( cfg -- cfg' )
dup contains-write-barrier? [
- needs-loops needs-dominance needs-predecessors
+ needs-loops
dup [ remove-dead-barriers ] each-basic-block
dup compute-slot-sets
- insert-extra-barriers
+ dup insert-extra-barriers
dup compute-safe-sets
dup [ write-barriers-step ] each-basic-block
] when ;