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

SCM Repository

[diderot] Annotation of /branches/pure-cfg/src/compiler/translate/translate.sml
ViewVC logotype

Annotation of /branches/pure-cfg/src/compiler/translate/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 609 - (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 494 * 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 394 structure DstTy = HighILTypes
26 : jhr 539 structure Census = HighILCensus
27 : jhr 137
28 : jhr 494 type env = IL.var VMap.map
29 :    
30 : jhr 197 fun lookup env x = (case VMap.find (env, x)
31 : jhr 176 of SOME x' => x'
32 :     | NONE => raise Fail(concat[
33 : jhr 197 "no binding for ", Var.uniqueNameOf x, " in environment"
34 : jhr 176 ])
35 :     (* end case *))
36 :    
37 : jhr 394 fun cvtTy ty = (case TypeUtil.prune ty
38 :     of Ty.T_Bool => DstTy.BoolTy
39 :     | Ty.T_Int => DstTy.IntTy
40 :     | Ty.T_String => DstTy.StringTy
41 :     | Ty.T_Kernel _ => DstTy.KernelTy
42 : jhr 426 | Ty.T_Tensor(Ty.Shape dd) => let
43 :     fun cvtDim (Ty.DimConst 1) = NONE
44 :     | cvtDim (Ty.DimConst d) = SOME d
45 :     in
46 :     DstTy.TensorTy(List.mapPartial cvtDim dd)
47 :     end
48 : jhr 548 | Ty.T_Image{dim=Ty.DimConst d, shape} => DstTy.ImageTy d
49 :     | Ty.T_Field fld => DstTy.FieldTy
50 : jhr 394 | ty => raise Fail("cvtTy: unexpected " ^ TypeUtil.toString ty)
51 :     (* end case *))
52 :    
53 : jhr 189 (* create a new instance of a variable *)
54 : jhr 394 fun newVar x = IL.Var.new (Var.nameOf x, cvtTy(Var.monoTypeOf x))
55 : jhr 189
56 : jhr 563 (* generate fresh SSA variables and add them to the environment *)
57 :     fun freshVars (env, xs) = let
58 :     fun cvtVar (x, (env, xs)) = let
59 :     val x' = newVar x
60 :     in
61 :     (VMap.insert(env, x, x'), x'::xs)
62 :     end
63 :     val (env, xs) = List.foldl cvtVar (env, []) xs
64 :     in
65 :     (env, List.rev xs)
66 :     end
67 :    
68 : jhr 498 (* a pending-join node tracks the phi nodes needed to join the assignments
69 :     * that flow into the join node.
70 : jhr 494 *)
71 :     datatype join = JOIN of {
72 :     arity : int, (* number of predecessors *)
73 :     nd : IL.node, (* the CFG node for this pending join *)
74 : jhr 496 phiMap : IL.phi VMap.map ref, (* a mapping from Simple AST variables that are assigned *)
75 : jhr 494 (* to their phi nodes. *)
76 : jhr 496 predKill : int list ref (* killed predecessor edges (because of DIE or STABILIZE *)
77 : jhr 494 }
78 :    
79 : jhr 498 (* a stack of pending joins. The first component specifies the path index of the current
80 :     * path to the join.
81 :     *)
82 :     type pending_joins = (int * join) list
83 :    
84 : jhr 494 (* create a new pending-join node *)
85 : jhr 496 fun newJoin arity = JOIN{
86 :     arity = arity, nd = IL.Node.mkJOIN [], phiMap = ref VMap.empty, predKill = ref []
87 :     }
88 : jhr 494
89 : jhr 497 fun killPath ((i, JOIN{predKill, ...}) :: _) = predKill := i :: !predKill
90 :     | killPath _ = ()
91 : jhr 496
92 : jhr 494 (* record an assignment to the IL variable dstVar (corresponding to the Simple AST variable
93 :     * srcVar) in the current pending-join node. The predIndex specifies which path into the
94 :     * JOIN node this assignment occurs on.
95 :     *)
96 : jhr 501 fun recordAssign (_, [], _, _) = ()
97 : jhr 497 | recordAssign (env, (predIndex, JOIN{arity, phiMap, ...})::_, srcVar, dstVar) = let
98 : jhr 494 val m = !phiMap
99 :     in
100 : jhr 509 case VMap.find (env, srcVar)
101 : jhr 506 of NONE => () (* local temporary *)
102 : jhr 509 | SOME dstVar' => (case VMap.find (m, srcVar)
103 :     of NONE => let
104 :     val lhs = newVar srcVar
105 :     val rhs = List.tabulate (arity, fn i => if (i = predIndex) then dstVar else dstVar')
106 :     in
107 :     phiMap := VMap.insert (m, srcVar, (lhs, rhs))
108 :     end
109 :     | SOME(lhs, rhs) => let
110 :     fun update (i, l as x::r) = if (i = predIndex)
111 :     then dstVar::r
112 :     else x::update(i+1, r)
113 :     | update _ = raise Fail "invalid predecessor index"
114 :     in
115 :     phiMap := VMap.insert (m, srcVar, (lhs, update(0, rhs)))
116 :     end
117 :     (* end case *))
118 : jhr 506 (* end case *)
119 : jhr 494 end
120 :    
121 :     (* complete a pending join operation by filling in the phi nodes from the phi map and
122 :     * updating the environment.
123 :     *)
124 : jhr 497 fun commitJoin (env, joinStk, JOIN{nd, phiMap, ...}) = let
125 : jhr 494 val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
126 : jhr 497 fun doVar (srcVar, phi as (dstVar, _), (env, phis)) = (
127 : jhr 501 recordAssign (env, joinStk, srcVar, dstVar);
128 : jhr 497 (VMap.insert (env, srcVar, dstVar), phi::phis))
129 : jhr 494 val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
130 :     in
131 : jhr 497 (* FIXME: prune killed paths. *)
132 : jhr 501 phis := phis';
133 : jhr 497 (env, SOME nd)
134 : jhr 494 end
135 :    
136 : jhr 168 (* expression translation *)
137 : jhr 501 fun cvtExp (env : env, lhs, exp) = (case exp
138 : jhr 188 of S.E_Var x => [(lhs, IL.VAR(lookup env x))]
139 :     | S.E_Lit lit => [(lhs, IL.LIT lit)]
140 : jhr 176 | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"
141 : jhr 188 | S.E_Apply(f, tyArgs, args, ty) => let
142 :     val args' = List.map (lookup env) args
143 :     in
144 :     TranslateBasis.translate (lhs, f, tyArgs, args')
145 :     end
146 :     | S.E_Cons args => [(lhs, IL.CONS(List.map (lookup env) args))]
147 : jhr 400 | S.E_Slice(x, indices, ty) => let
148 :     val x = lookup env x
149 :     val mask = List.map isSome indices
150 :     fun cvt NONE = NONE
151 :     | cvt (SOME x) = SOME(lookup env x)
152 :     val indices = List.mapPartial cvt indices
153 :     in
154 :     if List.all (fn b => b) mask
155 :     then [(lhs, IL.OP(HighOps.Subscript(IL.Var.ty x), x::indices))]
156 :     else [(lhs, IL.OP(HighOps.Slice(IL.Var.ty lhs, mask), x::indices))]
157 :     end
158 : jhr 407 | S.E_Input(_, name, NONE) =>
159 :     [(lhs, IL.OP(HighOps.Input(IL.Var.ty lhs, name), []))]
160 : jhr 229 | S.E_Input(_, name, SOME dflt) =>
161 : jhr 407 [(lhs, IL.OP(HighOps.InputWithDefault(IL.Var.ty lhs, name), [lookup env dflt]))]
162 : jhr 517 | S.E_LoadImage(info, name) => [(lhs, IL.OP(HighOps.LoadImage info, [lookup env name]))]
163 : jhr 176 (* end case *))
164 : jhr 168
165 : jhr 563 fun cvtBlock (state, env : env, joinStk, S.Block stms) = let
166 : jhr 502 fun cvt (env : env, cfg, []) = (cfg, env)
167 : jhr 497 | cvt (env, cfg, stm::stms) = (case stm
168 :     of S.S_Assign(lhs, rhs) => let
169 : jhr 501 val lhs' = newVar lhs
170 :     val assigns = cvtExp (env, lhs', rhs)
171 : jhr 497 in
172 : jhr 501 recordAssign (env, joinStk, lhs, lhs');
173 : jhr 506 cvt (
174 :     VMap.insert(env, lhs, lhs'),
175 :     IL.CFG.concat(cfg, IL.CFG.mkBlock assigns),
176 :     stms)
177 : jhr 497 end
178 :     | S.S_IfThenElse(x, b0, b1) => let
179 : jhr 192 val x' = lookup env x
180 : jhr 497 val join = newJoin 2
181 : jhr 563 val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
182 :     val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
183 : jhr 497 val cond = IL.Node.mkCOND {
184 :     cond = x',
185 : jhr 501 trueBranch = IL.Node.dummy,
186 :     falseBranch = IL.Node.dummy
187 : jhr 497 }
188 : jhr 190 in
189 : jhr 506 IL.Node.addEdge (IL.CFG.exit cfg, cond);
190 : jhr 497 case commitJoin (env, joinStk, join)
191 :     of (env, SOME joinNd) => (
192 : jhr 500 if IL.CFG.isEmpty cfg0
193 : jhr 507 then (
194 :     IL.Node.setTrueBranch (cond, joinNd);
195 :     IL.Node.setPred (joinNd, cond))
196 : jhr 501 else (
197 :     IL.Node.setTrueBranch (cond, IL.CFG.entry cfg0);
198 : jhr 507 IL.Node.setPred (IL.CFG.entry cfg0, cond);
199 : jhr 501 IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
200 : jhr 500 if IL.CFG.isEmpty cfg1
201 : jhr 507 then (
202 :     IL.Node.setFalseBranch (cond, joinNd);
203 :     IL.Node.setPred (joinNd, cond))
204 : jhr 501 else (
205 :     IL.Node.setFalseBranch (cond, IL.CFG.entry cfg1);
206 : jhr 507 IL.Node.setPred (IL.CFG.entry cfg1, cond);
207 : jhr 501 IL.Node.addEdge (IL.CFG.exit cfg1, joinNd));
208 : jhr 500 cvt (
209 :     env,
210 : jhr 501 IL.CFG{entry = IL.CFG.entry cfg, exit = joinNd},
211 : jhr 500 stms))
212 : jhr 541 (* the join node has only zero predecessors, so
213 : jhr 500 * it was killed.
214 :     *)
215 : jhr 504 | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
216 : jhr 192 (* end case *)
217 : jhr 190 end
218 : jhr 497 | S.S_New(strandId, args) => let
219 : jhr 498 val nd = IL.Node.mkNEW{
220 :     strand = strandId,
221 :     args = List.map (lookup env) args
222 :     }
223 : jhr 192 in
224 : jhr 497 cvt (env, IL.CFG.appendNode (cfg, nd), stms)
225 : jhr 194 end
226 : jhr 497 | S.S_Die => (
227 :     killPath joinStk;
228 : jhr 502 (IL.CFG.appendNode (cfg, IL.Node.mkDIE ()), env))
229 : jhr 563 | S.S_Stabilize => let
230 :     val stateOut = List.map (lookup env) state
231 :     in
232 :     killPath joinStk;
233 :     (IL.CFG.appendNode (cfg, IL.Node.mkSTABILIZE stateOut), env)
234 :     end
235 : jhr 192 (* end case *))
236 :     in
237 : jhr 500 cvt (env, IL.CFG.empty, stms)
238 : jhr 192 end
239 : jhr 168
240 : jhr 256 fun cvtTopLevelBlock (env, blk) = let
241 : jhr 563 val (cfg, env) = cvtBlock ([], env, [], blk)
242 : jhr 502 val entry = IL.Node.mkENTRY ()
243 : jhr 563 val exit = IL.Node.mkRETURN []
244 : jhr 256 in
245 : jhr 541 if IL.CFG.isEmpty cfg
246 :     then IL.Node.addEdge (entry, exit)
247 :     else (
248 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
249 :     (* NOTE: this addEdge could fail if all control paths end in DIE or STABILIZE,
250 :     * so we wrap it in a handler
251 :     *)
252 :     IL.Node.addEdge (IL.CFG.exit cfg, exit) handle _ => ());
253 : jhr 502 (IL.CFG{entry = entry, exit = exit}, env)
254 : jhr 256 end
255 :    
256 : jhr 563 fun cvtMethod (env, name, state, blk) = let
257 :     (* allocate fresh variables for the state variables *)
258 :     val (env, stateIn) = freshVars (env, state)
259 :     (* convert the body of the method *)
260 :     val (cfg, env) = cvtBlock (state, env, [], blk)
261 :     (* add the entry/exit nodes *)
262 :     val stateOut = List.map (lookup env) state
263 :     val entry = IL.Node.mkENTRY ()
264 :     val exit = IL.Node.mkACTIVE stateOut
265 : jhr 256 in
266 : jhr 563 if IL.CFG.isEmpty cfg
267 :     then IL.Node.addEdge (entry, exit)
268 :     else (
269 :     IL.Node.addEdge (entry, IL.CFG.entry cfg);
270 :     (* NOTE: this addEdge could fail if all control paths end in DIE or STABILIZE,
271 :     * so we wrap it in a handler
272 :     *)
273 :     IL.Node.addEdge (IL.CFG.exit cfg, exit) handle _ => ());
274 :     IL.Method{
275 :     name = name,
276 :     stateIn = stateIn,
277 :     stateOut = stateOut,
278 :     body = IL.CFG{entry = entry, exit = exit}
279 :     }
280 : jhr 256 end
281 :    
282 : jhr 609 fun translate (S.Program{globals, globalInit, init, strands}) = let
283 : jhr 256 val (globalInit, env) = cvtTopLevelBlock (VMap.empty, globalInit)
284 :     (* get the SSA names for the globals and a reduced environment that just defines
285 :     * the globals.
286 :     *)
287 : jhr 200 val (env, globs) = let
288 :     val lookup = lookup env
289 :     fun cvtVar (x, (env, globs)) = let
290 :     val x' = lookup x
291 :     in
292 :     (VMap.insert(env, x, x'), x'::globs)
293 :     end
294 :     val (env, globs) = List.foldl cvtVar (VMap.empty, []) globals
295 :     in
296 :     (env, List.rev globs)
297 :     end
298 : jhr 500 fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
299 : jhr 200 val (env, params) = let
300 :     fun cvtParam (x, (env, xs)) = let
301 :     val x' = newVar x
302 :     in
303 :     (VMap.insert(env, x, x'), x'::xs)
304 :     end
305 :     val (env, params) = List.foldl cvtParam (env, []) params
306 :     in
307 :     (env, List.rev params)
308 :     end
309 : jhr 256 val (stateInit, env) = cvtTopLevelBlock (env, stateInit)
310 :     val state' = List.map (lookup env) state
311 : jhr 563 fun cvtMeth (S.Method(name, blk)) =
312 :     cvtMethod (env, name, state, blk)
313 : jhr 200 in
314 : jhr 500 IL.Strand{
315 : jhr 200 name = name,
316 :     params = params,
317 : jhr 256 state = state',
318 : jhr 200 stateInit = stateInit,
319 : jhr 563 methods = List.map cvtMeth methods
320 : jhr 200 }
321 :     end
322 : jhr 508 val prog = IL.Program{
323 :     globals = globs,
324 :     globalInit = globalInit,
325 :     strands = List.map cvtStrand strands
326 :     }
327 : jhr 200 in
328 : jhr 508 Census.init prog;
329 :     prog
330 : jhr 200 end
331 : jhr 176
332 : jhr 137 end

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