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

SCM Repository

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

Annotation of /trunk/src/compiler/translate/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2636 - (view) (download)

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 : jhr 2356 * 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 2476 structure Ty = SimpleTypes
22 :     structure VMap = SimpleVar.Map
23 :     structure VSet = SimpleVar.Set
24 : jhr 168 structure IL = HighIL
25 : jhr 1640 structure Op = HighOps
26 : jhr 394 structure DstTy = HighILTypes
27 : jhr 1116 structure Census = HighILCensus
28 : jhr 137
29 : jhr 1640 val cvtTy = TranslateTy.tr
30 :    
31 : jhr 1116 (* maps from SimpleAST variables to the current corresponding SSA variable *)
32 : jhr 511 type env = IL.var VMap.map
33 :    
34 : jhr 1640 (* +DEBUG *)
35 :     fun prEnv (prefix, env) = let
36 :     val wid = ref 0
37 :     fun pr s = (print s; wid := !wid + size s)
38 :     fun nl () = if (!wid > 0) then (print "\n"; wid := 0) else ()
39 :     fun prElem (src, dst) = let
40 :     val s = String.concat [
41 : jhr 2476 " ", SimpleVar.uniqueNameOf src, "->", IL.Var.toString dst
42 : jhr 1640 ]
43 :     in
44 :     pr s;
45 :     if (!wid >= 100) then (nl(); pr " ") else ()
46 :     end
47 :     in
48 :     pr prefix; pr " ENV: {"; nl(); pr " ";
49 :     VMap.appi prElem env;
50 :     nl(); pr "}"; nl()
51 :     end
52 :     (* -DEBUG *)
53 :    
54 : jhr 197 fun lookup env x = (case VMap.find (env, x)
55 : jhr 2356 of SOME x' => x'
56 :     | NONE => raise Fail(concat[
57 : jhr 2476 "no binding for ", SimpleVar.uniqueNameOf x, " in environment"
58 : jhr 2356 ])
59 :     (* end case *))
60 : jhr 176
61 : jhr 189 (* create a new instance of a variable *)
62 : jhr 2476 fun newVar x = IL.Var.new (SimpleVar.nameOf x, cvtTy(SimpleVar.typeOf x))
63 : jhr 189
64 : jhr 1116 (* generate fresh SSA variables and add them to the environment *)
65 :     fun freshVars (env, xs) = let
66 : jhr 2356 fun cvtVar (x, (env, xs)) = let
67 :     val x' = newVar x
68 :     in
69 :     (VMap.insert(env, x, x'), x'::xs)
70 :     end
71 :     val (env, xs) = List.foldl cvtVar (env, []) xs
72 :     in
73 :     (env, List.rev xs)
74 :     end
75 : jhr 1116
76 :     (* a pending-join node tracks the phi nodes needed to join the assignments
77 :     * that flow into the join node.
78 :     *)
79 :     datatype join = JOIN of {
80 : jhr 2356 env : env, (* the environment that was current at the conditional *)
81 :     (* associated with this node. *)
82 :     arity : int ref, (* actual number of predecessors *)
83 :     nd : IL.node, (* the CFG node for this pending join *)
84 :     phiMap : IL.phi VMap.map ref, (* a mapping from Simple AST variables that are assigned *)
85 :     (* to their phi nodes. *)
86 :     predKill : bool array (* killed predecessor edges (because of DIE or STABILIZE *)
87 : jhr 1116 }
88 :    
89 :     (* a stack of pending joins. The first component specifies the path index of the current
90 :     * path to the join.
91 :     *)
92 :     type pending_joins = (int * join) list
93 :    
94 :     (* create a new pending-join node *)
95 : jhr 1232 fun newJoin (env, arity) = JOIN{
96 : jhr 2356 env = env, arity = ref arity, nd = IL.Node.mkJOIN [], phiMap = ref VMap.empty,
97 :     predKill = Array.array(arity, false)
98 :     }
99 : jhr 1116
100 :     (* record that a path to the top join in the stack has been killed because f DIE or STABILIZE *)
101 :     fun killPath ((i, JOIN{arity, predKill, ...}) :: _) = (
102 : jhr 2356 arity := !arity - 1;
103 :     Array.update (predKill, i, true))
104 : jhr 1116 | killPath _ = ()
105 :    
106 :     (* record an assignment to the IL variable dstVar (corresponding to the Simple AST variable
107 :     * srcVar) in the current pending-join node. The predIndex specifies which path into the
108 :     * JOIN node this assignment occurs on.
109 :     *)
110 : jhr 1232 fun recordAssign ([], _, _) = ()
111 :     | recordAssign ((predIndex, JOIN{env, phiMap, predKill, nd, ...})::_, srcVar, dstVar) = let
112 : jhr 2356 val arity = Array.length predKill (* the original arity before any killPath calls *)
113 :     val m = !phiMap
114 :     in
115 :     case VMap.find (env, srcVar)
116 :     of NONE => () (* local temporary *)
117 :     | SOME dstVar' => (case VMap.find (m, srcVar)
118 :     of NONE => let
119 :     val lhs = newVar srcVar
120 :     val rhs = List.tabulate (arity, fn i => if (i = predIndex) then dstVar else dstVar')
121 :     in
122 : jhr 1232 (*
123 : jhr 2476 print(concat["recordAssign: ", SimpleVar.uniqueNameOf srcVar, " --> ", IL.Var.toString lhs,
124 : jhr 1232 " @ ", IL.Node.toString nd, "\n"]);
125 :     *)
126 : jhr 2356 phiMap := VMap.insert (m, srcVar, (lhs, rhs))
127 :     end
128 :     | SOME(lhs, rhs) => let
129 :     fun update (i, l as x::r) = if (i = predIndex)
130 :     then dstVar::r
131 :     else x::update(i+1, r)
132 :     | update _ = raise Fail "invalid predecessor index"
133 :     in
134 :     phiMap := VMap.insert (m, srcVar, (lhs, update(0, rhs)))
135 :     end
136 :     (* end case *))
137 :     (* end case *)
138 :     end
139 : jhr 1116
140 :     (* complete a pending join operation by filling in the phi nodes from the phi map and
141 :     * updating the environment.
142 :     *)
143 : jhr 1232 fun commitJoin (joinStk, JOIN{env, arity, nd, phiMap, predKill}) = (case !arity
144 : jhr 2356 of 0 => (env, NONE)
145 :     | 1 => let
146 :     (* there is only one path to the join, so we do not need phi nodes, but
147 :     * we still need to propogate assignments to the next join on the stack.
148 :     *)
149 :     val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
150 :     val ix = let (* find pred of this join *)
151 :     fun find i = if Array.sub(predKill, i) then find(i+1) else i
152 :     in
153 :     find 0
154 :     end
155 :     fun doVar (srcVar, (_, xs), env) = let
156 :     val dstVar = List.nth(xs, ix)
157 :     in
158 : jhr 1766 (*
159 : jhr 2476 print(concat["doVar (", SimpleVar.uniqueNameOf srcVar, ", ", IL.phiToString phi, ", _) @ ", IL.Node.toString nd, "\n"]);
160 : jhr 1766 *)
161 : jhr 2356 recordAssign (joinStk, srcVar, dstVar);
162 :     VMap.insert (env, srcVar, dstVar)
163 :     end
164 :     val env = VMap.foldli doVar env (!phiMap)
165 :     in
166 :     (env, SOME nd)
167 :     end
168 :     | n => if (n = Array.length predKill)
169 :     then let
170 :     val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
171 :     fun doVar (srcVar, phi as (dstVar, _), (env, phis)) = (
172 : jhr 1232 (*
173 : jhr 2476 print(concat["doVar (", SimpleVar.uniqueNameOf srcVar, ", ", IL.phiToString phi, ", _) @ ", IL.Node.toString nd, "\n"]);
174 : jhr 1232 *)
175 : jhr 2356 recordAssign (joinStk, srcVar, dstVar);
176 :     (VMap.insert (env, srcVar, dstVar), phi::phis))
177 :     val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
178 :     in
179 :     phis := phis';
180 :     (env, SOME nd)
181 :     end
182 :     else raise Fail "FIXME: prune killed paths."
183 :     (* end case *))
184 : jhr 1116
185 : jhr 168 (* expression translation *)
186 : jhr 1116 fun cvtExp (env : env, lhs, exp) = (case exp
187 : jhr 2356 of S.E_Var x => [IL.ASSGN(lhs, IL.VAR(lookup env x))]
188 :     | S.E_Lit lit => [IL.ASSGN(lhs, IL.LIT lit)]
189 :     | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"
190 : jhr 2476 | S.E_Apply _ => raise Fail "unexpected E_Apply"
191 :     | S.E_Prim(f, tyArgs, args, ty) => let
192 : jhr 2356 val args' = List.map (lookup env) args
193 :     in
194 :     TranslateBasis.translate (lhs, f, tyArgs, args')
195 :     end
196 :     | S.E_Cons args => [IL.ASSGN(lhs, IL.CONS(IL.Var.ty lhs, List.map (lookup env) args))]
197 : jhr 2636 | S.E_Seq args => [IL.ASSGN(lhs, IL.CONS(IL.Var.ty lhs, List.map (lookup env) args))]
198 : jhr 2356 | S.E_Slice(x, indices, ty) => let
199 :     val x = lookup env x
200 :     val mask = List.map isSome indices
201 :     fun cvt NONE = NONE
202 :     | cvt (SOME x) = SOME(lookup env x)
203 :     val indices = List.mapPartial cvt indices
204 :     in
205 :     if List.all (fn b => b) mask
206 :     then [IL.ASSGN(lhs, IL.OP(Op.TensorSub(IL.Var.ty x), x::indices))]
207 :     else [IL.ASSGN(lhs, IL.OP(Op.Slice(IL.Var.ty x, mask), x::indices))]
208 :     end
209 :     | S.E_Coerce{srcTy, dstTy, x} => (case (srcTy, dstTy)
210 :     of (Ty.T_Int, Ty.T_Tensor _) =>
211 :     [IL.ASSGN(lhs, IL.OP(Op.IntToReal, [lookup env x]))]
212 :     | (Ty.T_Field _, Ty.T_Field _) =>
213 :     (* change in continuity is a no-op *)
214 :     [IL.ASSGN(lhs, IL.VAR(lookup env x))]
215 :     | _ => raise Fail(concat[
216 : jhr 2476 "unsupported type coercion: ", Ty.toString srcTy,
217 :     " ==> ", Ty.toString dstTy
218 : jhr 2356 ])
219 :     (* end case *))
220 : jhr 2636 | S.E_LoadImage(ty, nrrd, info) => [IL.ASSGN(lhs, IL.OP(Op.LoadImage(cvtTy ty, nrrd, info), []))]
221 : jhr 2356 (* end case *))
222 : jhr 168
223 : jhr 1640 (* add nodes to save the strand state, followed by an exit node *)
224 :     fun saveStrandState (env, (srcState, dstState), exit) = let
225 :     val stateOut = List.map (lookup env) srcState
226 :     fun save (x, x', cfg) = IL.CFG.appendNode (cfg, IL.Node.mkSAVE(x, x'))
227 :     in
228 :     IL.CFG.appendNode (
229 :     ListPair.foldlEq save IL.CFG.empty (dstState, stateOut),
230 :     exit)
231 :     end
232 : jhr 2356 (*DEBUG*)handle ex => raise ex
233 : jhr 1640
234 : jhr 1116 fun cvtBlock (state, env : env, joinStk, S.Block stms) = let
235 : jhr 2356 fun cvt (env : env, cfg, []) = (cfg, env)
236 :     | cvt (env, cfg, stm::stms) = (case stm
237 :     of S.S_Var x => let
238 :     val x' = newVar x
239 :     in
240 :     cvt (VMap.insert (env, x, x'), cfg, stms)
241 :     end
242 :     | S.S_Assign(lhs, rhs) => let
243 :     val lhs' = newVar lhs
244 :     val assigns = cvtExp (env, lhs', rhs)
245 :     in
246 : jhr 1232 (*
247 :     print "doAssign\n";
248 :     *)
249 : jhr 2356 recordAssign (joinStk, lhs, lhs');
250 :     cvt (
251 :     VMap.insert(env, lhs, lhs'),
252 :     IL.CFG.concat(cfg, IL.CFG.mkBlock assigns),
253 :     stms)
254 :     end
255 :     | S.S_IfThenElse(x, b0, b1) => let
256 :     val x' = lookup env x
257 :     val join = newJoin (env, 2)
258 :     val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
259 :     val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
260 :     val cond = IL.Node.mkCOND {
261 :     cond = x',
262 :     trueBranch = IL.Node.dummy,
263 :     falseBranch = IL.Node.dummy
264 :     }
265 :     in
266 :     IL.Node.addEdge (IL.CFG.exit cfg, cond);
267 :     case commitJoin (joinStk, join)
268 :     of (env, SOME joinNd) => (
269 :     if IL.CFG.isEmpty cfg0
270 :     then (
271 :     IL.Node.setTrueBranch (cond, joinNd);
272 :     IL.Node.setPred (joinNd, cond))
273 :     else (
274 :     IL.Node.setTrueBranch (cond, IL.CFG.entry cfg0);
275 :     IL.Node.setPred (IL.CFG.entry cfg0, cond);
276 :     IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
277 :     if IL.CFG.isEmpty cfg1
278 :     then (
279 :     IL.Node.setFalseBranch (cond, joinNd);
280 :     IL.Node.setPred (joinNd, cond))
281 :     else (
282 :     IL.Node.setFalseBranch (cond, IL.CFG.entry cfg1);
283 :     IL.Node.setPred (IL.CFG.entry cfg1, cond);
284 :     IL.Node.addEdge (IL.CFG.exit cfg1, joinNd));
285 :     cvt (
286 :     env,
287 : jhr 1339 IL.CFG.concat (
288 :     cfg,
289 :     IL.CFG{entry = cond, exit = joinNd}),
290 : jhr 2356 stms))
291 :     (* the join node has only zero predecessors, so
292 :     * it was killed.
293 :     *)
294 :     | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
295 :     (* end case *)
296 :     end
297 :     | S.S_New(strandId, args) => let
298 :     val nd = IL.Node.mkNEW{
299 :     strand = strandId,
300 :     args = List.map (lookup env) args
301 :     }
302 :     in
303 :     cvt (env, IL.CFG.appendNode (cfg, nd), stms)
304 :     end
305 :     | S.S_Die => (
306 : jhr 1640 killPath joinStk;
307 : jhr 2356 (IL.CFG.appendNode (cfg, IL.Node.mkDIE ()), env))
308 :     | S.S_Stabilize => (
309 :     killPath joinStk;
310 : jhr 1640 (IL.CFG.concat (cfg, saveStrandState (env, state, IL.Node.mkSTABILIZE())), env))
311 : jhr 2356 | S.S_Return _ => raise Fail "unexpected return"
312 : jhr 1640 | S.S_Print args => let
313 :     val args = List.map (lookup env) args
314 :     val nd = IL.Node.mkMASSIGN([], Op.Print(List.map IL.Var.ty args), args)
315 :     in
316 :     cvt (env, IL.CFG.appendNode (cfg, nd), stms)
317 :     end
318 : jhr 2356 (* end case *))
319 :     in
320 :     cvt (env, IL.CFG.empty, stms)
321 :     end
322 : jhr 1339 (*DEBUG*)handle ex => raise ex
323 : jhr 168
324 : jhr 1232 fun cvtTopLevelBlock (env, blk, mkExit) = let
325 : jhr 2356 val (cfg, env) = cvtBlock (([], []), env, [], blk)
326 : jhr 1640 val cfg = IL.CFG.prependNode (IL.Node.mkENTRY(), cfg)
327 :     val cfg = IL.CFG.concat (cfg, mkExit env)
328 : jhr 2356 in
329 :     (cfg, env)
330 :     end
331 : jhr 1339 (*DEBUG*)handle ex => raise ex
332 : jhr 256
333 : jhr 1116 (* FIXME: the following function could be refactored with cvtTopLevelBlock to share code *)
334 : jhr 1232 fun cvtFragmentBlock (env0, blk) = let
335 : jhr 2356 val (cfg, env) = cvtBlock (([], []), env0, [], blk)
336 :     val entry = IL.Node.mkENTRY ()
337 :     (* the live variables out are those that were not live coming in *)
338 :     val liveOut = VMap.foldli
339 :     (fn (x, x', xs) => if VMap.inDomain(env0, x) then xs else x'::xs)
340 :     [] env
341 :     val exit = IL.Node.mkFRAGMENT liveOut
342 :     in
343 :     if IL.CFG.isEmpty cfg
344 :     then IL.Node.addEdge (entry, exit)
345 :     else (
346 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
347 :     IL.Node.addEdge (IL.CFG.exit cfg, exit));
348 :     (IL.CFG{entry = entry, exit = exit}, env)
349 :     end
350 : jhr 1339 (*DEBUG*)handle ex => raise ex
351 : jhr 1116
352 : jhr 1640 fun cvtMethod (env, name, state, svars, blk) = let
353 :     (* load the state into fresh variables *)
354 :     val (env, loadCFG) = let
355 :     (* allocate shadow variables for the state variables *)
356 :     val (env, stateIn) = freshVars (env, state)
357 :     fun load (x, x') = IL.ASSGN(x, IL.STATE x')
358 :     in
359 :     (env, IL.CFG.mkBlock (ListPair.map load (stateIn, svars)))
360 :     end
361 : jhr 2356 (* convert the body of the method *)
362 :     val (cfg, env) = cvtBlock ((state, svars), env, [], blk)
363 :     (* add the entry/exit nodes *)
364 :     val entry = IL.Node.mkENTRY ()
365 : jhr 1640 val loadCFG = IL.CFG.prependNode (entry, loadCFG)
366 : jhr 2356 val exit = (case name
367 : jhr 1640 of StrandUtil.Update => IL.Node.mkACTIVE ()
368 :     | StrandUtil.Stabilize => IL.Node.mkRETURN []
369 : jhr 1444 (* end case *))
370 : jhr 1640 val body = IL.CFG.concat (loadCFG, cfg)
371 :     (*DEBUG**val _ = prEnv (StrandUtil.nameToString name, env);*)
372 :     (* FIXME: the following code doesn't work properly *)
373 :     val body = if IL.Node.hasSucc(IL.CFG.exit body)
374 :     then IL.CFG.concat (body, saveStrandState (env, (state, svars), exit))
375 :     else IL.CFG{entry = IL.CFG.entry body, exit = exit}
376 : jhr 2356 in
377 :     IL.Method{
378 :     name = name,
379 :     body = body
380 :     }
381 :     end
382 : jhr 1640 (*DEBUG*)handle ex => (print(concat["error in cvtMethod(", StrandUtil.nameToString name, ", ...)\n"]); raise ex)
383 : jhr 1116
384 :     (* convert the initially code *)
385 :     fun cvtInitially (env, S.Initially{isArray, rangeInit, create, iters}) = let
386 : jhr 2356 val S.C_Create{argInit, name, args} = create
387 :     fun cvtIter ({param, lo, hi}, (env, iters)) = let
388 :     val param' = newVar param
389 :     val env = VMap.insert (env, param, param')
390 :     val iter = (param', lookup env lo, lookup env hi)
391 :     in
392 :     (env, iter::iters)
393 :     end
394 :     val (cfg, env) = cvtFragmentBlock (env, rangeInit)
395 :     val (env, iters) = List.foldl cvtIter (env, []) iters
396 :     val (argInitCFG, env) = cvtFragmentBlock (env, argInit)
397 :     in
398 :     IL.Initially{
399 :     isArray = isArray,
400 :     rangeInit = cfg,
401 :     iters = List.rev iters,
402 :     create = (argInitCFG, name, List.map (lookup env) args)
403 :     }
404 :     end
405 : jhr 256
406 : jhr 1640 (* check strands for properties *)
407 :     fun checkProps strands = let
408 : jhr 2356 val hasDie = ref false
409 :     val hasNew = ref false
410 :     fun chkStm e = (case e
411 : jhr 1640 of S.S_IfThenElse(_, b1, b2) => (chkBlk b1; chkBlk b2)
412 :     | S.S_New _ => (hasNew := true)
413 :     | S.S_Die => (hasDie := true)
414 :     | _ => ()
415 : jhr 2356 (* end case *))
416 :     and chkBlk (S.Block body) = List.app chkStm body
417 :     fun chkStrand (S.Strand{stateInit, methods, ...}) = let
418 :     fun chkMeth (S.Method(_, body)) = chkBlk body
419 :     in
420 :     chkBlk stateInit;
421 :     List.app chkMeth methods
422 :     end
423 :     fun condCons (x, v, l) = if !x then v::l else l
424 :     in
425 :     List.app chkStrand strands;
426 :     condCons (hasDie, StrandUtil.StrandsMayDie,
427 :     condCons (hasNew, StrandUtil.NewStrands, []))
428 :     end
429 : jhr 1640
430 : jhr 2636 fun cvtInputs inputs = let
431 :     fun cvt ((x, inp), (env, stms)) = let
432 :     val x' = newVar x
433 :     val stm = IL.ASSGN(x', IL.OP(Op.Input(Inputs.map cvtTy inp), []))
434 :     in
435 :     (VMap.insert(env, x, x'), stm::stms)
436 :     end
437 :     val (env, stms) = List.foldr cvt (VMap.empty, []) inputs
438 :     in
439 :     (IL.CFG.mkBlock stms, env)
440 :     end
441 :    
442 :     (* gather the top-level definitions in a block. This is a hack that is used to make all
443 :     * of the globally defined variables visible to the rest of the program (including intermediate
444 :     * results) so that later transforms (e.g., field normalization) will work. Eventually the
445 :     * variable analysis phase ought to clean things up.
446 :     *)
447 :     fun definedVars (IL.CFG{entry, ...}) = let
448 :     fun gather (nd, vars) = (case IL.Node.kind nd
449 :     of IL.NULL => vars
450 :     | IL.ENTRY{succ, ...} => gather(!succ, vars)
451 :     | IL.COND{trueBranch, ...} => let
452 :     val (phis, succ) = findJoin (!trueBranch)
453 :     val vars = List.foldl (fn ((x, _), vars) => x::vars) vars (!phis)
454 : jhr 1640 in
455 : jhr 2636 gather (succ, vars)
456 : jhr 1640 end
457 : jhr 2636 | IL.COM{succ, ...} => gather (!succ, vars)
458 :     | IL.ASSIGN{stm=(x, _), succ, ...} => gather(!succ, x::vars)
459 :     | IL.MASSIGN{stm=(xs, _, _), succ, ...} => gather(!succ, xs@vars)
460 :     | _ => raise Fail("gather: unexpected " ^ IL.Node.toString nd)
461 :     (* end case *))
462 :     and findJoin nd = (case IL.Node.kind nd
463 :     of IL.JOIN{phis, succ, ...} => (phis, !succ)
464 :     | IL.COND{trueBranch, ...} => findJoin (#2 (findJoin (!trueBranch)))
465 :     | IL.COM{succ, ...} => findJoin (!succ)
466 :     | IL.ASSIGN{succ, ...} => findJoin (!succ)
467 :     | IL.MASSIGN{succ, ...} => findJoin (!succ)
468 :     | _ => raise Fail("findJoin: unexpected " ^ IL.Node.toString nd)
469 :     (* end case *))
470 :     in
471 :     List.rev (gather (entry, []))
472 :     end
473 :    
474 :     fun translate (S.Program{props, inputs, globals, globalInit, init, strands, ...}) = let
475 :     val (globalInit, env) = let
476 :     val (inputBlk, inputEnv) = cvtInputs inputs
477 :     val (globBlk, env) = cvtBlock (([], []), inputEnv, [], globalInit)
478 :     val cfg = IL.CFG.prependNode (IL.Node.mkENTRY(), inputBlk)
479 :     val cfg = IL.CFG.concat(cfg, globBlk)
480 :     val exit = IL.Node.mkRETURN(VMap.listItems inputEnv @ definedVars globBlk)
481 :     val cfg = IL.CFG.concat (cfg, IL.CFG{entry = exit, exit = exit})
482 : jhr 1640 in
483 : jhr 2636 (cfg, env)
484 : jhr 1640 end
485 : jhr 2636 (* construct a reduced environment that just defines the globals (including inputs). *)
486 : jhr 2356 val env = let
487 :     val lookup = lookup env
488 :     fun cvtVar (x, env) = VMap.insert(env, x, lookup x)
489 : jhr 2636 val env = List.foldl (fn ((x, _), env) => cvtVar(x, env)) VMap.empty inputs
490 :     val env = List.foldl cvtVar env globals
491 : jhr 2356 in
492 :     env
493 :     end
494 :     val init = cvtInitially (env, init)
495 :     fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
496 :     (* extend the global environment with the strand's parameters *)
497 :     val (env, params) = let
498 :     fun cvtParam (x, (env, xs)) = let
499 :     val x' = newVar x
500 :     in
501 :     (VMap.insert(env, x, x'), x'::xs)
502 :     end
503 :     val (env, params) = List.foldl cvtParam (env, []) params
504 :     in
505 :     (env, List.rev params)
506 :     end
507 : jhr 1640 (* create the state variables *)
508 :     val svars = let
509 :     fun newSVar x = IL.StateVar.new (
510 : jhr 2476 SimpleVar.kindOf x = S.StrandOutputVar,
511 :     SimpleVar.nameOf x, cvtTy(SimpleVar.typeOf x))
512 : jhr 1640 in
513 :     List.map newSVar state
514 :     end
515 : jhr 2356 (* convert the state initialization code *)
516 :     val (stateInit, env) = let
517 : jhr 1640 fun mkExit env = saveStrandState (env, (state, svars), IL.Node.mkSINIT())
518 : jhr 2356 in
519 :     cvtTopLevelBlock (env, stateInit, mkExit)
520 :     end
521 :     fun cvtMeth (S.Method(name, blk)) = cvtMethod (env, name, state, svars, blk)
522 :     in
523 :     IL.Strand{
524 :     name = name,
525 :     params = params,
526 :     state = svars,
527 :     stateInit = stateInit,
528 :     methods = List.map cvtMeth methods
529 :     }
530 :     end
531 :     val prog = IL.Program{
532 : jhr 2636 (* FIXME: we should just use the properties from the Simple program *)
533 : jhr 1640 props = checkProps strands,
534 : jhr 2356 globalInit = globalInit,
535 :     initially = init,
536 :     strands = List.map cvtStrand strands
537 :     }
538 :     in
539 :     Census.init prog;
540 :     prog
541 :     end
542 : jhr 176
543 : jhr 137 end

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