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

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