1 ! Copyright (C) 2008, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: namespaces assocs accessors kernel kernel.private combinators
4 classes.algebra sequences slots.private fry vectors
5 classes.tuple.private math math.private arrays
6 stack-checker.branches stack-checker.values
11 compiler.tree.combinators
12 compiler.tree.propagation
13 compiler.tree.propagation.info
14 compiler.tree.escape-analysis.simple
15 compiler.tree.escape-analysis.allocations ;
16 IN: compiler.tree.tuple-unboxing
18 ! This pass must run after escape analysis
20 GENERIC: unbox-tuples* ( node -- node/nodes )
22 : unbox-output? ( node -- values )
23 out-d>> first unboxed-allocation ;
25 : (expand-#push) ( object value -- nodes )
26 dup unboxed-allocation dup [
27 [ object-slots ] [ drop ] [ ] tri*
28 [ (expand-#push) ] 2map-flat
33 : expand-#push ( #push -- nodes )
34 [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
36 M: #push unbox-tuples* ( #push -- nodes )
37 dup unbox-output? [ expand-#push ] when ;
39 : unbox-<tuple-boa> ( #call -- nodes )
40 dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
42 : (flatten-values) ( values accum -- )
44 dup unboxed-allocation
45 [ _ (flatten-values) ] [ _ push ] ?if
48 : flatten-values ( values -- values' )
50 10 <vector> [ (flatten-values) ] keep
53 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
54 [ in-d>> flatten-values ]
55 [ out-d>> flatten-values ]
57 out-d>> first slot-accesses get at
58 [ slot#>> ] [ value>> ] bi allocation nth
62 : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
63 [ drop ] [ zip ] 2bi #data-shuffle ;
65 : unbox-slot-access ( #call -- nodes )
66 dup out-d>> first unboxed-slot-access? [
67 prepare-slot-access slot-access-shuffle
70 M: #call unbox-tuples*
72 { \ <tuple-boa> [ unbox-<tuple-boa> ] }
73 { \ slot [ unbox-slot-access ] }
77 M: #declare unbox-tuples*
78 #! We don't look at declarations after escape analysis anyway.
81 M: #copy unbox-tuples*
82 [ flatten-values ] change-in-d
83 [ flatten-values ] change-out-d ;
85 M: #shuffle unbox-tuples*
86 [ flatten-values ] change-in-d
87 [ flatten-values ] change-out-d
88 [ flatten-values ] change-in-r
89 [ flatten-values ] change-out-r
90 [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
92 M: #terminate unbox-tuples*
93 [ flatten-values ] change-in-d
94 [ flatten-values ] change-in-r ;
97 ! pad-with-bottom is only needed if some branches are terminated,
98 ! which means all output values are bottom
99 [ [ flatten-values ] map pad-with-bottom ] change-phi-in-d
100 [ flatten-values ] change-out-d ;
102 M: #recursive unbox-tuples*
103 [ label>> [ flatten-values ] change-enter-out drop ]
104 [ [ flatten-values ] change-in-d ]
107 M: #enter-recursive unbox-tuples*
108 [ flatten-values ] change-in-d
109 [ flatten-values ] change-out-d ;
111 M: #call-recursive unbox-tuples*
112 [ flatten-values ] change-in-d
113 [ flatten-values ] change-out-d ;
115 M: #return-recursive unbox-tuples*
116 [ flatten-values ] change-in-d
117 [ flatten-values ] change-out-d ;
119 : value-declaration ( value -- quot )
120 value-class [ 1array '[ _ declare ] ] [ [ ] ] if* ;
122 : unbox-parameter-quot ( allocation -- quot )
123 dup unboxed-allocation {
124 { [ dup not ] [ 2drop [ ] ] }
126 [ value-declaration ] [
128 [ unbox-parameter-quot ] [ 2 + '[ _ slot ] ] bi*
131 ] bi* '[ @ _ cleave ]
135 : unbox-parameters-quot ( values -- quot )
136 [ unbox-parameter-quot ] map
137 dup [ [ ] = ] all? [ drop [ ] ] [ '[ _ spread ] ] if ;
139 : unbox-parameters-nodes ( new-values old-values -- nodes )
140 [ flatten-values ] [ unbox-parameters-quot ] bi build-sub-tree ;
142 : new-and-old-values ( values -- new-values old-values )
143 [ length [ <value> ] replicate ] keep ;
145 : unbox-hairy-introduce ( #introduce -- nodes )
146 dup out-d>> new-and-old-values
147 [ drop >>out-d ] [ unbox-parameters-nodes ] 2bi
148 swap prefix propagate ;
150 M: #introduce unbox-tuples*
151 ! For every output that is unboxed, insert slot accessors
152 ! to convert the stack value into its unboxed form
153 dup out-d>> [ unboxed-allocation ] any? [
154 unbox-hairy-introduce
157 ! These nodes never participate in unboxing
158 : assert-not-unboxed ( values -- )
160 [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
161 [ "Unboxing wrong value" throw ] when ;
163 M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
165 M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
167 M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
169 M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
171 M: #alien-callback unbox-tuples* ;
173 : unbox-tuples ( nodes -- nodes )
174 allocations get escaping-allocations get assoc-diff assoc-empty?
175 [ [ unbox-tuples* ] map-nodes ] unless ;