Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] Annotation of /branches/lamont_dev/src/compiler/translate/translate.sml
ViewVC logotype

Annotation of /branches/lamont_dev/src/compiler/translate/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1444 - (view) (download)
Original Path: trunk/src/compiler/translate/translate.sml

1 : jhr 137 (* translate.sml
2 :     *
3 : jhr 435 * COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 : jhr 137 * All rights reserved.
5 :     *
6 : jhr 1116 * Translate Simple-AST code into the IL representation. This translation is based on the
7 :     * algorithm described in
8 :     *
9 :     * Single-pass generation of static single assignment form for structured languages
10 :     * ACM TOPLAS, Nov. 1994
11 :     * by Brandis and MossenBock.
12 : jhr 137 *)
13 :    
14 :     structure Translate : sig
15 :    
16 : jhr 176 val translate : Simple.program -> HighIL.program
17 : jhr 137
18 :     end = struct
19 :    
20 : jhr 176 structure S = Simple
21 : jhr 394 structure Ty = Types
22 : jhr 137 structure VMap = Var.Map
23 : jhr 189 structure VSet = Var.Set
24 : jhr 168 structure IL = HighIL
25 : jhr 394 structure DstTy = HighILTypes
26 : jhr 1116 structure Census = HighILCensus
27 : jhr 137
28 : jhr 1116 (* maps from SimpleAST variables to the current corresponding SSA variable *)
29 : jhr 511 type env = IL.var VMap.map
30 :    
31 : jhr 197 fun lookup env x = (case VMap.find (env, x)
32 : jhr 176 of SOME x' => x'
33 :     | NONE => raise Fail(concat[
34 : jhr 197 "no binding for ", Var.uniqueNameOf x, " in environment"
35 : jhr 176 ])
36 :     (* end case *))
37 :    
38 : jhr 394 fun cvtTy ty = (case TypeUtil.prune ty
39 :     of Ty.T_Bool => DstTy.BoolTy
40 :     | Ty.T_Int => DstTy.IntTy
41 :     | Ty.T_String => DstTy.StringTy
42 :     | Ty.T_Kernel _ => DstTy.KernelTy
43 : jhr 426 | Ty.T_Tensor(Ty.Shape dd) => let
44 :     fun cvtDim (Ty.DimConst 1) = NONE
45 :     | cvtDim (Ty.DimConst d) = SOME d
46 :     in
47 :     DstTy.TensorTy(List.mapPartial cvtDim dd)
48 :     end
49 : jhr 1116 | Ty.T_Image{dim=Ty.DimConst d, shape} => DstTy.ImageTy d
50 :     | Ty.T_Field fld => DstTy.FieldTy
51 : jhr 394 | ty => raise Fail("cvtTy: unexpected " ^ TypeUtil.toString ty)
52 :     (* end case *))
53 :    
54 : jhr 189 (* create a new instance of a variable *)
55 : jhr 394 fun newVar x = IL.Var.new (Var.nameOf x, cvtTy(Var.monoTypeOf x))
56 : jhr 189
57 : jhr 1116 (* generate fresh SSA variables and add them to the environment *)
58 :     fun freshVars (env, xs) = let
59 :     fun cvtVar (x, (env, xs)) = let
60 :     val x' = newVar x
61 :     in
62 :     (VMap.insert(env, x, x'), x'::xs)
63 :     end
64 :     val (env, xs) = List.foldl cvtVar (env, []) xs
65 :     in
66 :     (env, List.rev xs)
67 :     end
68 :    
69 :     (* a pending-join node tracks the phi nodes needed to join the assignments
70 :     * that flow into the join node.
71 :     *)
72 :     datatype join = JOIN of {
73 : jhr 1232 env : env, (* the environment that was current at the conditional *)
74 :     (* associated with this node. *)
75 : jhr 1116 arity : int ref, (* actual number of predecessors *)
76 :     nd : IL.node, (* the CFG node for this pending join *)
77 :     phiMap : IL.phi VMap.map ref, (* a mapping from Simple AST variables that are assigned *)
78 :     (* to their phi nodes. *)
79 :     predKill : bool array (* killed predecessor edges (because of DIE or STABILIZE *)
80 :     }
81 :    
82 :     (* a stack of pending joins. The first component specifies the path index of the current
83 :     * path to the join.
84 :     *)
85 :     type pending_joins = (int * join) list
86 :    
87 :     (* create a new pending-join node *)
88 : jhr 1232 fun newJoin (env, arity) = JOIN{
89 :     env = env, arity = ref arity, nd = IL.Node.mkJOIN [], phiMap = ref VMap.empty,
90 : jhr 1116 predKill = Array.array(arity, false)
91 :     }
92 :    
93 :     (* record that a path to the top join in the stack has been killed because f DIE or STABILIZE *)
94 :     fun killPath ((i, JOIN{arity, predKill, ...}) :: _) = (
95 :     arity := !arity - 1;
96 :     Array.update (predKill, i, true))
97 :     | killPath _ = ()
98 :    
99 :     (* record an assignment to the IL variable dstVar (corresponding to the Simple AST variable
100 :     * srcVar) in the current pending-join node. The predIndex specifies which path into the
101 :     * JOIN node this assignment occurs on.
102 :     *)
103 : jhr 1232 fun recordAssign ([], _, _) = ()
104 :     | recordAssign ((predIndex, JOIN{env, phiMap, predKill, nd, ...})::_, srcVar, dstVar) = let
105 : jhr 1116 val arity = Array.length predKill (* the original arity before any killPath calls *)
106 :     val m = !phiMap
107 :     in
108 :     case VMap.find (env, srcVar)
109 :     of NONE => () (* local temporary *)
110 :     | SOME dstVar' => (case VMap.find (m, srcVar)
111 :     of NONE => let
112 :     val lhs = newVar srcVar
113 :     val rhs = List.tabulate (arity, fn i => if (i = predIndex) then dstVar else dstVar')
114 :     in
115 : jhr 1232 (*
116 :     print(concat["recordAssign: ", Var.uniqueNameOf srcVar, " --> ", IL.Var.toString lhs,
117 :     " @ ", IL.Node.toString nd, "\n"]);
118 :     *)
119 : jhr 1116 phiMap := VMap.insert (m, srcVar, (lhs, rhs))
120 :     end
121 :     | SOME(lhs, rhs) => let
122 :     fun update (i, l as x::r) = if (i = predIndex)
123 :     then dstVar::r
124 :     else x::update(i+1, r)
125 :     | update _ = raise Fail "invalid predecessor index"
126 :     in
127 :     phiMap := VMap.insert (m, srcVar, (lhs, update(0, rhs)))
128 :     end
129 :     (* end case *))
130 :     (* end case *)
131 :     end
132 :    
133 :     (* complete a pending join operation by filling in the phi nodes from the phi map and
134 :     * updating the environment.
135 :     *)
136 : jhr 1232 fun commitJoin (joinStk, JOIN{env, arity, nd, phiMap, predKill}) = (case !arity
137 : jhr 1116 of 0 => (env, NONE)
138 :     | 1 => (* there is only one path to the join, so we do not need phi nodes *)
139 :     (env, SOME nd)
140 :     | n => if (n = Array.length predKill)
141 :     then let
142 :     val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
143 :     fun doVar (srcVar, phi as (dstVar, _), (env, phis)) = (
144 : jhr 1232 (*
145 :     print(concat["doVar (", Var.uniqueNameOf srcVar, ", ", IL.phiToString phi, ", _) @ ", IL.Node.toString nd, "\n"]);
146 :     *)
147 :     recordAssign (joinStk, srcVar, dstVar);
148 : jhr 1116 (VMap.insert (env, srcVar, dstVar), phi::phis))
149 :     val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
150 :     in
151 :     phis := phis';
152 :     (env, SOME nd)
153 :     end
154 :     else raise Fail "FIXME: prune killed paths."
155 :     (* end case *))
156 :    
157 : jhr 168 (* expression translation *)
158 : jhr 1116 fun cvtExp (env : env, lhs, exp) = (case exp
159 : jhr 188 of S.E_Var x => [(lhs, IL.VAR(lookup env x))]
160 :     | S.E_Lit lit => [(lhs, IL.LIT lit)]
161 : jhr 176 | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"
162 : jhr 188 | S.E_Apply(f, tyArgs, args, ty) => let
163 :     val args' = List.map (lookup env) args
164 :     in
165 :     TranslateBasis.translate (lhs, f, tyArgs, args')
166 :     end
167 : jhr 1116 | S.E_Cons args => [(lhs, IL.CONS(IL.Var.ty lhs, List.map (lookup env) args))]
168 : jhr 400 | S.E_Slice(x, indices, ty) => let
169 :     val x = lookup env x
170 :     val mask = List.map isSome indices
171 :     fun cvt NONE = NONE
172 :     | cvt (SOME x) = SOME(lookup env x)
173 :     val indices = List.mapPartial cvt indices
174 :     in
175 :     if List.all (fn b => b) mask
176 :     then [(lhs, IL.OP(HighOps.Subscript(IL.Var.ty x), x::indices))]
177 :     else [(lhs, IL.OP(HighOps.Slice(IL.Var.ty lhs, mask), x::indices))]
178 :     end
179 : jhr 1301 | S.E_Input(_, name, desc, NONE) =>
180 :     [(lhs, IL.OP(HighOps.Input(IL.Var.ty lhs, name, desc), []))]
181 :     | S.E_Input(_, name, desc, SOME dflt) =>
182 :     [(lhs, IL.OP(HighOps.InputWithDefault(IL.Var.ty lhs, name, desc), [lookup env dflt]))]
183 : jhr 1116 | S.E_LoadImage(info, name) => [(lhs, IL.OP(HighOps.LoadImage info, [lookup env name]))]
184 : jhr 176 (* end case *))
185 : jhr 168
186 : jhr 1116 fun cvtBlock (state, env : env, joinStk, S.Block stms) = let
187 :     fun cvt (env : env, cfg, []) = (cfg, env)
188 :     | cvt (env, cfg, stm::stms) = (case stm
189 :     of S.S_Var x => let
190 :     val x' = newVar x
191 :     in
192 :     cvt (VMap.insert (env, x, x'), cfg, stms)
193 :     end
194 :     | S.S_Assign(lhs, rhs) => let
195 :     val lhs' = newVar lhs
196 :     val assigns = cvtExp (env, lhs', rhs)
197 :     in
198 : jhr 1232 (*
199 :     print "doAssign\n";
200 :     *)
201 :     recordAssign (joinStk, lhs, lhs');
202 : jhr 1116 cvt (
203 :     VMap.insert(env, lhs, lhs'),
204 :     IL.CFG.concat(cfg, IL.CFG.mkBlock assigns),
205 :     stms)
206 :     end
207 :     | S.S_IfThenElse(x, b0, b1) => let
208 : jhr 192 val x' = lookup env x
209 : jhr 1232 val join = newJoin (env, 2)
210 : jhr 1116 val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
211 :     val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
212 :     val cond = IL.Node.mkCOND {
213 :     cond = x',
214 :     trueBranch = IL.Node.dummy,
215 :     falseBranch = IL.Node.dummy
216 :     }
217 : jhr 190 in
218 : jhr 1116 IL.Node.addEdge (IL.CFG.exit cfg, cond);
219 : jhr 1232 case commitJoin (joinStk, join)
220 : jhr 1116 of (env, SOME joinNd) => (
221 :     if IL.CFG.isEmpty cfg0
222 :     then (
223 :     IL.Node.setTrueBranch (cond, joinNd);
224 :     IL.Node.setPred (joinNd, cond))
225 :     else (
226 :     IL.Node.setTrueBranch (cond, IL.CFG.entry cfg0);
227 :     IL.Node.setPred (IL.CFG.entry cfg0, cond);
228 :     IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
229 :     if IL.CFG.isEmpty cfg1
230 :     then (
231 :     IL.Node.setFalseBranch (cond, joinNd);
232 :     IL.Node.setPred (joinNd, cond))
233 :     else (
234 :     IL.Node.setFalseBranch (cond, IL.CFG.entry cfg1);
235 :     IL.Node.setPred (IL.CFG.entry cfg1, cond);
236 :     IL.Node.addEdge (IL.CFG.exit cfg1, joinNd));
237 :     cvt (
238 :     env,
239 : jhr 1339 IL.CFG.concat (
240 :     cfg,
241 :     IL.CFG{entry = cond, exit = joinNd}),
242 : jhr 1116 stms))
243 :     (* the join node has only zero predecessors, so
244 :     * it was killed.
245 :     *)
246 :     | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
247 : jhr 192 (* end case *)
248 : jhr 190 end
249 : jhr 1116 | S.S_New(strandId, args) => let
250 :     val nd = IL.Node.mkNEW{
251 :     strand = strandId,
252 :     args = List.map (lookup env) args
253 :     }
254 : jhr 192 in
255 : jhr 1116 cvt (env, IL.CFG.appendNode (cfg, nd), stms)
256 : jhr 194 end
257 : jhr 1116 | S.S_Die => (
258 :     killPath joinStk;
259 :     (IL.CFG.appendNode (cfg, IL.Node.mkDIE ()), env))
260 : jhr 256 | S.S_Stabilize => let
261 : jhr 1116 val stateOut = List.map (lookup env) state
262 : jhr 256 in
263 : jhr 1116 killPath joinStk;
264 :     (IL.CFG.appendNode (cfg, IL.Node.mkSTABILIZE stateOut), env)
265 : jhr 256 end
266 : jhr 192 (* end case *))
267 :     in
268 : jhr 1116 cvt (env, IL.CFG.empty, stms)
269 : jhr 192 end
270 : jhr 1339 (*DEBUG*)handle ex => raise ex
271 : jhr 168
272 : jhr 1232 fun cvtTopLevelBlock (env, blk, mkExit) = let
273 : jhr 1116 val (cfg, env) = cvtBlock ([], env, [], blk)
274 :     val entry = IL.Node.mkENTRY ()
275 : jhr 1232 val exit = mkExit env
276 : jhr 256 in
277 : jhr 1116 if IL.CFG.isEmpty cfg
278 :     then IL.Node.addEdge (entry, exit)
279 :     else (
280 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
281 :     (* NOTE: this addEdge could fail if all control paths end in DIE or STABILIZE,
282 :     * so we wrap it in a handler
283 :     *)
284 :     IL.Node.addEdge (IL.CFG.exit cfg, exit) handle _ => ());
285 :     (IL.CFG{entry = entry, exit = exit}, env)
286 : jhr 256 end
287 : jhr 1339 (*DEBUG*)handle ex => raise ex
288 : jhr 256
289 : jhr 1116 (* FIXME: the following function could be refactored with cvtTopLevelBlock to share code *)
290 : jhr 1232 fun cvtFragmentBlock (env0, blk) = let
291 :     val (cfg, env) = cvtBlock ([], env0, [], blk)
292 : jhr 1116 val entry = IL.Node.mkENTRY ()
293 : jhr 1232 (* the live variables out are those that were not live coming in *)
294 :     val liveOut = VMap.foldli
295 :     (fn (x, x', xs) => if VMap.inDomain(env0, x) then xs else x'::xs)
296 :     [] env
297 :     val exit = IL.Node.mkFRAGMENT liveOut
298 : jhr 1116 in
299 :     if IL.CFG.isEmpty cfg
300 :     then IL.Node.addEdge (entry, exit)
301 :     else (
302 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
303 : jhr 1232 IL.Node.addEdge (IL.CFG.exit cfg, exit));
304 : jhr 1116 (IL.CFG{entry = entry, exit = exit}, env)
305 :     end
306 : jhr 1339 (*DEBUG*)handle ex => raise ex
307 : jhr 1116
308 :     fun cvtMethod (env, name, state, blk) = let
309 :     (* allocate fresh variables for the state variables *)
310 :     val (env, stateIn) = freshVars (env, state)
311 :     (* convert the body of the method *)
312 :     val (cfg, env) = cvtBlock (state, env, [], blk)
313 :     (* add the entry/exit nodes *)
314 :     val stateOut = List.map (lookup env) state
315 :     val entry = IL.Node.mkENTRY ()
316 : jhr 1444 val exit = (case name
317 :     of MethodName.Update => IL.Node.mkACTIVE stateOut
318 :     | MethodName.Stabilize => IL.Node.mkRETURN stateOut
319 :     (* end case *))
320 : jhr 1116 in
321 :     if IL.CFG.isEmpty cfg
322 :     then IL.Node.addEdge (entry, exit)
323 :     else (
324 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
325 :     (* NOTE: this addEdge could fail if all control paths end in DIE or STABILIZE,
326 :     * so we wrap it in a handler
327 :     *)
328 :     IL.Node.addEdge (IL.CFG.exit cfg, exit) handle _ => ());
329 :     IL.Method{
330 :     name = name,
331 :     stateIn = stateIn,
332 :     body = IL.CFG{entry = entry, exit = exit}
333 :     }
334 :     end
335 : jhr 1444 (*DEBUG*)handle ex => (print(concat["error in cvtMethod(", MethodName.toString name, ", ...)\n"]); raise ex)
336 : jhr 1116
337 :     (* convert the initially code *)
338 :     fun cvtInitially (env, S.Initially{isArray, rangeInit, create, iters}) = let
339 :     val S.C_Create{argInit, name, args} = create
340 :     fun cvtIter ({param, lo, hi}, (env, iters)) = let
341 :     val param' = newVar param
342 :     val env = VMap.insert (env, param, param')
343 :     val iter = (param', lookup env lo, lookup env hi)
344 : jhr 256 in
345 : jhr 1116 (env, iter::iters)
346 : jhr 256 end
347 : jhr 1116 val (cfg, env) = cvtFragmentBlock (env, rangeInit)
348 :     val (env, iters) = List.foldl cvtIter (env, []) iters
349 :     val (argInitCFG, env) = cvtFragmentBlock (env, argInit)
350 : jhr 256 in
351 : jhr 1116 IL.Initially{
352 :     isArray = isArray,
353 :     rangeInit = cfg,
354 :     iters = List.rev iters,
355 :     create = (argInitCFG, name, List.map (lookup env) args)
356 :     }
357 : jhr 256 end
358 :    
359 : jhr 1116 fun translate (S.Program{globals, globalInit, init, strands}) = let
360 : jhr 1232 val (globalInit, env) =
361 :     cvtTopLevelBlock (
362 :     VMap.empty, globalInit,
363 :     fn env => IL.Node.mkRETURN(VMap.listItems env))
364 : jhr 1116 (* construct a reduced environment that just defines the globals. *)
365 :     val env = let
366 : jhr 200 val lookup = lookup env
367 : jhr 1116 fun cvtVar (x, env) = VMap.insert(env, x, lookup x)
368 :     val env = List.foldl cvtVar VMap.empty globals
369 : jhr 200 in
370 : jhr 1116 env
371 : jhr 200 end
372 : jhr 1116 val init = cvtInitially (env, init)
373 : jhr 511 fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
374 : jhr 1232 (* extend the global environment with the strand's parameters *)
375 : jhr 200 val (env, params) = let
376 :     fun cvtParam (x, (env, xs)) = let
377 :     val x' = newVar x
378 :     in
379 :     (VMap.insert(env, x, x'), x'::xs)
380 :     end
381 :     val (env, params) = List.foldl cvtParam (env, []) params
382 :     in
383 :     (env, List.rev params)
384 :     end
385 : jhr 1232 (* convert the state initialization code *)
386 :     val (stateInit, env) = let
387 :     fun mkExit env = IL.Node.mkSINIT(List.map (lookup env) state)
388 :     in
389 :     cvtTopLevelBlock (env, stateInit, mkExit)
390 :     end
391 :     (* the state-variable list is constructed by generating fresh variables for the
392 :     * state variables and pairing them with a boolean that is true if the variable
393 :     * is an output variable. Note that these IL variables are not defined or used.
394 :     *)
395 : jhr 1116 val state' = let
396 : jhr 1232 fun cvtStateVar x = (Var.kindOf x = S.StrandOutputVar, newVar x)
397 : jhr 200 in
398 : jhr 1116 List.map cvtStateVar state
399 : jhr 200 end
400 : jhr 1116 fun cvtMeth (S.Method(name, blk)) = cvtMethod (env, name, state, blk)
401 : jhr 200 in
402 : jhr 511 IL.Strand{
403 : jhr 200 name = name,
404 :     params = params,
405 : jhr 256 state = state',
406 : jhr 200 stateInit = stateInit,
407 : jhr 1116 methods = List.map cvtMeth methods
408 : jhr 200 }
409 :     end
410 : jhr 511 val prog = IL.Program{
411 : jhr 1116 globalInit = globalInit,
412 :     initially = init,
413 :     strands = List.map cvtStrand strands
414 :     }
415 : jhr 511 in
416 :     Census.init prog;
417 :     prog
418 : jhr 200 end
419 : jhr 176
420 : jhr 137 end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0