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
12 IN: compiler.tree.propagation.simple
14 ! Propagation for straight-line code.
16 M: #introduce propagate-before
17 out-d>> [ object-info swap set-value-info ] each ;
19 M: #push propagate-before
20 [ literal>> <literal-info> ] [ out-d>> first ] bi
23 : refine-value-infos ( classes values -- )
24 [ refine-value-info ] 2each ;
26 : class-infos ( classes -- infos )
27 [ <class-info> ] map ;
29 : set-value-infos ( infos values -- )
30 [ set-value-info ] 2each ;
32 GENERIC: add-depends-on-class ( obj -- )
34 M: class add-depends-on-class
35 add-depends-on-conditionally ;
37 M: maybe add-depends-on-class
38 class>> add-depends-on-class ;
40 M: anonymous-union add-depends-on-class
41 members>> [ add-depends-on-class ] each ;
43 M: anonymous-intersection add-depends-on-class
44 participants>> [ add-depends-on-class ] each ;
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.
51 [ add-depends-on-class ]
52 [ <class-info> swap refine-value-info ]
56 : predicate-constraints ( value class boolean-value -- constraint )
57 [ [ is-instance-of ] dip t--> ]
58 [ [ class-not is-instance-of ] dip f--> ]
61 : custom-constraints ( #call quot -- )
62 [ [ in-d>> ] [ out-d>> ] bi append ] dip
63 with-datastack first assume ;
65 : compute-constraints ( #call word -- )
66 dup "constraints" word-prop [ nip custom-constraints ] [
68 [ [ in-d>> first ] [ out-d>> first ] bi ]
69 [ "predicating" word-prop ] bi*
70 swap predicate-constraints assume
74 ERROR: invalid-outputs #call infos ;
76 : check-outputs ( #call infos -- infos )
77 over out-d>> over [ length ] bi@ =
78 [ nip ] [ invalid-outputs ] if ;
80 : call-outputs-quot ( #call word -- infos )
82 [ in-d>> [ value-info ] map ]
83 [ "outputs" word-prop ] bi*
84 with-datastack check-outputs ;
86 : literal-inputs? ( #call -- ? )
87 in-d>> [ value-info literal?>> ] all? ;
89 : input-classes-match? ( #call word -- ? )
90 [ in-d>> ] [ "input-classes" word-prop ] bi*
91 [ [ value-info literal>> ] dip instance? ] 2all? ;
93 : foldable-call? ( #call word -- ? )
96 [ drop literal-inputs? ]
97 [ input-classes-match? ]
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 ]
106 : fold-call ( #call word -- )
107 [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
109 : predicate-output-infos/literal ( info class -- info )
111 '[ _ _ instance? <literal-info> ]
115 : predicate-output-infos/class ( info class -- info )
116 [ class>> ] dip evaluate-class-predicate
117 dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
119 : predicate-output-infos ( info class -- info )
121 [ predicate-output-infos/literal ]
122 [ predicate-output-infos/class ]
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 ;
134 : default-output-value-infos ( #call word -- infos )
135 "default-output-classes" word-prop
136 [ class-infos ] [ out-d>> length object-info <repetition> ] ?if ;
138 : output-value-infos ( #call word -- infos )
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 ]
147 M: #call propagate-before
149 { [ 2dup foldable-call? ] [ fold-call ] }
150 { [ 2dup do-inlining ] [
151 [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
154 [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
155 [ compute-constraints ]
160 M: #call annotate-node
161 dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
163 : propagate-input-classes ( node input-classes -- )
164 class-infos swap in-d>> refine-value-infos ;
166 M: #call propagate-after
167 dup word>> "input-classes" word-prop dup
168 [ propagate-input-classes ] [ 2drop ] if ;
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 ;
174 M: #alien-node propagate-before propagate-alien-invoke ;
176 M: #alien-callback propagate-around child>> (propagate) ;
178 M: #return annotate-node dup in-d>> (annotate-node) ;