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 M: #declare propagate-before
  20     ! We need to force the caller word to recompile when the
  21     ! classes mentioned in the declaration are redefined, since
  22     ! now we're making assumptions about their definitions.
  23     declaration>> [
  24         [ add-depends-on-class ]
  25         [ <class-info> swap refine-value-info ]
  26         bi
  27     ] assoc-each ;
  28
  29 : predicate-constraints ( value class boolean-value -- constraint )
  30     [ [ is-instance-of ] dip t--> ]
  31     [ [ class-not is-instance-of ] dip f--> ]
  32     3bi 2array ;
  33
  34 : custom-constraints ( #call quot -- )
  35     [ [ in-d>> ] [ out-d>> ] bi append ] dip
  36     with-datastack first assume ;
  37
  38 : compute-constraints ( #call word -- )
  39     dup "constraints" word-prop [ nip custom-constraints ] [
  40         dup predicate? [
  41             [ [ in-d>> first ] [ out-d>> first ] bi ]
  42             [ "predicating" word-prop ] bi*
  43             swap predicate-constraints assume
  44         ] [ 2drop ] if
  45     ] if* ;
  46
  47 ERROR: invalid-outputs #call infos ;
  48
  49 : check-outputs ( #call infos -- infos )
  50     over out-d>> over 2length =
  51     [ nip ] [ invalid-outputs ] if ;
  52
  53 : call-outputs-quot ( #call word -- infos )
  54     dupd
  55     [ in-d>> [ value-info ] map ]
  56     [ "outputs" word-prop ] bi*
  57     with-datastack check-outputs ;
  58
  59 : literal-inputs? ( #call -- ? )
  60     in-d>> [ value-info literal?>> ] all? ;
  61
  62 : input-classes-match? ( #call word -- ? )
  63     [ in-d>> ] [ "input-classes" word-prop ] bi*
  64     [ [ value-info literal>> ] dip instance? ] 2all? ;
  65
  66 : foldable-call? ( #call word -- ? )
  67     {
  68         [ nip foldable? ]
  69         [ drop literal-inputs? ]
  70         [ input-classes-match? ]
  71     } 2&& ;
  72
  73 : (fold-call) ( #call word -- info )
  74     [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
  75     '[ _ _ with-datastack [ <literal-info> ] map nip ]
  76     [ drop length [ object-info ] replicate ]
  77     recover ;
  78
  79 : fold-call ( #call word -- )
  80     [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
  81
  82 : predicate-output-infos/literal ( info class -- info )
  83     [ literal>> ] dip
  84     '[ _ _ instance? <literal-info> ]
  85     [ drop object-info ]
  86     recover ;
  87
  88 : predicate-output-infos/class ( info class -- info )
  89     [ class>> ] dip evaluate-class-predicate
  90     dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
  91
  92 : predicate-output-infos ( info class -- info )
  93     over literal?>>
  94     [ predicate-output-infos/literal ]
  95     [ predicate-output-infos/class ]
  96     if ;
  97
  98 : propagate-predicate ( #call word -- infos )
  99     [ in-d>> first value-info ]
 100     [ "predicating" word-prop ] bi*
 101     [ nip +conditional+ depends-on ]
 102     [ predicate-output-infos 1array ] 2bi ;
 103
 104 : default-output-value-infos ( #call word -- infos )
 105     "default-output-classes" word-prop
 106     [ class-infos ] [ out-d>> length object-info <repetition> ] ?if-old ;
 107
 108 : output-value-infos ( #call word -- infos )
 109     {
 110         { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
 111         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
 112         { [ dup predicate? ] [ propagate-predicate ] }
 113         { [ dup "outputs" word-prop ] [ call-outputs-quot ] }
 114         [ default-output-value-infos ]
 115     } cond ;
 116
 117 M: #call propagate-before
 118     dup word>> {
 119         { [ 2dup foldable-call? ] [ fold-call ] }
 120         { [ 2dup do-inlining ] [
 121             [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
 122         ] }
 123         [
 124             [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
 125             [ compute-constraints ]
 126             2bi
 127         ]
 128     } cond ;
 129
 130 M: #call annotate-node
 131     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
 132
 133 : propagate-input-infos ( node infos/f -- )
 134     swap in-d>> refine-value-infos ;
 135
 136 M: #call propagate-after
 137     dup word>> word>input-infos propagate-input-infos ;
 138
 139 : propagate-alien-invoke ( node -- )
 140     [ out-d>> ] [ params>> return>> ] bi
 141     [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 142
 143 M: #alien-node propagate-before propagate-alien-invoke ;
 144
 145 M: #alien-callback propagate-around child>> (propagate) ;
 146
 147 M: #return annotate-node dup in-d>> (annotate-node) ;