basis/compiler/cfg/ssa/interference/interference.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators combinators.short-circuit
   4 compiler.cfg.dominance compiler.cfg.ssa.interference.live-ranges
   5 kernel locals math math.order sequences sorting.slots ;
   6 IN: compiler.cfg.ssa.interference
   7
   8 TUPLE: vreg-info vreg value def-index bb pre-of color equal-anc-in equal-anc-out ;
   9
  10 :: <vreg-info> ( vreg value bb -- info )
  11     vreg-info new
  12         vreg >>vreg
  13         bb >>bb
  14         value >>value
  15         bb pre-of >>pre-of
  16         vreg bb def-index >>def-index ;
  17
  18 <PRIVATE
  19
  20 ! Our dominance pass computes dominance information on a
  21 ! per-basic block level. Rig up a more fine-grained dominance
  22 ! test here.
  23 : locally-dominates? ( vreg1 vreg2 -- ? )
  24     [ def-index>> ] bi@ < ;
  25
  26 :: vreg-dominates? ( vreg1 vreg2 -- ? )
  27     vreg1 bb>> :> bb1
  28     vreg2 bb>> :> bb2
  29     bb1 bb2 eq?
  30     [ vreg1 vreg2 locally-dominates? ] [ bb1 bb2 dominates? ] if ;
  31
  32 ! Testing individual vregs for live range intersection.
  33 : kill-after-def? ( vreg1 vreg2 bb -- ? )
  34     ! If first register is used after second one is defined, they interfere.
  35     ! If they are used in the same instruction, no interference. If the
  36     ! instruction is a def-is-use-insn, then there will be a use at +1
  37     ! (instructions are 2 apart) and so outputs will interfere with
  38     ! inputs.
  39     [ kill-index ] [ def-index ] bi-curry bi* > ;
  40
  41 : interferes-first-dominates? ( vreg1 vreg2 -- ? )
  42     ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
  43     ! occurs before vreg1 is killed.
  44     [ [ vreg>> ] bi@ ] [ nip bb>> ] 2bi kill-after-def? ;
  45
  46 : interferes-second-dominates? ( vreg1 vreg2 -- ? )
  47     ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
  48     ! occurs before vreg2 is killed.
  49     swap interferes-first-dominates? ;
  50
  51 : interferes-same-block? ( vreg1 vreg2 -- ? )
  52     ! If both are defined in the same basic block, they interfere if their
  53     ! local live ranges intersect.
  54     2dup locally-dominates? [ swap ] unless
  55     interferes-first-dominates? ;
  56
  57 :: vregs-intersect? ( vreg1 vreg2 -- ? )
  58     vreg1 bb>> :> bb1
  59     vreg2 bb>> :> bb2
  60     {
  61         { [ bb1 bb2 eq? ] [ vreg1 vreg2 interferes-same-block? ] }
  62         { [ bb1 bb2 dominates? ] [ vreg1 vreg2 interferes-first-dominates? ] }
  63         { [ bb2 bb1 dominates? ] [ vreg1 vreg2 interferes-second-dominates? ] }
  64         [ f ]
  65     } cond ;
  66
  67 ! Value-based interference test.
  68 : chain-intersect ( vreg1 vreg2 -- vreg )
  69     [ 2dup { [ nip ] [ vregs-intersect? not ] } 2&& ]
  70     [ equal-anc-in>> ]
  71     while nip ;
  72
  73 : update-equal-anc-out ( vreg1 vreg2 -- )
  74     dupd chain-intersect >>equal-anc-out drop ;
  75
  76 : same-sets? ( vreg1 vreg2 -- ? )
  77     [ color>> ] bi@ eq? ;
  78
  79 : same-values? ( vreg1 vreg2 -- ? )
  80     [ value>> ] bi@ eq? ;
  81
  82 : vregs-interfere? ( vreg1 vreg2 -- ? )
  83     [ f >>equal-anc-out ] dip
  84
  85     2dup same-sets? [ equal-anc-out>> ] when
  86
  87     2dup same-values?
  88     [ update-equal-anc-out f ] [ chain-intersect >boolean ] if ;
  89
  90 ! Merging lists of vregs sorted by dominance.
  91 M: vreg-info <=> ( vreg1 vreg2 -- <=> )
  92     { { pre-of>> <=> } { def-index>> <=> } } compare-slots ;
  93
  94 SYMBOLS: blue red ;
  95
  96 TUPLE: iterator seq n ;
  97 : <iterator> ( seq -- iterator ) 0 iterator boa ; inline
  98 : done? ( iterator -- ? ) [ seq>> length ] [ n>> ] bi = ; inline
  99 : this ( iterator -- obj ) [ n>> ] [ seq>> ] bi nth ; inline
 100 : ++ ( iterator -- ) [ 1 + ] change-n drop ; inline
 101 : take ( iterator -- obj ) [ this ] [ ++ ] bi ; inline
 102
 103 : blue-smaller? ( blue red -- ? )
 104     [ this ] bi@ before? ; inline
 105
 106 : take-blue? ( blue red -- ? )
 107     {
 108         [ nip done? ]
 109         [
 110             {
 111                 [ drop done? not ]
 112                 [ blue-smaller? ]
 113             } 2&&
 114         ]
 115     } 2|| ; inline
 116
 117 : merge-sets ( blue red -- seq )
 118     [ <iterator> ] bi@
 119     [ 2dup [ done? ] both? not ]
 120     [
 121         2dup take-blue?
 122         [ over take blue >>color ]
 123         [ dup take red >>color ]
 124         if
 125     ] produce 2nip ;
 126
 127 : update-for-merge ( seq -- )
 128     [
 129         dup [ equal-anc-in>> ] [ equal-anc-out>> ] bi
 130         2dup and [ [ vreg-dominates? ] most ] [ or ] if
 131         >>equal-anc-in
 132         drop
 133     ] each ;
 134
 135 ! Linear-time live range intersection test in a merged set.
 136 : find-parent ( dom current -- vreg )
 137     over empty? [ 2drop f ] [
 138         over last over vreg-dominates?
 139         [ drop last ] [ over pop* find-parent ] if
 140     ] if ;
 141
 142 :: linear-interference-test ( seq -- ? )
 143     V{ } clone :> dom
 144     seq [| vreg |
 145         dom vreg find-parent
 146         { [ ] [ vreg same-sets? not ] [ vreg swap vregs-interfere? ] } 1&&
 147         [ t ] [ vreg dom push f ] if
 148     ] any? ;
 149
 150 : sets-interfere-1? ( seq1 seq2 -- merged/f ? )
 151     [ first ] bi@
 152     2dup before? [ swap ] unless
 153     2dup same-values? [
 154         2dup equal-anc-in<<
 155         2array f
 156     ] [
 157         2dup vregs-intersect?
 158         [ 2drop f t ] [ 2array f ] if
 159     ] if ;
 160
 161 PRIVATE>
 162
 163 : sets-interfere? ( seq1 seq2 -- merged/f ? )
 164     2dup [ length 1 = ] both? [ sets-interfere-1? ] [
 165         merge-sets dup linear-interference-test
 166         [ drop f t ] [ dup update-for-merge f ] if
 167     ] if ;