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

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