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

Parent Directory | Revision Log

---

Revision 3349 - (view) (download)

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

---

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