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
   6 compiler.tree
   7 compiler.tree.combinators
   8 compiler.tree.propagation.info
   9 compiler.tree.propagation.nodes
  10 compiler.tree.propagation.simple
  11 compiler.tree.propagation.constraints ;
  12 IN: compiler.tree.propagation.branches
  13
  14 ! For conditionals, an assoc of child node # --> constraint
  15 GENERIC: child-constraints ( node -- seq )
  16
  17 M: #if child-constraints
  18     in-d>> first [ =t ] [ =f ] bi 2array ;
  19
  20 M: #dispatch child-constraints
  21     children>> length f <repetition> ;
  22
  23 GENERIC: live-branches ( #branch -- indices )
  24
  25 M: #if live-branches
  26     in-d>> first value-info class>> {
  27         { [ dup null-class? ] [ { f f } ] }
  28         { [ dup true-class? ] [ { t f } ] }
  29         { [ dup false-class? ] [ { f t } ] }
  30         [ { t t } ]
  31     } cond nip ;
  32
  33 M: #dispatch live-branches
  34     [ children>> length ] [ in-d>> first value-info interval>> ] bi
  35     '[ _ interval-contains? ] map ;
  36
  37 : live-children ( #branch -- children )
  38     [ children>> ] [ live-branches>> ] bi select-children ;
  39
  40 SYMBOL: infer-children-data
  41
  42 : copy-value-info ( -- )
  43     value-infos [ clone ] change
  44     constraints [ clone ] change ;
  45
  46 : no-value-info ( -- )
  47     value-infos off
  48     constraints off ;
  49
  50 : infer-children ( node -- )
  51     [ live-children ] [ child-constraints ] bi [
  52         [
  53             over
  54             [ copy-value-info assume (propagate) ]
  55             [ 2drop no-value-info ]
  56             if
  57         ] H{ } make-assoc
  58     ] 2map infer-children-data set ;
  59
  60 : compute-phi-input-infos ( phi-in -- phi-info )
  61     infer-children-data get
  62     [
  63         '[
  64             _ [
  65                 dup +bottom+ eq?
  66                 [ drop null-info ] [ value-info ] if
  67             ] bind
  68         ] map
  69     ] 2map ;
  70
  71 : annotate-phi-inputs ( #phi -- )
  72     dup phi-in-d>> compute-phi-input-infos >>phi-info-d drop ;
  73
  74 : merge-value-infos ( infos outputs -- )
  75     [ [ value-infos-union ] map ] dip set-value-infos ;
  76
  77 SYMBOL: condition-value
  78
  79 M: #phi propagate-before ( #phi -- )
  80     [ annotate-phi-inputs ]
  81     [ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
  82     bi ;
  83
  84 : branch-phi-constraints ( output values booleans -- )
  85      {
  86         {
  87             { { t } { f } }
  88             [
  89                 drop condition-value get
  90                 [ [ =t ] [ =t ] bi* <--> ]
  91                 [ [ =f ] [ =f ] bi* <--> ] 2bi /\
  92             ]
  93         }
  94         {
  95             { { f } { t } }
  96             [
  97                 drop condition-value get
  98                 [ [ =t ] [ =f ] bi* <--> ]
  99                 [ [ =f ] [ =t ] bi* <--> ] 2bi /\
 100             ]
 101         }
 102         {
 103             { { t f } { f } }
 104             [
 105                 first =t
 106                 condition-value get =t /\
 107                 swap t-->
 108             ]
 109         }
 110         {
 111             { { f } { t f } }
 112             [
 113                 second =t
 114                 condition-value get =f /\
 115                 swap t-->
 116             ]
 117         }
 118         ! {
 119         !     { { t f } { } }
 120         !     [ B
 121         !         first
 122         !         [ [ =t ] bi@ <--> ]
 123         !         [ [ =f ] bi@ <--> ] 2bi /\
 124         !     ]
 125         ! }
 126         ! {
 127         !     { { } { t f } }
 128         !     [
 129         !         second
 130         !         [ [ =t ] bi@ <--> ]
 131         !         [ [ =f ] bi@ <--> ] 2bi /\
 132         !     ]
 133         ! }
 134         [ 3drop f ]
 135     } case assume ;
 136
 137 M: #phi propagate-after ( #phi -- )
 138     condition-value get [
 139         [ out-d>> ]
 140         [ phi-in-d>> <flipped> ]
 141         [ phi-info-d>> <flipped> ] tri
 142         [
 143             [ possible-boolean-values ] map
 144             branch-phi-constraints
 145         ] 3each
 146     ] [ drop ] if ;
 147
 148 M: #phi propagate-around ( #phi -- )
 149     [ propagate-before ] [ propagate-after ] bi ;
 150
 151 M: #branch propagate-around
 152     dup live-branches >>live-branches
 153     [ infer-children ] [ annotate-node ] bi ;
 154
 155 M: #if propagate-around
 156     [ in-d>> first condition-value set ] [ call-next-method ] bi ;
 157
 158 M: #dispatch propagate-around
 159     condition-value off call-next-method ;