1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry arrays generic assocs kernel math namespaces parser
4 sequences words vectors math.intervals classes
5 accessors combinators stack-checker.state stack-checker.visitor
6 stack-checker.inlining ;
9 ! High-level tree SSA form.
11 TUPLE: node < identity-tuple ;
13 M: node hashcode* drop node hashcode* ;
15 TUPLE: #introduce < node out-d ;
17 : #introduce ( out-d -- node )
18 \ #introduce new swap >>out-d ;
20 TUPLE: #call < node word in-d out-d body method class info ;
22 : #call ( inputs outputs word -- node )
28 TUPLE: #call-recursive < node label in-d out-d info ;
30 : #call-recursive ( inputs outputs label -- node )
36 TUPLE: #push < node literal out-d ;
38 : #push ( literal value -- node )
43 TUPLE: #renaming < node ;
45 TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;
47 : #shuffle ( in-d out-d in-r out-r mapping -- node )
55 : #data-shuffle ( in-d out-d mapping -- node )
56 [ f f ] dip #shuffle ; inline
58 : #drop ( inputs -- node )
59 { } { } #data-shuffle ;
61 TUPLE: #terminate < node in-d in-r ;
63 : #terminate ( in-d in-r -- node )
68 TUPLE: #branch < node in-d children live-branches ;
70 : new-branch ( value children class -- node )
73 swap 1array >>in-d ; inline
75 TUPLE: #if < #branch ;
77 : #if ( ? true false -- node )
78 2array \ #if new-branch ;
80 TUPLE: #dispatch < #branch ;
82 : #dispatch ( n branches -- node )
83 \ #dispatch new-branch ;
85 TUPLE: #phi < node phi-in-d phi-info-d out-d terminated ;
87 : #phi ( d-phi-in d-phi-out terminated -- node )
93 TUPLE: #declare < node declaration ;
95 : #declare ( declaration -- node )
99 TUPLE: #return < node in-d info ;
101 : #return ( stack -- node )
105 TUPLE: #recursive < node in-d word label loop? child ;
107 : #recursive ( label inputs child -- node )
113 TUPLE: #enter-recursive < node in-d out-d label info ;
115 : #enter-recursive ( label inputs outputs -- node )
116 \ #enter-recursive new
121 TUPLE: #return-recursive < #renaming in-d out-d label info ;
123 : #return-recursive ( label inputs outputs -- node )
124 \ #return-recursive new
129 TUPLE: #copy < #renaming in-d out-d ;
131 : #copy ( inputs outputs -- node )
136 TUPLE: #alien-node < node params ;
138 : new-alien-node ( params class -- node )
142 swap >>params ; inline
144 TUPLE: #alien-invoke < #alien-node in-d out-d ;
146 : #alien-invoke ( params -- node )
147 \ #alien-invoke new-alien-node ;
149 TUPLE: #alien-indirect < #alien-node in-d out-d ;
151 : #alien-indirect ( params -- node )
152 \ #alien-indirect new-alien-node ;
154 TUPLE: #alien-callback < #alien-node ;
156 : #alien-callback ( params -- node )
157 \ #alien-callback new
160 : node, ( node -- ) stack-visitor get push ;
162 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
164 M: #shuffle inputs/outputs mapping>> unzip swap ;
165 M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
166 M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
168 : recursive-phi-in ( #enter-recursive -- seq )
169 [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
171 : ends-with-terminate? ( nodes -- ? )
172 [ f ] [ peek #terminate? ] if-empty ;
174 M: vector child-visitor V{ } clone ;
175 M: vector #introduce, #introduce node, ;
176 M: vector #call, #call node, ;
177 M: vector #push, #push node, ;
178 M: vector #shuffle, #shuffle node, ;
179 M: vector #drop, #drop node, ;
180 M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
181 M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
182 M: vector #return, #return node, ;
183 M: vector #enter-recursive, #enter-recursive node, ;
184 M: vector #return-recursive, #return-recursive node, ;
185 M: vector #call-recursive, #call-recursive node, ;
186 M: vector #terminate, #terminate node, ;
187 M: vector #if, #if node, ;
188 M: vector #dispatch, #dispatch node, ;
189 M: vector #phi, #phi node, ;
190 M: vector #declare, #declare node, ;
191 M: vector #recursive, #recursive node, ;
192 M: vector #copy, #copy node, ;
193 M: vector #alien-invoke, #alien-invoke node, ;
194 M: vector #alien-indirect, #alien-indirect node, ;
195 M: vector #alien-callback, #alien-callback node, ;