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

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