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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/src/compiler/translate/translate.sml revision 511, Tue Feb 8 17:01:43 2011 UTC branches/lamont_dev/src/compiler/translate/translate.sml revision 1865, Tue May 1 15:18:00 2012 UTC
# Line 3  Line 3 
3   * COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)   * COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4   * All rights reserved.   * All rights reserved.
5   *   *
6   * Translate Simple-AST code into the IL representation.   * 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   *)   *)
13    
14  structure Translate : sig  structure Translate : sig
# Line 17  Line 22 
22      structure VMap = Var.Map      structure VMap = Var.Map
23      structure VSet = Var.Set      structure VSet = Var.Set
24      structure IL = HighIL      structure IL = HighIL
25        structure Op = HighOps
26      structure DstTy = HighILTypes      structure DstTy = HighILTypes
27        structure Census = HighILCensus
28    
29      structure Census = CensusFn (IL)      val cvtTy = TranslateTy.tr
30    
31      (* maps from SimpleAST variables to the current corresponding SSA variable *)
32      type env = IL.var VMap.map      type env = IL.var VMap.map
33    
34    (* +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      fun lookup env x = (case VMap.find (env, x)      fun lookup env x = (case VMap.find (env, x)
55             of SOME x' => x'             of SOME x' => x'
56              | NONE => raise Fail(concat[              | NONE => raise Fail(concat[
# Line 30  Line 58 
58                  ])                  ])
59            (* end case *))            (* end case *))
60    
     fun cvtTy ty = (case TypeUtil.prune ty  
            of Ty.T_Bool => DstTy.BoolTy  
             | Ty.T_Int => DstTy.IntTy  
             | Ty.T_String => DstTy.StringTy  
             | Ty.T_Kernel _ => DstTy.KernelTy  
             | Ty.T_Tensor(Ty.Shape dd) => let  
                 fun cvtDim (Ty.DimConst 1) = NONE  
                   | cvtDim (Ty.DimConst d) = SOME d  
                 in  
                   DstTy.TensorTy(List.mapPartial cvtDim dd)  
                 end  
             | Ty.T_Image _ => DstTy.ImageTy  
             | Ty.T_Field _ => DstTy.FieldTy  
             | ty => raise Fail("cvtTy: unexpected " ^ TypeUtil.toString ty)  
           (* end case *))  
   
61    (* create a new instance of a variable *)    (* create a new instance of a variable *)
62      fun newVar x = IL.Var.new (Var.nameOf x, cvtTy(Var.monoTypeOf x))      fun newVar x = IL.Var.new (Var.nameOf x, cvtTy(Var.monoTypeOf x))
63    
64      (* 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      (* 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            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          }
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        fun newJoin (env, arity) = JOIN{
96                env = env, arity = ref arity, nd = IL.Node.mkJOIN [], phiMap = ref VMap.empty,
97                predKill = Array.array(arity, false)
98              }
99    
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              arity := !arity - 1;
103              Array.update (predKill, i, true))
104          | 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        fun recordAssign ([], _, _) = ()
111          | recordAssign ((predIndex, JOIN{env, phiMap, predKill, nd, ...})::_, srcVar, dstVar) = let
112              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    (*
123    print(concat["recordAssign: ", Var.uniqueNameOf srcVar, " --> ", IL.Var.toString lhs,
124    " @ ", IL.Node.toString nd, "\n"]);
125    *)
126                              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    
140      (* complete a pending join operation by filling in the phi nodes from the phi map and
141       * updating the environment.
142       *)
143        fun commitJoin (joinStk, JOIN{env, arity, nd, phiMap, predKill}) = (case !arity
144               of 0 => (env, NONE)
145                | 1 => (* there is only one path to the join, so we do not need phi nodes *)
146                    (env, SOME nd)
147                | n => if (n = Array.length predKill)
148                    then let
149                      val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
150                      fun doVar (srcVar, phi as (dstVar, _), (env, phis)) = (
151    (*
152    print(concat["doVar (", Var.uniqueNameOf srcVar, ", ", IL.phiToString phi, ", _) @ ", IL.Node.toString nd, "\n"]);
153    *)
154                            recordAssign (joinStk, srcVar, dstVar);
155                            (VMap.insert (env, srcVar, dstVar), phi::phis))
156                      val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
157                      in
158                        phis := phis';
159                        (env, SOME nd)
160                      end
161                    else raise Fail "FIXME: prune killed paths."
162              (* end case *))
163    
164    (* expression translation *)    (* expression translation *)
165      fun cvtExp (env, lhs, exp) = (case exp      fun cvtExp (env : env, lhs, exp) = (case exp
166             of S.E_Var x => [(lhs, IL.VAR(lookup env x))]             of S.E_Var x => [IL.ASSGN(lhs, IL.VAR(lookup env x))]
167              | S.E_Lit lit => [(lhs, IL.LIT lit)]              | S.E_Lit lit => [IL.ASSGN(lhs, IL.LIT lit)]
168            | S.E_RadiusQuery (S.E_Lit lit) => [IL.ASSGN(lhs,IL.RQUERY lit)]
169              | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"              | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"
170              | S.E_Apply(f, tyArgs, args, ty) => let              | S.E_Apply(f, tyArgs, args, ty) => let
171                  val args' = List.map (lookup env) args                  val args' = List.map (lookup env) args
172                  in                  in
173                    TranslateBasis.translate (lhs, f, tyArgs, args')                    TranslateBasis.translate (lhs, f, tyArgs, args')
174                  end                  end
175              | S.E_Cons args => [(lhs, IL.CONS(List.map (lookup env) args))]              | S.E_Cons args => [IL.ASSGN(lhs, IL.CONS(IL.Var.ty lhs, List.map (lookup env) args))]
176              | S.E_Slice(x, indices, ty) => let              | S.E_Slice(x, indices, ty) => let
177                  val x = lookup env x                  val x = lookup env x
178                  val mask = List.map isSome indices                  val mask = List.map isSome indices
# Line 68  Line 181 
181                  val indices = List.mapPartial cvt indices                  val indices = List.mapPartial cvt indices
182                  in                  in
183                    if List.all (fn b => b) mask                    if List.all (fn b => b) mask
184                      then [(lhs, IL.OP(HighOps.Subscript(IL.Var.ty x), x::indices))]                      then [IL.ASSGN(lhs, IL.OP(HighOps.TensorSub(IL.Var.ty x), x::indices))]
185                      else [(lhs, IL.OP(HighOps.Slice(IL.Var.ty lhs, mask), x::indices))]                      else [IL.ASSGN(lhs, IL.OP(HighOps.Slice(IL.Var.ty lhs, mask), x::indices))]
186                  end                  end
187              | S.E_Input(_, name, NONE) =>              | S.E_Input(_, name, desc, NONE) =>
188                  [(lhs, IL.OP(HighOps.Input(IL.Var.ty lhs, name), []))]                  [IL.ASSGN(lhs, IL.OP(HighOps.Input(IL.Var.ty lhs, name, desc), []))]
189              | S.E_Input(_, name, SOME dflt) =>              | S.E_Input(_, name, desc, SOME dflt) =>
190                  [(lhs, IL.OP(HighOps.InputWithDefault(IL.Var.ty lhs, name), [lookup env dflt]))]                  [IL.ASSGN(lhs, IL.OP(HighOps.InputWithDefault(IL.Var.ty lhs, name, desc), [lookup env dflt]))]
191              | S.E_Field fld => [(lhs, IL.OP(HighOps.Field fld, []))]              | S.E_LoadImage(info, name) => [IL.ASSGN(lhs, IL.OP(HighOps.LoadImage info, [lookup env name]))]
             | S.E_LoadImage info => [(lhs, IL.OP(HighOps.LoadImage info, []))]  
192            (* end case *))            (* end case *))
193    
194    (* convert a Simple AST block to an IL statement.  We return the statement that represents the    (* add nodes to save the strand state, followed by an exit node *)
195     * block, plus the environment mapping Simple AST variables to their current SSA representations      fun saveStrandState (env, (srcState, dstState), exit) = let
196     * and the set of Simple AST variables that were assigned to in the block.            val stateOut = List.map (lookup env) srcState
197     *)            fun save (x, x', cfg) = IL.CFG.appendNode (cfg, IL.Node.mkSAVE(x, x'))
198      fun cvtBlock (env, S.Block stms, optExit) = let            in
199            fun toBlock (env, assigned, [], assignments) = let              IL.CFG.appendNode (
200                  val stm = IL.Stmt.mkBLOCK(List.rev assignments, optExit)                ListPair.foldlEq save IL.CFG.empty (dstState, stateOut),
201                  in                exit)
202                    (stm, IL.Stmt.tail stm, env, assigned)            end
203                  end  handle ex => raise ex
204              | toBlock (env, assigned, S.S_Assign(x, e)::rest, assignments) = let  
205        fun cvtBlock (state, env : env, joinStk, S.Block stms) = let
206              fun cvt (env : env, cfg, []) = (cfg, env)
207                | cvt (env, cfg, stm::stms) = (case stm
208                     of S.S_Var x => let
209                  val x' = newVar x                  val x' = newVar x
                 val stms = cvtExp(env, x', e)  
                 val assigned = VSet.add(assigned, x)  
                 val env = VMap.insert(env, x, x')  
                 in  
                   toBlock (env, assigned, rest, stms@assignments)  
                 end  
             | toBlock (env, assigned, stms, assignments) = let  
                 val (next, last, env, assigned) = toStmt (env, assigned, stms)  
                 val blk = IL.Stmt.mkBLOCK(List.rev assignments, SOME next)  
210                  in                  in
211                    IL.Node.addEdge (IL.Stmt.tail blk, IL.Stmt.entry next);                          cvt (VMap.insert (env, x, x'), cfg, stms)
                   (blk, last, env, assigned)  
212                  end                  end
213            and toStmt (env, assigned, []) = let                    | S.S_Assign(lhs, rhs) => let
214                (* this case only occurs for the empty else arm of an if-then-else statement *)                        val lhs' = newVar lhs
215                  val stm = IL.Stmt.mkBLOCK([], optExit)                        val assigns = cvtExp (env, lhs', rhs)
216                  in                  in
217                    (stm, IL.Stmt.tail stm, env, assigned)  (*
218                  end  print "doAssign\n";
             | toStmt (env, assigned, stms as stm::rest) = (case stm  
                  of S.S_Assign _ => toBlock (env, assigned, stms, [])  
                   | S.S_IfThenElse(x, b1, b2) => let  
                       val x' = lookup env x  
                       val (s1, last1, env1, assigned1) = cvtBlock(env, b1, NONE)  
                       val (s2, last2, env2, assigned2) = cvtBlock(env, b2, NONE)  
                       val assigned = VSet.union(assigned1, assigned2)  
 (* PROBLEM: what about variables that are assigned for the first time in one branch  
  * and not the other?  This situation should only occur for variables who's scope is  
  * the branch of the if.  Short-term solution is to ignore variables that are defined  
  * in only one branch.  
219   *)   *)
220                        val (env, phis) = let                          recordAssign (joinStk, lhs, lhs');
221                              fun mkPhi (x, (env, phis)) = (                          cvt (
222                                    case (VMap.find(env1, x), VMap.find(env2, x))                            VMap.insert(env, lhs, lhs'),
223                                     of (SOME x1, SOME x2) => let                            IL.CFG.concat(cfg, IL.CFG.mkBlock assigns),
224                                          val x' = newVar x                            stms)
                                         in  
                                           (VMap.insert(env, x, x'), (x', [x1, x2])::phis)  
225                                          end                                          end
226                                      | _ => (env, phis)                    | S.S_IfThenElse(x, b0, b1) => let
227                                    (* end case *))                        val x' = lookup env x
228                          val join = newJoin (env, 2)
229                          val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
230                          val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
231                          val cond = IL.Node.mkCOND {
232                                  cond = x',
233                                  trueBranch = IL.Node.dummy,
234                                  falseBranch = IL.Node.dummy
235                                }
236                              in                              in
237                                VSet.foldl mkPhi (env, []) assigned                          IL.Node.addEdge (IL.CFG.exit cfg, cond);
238                            case commitJoin (joinStk, join)
239                             of (env, SOME joinNd) => (
240                                  if IL.CFG.isEmpty cfg0
241                                    then (
242                                      IL.Node.setTrueBranch (cond, joinNd);
243                                      IL.Node.setPred (joinNd, cond))
244                                    else (
245                                      IL.Node.setTrueBranch (cond, IL.CFG.entry cfg0);
246                                      IL.Node.setPred (IL.CFG.entry cfg0, cond);
247                                      IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
248                                  if IL.CFG.isEmpty cfg1
249                                    then (
250                                      IL.Node.setFalseBranch (cond, joinNd);
251                                      IL.Node.setPred (joinNd, cond))
252                                    else (
253                                      IL.Node.setFalseBranch (cond, IL.CFG.entry cfg1);
254                                      IL.Node.setPred (IL.CFG.entry cfg1, cond);
255                                      IL.Node.addEdge (IL.CFG.exit cfg1, joinNd));
256                                  cvt (
257                                    env,
258                                    IL.CFG.concat (
259                                      cfg,
260                                      IL.CFG{entry = cond, exit = joinNd}),
261                                    stms))
262                            (* the join node has only zero predecessors, so
263                             * it was killed.
264                             *)
265                              | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
266                            (* end case *)
267                              end                              end
268              | S.S_Foreach(x,blk) => let
269                  val x' = lookup env x
270                    val join = newJoin (env, 1)
271                          val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, blk)
272                          val forNode = IL.Node.mkFOREACH{
273                       cond = x',
274                       stmBranch = IL.Node.dummy
275                  }
276                        in                        in
277                          case rest               case commitJoin (joinStk, join)
278                           of [] => let                           of (env, SOME joinNd) => (
279                                val join = IL.Stmt.mkJOIN (phis, optExit)                                if IL.CFG.isEmpty cfg0
280                                val joinNd = IL.Stmt.entry join                                  then (
281                                val stm = IL.Stmt.mkIF(x', s1, s2, SOME join)                                        ())
282                                in                                  else (
283                                  IL.Node.addEdge (last2, joinNd);                                    IL.Node.addEdge (forNode,joinNd);
284                                  IL.Node.addEdge (last1, joinNd);                                    IL.Node.setPred (IL.CFG.entry cfg0, forNode);
285                                  (stm, joinNd, env, assigned)                    IL.Node.setStmBranch(forNode, IL.CFG.entry cfg0);
286                                end                                    IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
287                            | _ => let                  cvt (
288                                val (next, last, env, assigned) = toStmt (env, assigned, rest)                                  env,
289                                val join = IL.Stmt.mkJOIN (phis, SOME next)                          IL.CFG.appendNode(cfg, joinNd),
290                                val joinNd = IL.Stmt.entry join                                  stms))
291                                val stm = IL.Stmt.mkIF(x', s1, s2, SOME join)  
292                                in  
293                                  IL.Node.addEdge (last2, joinNd);                          (* the join node has only zero predecessors, so
294                                  IL.Node.addEdge (last1, joinNd);                           * it was killed. *)
295                                  IL.Node.addEdge (joinNd, IL.Stmt.entry next);  
296                                  (stm, last, env, assigned)                            | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
                               end  
297                          (* end case *)                          (* end case *)
298                        end                        end
299                    | S.S_New(name, xs) => let  
300                        val xs' = List.map (lookup env) xs                    | S.S_New(strandId, args) => let
301                        in                        val nd = IL.Node.mkNEW{
302                          case rest                                strand = strandId,
303                           of [] => let                                args = List.map (lookup env) args
304                                val stm = IL.Stmt.mkNEW(name, xs', optExit)                              }
305                                in                                in
306                                  (stm, IL.Stmt.tail stm, env, assigned)                          cvt (env, IL.CFG.appendNode (cfg, nd), stms)
307                                end                                end
308                            | _ => let                    | S.S_Die => (
309                                val (next, last, env, assigned) = toStmt (env, assigned, rest)                        killPath joinStk;
310                                val stm = IL.Stmt.mkNEW(name, xs', SOME next)                        (IL.CFG.appendNode (cfg, IL.Node.mkDIE ()), env))
311                      | S.S_Stabilize => (
312                          killPath joinStk;
313                          (IL.CFG.concat (cfg, saveStrandState (env, state, IL.Node.mkSTABILIZE())), env))
314                      | 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                                in
318                                  IL.Node.addEdge (IL.Stmt.tail stm, IL.Stmt.entry next);                          cvt (env, IL.CFG.appendNode (cfg, nd), stms)
                                 (stm, last, env, assigned)  
                               end  
319                        end                        end
320                    | S.S_Die => let                  (* end case *))
                       val stm = IL.Stmt.mkDIE()  
321                        in                        in
322                          (stm, IL.Stmt.tail stm, env, assigned)              cvt (env, IL.CFG.empty, stms)
323                        end                        end
324                    | S.S_Stabilize => let  (*DEBUG*)handle ex => raise ex
325                        val stm = IL.Stmt.mkSTABILIZE()  
326        fun cvtTopLevelBlock (env, blk, mkExit) = let
327              val (cfg, env) = cvtBlock (([], []), env, [], blk)
328              val cfg = IL.CFG.prependNode (IL.Node.mkENTRY(), cfg)
329              val cfg = IL.CFG.concat (cfg, mkExit env)
330              in
331                (cfg, env)
332              end
333    (*DEBUG*)handle ex => raise ex
334    
335    (* FIXME: the following function could be refactored with cvtTopLevelBlock to share code *)
336        fun cvtFragmentBlock (env0, blk) = let
337              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    (*DEBUG*)handle ex => raise ex
353    
354        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                        in
361                          (stm, IL.Stmt.tail stm, env, assigned)                    (env, IL.CFG.mkBlock (ListPair.map load (stateIn, svars)))
362                        end                        end
363            (* 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              val loadCFG = IL.CFG.prependNode (entry, loadCFG)
368              val exit = (case name
369                     of StrandUtil.Update => IL.Node.mkACTIVE ()
370                      | StrandUtil.Stabilize => IL.Node.mkRETURN []
371                  (* end case *))                  (* end case *))
372              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            in            in
379              toStmt (env, VSet.empty, stms)              IL.Method{
380                    name = name,
381                    body = body
382                  }
383            end            end
384    (*DEBUG*)handle ex => (print(concat["error in cvtMethod(", StrandUtil.nameToString name, ", ...)\n"]); raise ex)
385    
386      fun cvtTopLevelBlock (env, blk) = let    (* convert the initially code *)
387            val exit = IL.Stmt.mkEXIT ()      fun cvtInitially (env, S.Initially{isArray, rangeInit, create, iters}) = let
388            val (stm, last, env, assigned) = cvtBlock (env, blk, SOME exit)            val S.C_Create{argInit, name, args} = create
389            val entry = IL.Stmt.mkENTRY (SOME stm)            fun cvtIter ({param, lo, hi}, (env, iters)) = let
390            in                  val param' = newVar param
391              IL.Node.addEdge (IL.Stmt.tail entry, IL.Stmt.entry stm);                  val env = VMap.insert (env, param, param')
392            (* NOTE: this could fail if all control paths end in DIE or STABILIZE, so we                  val iter = (param', lookup env lo, lookup env hi)
393             * wrap it in a handler                  in
394             *)                    (env, iter::iters)
395              IL.Node.addEdge (last, IL.Stmt.entry exit) handle _ => ();                  end
396              (entry, env)            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            end
407    
408    (* generate fresh SSA variables and add them to the environment *)    (* check strands for properties *)
409      fun freshVars (env, xs) = let      fun checkProps strands = let
410            fun cvtVar (x, (env, xs)) = let            val hasDie = ref false
411                  val x' = newVar x            val hasNew = ref false
412              fun chkStm e = (case e
413                     of S.S_IfThenElse(_, b1, b2) => (chkBlk b1; chkBlk b2)
414                      | S.S_New _ => (hasNew := true)
415                      | S.S_Die => (hasDie := true)
416                      | _ => ()
417                  (* 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                  in
422                    (VMap.insert(env, x, x'), x'::xs)                    chkBlk stateInit;
423                      List.app chkMeth methods
424                  end                  end
425            val (env, xs) = List.foldl cvtVar (env, []) xs            fun condCons (x, v, l) = if !x then v::l else l
426            in            in
427              (env, List.rev xs)              List.app chkStrand strands;
428                condCons (hasDie, StrandUtil.StrandsMayDie,
429                condCons (hasNew, StrandUtil.NewStrands, []))
430            end            end
431    
432      fun translate (S.Program{globals, globalInit, strands}) = let      fun translate (S.Program{globals, globalInit, init, strands}) = let
433            val (globalInit, env) = cvtTopLevelBlock (VMap.empty, globalInit)            val (globalInit, env) = let
434          (* get the SSA names for the globals and a reduced environment that just defines                  fun mkExit env = let
435           * the globals.                        val nd = IL.Node.mkRETURN(VMap.listItems env)
436           *)                        in
437            val (env, globs) = let                          IL.CFG{entry = nd, exit = nd}
438                  val lookup = lookup env                        end
                 fun cvtVar (x, (env, globs)) = let  
                       val x' = lookup x  
439                        in                        in
440                          (VMap.insert(env, x, x'), x'::globs)                    cvtTopLevelBlock (VMap.empty, globalInit, mkExit)
441                        end                        end
442                  val (env, globs) = List.foldl cvtVar (VMap.empty, []) globals          (* construct a reduced environment that just defines the globals. *)
443              val env = let
444                    val lookup = lookup env
445                    fun cvtVar (x, env) = VMap.insert(env, x, lookup x)
446                    val env = List.foldl cvtVar VMap.empty globals
447                  in                  in
448                    (env, List.rev globs)                    env
449                  end                  end
450              val init = cvtInitially (env, init)
451            fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let            fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
452                  (* extend the global environment with the strand's parameters *)
453                  val (env, params) = let                  val (env, params) = let
454                        fun cvtParam (x, (env, xs)) = let                        fun cvtParam (x, (env, xs)) = let
455                              val x' = newVar x                              val x' = newVar x
# Line 243  Line 460 
460                        in                        in
461                          (env, List.rev params)                          (env, List.rev params)
462                        end                        end
463                  val (stateInit, env) = cvtTopLevelBlock (env, stateInit)                (* create the state variables *)
464                  val state' = List.map (lookup env) state                  val svars = let
465                  fun cvtMethod (S.Method(name, blk)) = let                        fun newSVar x = IL.StateVar.new (
466                      (* allocate fresh variables for the state variables *)                              Var.kindOf x = S.StrandOutputVar,
467                        val (env, stateIn) = freshVars (env, state)                              Var.nameOf x, cvtTy(Var.monoTypeOf x))
468                        val (body, env) = cvtTopLevelBlock (env, blk)                        in
469                        val stateOut = List.map (lookup env) state                          List.map newSVar state
470                          end
471                  (* convert the state initialization code *)
472                    val (stateInit, env) = let
473                          fun mkExit env = saveStrandState (env, (state, svars), IL.Node.mkSINIT())
474                        in                        in
475                          IL.Method{name=name, stateIn=stateIn, stateOut=stateOut, body=body}                          cvtTopLevelBlock (env, stateInit, mkExit)
476                        end                        end
477                    fun cvtMeth (S.Method(name, blk)) = cvtMethod (env, name, state, svars, blk)
478                  in                  in
479                    IL.Strand{                    IL.Strand{
480                        name = name,                        name = name,
481                        params = params,                        params = params,
482                        state = state',                        state = svars,
483                        stateInit = stateInit,                        stateInit = stateInit,
484                        methods = List.map cvtMethod methods                        methods = List.map cvtMeth methods
485                      }                      }
486                  end                  end
487            val prog = IL.Program{            val prog = IL.Program{
488                  globals = globs,                    props = checkProps strands,
489                  globalInit = globalInit,                  globalInit = globalInit,
490                      initially = init,
491                  strands = List.map cvtStrand strands                  strands = List.map cvtStrand strands
492                }                }
493            in            in

Legend:
Removed from v.511  
changed lines
  Added in v.1865

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