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

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