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 1868 - (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 :     * 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 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 :     " ", Var.uniqueNameOf src, "->", IL.Var.toString dst
42 :     ]
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 176 of SOME x' => x'
56 :     | NONE => raise Fail(concat[
57 : jhr 197 "no binding for ", Var.uniqueNameOf x, " in environment"
58 : jhr 176 ])
59 :     (* end case *))
60 :    
61 : jhr 189 (* create a new instance of a variable *)
62 : jhr 394 fun newVar x = IL.Var.new (Var.nameOf x, cvtTy(Var.monoTypeOf x))
63 : jhr 189
64 : jhr 1116 (* generate fresh SSA variables and add them to the environment *)
65 :     fun freshVars (env, xs) = let
66 :     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 :    
76 : lamonts 1868 datatype joinType
77 :     = NORMAL_JOIN
78 :     | FOREACH_JOIN
79 :    
80 :    
81 : jhr 1116 (* a pending-join node tracks the phi nodes needed to join the assignments
82 :     * that flow into the join node.
83 :     *)
84 : lamonts 1868 datatype join
85 :     = JOIN of {
86 :     env : env ref, (* the environment that was current at the conditional *)
87 :     (* associated with this node. *)
88 :     arity : int ref, (* actual number of predecessors *)
89 :     nd : IL.node, (* the CFG node for this pending join *)
90 :     phiMap : IL.phi VMap.map ref, (* a mapping from Simple AST variables that are assigned *)
91 :     (* to their phi nodes. *)
92 :     predKill : bool array, (* killed predecessor edges (because of DIE or STABILIZE *)
93 :     joinTy : joinType
94 :     }
95 : jhr 1116
96 : lamonts 1868
97 : jhr 1116 (* a stack of pending joins. The first component specifies the path index of the current
98 :     * path to the join.
99 :     *)
100 :     type pending_joins = (int * join) list
101 :    
102 : lamonts 1868
103 :     fun writeToFile(stringList) = let
104 :     val outfile = TextIO.openAppend("/home/lamont/debug.out");
105 :     fun printS(stream,[]) = TextIO.closeOut(stream)
106 :     | printS(stream,x::rest) =
107 :     (TextIO.output(outfile,x);
108 :     printS(stream,rest))
109 :     in
110 :     printS(outfile,stringList)
111 :     end
112 :    
113 :    
114 : jhr 1116 (* create a new pending-join node *)
115 : jhr 1232 fun newJoin (env, arity) = JOIN{
116 : lamonts 1868 env = ref env, arity = ref arity, joinTy = NORMAL_JOIN, nd = IL.Node.mkJOIN [], phiMap = ref VMap.empty,
117 : jhr 1116 predKill = Array.array(arity, false)
118 : lamonts 1868 }
119 : jhr 1116
120 : lamonts 1868 fun newJoinWithNode(env,arity,nd as IL.ND{kind=IL.FOREACH{...}, ...}) = JOIN {
121 :     env = ref env, arity = ref arity, joinTy = FOREACH_JOIN, nd = nd, phiMap = ref VMap.empty,
122 :     predKill = Array.array(arity, false)
123 :     }
124 :    
125 : jhr 1116 (* record that a path to the top join in the stack has been killed because f DIE or STABILIZE *)
126 :     fun killPath ((i, JOIN{arity, predKill, ...}) :: _) = (
127 :     arity := !arity - 1;
128 :     Array.update (predKill, i, true))
129 :     | killPath _ = ()
130 :    
131 :     (* record an assignment to the IL variable dstVar (corresponding to the Simple AST variable
132 :     * srcVar) in the current pending-join node. The predIndex specifies which path into the
133 :     * JOIN node this assignment occurs on.
134 :     *)
135 : jhr 1232 fun recordAssign ([], _, _) = ()
136 : lamonts 1868 | recordAssign ((predIndex, JOIN{env, phiMap, predKill, nd, joinTy, ...})::_, srcVar, dstVar) = let
137 : jhr 1116 val arity = Array.length predKill (* the original arity before any killPath calls *)
138 :     val m = !phiMap
139 :     in
140 : lamonts 1868 (*(if joinTy = FOREACH_JOIN then
141 :     print(concat["Beginning recordAssign: ", Var.uniqueNameOf srcVar, "\n"])
142 :     else
143 :     ()); *)
144 :    
145 :     case VMap.find (!env, srcVar)
146 :     of NONE => (*print(concat["Not in Environment recordAssign: ", Var.uniqueNameOf srcVar, "\n"])*) () (* local temporary *)
147 : jhr 1116 | SOME dstVar' => (case VMap.find (m, srcVar)
148 :     of NONE => let
149 :     val lhs = newVar srcVar
150 :     val rhs = List.tabulate (arity, fn i => if (i = predIndex) then dstVar else dstVar')
151 : lamonts 1868 fun printRhs ([]) = ()
152 :     | printRhs (dstvar::rest) =
153 :     (print(concat["rhs: ", IL.Var.toString dstvar, "\n"]);
154 :     printRhs(rest))
155 : jhr 1116 in
156 : lamonts 1868 if joinTy = FOREACH_JOIN then
157 :     let
158 :     val IL.ND{kind=IL.FOREACH{shouldReplace, ...}, ...} = nd
159 :     in
160 :     (env := VMap.insert(!env,srcVar,lhs);
161 :     shouldReplace := true)
162 :     end
163 :     else
164 :     ();
165 :    
166 : jhr 1116 phiMap := VMap.insert (m, srcVar, (lhs, rhs))
167 :     end
168 :     | SOME(lhs, rhs) => let
169 : lamonts 1868 fun printRhs ([]) = ()
170 :     | printRhs (dstvar::rest) =
171 :     (print(concat["rhs: ", IL.Var.toString dstvar, "\n"]);
172 :     printRhs(rest))
173 : jhr 1116 fun update (i, l as x::r) = if (i = predIndex)
174 :     then dstVar::r
175 :     else x::update(i+1, r)
176 :     | update _ = raise Fail "invalid predecessor index"
177 :     in
178 : lamonts 1868 (* (if joinTy = FOREACH_JOIN then
179 :     (print(concat["sOMDE recordAssign: ", Var.uniqueNameOf srcVar, " --> ", IL.Var.toString lhs,
180 :     " @ ", IL.Node.toString nd, "\n"]);
181 :     printRhs(rhs))
182 :     else
183 :     ()); *)
184 : jhr 1116 phiMap := VMap.insert (m, srcVar, (lhs, update(0, rhs)))
185 :     end
186 :     (* end case *))
187 :     (* end case *)
188 :     end
189 :    
190 :     (* complete a pending join operation by filling in the phi nodes from the phi map and
191 :     * updating the environment.
192 :     *)
193 : lamonts 1868 fun commitJoin (joinStk, JOIN{env, arity, nd, phiMap, predKill,joinTy,...}) = (case !arity
194 :     of 0 => (!env, NONE)
195 : jhr 1116 | 1 => (* there is only one path to the join, so we do not need phi nodes *)
196 : lamonts 1868 (!env, SOME nd)
197 : jhr 1116 | n => if (n = Array.length predKill)
198 :     then let
199 : lamonts 1868 val phis = (case joinTy of
200 :     NORMAL_JOIN => let
201 :     val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
202 :     in
203 :     phis
204 :     end
205 :     |FOREACH_JOIN => let
206 :     val IL.ND{kind=IL.FOREACH{phis, ...}, ...} = nd
207 :     in
208 :     phis
209 :     end)
210 : jhr 1116 fun doVar (srcVar, phi as (dstVar, _), (env, phis)) = (
211 : lamonts 1868 (*print(concat["doVar (", Var.uniqueNameOf srcVar, ", ", IL.phiToString phi, ", _) @ ", IL.Node.toString nd, "\n"]);*)
212 :    
213 : jhr 1232 recordAssign (joinStk, srcVar, dstVar);
214 : jhr 1116 (VMap.insert (env, srcVar, dstVar), phi::phis))
215 : lamonts 1868 val (env', phis') = VMap.foldli doVar (!env, []) (!phiMap)
216 : jhr 1116 in
217 :     phis := phis';
218 : lamonts 1868 (env', SOME nd)
219 : jhr 1116 end
220 :     else raise Fail "FIXME: prune killed paths."
221 :     (* end case *))
222 :    
223 : jhr 168 (* expression translation *)
224 : jhr 1116 fun cvtExp (env : env, lhs, exp) = (case exp
225 : lamonts 1868 of S.E_Var x => [IL.ASSGN(lhs, IL.VAR(lookup env x))]
226 : jhr 1640 | S.E_Lit lit => [IL.ASSGN(lhs, IL.LIT lit)]
227 : lamonts 1832 | S.E_RadiusQuery (S.E_Lit lit) => [IL.ASSGN(lhs,IL.RQUERY lit)]
228 : jhr 176 | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"
229 : jhr 188 | S.E_Apply(f, tyArgs, args, ty) => let
230 :     val args' = List.map (lookup env) args
231 : lamonts 1868 fun printArgs([]) = ()
232 :     | printArgs(x::rest) =
233 :     (* (print(concat["Arg:", IL.Var.toString x, "\n"]); *)
234 :     printArgs(rest)
235 : jhr 188 in
236 : lamonts 1868 printArgs(args');
237 : jhr 188 TranslateBasis.translate (lhs, f, tyArgs, args')
238 :     end
239 : jhr 1640 | S.E_Cons args => [IL.ASSGN(lhs, IL.CONS(IL.Var.ty lhs, List.map (lookup env) args))]
240 : jhr 400 | S.E_Slice(x, indices, ty) => let
241 :     val x = lookup env x
242 :     val mask = List.map isSome indices
243 :     fun cvt NONE = NONE
244 :     | cvt (SOME x) = SOME(lookup env x)
245 :     val indices = List.mapPartial cvt indices
246 :     in
247 :     if List.all (fn b => b) mask
248 : jhr 1640 then [IL.ASSGN(lhs, IL.OP(HighOps.TensorSub(IL.Var.ty x), x::indices))]
249 :     else [IL.ASSGN(lhs, IL.OP(HighOps.Slice(IL.Var.ty lhs, mask), x::indices))]
250 : jhr 400 end
251 : jhr 1301 | S.E_Input(_, name, desc, NONE) =>
252 : jhr 1640 [IL.ASSGN(lhs, IL.OP(HighOps.Input(IL.Var.ty lhs, name, desc), []))]
253 : jhr 1301 | S.E_Input(_, name, desc, SOME dflt) =>
254 : jhr 1640 [IL.ASSGN(lhs, IL.OP(HighOps.InputWithDefault(IL.Var.ty lhs, name, desc), [lookup env dflt]))]
255 :     | S.E_LoadImage(info, name) => [IL.ASSGN(lhs, IL.OP(HighOps.LoadImage info, [lookup env name]))]
256 : jhr 176 (* end case *))
257 : jhr 168
258 : jhr 1640 (* add nodes to save the strand state, followed by an exit node *)
259 :     fun saveStrandState (env, (srcState, dstState), exit) = let
260 :     val stateOut = List.map (lookup env) srcState
261 :     fun save (x, x', cfg) = IL.CFG.appendNode (cfg, IL.Node.mkSAVE(x, x'))
262 :     in
263 :     IL.CFG.appendNode (
264 :     ListPair.foldlEq save IL.CFG.empty (dstState, stateOut),
265 :     exit)
266 :     end
267 :     handle ex => raise ex
268 :    
269 : lamonts 1868
270 :    
271 :    
272 : jhr 1116 fun cvtBlock (state, env : env, joinStk, S.Block stms) = let
273 : lamonts 1868 fun cvtLoopBlock(forNode as IL.ND{kind=IL.FOREACH{shouldReplace, ...}, ...},state,joinStk,blk) = let
274 :     val (_,JOIN{env,...})::_ = joinStk
275 :     val(cfg0,e) = cvtBlock (state,!env,joinStk, blk)
276 :     in
277 :     (print(Bool.toString(!shouldReplace));
278 :     if(!shouldReplace = true) then
279 :     (print("got here\n"); shouldReplace := false;
280 :     cvtLoopBlock(forNode,state,joinStk,blk))
281 :     else
282 :     (cfg0,e))
283 :     end
284 :    
285 : jhr 1116 fun cvt (env : env, cfg, []) = (cfg, env)
286 :     | cvt (env, cfg, stm::stms) = (case stm
287 :     of S.S_Var x => let
288 :     val x' = newVar x
289 :     in
290 :     cvt (VMap.insert (env, x, x'), cfg, stms)
291 :     end
292 :     | S.S_Assign(lhs, rhs) => let
293 :     val lhs' = newVar lhs
294 :     val assigns = cvtExp (env, lhs', rhs)
295 :     in
296 : jhr 1232 (*
297 :     print "doAssign\n";
298 :     *)
299 : lamonts 1868 (*print(concat["About to assign ",IL.Var.toString lhs', "\n"]);*)
300 : jhr 1232 recordAssign (joinStk, lhs, lhs');
301 : jhr 1116 cvt (
302 :     VMap.insert(env, lhs, lhs'),
303 :     IL.CFG.concat(cfg, IL.CFG.mkBlock assigns),
304 :     stms)
305 :     end
306 :     | S.S_IfThenElse(x, b0, b1) => let
307 : jhr 192 val x' = lookup env x
308 : jhr 1232 val join = newJoin (env, 2)
309 : jhr 1116 val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
310 :     val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
311 :     val cond = IL.Node.mkCOND {
312 :     cond = x',
313 :     trueBranch = IL.Node.dummy,
314 :     falseBranch = IL.Node.dummy
315 :     }
316 : jhr 190 in
317 : jhr 1116 IL.Node.addEdge (IL.CFG.exit cfg, cond);
318 : jhr 1232 case commitJoin (joinStk, join)
319 : jhr 1116 of (env, SOME joinNd) => (
320 :     if IL.CFG.isEmpty cfg0
321 :     then (
322 :     IL.Node.setTrueBranch (cond, joinNd);
323 :     IL.Node.setPred (joinNd, cond))
324 :     else (
325 :     IL.Node.setTrueBranch (cond, IL.CFG.entry cfg0);
326 :     IL.Node.setPred (IL.CFG.entry cfg0, cond);
327 :     IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
328 :     if IL.CFG.isEmpty cfg1
329 :     then (
330 :     IL.Node.setFalseBranch (cond, joinNd);
331 :     IL.Node.setPred (joinNd, cond))
332 :     else (
333 :     IL.Node.setFalseBranch (cond, IL.CFG.entry cfg1);
334 :     IL.Node.setPred (IL.CFG.entry cfg1, cond);
335 :     IL.Node.addEdge (IL.CFG.exit cfg1, joinNd));
336 :     cvt (
337 :     env,
338 : jhr 1339 IL.CFG.concat (
339 :     cfg,
340 :     IL.CFG{entry = cond, exit = joinNd}),
341 : jhr 1116 stms))
342 :     (* the join node has only zero predecessors, so
343 :     * it was killed.
344 :     *)
345 :     | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
346 : jhr 192 (* end case *)
347 : jhr 190 end
348 : lamonts 1868 | S.S_Foreach(x,blk) => let
349 : lamonts 1864 val x' = lookup env x
350 : lamonts 1865 val forNode = IL.Node.mkFOREACH{
351 : lamonts 1864 cond = x',
352 : lamonts 1868 phis = [],
353 : lamonts 1864 stmBranch = IL.Node.dummy
354 :     }
355 : lamonts 1868 val join = newJoinWithNode(env, 2,forNode)
356 :     val (cfg0, _) = cvtLoopBlock(forNode,state,(1, join)::joinStk, blk)
357 : lamonts 1865 in
358 :     case commitJoin (joinStk, join)
359 : lamonts 1868 of (env, SOME joinND) => (
360 : lamonts 1864 if IL.CFG.isEmpty cfg0
361 :     then (
362 : lamonts 1865 ())
363 : lamonts 1864 else (
364 : lamonts 1868 IL.Node.setPred (IL.CFG.entry cfg0, joinND);
365 :     IL.Node.setStmBranch(joinND, IL.CFG.entry cfg0);
366 :     IL.Node.addEdge (IL.CFG.exit cfg0, joinND));
367 : lamonts 1864 cvt (
368 :     env,
369 : lamonts 1868 IL.CFG.appendNode (cfg, joinND),
370 : lamonts 1864 stms))
371 : lamonts 1865
372 :    
373 : lamonts 1864 (* the join node has only zero predecessors, so
374 : lamonts 1865 * it was killed. *)
375 :    
376 : lamonts 1864 | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
377 : lamonts 1865 (* end case *)
378 : lamonts 1832 end
379 :    
380 : jhr 1116 | S.S_New(strandId, args) => let
381 :     val nd = IL.Node.mkNEW{
382 :     strand = strandId,
383 :     args = List.map (lookup env) args
384 :     }
385 : jhr 192 in
386 : jhr 1116 cvt (env, IL.CFG.appendNode (cfg, nd), stms)
387 : jhr 194 end
388 : jhr 1116 | S.S_Die => (
389 :     killPath joinStk;
390 :     (IL.CFG.appendNode (cfg, IL.Node.mkDIE ()), env))
391 : jhr 1640 | S.S_Stabilize => (
392 :     killPath joinStk;
393 :     (IL.CFG.concat (cfg, saveStrandState (env, state, IL.Node.mkSTABILIZE())), env))
394 :     | S.S_Print args => let
395 :     val args = List.map (lookup env) args
396 :     val nd = IL.Node.mkMASSIGN([], Op.Print(List.map IL.Var.ty args), args)
397 :     in
398 :     cvt (env, IL.CFG.appendNode (cfg, nd), stms)
399 :     end
400 : jhr 192 (* end case *))
401 :     in
402 : jhr 1116 cvt (env, IL.CFG.empty, stms)
403 : jhr 192 end
404 : jhr 1339 (*DEBUG*)handle ex => raise ex
405 : jhr 168
406 : jhr 1232 fun cvtTopLevelBlock (env, blk, mkExit) = let
407 : jhr 1640 val (cfg, env) = cvtBlock (([], []), env, [], blk)
408 :     val cfg = IL.CFG.prependNode (IL.Node.mkENTRY(), cfg)
409 :     val cfg = IL.CFG.concat (cfg, mkExit env)
410 : jhr 256 in
411 : jhr 1640 (cfg, env)
412 : jhr 256 end
413 : jhr 1339 (*DEBUG*)handle ex => raise ex
414 : jhr 256
415 : jhr 1116 (* FIXME: the following function could be refactored with cvtTopLevelBlock to share code *)
416 : jhr 1232 fun cvtFragmentBlock (env0, blk) = let
417 : jhr 1640 val (cfg, env) = cvtBlock (([], []), env0, [], blk)
418 : jhr 1116 val entry = IL.Node.mkENTRY ()
419 : jhr 1232 (* the live variables out are those that were not live coming in *)
420 :     val liveOut = VMap.foldli
421 :     (fn (x, x', xs) => if VMap.inDomain(env0, x) then xs else x'::xs)
422 :     [] env
423 :     val exit = IL.Node.mkFRAGMENT liveOut
424 : jhr 1116 in
425 :     if IL.CFG.isEmpty cfg
426 :     then IL.Node.addEdge (entry, exit)
427 :     else (
428 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
429 : jhr 1232 IL.Node.addEdge (IL.CFG.exit cfg, exit));
430 : jhr 1116 (IL.CFG{entry = entry, exit = exit}, env)
431 :     end
432 : jhr 1339 (*DEBUG*)handle ex => raise ex
433 : jhr 1116
434 : jhr 1640 fun cvtMethod (env, name, state, svars, blk) = let
435 :     (* load the state into fresh variables *)
436 :     val (env, loadCFG) = let
437 :     (* allocate shadow variables for the state variables *)
438 :     val (env, stateIn) = freshVars (env, state)
439 :     fun load (x, x') = IL.ASSGN(x, IL.STATE x')
440 :     in
441 :     (env, IL.CFG.mkBlock (ListPair.map load (stateIn, svars)))
442 :     end
443 : jhr 1116 (* convert the body of the method *)
444 : jhr 1640 val (cfg, env) = cvtBlock ((state, svars), env, [], blk)
445 : jhr 1116 (* add the entry/exit nodes *)
446 :     val entry = IL.Node.mkENTRY ()
447 : jhr 1640 val loadCFG = IL.CFG.prependNode (entry, loadCFG)
448 : jhr 1444 val exit = (case name
449 : jhr 1640 of StrandUtil.Update => IL.Node.mkACTIVE ()
450 :     | StrandUtil.Stabilize => IL.Node.mkRETURN []
451 : jhr 1444 (* end case *))
452 : jhr 1640 val body = IL.CFG.concat (loadCFG, cfg)
453 :     (*DEBUG**val _ = prEnv (StrandUtil.nameToString name, env);*)
454 :     (* FIXME: the following code doesn't work properly *)
455 :     val body = if IL.Node.hasSucc(IL.CFG.exit body)
456 :     then IL.CFG.concat (body, saveStrandState (env, (state, svars), exit))
457 :     else IL.CFG{entry = IL.CFG.entry body, exit = exit}
458 : jhr 1116 in
459 :     IL.Method{
460 :     name = name,
461 : jhr 1640 body = body
462 : jhr 1116 }
463 :     end
464 : jhr 1640 (*DEBUG*)handle ex => (print(concat["error in cvtMethod(", StrandUtil.nameToString name, ", ...)\n"]); raise ex)
465 : jhr 1116
466 :     (* convert the initially code *)
467 :     fun cvtInitially (env, S.Initially{isArray, rangeInit, create, iters}) = let
468 :     val S.C_Create{argInit, name, args} = create
469 :     fun cvtIter ({param, lo, hi}, (env, iters)) = let
470 :     val param' = newVar param
471 :     val env = VMap.insert (env, param, param')
472 :     val iter = (param', lookup env lo, lookup env hi)
473 : jhr 256 in
474 : jhr 1116 (env, iter::iters)
475 : jhr 256 end
476 : jhr 1116 val (cfg, env) = cvtFragmentBlock (env, rangeInit)
477 :     val (env, iters) = List.foldl cvtIter (env, []) iters
478 :     val (argInitCFG, env) = cvtFragmentBlock (env, argInit)
479 : jhr 256 in
480 : jhr 1116 IL.Initially{
481 :     isArray = isArray,
482 :     rangeInit = cfg,
483 :     iters = List.rev iters,
484 :     create = (argInitCFG, name, List.map (lookup env) args)
485 :     }
486 : jhr 256 end
487 :    
488 : jhr 1640 (* check strands for properties *)
489 :     fun checkProps strands = let
490 :     val hasDie = ref false
491 :     val hasNew = ref false
492 :     fun chkStm e = (case e
493 :     of S.S_IfThenElse(_, b1, b2) => (chkBlk b1; chkBlk b2)
494 :     | S.S_New _ => (hasNew := true)
495 :     | S.S_Die => (hasDie := true)
496 :     | _ => ()
497 :     (* end case *))
498 :     and chkBlk (S.Block body) = List.app chkStm body
499 :     fun chkStrand (S.Strand{stateInit, methods, ...}) = let
500 :     fun chkMeth (S.Method(_, body)) = chkBlk body
501 :     in
502 :     chkBlk stateInit;
503 :     List.app chkMeth methods
504 :     end
505 :     fun condCons (x, v, l) = if !x then v::l else l
506 :     in
507 :     List.app chkStrand strands;
508 :     condCons (hasDie, StrandUtil.StrandsMayDie,
509 :     condCons (hasNew, StrandUtil.NewStrands, []))
510 :     end
511 :    
512 : jhr 1116 fun translate (S.Program{globals, globalInit, init, strands}) = let
513 : jhr 1640 val (globalInit, env) = let
514 :     fun mkExit env = let
515 :     val nd = IL.Node.mkRETURN(VMap.listItems env)
516 :     in
517 :     IL.CFG{entry = nd, exit = nd}
518 :     end
519 :     in
520 :     cvtTopLevelBlock (VMap.empty, globalInit, mkExit)
521 :     end
522 : jhr 1116 (* construct a reduced environment that just defines the globals. *)
523 :     val env = let
524 : jhr 200 val lookup = lookup env
525 : jhr 1116 fun cvtVar (x, env) = VMap.insert(env, x, lookup x)
526 :     val env = List.foldl cvtVar VMap.empty globals
527 : jhr 200 in
528 : jhr 1116 env
529 : jhr 200 end
530 : jhr 1116 val init = cvtInitially (env, init)
531 : jhr 511 fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
532 : jhr 1232 (* extend the global environment with the strand's parameters *)
533 : jhr 200 val (env, params) = let
534 :     fun cvtParam (x, (env, xs)) = let
535 :     val x' = newVar x
536 :     in
537 :     (VMap.insert(env, x, x'), x'::xs)
538 :     end
539 :     val (env, params) = List.foldl cvtParam (env, []) params
540 :     in
541 :     (env, List.rev params)
542 :     end
543 : jhr 1640 (* create the state variables *)
544 :     val svars = let
545 :     fun newSVar x = IL.StateVar.new (
546 :     Var.kindOf x = S.StrandOutputVar,
547 :     Var.nameOf x, cvtTy(Var.monoTypeOf x))
548 :     in
549 :     List.map newSVar state
550 :     end
551 : jhr 1232 (* convert the state initialization code *)
552 :     val (stateInit, env) = let
553 : jhr 1640 fun mkExit env = saveStrandState (env, (state, svars), IL.Node.mkSINIT())
554 : jhr 1232 in
555 :     cvtTopLevelBlock (env, stateInit, mkExit)
556 :     end
557 : jhr 1640 fun cvtMeth (S.Method(name, blk)) = cvtMethod (env, name, state, svars, blk)
558 : jhr 200 in
559 : jhr 511 IL.Strand{
560 : jhr 200 name = name,
561 :     params = params,
562 : jhr 1640 state = svars,
563 : jhr 200 stateInit = stateInit,
564 : jhr 1116 methods = List.map cvtMeth methods
565 : jhr 200 }
566 :     end
567 : jhr 511 val prog = IL.Program{
568 : jhr 1640 props = checkProps strands,
569 : jhr 1116 globalInit = globalInit,
570 :     initially = init,
571 :     strands = List.map cvtStrand strands
572 :     }
573 : jhr 511 in
574 :     Census.init prog;
575 :     prog
576 : jhr 200 end
577 : jhr 176
578 : jhr 137 end

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