basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs fry kernel locals math math.order arrays
   4 namespaces sequences sorting sets combinators combinators.short-circuit make
   5 compiler.cfg.def-use
   6 compiler.cfg.instructions
   7 compiler.cfg.liveness
   8 compiler.cfg.dominance
   9 compiler.cfg.ssa.destruction.state
  10 compiler.cfg.ssa.destruction.forest
  11 compiler.cfg.ssa.destruction.interference ;
  12 IN: compiler.cfg.ssa.destruction.process-blocks
  13
  14 ! phi-union maps a vreg to the predecessor block
  15 ! that carries it to the phi node's block
  16
  17 ! unioned-blocks is a set of bb's which defined
  18 ! the source vregs above
  19 SYMBOLS: phi-union unioned-blocks ;
  20
  21 :: operand-live-into-phi-node's-block? ( bb src dst -- ? )
  22     src bb live-in key? ;
  23
  24 :: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
  25     dst src def-of live-out key? ;
  26
  27 :: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
  28     { [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ;
  29
  30 :: operand-being-renamed? ( bb src dst -- ? )
  31     src processed-names get key? ;
  32
  33 :: two-operands-in-same-block? ( bb src dst -- ? )
  34     src def-of unioned-blocks get key? ;
  35
  36 : trivial-interference? ( bb src dst -- ? )
  37     {
  38         [ operand-live-into-phi-node's-block? ]
  39         [ phi-node-is-live-out-of-operand's-block? ]
  40         [ operand-is-phi-node-and-live-into-operand's-block? ]
  41         [ operand-being-renamed? ]
  42         [ two-operands-in-same-block? ]
  43     } 3|| ;
  44
  45 : don't-coalesce ( bb src dst -- )
  46     2nip processed-name ;
  47
  48 :: trivial-interference ( bb src dst -- )
  49     dst src bb waiting-for push-at
  50     src used-by-another get push ;
  51
  52 :: add-to-renaming-set ( bb src dst -- )
  53     bb src phi-union get set-at
  54     src def-of unioned-blocks get conjoin ;
  55
  56 : process-phi-operand ( bb src dst -- )
  57     {
  58         { [ 2dup eq? ] [ don't-coalesce ] }
  59         { [ 3dup trivial-interference? ] [ trivial-interference ] }
  60         [ add-to-renaming-set ]
  61     } cond ;
  62
  63 : node-is-live-in-of-child? ( node child -- ? )
  64     [ vreg>> ] [ bb>> live-in ] bi* key? ;
  65
  66 : node-is-live-out-of-child? ( node child -- ? )
  67     [ vreg>> ] [ bb>> live-out ] bi* key? ;
  68
  69 :: insert-copy ( bb src dst -- )
  70     bb src dst trivial-interference
  71     src phi-union get delete-at ;
  72
  73 :: insert-copy-for-parent ( bb src node dst -- )
  74     src node vreg>> eq? [ bb src dst insert-copy ] when ;
  75
  76 : insert-copies-for-parent ( ##phi node child -- )
  77     drop
  78     [ [ inputs>> ] [ dst>> ] bi ] dip
  79     '[ _ _ insert-copy-for-parent ] assoc-each ;
  80
  81 : defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
  82
  83 : add-interference ( ##phi node child -- )
  84     [ vreg>> ] bi@ 2array , drop ;
  85
  86 : process-df-child ( ##phi node child -- )
  87     {
  88         { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
  89         { [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
  90         { [ 2dup defined-in-same-block? ] [ add-interference ] }
  91         [ 3drop ]
  92     } cond ;
  93
  94 : process-df-node ( ##phi node -- )
  95     dup children>>
  96     [ [ process-df-child ] with with each ]
  97     [ nip [ process-df-node ] with each ]
  98     3bi ;
  99
 100 : process-phi-union ( ##phi dom-forest -- )
 101     [ process-df-node ] with each ;
 102
 103 : add-local-interferences ( ##phi -- )
 104     [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
 105
 106 : compute-local-interferences ( ##phi -- pairs )
 107     [
 108         [ phi-union get keys compute-dom-forest process-phi-union ]
 109         [ add-local-interferences ]
 110         bi
 111     ] { } make ;
 112
 113 :: insert-copies-for-interference ( ##phi src -- )
 114     ##phi inputs>> [| bb src' |
 115         src src' eq? [ bb src ##phi dst>> insert-copy ] when
 116     ] assoc-each ;
 117
 118 : process-local-interferences ( ##phi pairs -- )
 119     [
 120         first2 2dup interferes?
 121         [ drop insert-copies-for-interference ] [ 3drop ] if
 122     ] with each ;
 123
 124 : add-renaming-set ( ##phi -- )
 125     [ phi-union get ] dip dst>> renaming-sets get set-at
 126     phi-union get [ drop processed-name ] assoc-each ;
 127
 128 : process-phi ( ##phi -- )
 129     H{ } clone phi-union set
 130     H{ } clone unioned-blocks set
 131     [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
 132     [ dup compute-local-interferences process-local-interferences ]
 133     [ add-renaming-set ]
 134     tri ;
 135
 136 : process-block ( bb -- )
 137     instructions>>
 138     [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;