Paste: GRWBE

Author: littledan
Mode: factor
Date: Thu, 13 Aug 2009 04:20:46
Plain Text | 
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.dataflow-analysis fry combinators.short-circuit ;
IN: compiler.cfg.write-barrier

! Eliminate redundant write barrier hits.

! Objects which have already been marked, as well as
! freshly-allocated objects
SYMBOL: safe

! Objects which have been mutated
SYMBOL: mutated

GENERIC: eliminate-write-barrier ( insn -- ? )

M: ##allot eliminate-write-barrier
    dst>> safe get conjoin t ;

M: ##write-barrier eliminate-write-barrier
    src>> dup [ safe get key? not ] [ mutated get key? ] bi and
    [ safe get conjoin t ] [ drop f ] if ;

M: ##set-slot eliminate-write-barrier
    obj>> mutated get conjoin t ;

M: ##set-slot-imm eliminate-write-barrier
    obj>> mutated get conjoin t ;

M: insn eliminate-write-barrier drop t ;

FORWARD-ANALYSIS: safe

: has-allocation? ( bb -- ? )
    instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;

M: safe-analysis transfer-set
    drop [ H{ } assoc-clone-like ] dip
    instructions>> over '[
        dup ##write-barrier? [
            src>> _ conjoin
        ] [ drop ] if
    ] each ;

M: safe-analysis join-sets
    drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;

: write-barriers-step ( bb -- )
    dup safe-in H{ } assoc-clone-like safe set
    H{ } clone mutated set
    instructions>> [ eliminate-write-barrier ] filter-here ;

: eliminate-write-barriers ( cfg -- cfg' )
     dup compute-safe-sets
    dup [ write-barriers-step ] each-basic-block ;

Annotation: hoisting write barriers out of loops

Author: littledan
Mode: factor
Date: Fri, 14 Aug 2009 01:16:41
Plain Text | 
! 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
compiler.cfg
compiler.cfg.dominance
compiler.cfg.predecessors
compiler.cfg.loop-detection
compiler.cfg.rpo
compiler.cfg.instructions 
compiler.cfg.registers
compiler.cfg.dataflow-analysis 
compiler.cfg.utilities ;
IN: compiler.cfg.write-barrier

! Eliminate redundant write barrier hits.

! Objects which have already been marked, as well as
! freshly-allocated objects
SYMBOL: safe

! Objects which have been mutated
SYMBOL: mutated

GENERIC: eliminate-write-barrier ( insn -- ? )

M: ##allot eliminate-write-barrier
    dst>> safe get conjoin t ;

M: ##write-barrier eliminate-write-barrier
    src>> dup safe get key? not
    [ safe get conjoin t ] [ drop f ] if ;

M: insn eliminate-write-barrier drop t ;

! This doesn't actually benefit from being a dataflow analysis
! might as well be dominator-based
! Dealing with phi functions would help, though
FORWARD-ANALYSIS: safe

: has-allocation? ( bb -- ? )
    instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;

M: safe-analysis transfer-set
    drop [ H{ } assoc-clone-like safe set ] dip
    instructions>> [
        eliminate-write-barrier drop
    ] each safe get ;

M: safe-analysis join-sets
    drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;

: write-barriers-step ( bb -- )
    dup safe-in H{ } assoc-clone-like safe set
    instructions>> [ eliminate-write-barrier ] filter-here ;

GENERIC: remove-dead-barrier ( insn -- ? )

M: ##write-barrier remove-dead-barrier
    src>> mutated get key? ;

M: ##set-slot remove-dead-barrier
    obj>> mutated get conjoin t ;

M: ##set-slot-imm remove-dead-barrier
    obj>> mutated get conjoin t ;

M: insn remove-dead-barrier drop t ;

: remove-dead-barriers ( bb -- )
    H{ } clone mutated set
    instructions>> [ remove-dead-barrier ] filter-here ;

! Availability of slot
! Anticipation of this and set-slot would help too, maybe later
FORWARD-ANALYSIS: slot

M: slot-analysis transfer-set
    drop [ H{ } assoc-clone-like ] dip
    instructions>> over '[
        dup ##read? [
            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 ;

: emit-barriers ( vregs bb -- )
    predecessors>> [ make-barriers ] with each ;

: write-barriers ( bbs -- bb=>barriers )
    [
        dup instructions>>
        [ ##write-barrier? ] filter
        [ src>> ] map
    ] { } map>assoc
    [ nip empty? not ] assoc-filter ;

: filter-dominant ( bb=>barriers bbs -- barriers )
    '[ drop _ [ dominates? ] with all? ] assoc-filter
    values concat prune ;

: dominant-write-barriers ( loop -- vregs )
    [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;

: insert-extra-barriers ( -- )
    loops get values [| loop |
        loop dominant-write-barriers
        loop header>> '[ _ slot-available? ] filter
        [ loop header>> emit-barriers ] unless-empty
    ] each ;

: contains-write-barrier? ( cfg -- ? )
    post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;

: eliminate-write-barriers ( cfg -- cfg' )
    dup contains-write-barrier? [
        needs-loops needs-dominance needs-predecessors
        dup [ remove-dead-barriers ] each-basic-block
        dup compute-slot-sets
        insert-extra-barriers
        dup compute-safe-sets
        dup [ write-barriers-step ] each-basic-block
    ] when ;

New Annotation

Summary:
Author:
Mode:
Body: