basis/compiler/tree/propagation/branches/branches.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry kernel sequences assocs accessors
   4 math.intervals arrays classes.algebra combinators columns
   5 stack-checker.branches locals math namespaces
   6 compiler.utilities
   7 compiler.tree
   8 compiler.tree.combinators
   9 compiler.tree.propagation.info
  10 compiler.tree.propagation.nodes
  11 compiler.tree.propagation.simple
  12 compiler.tree.propagation.constraints ;
  13 FROM: sets => union ;
  14 FROM: assocs => change-at ;
  15 IN: compiler.tree.propagation.branches
  16
  17 ! For conditionals, an assoc of child node # --> constraint
  18 GENERIC: child-constraints ( node -- seq )
  19
  20 M: #if child-constraints
  21     in-d>> first [ =t ] [ =f ] bi 2array ;
  22
  23 M: #dispatch child-constraints
  24     children>> length f <repetition> ;
  25
  26 ! There is an important invariant here, either no flags are set
  27 ! in live-branches, exactly one is set, or all are set.
  28
  29 GENERIC: live-branches ( #branch -- indices )
  30
  31 M: #if live-branches
  32     in-d>> first value-info class>> {
  33         { [ dup null-class? ] [ { f f } ] }
  34         { [ dup true-class? ] [ { t f } ] }
  35         { [ dup false-class? ] [ { f t } ] }
  36         [ { t t } ]
  37     } cond nip ;
  38
  39 M: #dispatch live-branches
  40     [ children>> ] [ in-d>> first value-info ] bi {
  41         { [ dup class>> null-class? ] [ drop length f <array> ] }
  42         { [ dup literal>> integer? not ] [ drop length t <array> ] }
  43         { [ 2dup literal>> swap bounds-check? not ] [ drop length t <array> ] }
  44         [ literal>> swap length f <array> [ [ t ] 2dip set-nth ] keep ]
  45     } cond ;
  46
  47 : live-children ( #branch -- children )
  48     [ children>> ] [ live-branches>> ] bi select-children ;
  49
  50 SYMBOL: infer-children-data
  51
  52 : copy-value-info ( -- )
  53     value-infos [ H{ } clone suffix ] change
  54     constraints [ H{ } clone suffix ] change ;
  55
  56 : no-value-info ( -- )
  57     value-infos off
  58     constraints off ;
  59
  60 : infer-children ( node -- )
  61     [ live-children ] [ child-constraints ] bi [
  62         [
  63             over
  64             [ copy-value-info assume (propagate) ]
  65             [ 2drop no-value-info ]
  66             if
  67         ] H{ } make-assoc
  68     ] 2map infer-children-data set ;
  69
  70 : compute-phi-input-infos ( phi-in -- phi-info )
  71     infer-children-data get
  72     [
  73         '[
  74             _ [
  75                 dup +bottom+ eq?
  76                 [ drop null-info ] [ value-info ] if
  77             ] with-variables
  78         ] map
  79     ] 2map ;
  80
  81 : annotate-phi-inputs ( #phi -- )
  82     dup phi-in-d>> compute-phi-input-infos >>phi-info-d drop ;
  83
  84 : merge-value-infos ( infos outputs -- )
  85     [ [ value-infos-union ] map ] dip set-value-infos ;
  86
  87 SYMBOL: condition-value
  88
  89 M: #phi propagate-before ( #phi -- )
  90     [ annotate-phi-inputs ]
  91     [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
  92     bi ;
  93
  94 :: update-constraints ( new old -- )
  95     new [| key value | key old [ value union ] change-at ] assoc-each ;
  96
  97 : include-child-constraints ( i -- )
  98     infer-children-data get nth constraints swap at last
  99     constraints get last update-constraints ;
 100
 101 : branch-phi-constraints ( output values booleans -- )
 102     {
 103         {
 104             { { t } { f } }
 105             [
 106                 drop condition-value get
 107                 [ [ =t ] [ =t ] bi* <--> ]
 108                 [ [ =f ] [ =f ] bi* <--> ] 2bi /\
 109             ]
 110         }
 111         {
 112             { { f } { t } }
 113             [
 114                 drop condition-value get
 115                 [ [ =t ] [ =f ] bi* <--> ]
 116                 [ [ =f ] [ =t ] bi* <--> ] 2bi /\
 117             ]
 118         }
 119         {
 120             { { t f } { f } }
 121             [
 122                 first =t
 123                 condition-value get =t /\
 124                 swap t-->
 125             ]
 126         }
 127         {
 128             { { f } { t f } }
 129             [
 130                 second =t
 131                 condition-value get =f /\
 132                 swap t-->
 133             ]
 134         }
 135         {
 136             { { t f } { t } }
 137             [
 138                 first =f
 139                 condition-value get =t /\
 140                 swap f-->
 141             ]
 142         }
 143         {
 144             { { t } { t f } }
 145             [
 146                 second =f
 147                 condition-value get =f /\
 148                 swap f-->
 149             ]
 150         }
 151         {
 152             { { t f } { } }
 153             [
 154                 first
 155                 [ [ =t ] bi@ <--> ]
 156                 [ [ =f ] bi@ <--> ] 2bi /\
 157                 0 include-child-constraints
 158             ]
 159         }
 160         {
 161             { { } { t f } }
 162             [
 163                 second
 164                 [ [ =t ] bi@ <--> ]
 165                 [ [ =f ] bi@ <--> ] 2bi /\
 166                 1 include-child-constraints
 167             ]
 168         }
 169         [ 3drop f ]
 170     } case assume ;
 171
 172 M: #phi propagate-after ( #phi -- )
 173     condition-value get [
 174         [ out-d>> ]
 175         [ phi-in-d>> flip ]
 176         [ phi-info-d>> flip ] tri
 177         [
 178             [ possible-boolean-values ] map
 179             branch-phi-constraints
 180         ] 3each
 181     ] [ drop ] if ;
 182
 183 M: #branch propagate-around
 184     dup live-branches >>live-branches
 185     [ infer-children ] [ annotate-node ] bi ;
 186
 187 M: #if propagate-around
 188     [ in-d>> first condition-value set ] [ call-next-method ] bi ;
 189
 190 M: #dispatch propagate-around
 191     condition-value off call-next-method ;