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 effects 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 ;
47 : #shuffle ( inputs outputs mapping -- node )
53 : #drop ( inputs -- node )
56 TUPLE: #>r < #renaming in-d out-r ;
58 : #>r ( inputs outputs -- node )
63 TUPLE: #r> < #renaming in-r out-d ;
65 : #r> ( inputs outputs -- node )
70 TUPLE: #terminate < node in-d in-r ;
72 : #terminate ( in-d in-r -- node )
77 TUPLE: #branch < node in-d children live-branches ;
79 : new-branch ( value children class -- node )
82 swap 1array >>in-d ; inline
84 TUPLE: #if < #branch ;
86 : #if ( ? true false -- node )
87 2array \ #if new-branch ;
89 TUPLE: #dispatch < #branch ;
91 : #dispatch ( n branches -- node )
92 \ #dispatch new-branch ;
94 TUPLE: #phi < node phi-in-d phi-info-d out-d terminated ;
96 : #phi ( d-phi-in d-phi-out terminated -- node )
102 TUPLE: #declare < node declaration ;
104 : #declare ( declaration -- node )
108 TUPLE: #return < node in-d info ;
110 : #return ( stack -- node )
114 TUPLE: #recursive < node in-d word label loop? child ;
116 : #recursive ( label inputs child -- node )
122 TUPLE: #enter-recursive < node in-d out-d label info ;
124 : #enter-recursive ( label inputs outputs -- node )
125 \ #enter-recursive new
130 TUPLE: #return-recursive < #renaming in-d out-d label info ;
132 : #return-recursive ( label inputs outputs -- node )
133 \ #return-recursive new
138 TUPLE: #copy < #renaming in-d out-d ;
140 : #copy ( inputs outputs -- node )
145 TUPLE: #alien-node < node params ;
147 : new-alien-node ( params class -- node )
151 swap >>params ; inline
153 TUPLE: #alien-invoke < #alien-node in-d out-d ;
155 : #alien-invoke ( params -- node )
156 \ #alien-invoke new-alien-node ;
158 TUPLE: #alien-indirect < #alien-node in-d out-d ;
160 : #alien-indirect ( params -- node )
161 \ #alien-indirect new-alien-node ;
163 TUPLE: #alien-callback < #alien-node ;
165 : #alien-callback ( params -- node )
166 \ #alien-callback new
169 : node, ( node -- ) stack-visitor get push ;
171 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
173 M: #shuffle inputs/outputs mapping>> unzip swap ;
174 M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
175 M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
176 M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
177 M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
179 : shuffle-effect ( #shuffle -- effect )
180 [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
184 : recursive-phi-in ( #enter-recursive -- seq )
185 [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
187 : ends-with-terminate? ( nodes -- ? )
188 [ f ] [ peek #terminate? ] if-empty ;
190 M: vector child-visitor V{ } clone ;
191 M: vector #introduce, #introduce node, ;
192 M: vector #call, #call node, ;
193 M: vector #push, #push node, ;
194 M: vector #shuffle, #shuffle node, ;
195 M: vector #drop, #drop node, ;
196 M: vector #>r, #>r node, ;
197 M: vector #r>, #r> node, ;
198 M: vector #return, #return node, ;
199 M: vector #enter-recursive, #enter-recursive node, ;
200 M: vector #return-recursive, #return-recursive node, ;
201 M: vector #call-recursive, #call-recursive node, ;
202 M: vector #terminate, #terminate node, ;
203 M: vector #if, #if node, ;
204 M: vector #dispatch, #dispatch node, ;
205 M: vector #phi, #phi node, ;
206 M: vector #declare, #declare node, ;
207 M: vector #recursive, #recursive node, ;
208 M: vector #copy, #copy node, ;
209 M: vector #alien-invoke, #alien-invoke node, ;
210 M: vector #alien-indirect, #alien-indirect node, ;
211 M: vector #alien-callback, #alien-callback node, ;