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

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