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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3501 - (view) (download)

1 : jhr 3471 (* translate.sml
2 :     *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2015 The University of Chicago
6 :     * All rights reserved.
7 :     *
8 : jhr 3476 * Translate Simple-AST code into the HighIR representation. This translation is based on the
9 : jhr 3471 * algorithm described in
10 :     *
11 :     * Single-pass generation of static single assignment form for structured languages
12 :     * ACM TOPLAS, Nov. 1994
13 :     * by Brandis and MossenBock.
14 :     *)
15 :    
16 :     structure Translate : sig
17 :    
18 : jhr 3476 val translate : Simple.program -> HighIR.program
19 : jhr 3471
20 :     end = struct
21 :    
22 :     structure S = Simple
23 :     structure Ty = SimpleTypes
24 : jhr 3485 structure SV = SimpleVar
25 :     structure VMap = SV.Map
26 :     structure VSet = SV.Set
27 : jhr 3476 structure IR = HighIR
28 : jhr 3471 structure Op = HighOps
29 : jhr 3476 structure DstTy = HighTypes
30 :     structure Census = HighCensus
31 : jhr 3493 structure Inp = Inputs
32 : jhr 3471
33 :     val cvtTy = TranslateTy.tr
34 :    
35 :     (* maps from SimpleAST variables to the current corresponding SSA variable *)
36 : jhr 3476 type env = IR.var VMap.map
37 : jhr 3471
38 :     (* +DEBUG *)
39 :     fun prEnv (prefix, env) = let
40 :     val wid = ref 0
41 :     fun pr s = (print s; wid := !wid + size s)
42 :     fun nl () = if (!wid > 0) then (print "\n"; wid := 0) else ()
43 :     fun prElem (src, dst) = let
44 :     val s = String.concat [
45 : jhr 3485 " ", SV.uniqueNameOf src, "->", IR.Var.toString dst
46 : jhr 3471 ]
47 :     in
48 :     pr s;
49 :     if (!wid >= 100) then (nl(); pr " ") else ()
50 :     end
51 :     in
52 :     pr prefix; pr " ENV: {"; nl(); pr " ";
53 :     VMap.appi prElem env;
54 :     nl(); pr "}"; nl()
55 :     end
56 :     (* -DEBUG *)
57 :    
58 :     fun lookup env x = (case VMap.find (env, x)
59 :     of SOME x' => x'
60 :     | NONE => raise Fail(concat[
61 : jhr 3485 "no binding for ", SV.uniqueNameOf x, " in environment"
62 : jhr 3471 ])
63 :     (* end case *))
64 :    
65 :     (* create a new instance of a variable *)
66 : jhr 3485 fun newVar x = IR.Var.new (SV.nameOf x, cvtTy(SV.typeOf x))
67 : jhr 3471
68 :     (* generate fresh SSA variables and add them to the environment *)
69 :     fun freshVars (env, xs) = let
70 :     fun cvtVar (x, (env, xs)) = let
71 :     val x' = newVar x
72 :     in
73 :     (VMap.insert(env, x, x'), x'::xs)
74 :     end
75 :     val (env, xs) = List.foldl cvtVar (env, []) xs
76 :     in
77 :     (env, List.rev xs)
78 :     end
79 :    
80 :     (* a pending-join node tracks the phi nodes needed to join the assignments
81 :     * that flow into the join node.
82 :     *)
83 :     datatype join = JOIN of {
84 :     env : env, (* the environment that was current at the conditional *)
85 :     (* associated with this node. *)
86 :     arity : int ref, (* actual number of predecessors *)
87 : jhr 3476 nd : IR.node, (* the CFG node for this pending join *)
88 :     phiMap : (IR.var * IR.var list) VMap.map ref,
89 : jhr 3471 (* a mapping from Simple AST variables that are assigned *)
90 :     (* to their phi nodes. *)
91 :     predKill : bool array (* killed predecessor edges (because of DIE or STABILIZE *)
92 :     }
93 :    
94 :     (* a stack of pending joins. The first component specifies the path index of the current
95 :     * path to the join.
96 :     *)
97 :     type pending_joins = (int * join) list
98 :    
99 :     (* create a new pending-join node *)
100 :     fun newJoin (env, arity) = JOIN{
101 : jhr 3476 env = env, arity = ref arity, nd = IR.Node.mkJOIN [], phiMap = ref VMap.empty,
102 : jhr 3471 predKill = Array.array(arity, false)
103 :     }
104 :    
105 : jhr 3501 (* create a new pending-join node *)
106 :     fun newForeach (env, x, xs) = JOIN{
107 :     env = env.
108 :     arity = ref 2,
109 :     nd = IR.Node.mkFOREACH(x, xs),
110 :     phiMap = ref VMap.empty,
111 :     predKill = Arry.array(2, false)
112 :     }
113 : jhr 3500
114 : jhr 3471 (* record that a path to the top join in the stack has been killed because f DIE or STABILIZE *)
115 :     fun killPath ((i, JOIN{arity, predKill, ...}) :: _) = (
116 :     arity := !arity - 1;
117 :     Array.update (predKill, i, true))
118 :     | killPath _ = ()
119 :    
120 : jhr 3476 (* record an assignment to the IR variable dstVar (corresponding to the Simple AST variable
121 : jhr 3471 * srcVar) in the current pending-join node. The predIndex specifies which path into the
122 :     * JOIN node this assignment occurs on.
123 :     *)
124 :     fun recordAssign ([], _, _) = ()
125 :     | recordAssign ((predIndex, JOIN{env, phiMap, predKill, nd, ...})::_, srcVar, dstVar) = let
126 :     val arity = Array.length predKill (* the original arity before any killPath calls *)
127 :     val m = !phiMap
128 :     in
129 :     case VMap.find (env, srcVar)
130 :     of NONE => () (* local temporary *)
131 :     | SOME dstVar' => (case VMap.find (m, srcVar)
132 :     of NONE => let
133 :     val lhs = newVar srcVar
134 :     val rhs = List.tabulate (arity, fn i => if (i = predIndex) then dstVar else dstVar')
135 :     in
136 :     (*
137 : jhr 3485 print(concat["recordAssign: ", SV.uniqueNameOf srcVar, " --> ", IR.Var.toString lhs,
138 : jhr 3476 " @ ", IR.Node.toString nd, "\n"]);
139 : jhr 3471 *)
140 :     phiMap := VMap.insert (m, srcVar, (lhs, rhs))
141 :     end
142 :     | SOME(lhs, rhs) => let
143 :     fun update (i, l as x::r) = if (i = predIndex)
144 :     then dstVar::r
145 :     else x::update(i+1, r)
146 :     | update _ = raise Fail "invalid predecessor index"
147 :     in
148 :     phiMap := VMap.insert (m, srcVar, (lhs, update(0, rhs)))
149 :     end
150 :     (* end case *))
151 :     (* end case *)
152 :     end
153 :    
154 :     (* complete a pending join operation by filling in the phi nodes from the phi map and
155 :     * updating the environment.
156 :     *)
157 :     fun commitJoin (joinStk, JOIN{env, arity, nd, phiMap, predKill}) = let
158 : jhr 3476 val IR.JOIN{preds, mask, phis, ...} = IR.Node.kind nd
159 : jhr 3471 (* update the predKill array based on reachability *)
160 :     val _ = let
161 :     fun update (_, []) = ()
162 :     | update (i, nd::nds) = (
163 : jhr 3476 if IR.Node.isReachable nd then ()
164 : jhr 3471 else if Array.sub(predKill, i) then ()
165 :     else (arity := !arity-1; Array.update(predKill, i, true));
166 :     update (i+1, nds))
167 :     in
168 :     update (0, !preds)
169 :     end
170 :     (* compute the predecessor mask *)
171 :     val mask' = Array.foldr (op ::) [] predKill
172 :     in
173 :     mask := mask';
174 :     case !arity
175 :     of 0 => env (* all incoming edges are fake *)
176 :     | 1 => let
177 :     (* there is only one path to the join, so we do not need phi nodes, but
178 :     * we still need to propogate assignments to the next join on the stack.
179 :     *)
180 :     val ix = let (* find pred index of this join *)
181 :     fun find i = if Array.sub(predKill, i) then find(i+1) else i
182 :     in
183 :     find 0
184 :     end
185 :     fun doVar (srcVar, (_, xs), env) = let
186 :     val dstVar = List.nth(xs, ix)
187 :     in
188 :     (*
189 : jhr 3485 print(concat["doVar (", SV.uniqueNameOf srcVar, ", ", IR.phiToString phi, ", _) @ ", IR.Node.toString nd, "\n"]);
190 : jhr 3471 *)
191 :     recordAssign (joinStk, srcVar, dstVar);
192 :     VMap.insert (env, srcVar, dstVar)
193 :     end
194 :     val env = VMap.foldli doVar env (!phiMap)
195 :     in
196 :     env
197 :     end
198 :     | nPreds => if (nPreds < Array.length predKill)
199 :     then let
200 :     (* filter out variables that correspond to fake preds from the RHS of a phi *)
201 :     fun filterPhiRHS xs = let
202 :     fun f ([], _, xs') = List.rev xs'
203 :     | f (x::xs, i, xs') = if Array.sub(predKill, i)
204 :     then f (xs, i+1, NONE :: xs')
205 :     else f (xs, i+1, (SOME x) :: xs')
206 :     in
207 :     f (xs, 0, [])
208 :     end
209 :     fun doVar (srcVar, phi as (dstVar, srcVars), (env, phis)) = (
210 :     (*
211 : jhr 3485 print(concat["doVar (", SV.uniqueNameOf srcVar, ", ", IR.phiToString phi, ", _) @ ", IR.Node.toString nd, "\n"]);
212 : jhr 3471 *)
213 :     recordAssign (joinStk, srcVar, dstVar);
214 :     (VMap.insert (env, srcVar, dstVar), (dstVar, filterPhiRHS srcVars) ::phis))
215 :     val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
216 :     in
217 :     phis := phis';
218 :     env
219 :     end
220 :     else let
221 :     fun doVar (srcVar, phi as (dstVar, xs), (env, phis)) = let
222 :     val xs = List.map SOME xs
223 :     in
224 :     (*
225 : jhr 3485 print(concat["doVar (", SV.uniqueNameOf srcVar, ", ", IR.phiToString phi, ", _) @ ", IR.Node.toString nd, "\n"]);
226 : jhr 3471 *)
227 :     recordAssign (joinStk, srcVar, dstVar);
228 : jhr 3476 IR.Var.setBinding (dstVar, IR.VB_PHI xs);
229 : jhr 3471 (VMap.insert (env, srcVar, dstVar), (dstVar, xs)::phis)
230 :     end
231 :     val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
232 :     in
233 :     phis := phis';
234 :     env
235 :     end
236 :     (* end case *)
237 :     end
238 :    
239 :     (* expression translation *)
240 :     fun cvtExp (env : env, lhs, exp) = (case exp
241 : jhr 3476 of S.E_Var x => [IR.ASSGN(lhs, IR.VAR(lookup env x))]
242 :     | S.E_Lit lit => [IR.ASSGN(lhs, IR.LIT lit)]
243 : jhr 3485 | S.E_Select(x, fld) => raise Fail "FIXME"
244 : jhr 3471 | S.E_Apply _ => raise Fail "unexpected E_Apply"
245 :     | S.E_Prim(f, tyArgs, args, ty) => let
246 :     val args' = List.map (lookup env) args
247 :     in
248 :     TranslateBasis.translate (lhs, f, tyArgs, args')
249 :     end
250 : jhr 3485 | S.E_Tensor(args, _) => [IR.ASSGN(lhs, IR.CONS(List.map (lookup env) args, IR.Var.ty lhs))]
251 : jhr 3476 | S.E_Seq(args, _) => [IR.ASSGN(lhs, IR.SEQ(List.map (lookup env) args, IR.Var.ty lhs))]
252 : jhr 3471 | S.E_Slice(x, indices, ty) => let
253 :     val x = lookup env x
254 :     val mask = List.map isSome indices
255 :     fun cvt NONE = NONE
256 :     | cvt (SOME x) = SOME(lookup env x)
257 :     val indices = List.mapPartial cvt indices
258 :     in
259 :     if List.all (fn b => b) mask
260 : jhr 3476 then [IR.ASSGN(lhs, IR.OP(Op.TensorSub(IR.Var.ty x), x::indices))]
261 :     else [IR.ASSGN(lhs, IR.OP(Op.Slice(IR.Var.ty x, mask), x::indices))]
262 : jhr 3471 end
263 :     | S.E_Coerce{srcTy, dstTy, x} => (case (srcTy, dstTy)
264 :     of (Ty.T_Int, Ty.T_Tensor _) =>
265 : jhr 3476 [IR.ASSGN(lhs, IR.OP(Op.IntToReal, [lookup env x]))]
266 : jhr 3485 | (Ty.T_Sequence(ty, SOME n), Ty.T_Sequence(_, NONE)) =>
267 : jhr 3476 [IR.ASSGN(lhs, IR.OP(Op.MkDynamic(cvtTy ty, n), [lookup env x]))]
268 : jhr 3471 | (Ty.T_Field _, Ty.T_Field _) =>
269 :     (* change in continuity is a no-op *)
270 : jhr 3476 [IR.ASSGN(lhs, IR.VAR(lookup env x))]
271 : jhr 3471 | _ => raise Fail(concat[
272 :     "unsupported type coercion: ", Ty.toString srcTy,
273 :     " ==> ", Ty.toString dstTy
274 :     ])
275 :     (* end case *))
276 : jhr 3476 | S.E_LoadSeq(ty, nrrd) => [IR.ASSGN(lhs, IR.OP(Op.LoadSeq(cvtTy ty, nrrd), []))]
277 :     | S.E_LoadImage(_, nrrd, info) => [IR.ASSGN(lhs, IR.OP(Op.LoadImage(DstTy.ImageTy info, nrrd), []))]
278 : jhr 3471 (* end case *))
279 :    
280 :     (* add nodes to save the strand state, followed by an exit node *)
281 :     fun saveStrandState (env, (srcState, dstState), exit) = let
282 :     val stateOut = List.map (lookup env) srcState
283 : jhr 3476 fun save (x, x', cfg) = IR.CFG.appendNode (cfg, IR.Node.mkSAVE(x, x'))
284 : jhr 3471 in
285 : jhr 3476 IR.CFG.appendNode (
286 :     ListPair.foldlEq save IR.CFG.empty (dstState, stateOut),
287 : jhr 3471 exit)
288 :     end
289 :     (*DEBUG*)handle ex => raise ex
290 :    
291 : jhr 3501 fun cvtBlock (state, env : env, joinStk, blk as S.Block{code, ...}) = let
292 :     val _ = AnalyzeSimple.analyze blk
293 : jhr 3471 fun cvt (env : env, cfg, []) = (cfg, env)
294 :     | cvt (env, cfg, stm::stms) = (case stm
295 : jhr 3485 of S.S_Var(x, NONE) => let
296 : jhr 3471 val x' = newVar x
297 :     in
298 :     cvt (VMap.insert (env, x, x'), cfg, stms)
299 :     end
300 : jhr 3485 | S.S_Var(x, SOME e) => let
301 :     val x' = newVar x
302 :     val assigns = cvtExp (env, x', e)
303 :     in
304 :     recordAssign (joinStk, x, x');
305 :     cvt (
306 :     VMap.insert(env, x, x'),
307 :     IR.CFG.concat(cfg, IR.CFG.mkBlock assigns),
308 :     stms)
309 :     end
310 : jhr 3471 | S.S_Assign(lhs, rhs) => let
311 :     val lhs' = newVar lhs
312 :     val assigns = cvtExp (env, lhs', rhs)
313 :     in
314 :     (*
315 :     print "doAssign\n";
316 :     *)
317 :     recordAssign (joinStk, lhs, lhs');
318 :     cvt (
319 :     VMap.insert(env, lhs, lhs'),
320 : jhr 3476 IR.CFG.concat(cfg, IR.CFG.mkBlock assigns),
321 : jhr 3471 stms)
322 :     end
323 :     | S.S_IfThenElse(x, b0, b1) => let
324 :     val x' = lookup env x
325 :     val join as JOIN{nd=joinNd, ...} = newJoin (env, 2)
326 :     val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
327 :     val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
328 : jhr 3476 val cond = IR.Node.mkCOND x'
329 :     fun addEdgeToJoin nd = (case IR.Node.kind nd
330 :     of IR.EXIT{succ, ...} => (
331 : jhr 3471 succ := SOME joinNd;
332 : jhr 3476 IR.Node.setPred (joinNd, nd)) (* will be converted to fake later *)
333 :     | _ => IR.Node.addEdge(nd, joinNd)
334 : jhr 3471 (* end case *))
335 :     (* package the CFG the represents the conditional (cond, two blocks, and join) *)
336 :     (* QUESTION: under what conditions do we insert an UNREACHABLE exit node? Is it when there
337 :     * are no real predecessors to the join and the join stack is empty?
338 :     *)
339 :     val condCFG = (
340 : jhr 3476 if IR.CFG.isEmpty cfg0
341 : jhr 3471 then (
342 : jhr 3476 IR.Node.setTrueBranch (cond, joinNd);
343 :     IR.Node.setPred (joinNd, cond))
344 : jhr 3471 else (
345 : jhr 3476 IR.Node.setTrueBranch (cond, IR.CFG.entry cfg0);
346 :     IR.Node.setPred (IR.CFG.entry cfg0, cond);
347 :     addEdgeToJoin (IR.CFG.exit cfg0));
348 :     if IR.CFG.isEmpty cfg1
349 : jhr 3471 then (
350 : jhr 3476 IR.Node.setFalseBranch (cond, joinNd);
351 :     IR.Node.setPred (joinNd, cond))
352 : jhr 3471 else (
353 : jhr 3476 IR.Node.setFalseBranch (cond, IR.CFG.entry cfg1);
354 :     IR.Node.setPred (IR.CFG.entry cfg1, cond);
355 :     addEdgeToJoin (IR.CFG.exit cfg1));
356 :     IR.CFG{entry = cond, exit = joinNd})
357 : jhr 3471 val env = commitJoin (joinStk, join)
358 :     in
359 : jhr 3476 cvt (env, IR.CFG.concat (cfg, condCFG), stms)
360 : jhr 3471 end
361 : jhr 3500 | S.S_Foreach(x, xs, b) => let
362 :     val x' = newVar x
363 :     val xs' = lookup env xs
364 : jhr 3501 (* we need to create fresh SSA variables for the free locals that are
365 :     * assigned to in the body of the loop.
366 :     *)
367 :     val assignedVars = freeVarAssignments b
368 :     val join as JOIN{nd=foreachNd, ...} = newForeach (env, x', xs')
369 :     val (body, _) = cvtBlock (state, env, (1, join)::joinStk, b)
370 : jhr 3500 in
371 : jhr 3501 (* link in CFG edges *)
372 :     IR.Node.setBodyBranch(foreachNd, IR.CFG.entry body);
373 :     IR.Node.setPred (IR.CFG.entry body, foreachNd);
374 :    
375 : jhr 3500 ??
376 :     end
377 : jhr 3471 | S.S_New(strandId, args) => let
378 : jhr 3476 val nd = IR.Node.mkNEW{
379 : jhr 3471 strand = strandId,
380 :     args = List.map (lookup env) args
381 :     }
382 :     in
383 : jhr 3476 cvt (env, IR.CFG.appendNode (cfg, nd), stms)
384 : jhr 3471 end
385 :     | S.S_Continue => (
386 :     killPath joinStk;
387 : jhr 3476 (IR.CFG.concat (cfg, saveStrandState (env, state, IR.Node.mkACTIVE())), env))
388 : jhr 3471 | S.S_Die => (
389 :     killPath joinStk;
390 : jhr 3476 (IR.CFG.appendNode (cfg, IR.Node.mkDIE ()), env))
391 : jhr 3471 | S.S_Stabilize => (
392 :     killPath joinStk;
393 : jhr 3476 (IR.CFG.concat (cfg, saveStrandState (env, state, IR.Node.mkSTABILIZE())), env))
394 : jhr 3471 | S.S_Return _ => raise Fail "unexpected return"
395 :     | S.S_Print args => let
396 :     val args = List.map (lookup env) args
397 : jhr 3476 val nd = IR.Node.mkMASSIGN([], Op.Print(List.map IR.Var.ty args), args)
398 : jhr 3471 in
399 : jhr 3476 cvt (env, IR.CFG.appendNode (cfg, nd), stms)
400 : jhr 3471 end
401 : jhr 3500 | S.S_MapReduce{results, reductions, body, args, source} => ??
402 : jhr 3471 (* end case *))
403 :     in
404 : jhr 3476 cvt (env, IR.CFG.empty, stms)
405 : jhr 3471 end
406 :     (*DEBUG*)handle ex => raise ex
407 :    
408 :     fun cvtMethod (loadGlobals, env, name, state, svars, blk) = let
409 :     (* load the globals into fresh variables *)
410 :     val (loadGlobsCFG, env) = loadGlobals env
411 :     (* load the state into fresh variables *)
412 :     val (env, loadCFG) = let
413 :     (* allocate shadow variables for the state variables *)
414 :     val (env, stateIn) = freshVars (env, state)
415 : jhr 3476 fun load (x, x') = IR.ASSGN(x, IR.STATE x')
416 :     val cfg = IR.CFG.mkBlock (ListPair.map load (stateIn, svars))
417 : jhr 3471 in
418 : jhr 3476 (env, IR.CFG.concat(loadGlobsCFG, cfg))
419 : jhr 3471 end
420 :     (* convert the body of the method *)
421 :     val (cfg, env) = cvtBlock ((state, svars), env, [], blk)
422 :     (* add the entry/exit nodes *)
423 : jhr 3476 val entry = IR.Node.mkENTRY ()
424 :     val loadCFG = IR.CFG.prependNode (entry, loadCFG)
425 : jhr 3471 val exit = (case name
426 : jhr 3476 of StrandUtil.Initially => IR.Node.mkACTIVE ()
427 :     | StrandUtil.Update => IR.Node.mkACTIVE ()
428 :     | StrandUtil.Stabilize => IR.Node.mkRETURN []
429 : jhr 3471 (* end case *))
430 : jhr 3476 val body = IR.CFG.concat (loadCFG, cfg)
431 : jhr 3471 (*DEBUG**val _ = prEnv (StrandUtil.nameToString name, env);*)
432 :     (* FIXME: the following code doesn't work properly *)
433 : jhr 3476 val body = if IR.Node.hasSucc(IR.CFG.exit body)
434 :     then IR.CFG.concat (body, saveStrandState (env, (state, svars), exit))
435 :     else IR.CFG{entry = IR.CFG.entry body, exit = exit}
436 : jhr 3471 in
437 : jhr 3476 IR.Method{
438 : jhr 3471 name = name,
439 :     body = body
440 :     }
441 :     end
442 :     (*DEBUG*)handle ex => (print(concat["error in cvtMethod(", StrandUtil.nameToString name, ", ...)\n"]); raise ex)
443 :    
444 : jhr 3493 (* convert the initial strand creation code *)
445 :     fun cvtCreate (loadGlobals, S.Create{dim, code}) = let
446 :     (* load the globals into fresh variables *)
447 : jhr 3471 val (loadCFG, env) = loadGlobals VMap.empty
448 : jhr 3493 (* convert the code *)
449 :     val (cfg, _) = cvtBlock (([], []), env, [], code)
450 : jhr 3471 in
451 : jhr 3476 IR.Initially{
452 : jhr 3471 isArray = isArray,
453 :     rangeInit = cfg,
454 :     iters = List.rev iters,
455 :     create = (argInitCFG, name, List.map (lookup env) args)
456 :     }
457 :     end
458 :     (*DEBUG*)handle ex => raise ex
459 :    
460 :     (* a function for generating a block of assignments to load globals *)
461 :     fun loadGlobs globs env = let
462 : jhr 3476 fun load (env, [], stms) = (IR.CFG.mkBlock(List.rev stms), env)
463 : jhr 3471 | load (env, (x, x')::globs, stms) = let
464 :     val x'' = newVar x
465 : jhr 3476 val stm = IR.ASSGN(x'', IR.GLOBAL x')
466 : jhr 3471 val env = VMap.insert (env, x, x'')
467 :     in
468 :     load (env, globs, stm::stms)
469 :     end
470 :     in
471 :     load (env, globs, [])
472 :     end
473 :    
474 :     fun cvtInputs (inputInit, inputs) = let
475 :     val (initBlk, env) = cvtBlock (([], []), VMap.empty, [], inputInit)
476 : jhr 3493 fun cvt (S.INP{var, desc, init}, (gvs, stms)) = let
477 :     val name = SV.nameOf var
478 :     val var' = newVar var
479 :     val ty' = IR.Var.ty var'
480 :     val gVar = IR.GlobalVar.new(true, name, ty')
481 :     val rhs = (case init
482 :     of S.NoDefault =>
483 :     Op.Input(Inp.INP{ty = ty', name = name, desc = desc, init = NONE})
484 :     | S.ConstExpr => ??
485 :     | S.LoadSeq nrrd => ??
486 :     | S.Proxy(nrrd, info) => ??
487 :     | S.Image info =>
488 :     Op.InputWithDefault(Inp.INP{
489 :     })
490 :     (* end case *))
491 :     val stms = IR.ASSGN(var', rhs) :: IR.GASSGN(gVar, var') :: stms
492 :     in
493 :     ((var, gVar)::gvs, stms)
494 :     end
495 : jhr 3471 fun cvt ((x, inp), (gvs, stms)) = let
496 :     val x' = newVar x
497 : jhr 3476 val gx = IR.GlobalVar.new(
498 : jhr 3471 true,
499 : jhr 3485 SV.nameOf x,
500 :     cvtTy(SV.typeOf x))
501 : jhr 3471 val rhs = (case VMap.find(env, x)
502 : jhr 3476 of SOME dflt => IR.OP(Op.InputWithDefault(Inputs.map cvtTy inp), [dflt])
503 :     | NONE => IR.OP(Op.Input(Inputs.map cvtTy inp), [])
504 : jhr 3471 (* end case *))
505 : jhr 3476 val stms = IR.ASSGN(x', rhs) :: IR.GASSGN(gx, x') :: stms
506 : jhr 3471 in
507 :     ((x, gx)::gvs, stms)
508 :     end
509 :     val (gvs, stms) = List.foldr cvt ([], []) inputs
510 : jhr 3476 val cfg = IR.CFG.appendBlock (initBlk, stms)
511 :     val cfg = IR.CFG.prependNode (IR.Node.mkENTRY(), cfg)
512 :     val cfg = IR.CFG.appendNode (cfg, IR.Node.mkRETURN [])
513 : jhr 3471 in
514 :     (cfg, gvs)
515 :     end
516 :    
517 : jhr 3476 (* convert Simple globals to HighIR globals and return a function that generates
518 : jhr 3471 * an initial binding of globals to local shadow variables.
519 :     *)
520 :     fun cvtGlobals globals = let
521 :     fun cvt x = let
522 : jhr 3476 val gx = IR.GlobalVar.new(
523 : jhr 3471 false,
524 : jhr 3485 SV.nameOf x,
525 :     cvtTy(SV.typeOf x))
526 : jhr 3471 in
527 :     (x, gx)
528 :     end
529 :     in
530 :     List.map cvt globals
531 :     end
532 :    
533 : jhr 3485 fun translate prog = let
534 :     val S.Program{
535 :     props, consts, inputs, constInit, globals, funcs, init, strand, create, update
536 :     } = prog
537 : jhr 3471 val (inputInit, inputGlobs) = cvtInputs (inputDefaults, inputs)
538 :     val globals = cvtGlobals globals
539 :     (* create the global initialization code *)
540 :     val globalInit = let
541 :     (* we start by loading the input globals, since they may be needed to compute the
542 :     * other globals
543 :     *)
544 :     val (cfg, env) = loadGlobs inputGlobs VMap.empty
545 :     val (globBlk, env) = cvtBlock (([], []), env, [], globalInit)
546 : jhr 3476 (* build a sequence of statements for initializing the IR globals *)
547 : jhr 3471 val saveGlobsBlk = let
548 :     fun saveGlob (x, gx) = let
549 :     val x' = lookup env x (* the local variable that holds the global *)
550 :     in
551 : jhr 3476 IR.GASSGN(gx, x')
552 : jhr 3471 end
553 :     in
554 : jhr 3476 IR.CFG.mkBlock (List.map saveGlob globals)
555 : jhr 3471 end
556 : jhr 3476 val cfg = IR.CFG.prependNode (IR.Node.mkENTRY(), cfg)
557 :     val cfg = IR.CFG.concat(cfg, globBlk)
558 :     val cfg = IR.CFG.concat(cfg, saveGlobsBlk)
559 :     val cfg = IR.CFG.appendNode (cfg, IR.Node.mkRETURN [])
560 : jhr 3471 in
561 :     cfg
562 :     end
563 :     val loadGlobals = loadGlobs (inputGlobs @ globals)
564 :     val init = cvtInitially (loadGlobals, init)
565 :     fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
566 :     (* extend the global environment with the strand's parameters *)
567 :     val (env, params) = let
568 :     fun cvtParam (x, (env, xs)) = let
569 :     val x' = newVar x
570 :     in
571 :     (VMap.insert(env, x, x'), x'::xs)
572 :     end
573 :     val (env, params) = List.foldl cvtParam (VMap.empty, []) params
574 :     in
575 :     (env, List.rev params)
576 :     end
577 :     (* create the state variables *)
578 :     val svars = let
579 : jhr 3476 fun newSVar x = IR.StateVar.new (
580 : jhr 3485 SV.kindOf x = SV.StrandOutputVar,
581 :     SV.nameOf x, cvtTy(SV.typeOf x))
582 : jhr 3471 in
583 :     List.map newSVar state
584 :     end
585 :     (* convert the state initialization code *)
586 :     val (stateInit, env) = let
587 :     (* load globals into local variables *)
588 :     val (loadGlobsCFG, env) = loadGlobals env
589 :     val (cfg, env) = cvtBlock (([], []), env, [], stateInit)
590 : jhr 3476 val cfg = IR.CFG.concat(loadGlobsCFG, cfg)
591 :     val cfg = IR.CFG.prependNode (IR.Node.mkENTRY(), cfg)
592 :     val cfg = IR.CFG.concat (cfg,
593 :     saveStrandState (env, (state, svars), IR.Node.mkSINIT()))
594 : jhr 3471 in
595 :     (cfg, env)
596 :     end
597 :     fun cvtMeth (S.Method(name, blk)) =
598 :     cvtMethod (loadGlobals, env, name, state, svars, blk)
599 :     in
600 : jhr 3476 IR.Strand{
601 : jhr 3471 name = name,
602 :     params = params,
603 :     state = svars,
604 :     stateInit = stateInit,
605 :     methods = List.map cvtMeth methods
606 :     }
607 :     end
608 : jhr 3476 val prog = IR.Program{
609 : jhr 3471 props = props,
610 :     globals = List.map #2 (inputGlobs @ globals),
611 :     inputInit = inputInit,
612 :     globalInit = globalInit,
613 :     initially = init,
614 :     strands = List.map cvtStrand strands
615 :     }
616 :     in
617 :     Census.init prog;
618 :     prog
619 :     end
620 :    
621 :     end

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