basis/compiler/tree/propagation/simple/simple.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types arrays assocs classes
   4 classes.algebra classes.algebra.private classes.maybe
   5 classes.tuple.private combinators combinators.short-circuit
   6 compiler.tree compiler.tree.propagation.constraints
   7 compiler.tree.propagation.info
   8 compiler.tree.propagation.inlining
   9 compiler.tree.propagation.nodes compiler.tree.propagation.slots
  10 continuations fry kernel sequences stack-checker.dependencies
  11 words ;
  12 IN: compiler.tree.propagation.simple
  13
  14 ! Propagation for straight-line code.
  15
  16 M: #introduce propagate-before
  17     out-d>> [ object-info swap set-value-info ] each ;
  18
  19 M: #push propagate-before
  20     [ literal>> <literal-info> ] [ out-d>> first ] bi
  21     set-value-info ;
  22
  23 : refine-value-infos ( classes values -- )
  24     [ refine-value-info ] 2each ;
  25
  26 : class-infos ( classes -- infos )
  27     [ <class-info> ] map ;
  28
  29 : set-value-infos ( infos values -- )
  30     [ set-value-info ] 2each ;
  31
  32 GENERIC: add-depends-on-class ( obj -- )
  33
  34 M: class add-depends-on-class
  35     add-depends-on-conditionally ;
  36
  37 M: maybe add-depends-on-class
  38     class>> add-depends-on-class ;
  39
  40 M: anonymous-union add-depends-on-class
  41     members>> [ add-depends-on-class ] each ;
  42
  43 M: anonymous-intersection add-depends-on-class
  44     participants>> [ add-depends-on-class ] each ;
  45
  46 M: #declare propagate-before
  47     #! We need to force the caller word to recompile when the
  48     #! classes mentioned in the declaration are redefined, since
  49     #! now we're making assumptions but their definitions.
  50     declaration>> [
  51         [ add-depends-on-class ]
  52         [ <class-info> swap refine-value-info ]
  53         bi
  54     ] assoc-each ;
  55
  56 : predicate-constraints ( value class boolean-value -- constraint )
  57     [ [ is-instance-of ] dip t--> ]
  58     [ [ class-not is-instance-of ] dip f--> ]
  59     3bi /\ ;
  60
  61 : custom-constraints ( #call quot -- )
  62     [ [ in-d>> ] [ out-d>> ] bi append ] dip
  63     with-datastack first assume ;
  64
  65 : compute-constraints ( #call word -- )
  66     dup "constraints" word-prop [ nip custom-constraints ] [
  67         dup predicate? [
  68             [ [ in-d>> first ] [ out-d>> first ] bi ]
  69             [ "predicating" word-prop ] bi*
  70             swap predicate-constraints assume
  71         ] [ 2drop ] if
  72     ] if* ;
  73
  74 ERROR: invalid-outputs #call infos ;
  75
  76 : check-outputs ( #call infos -- infos )
  77     over out-d>> over [ length ] bi@ =
  78     [ nip ] [ invalid-outputs ] if ;
  79
  80 : call-outputs-quot ( #call word -- infos )
  81     dupd
  82     [ in-d>> [ value-info ] map ]
  83     [ "outputs" word-prop ] bi*
  84     with-datastack check-outputs ;
  85
  86 : literal-inputs? ( #call -- ? )
  87     in-d>> [ value-info literal?>> ] all? ;
  88
  89 : input-classes-match? ( #call word -- ? )
  90     [ in-d>> ] [ "input-classes" word-prop ] bi*
  91     [ [ value-info literal>> ] dip instance? ] 2all? ;
  92
  93 : foldable-call? ( #call word -- ? )
  94     {
  95         [ nip foldable? ]
  96         [ drop literal-inputs? ]
  97         [ input-classes-match? ]
  98     } 2&& ;
  99
 100 : (fold-call) ( #call word -- info )
 101     [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
 102     '[ _ _ with-datastack [ <literal-info> ] map nip ]
 103     [ drop length [ object-info ] replicate ]
 104     recover ;
 105
 106 : fold-call ( #call word -- )
 107     [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
 108
 109 : predicate-output-infos/literal ( info class -- info )
 110     [ literal>> ] dip
 111     '[ _ _ instance? <literal-info> ]
 112     [ drop object-info ]
 113     recover ;
 114
 115 : predicate-output-infos/class ( info class -- info )
 116     [ class>> ] dip evaluate-class-predicate
 117     dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
 118
 119 : predicate-output-infos ( info class -- info )
 120     over literal?>>
 121     [ predicate-output-infos/literal ]
 122     [ predicate-output-infos/class ]
 123     if ;
 124
 125 : propagate-predicate ( #call word -- infos )
 126     #! We need to force the caller word to recompile when the class
 127     #! is redefined, since now we're making assumptions but the
 128     #! class definition itself.
 129     [ in-d>> first value-info ]
 130     [ "predicating" word-prop ] bi*
 131     [ nip add-depends-on-conditionally ]
 132     [ predicate-output-infos 1array ] 2bi ;
 133
 134 : default-output-value-infos ( #call word -- infos )
 135     "default-output-classes" word-prop
 136     [ class-infos ] [ out-d>> length object-info <repetition> ] ?if ;
 137
 138 : output-value-infos ( #call word -- infos )
 139     {
 140         { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
 141         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
 142         { [ dup predicate? ] [ propagate-predicate ] }
 143         { [ dup "outputs" word-prop ] [ call-outputs-quot ] }
 144         [ default-output-value-infos ]
 145     } cond ;
 146
 147 M: #call propagate-before
 148     dup word>> {
 149         { [ 2dup foldable-call? ] [ fold-call ] }
 150         { [ 2dup do-inlining ] [
 151             [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
 152         ] }
 153         [
 154             [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
 155             [ compute-constraints ]
 156             2bi
 157         ]
 158     } cond ;
 159
 160 M: #call annotate-node
 161     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
 162
 163 : propagate-input-classes ( node input-classes -- )
 164     class-infos swap in-d>> refine-value-infos ;
 165
 166 M: #call propagate-after
 167     dup word>> "input-classes" word-prop dup
 168     [ propagate-input-classes ] [ 2drop ] if ;
 169
 170 : propagate-alien-invoke ( node -- )
 171     [ out-d>> ] [ params>> return>> ] bi
 172     [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 173
 174 M: #alien-node propagate-before propagate-alien-invoke ;
 175
 176 M: #alien-callback propagate-around child>> (propagate) ;
 177
 178 M: #return annotate-node dup in-d>> (annotate-node) ;