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

SCM Repository

[diderot] Annotation of /branches/charisee/src/compiler/cl-target/tree-to-cl.sml
ViewVC logotype

Annotation of /branches/charisee/src/compiler/cl-target/tree-to-cl.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2646 - (view) (download)

1 : jhr 1640 (* tree-to-cl.sml
2 : jhr 1117 *
3 :     * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     * All rights reserved.
5 :     *
6 : jhr 1640 * Translate TreeIL to the OpenCL version of CLang.
7 : jhr 1117 *)
8 :    
9 :     structure TreeToCL : sig
10 :    
11 :     datatype var = V of (CLang.ty * CLang.var)
12 :    
13 :     type env = var TreeIL.Var.Map.map
14 :    
15 :     val trType : TreeIL.Ty.ty -> CLang.ty
16 :    
17 : jhr 1640 val trBlock : env * TreeIL.block -> CLang.stm
18 : jhr 1117
19 : jhr 1370 val trFragment : env * TreeIL.block -> env * CLang.stm list
20 :    
21 : jhr 1117 val trAssign : env * TreeIL.var * TreeIL.exp -> CLang.stm list
22 :    
23 :     val trExp : env * TreeIL.exp -> CLang.exp
24 : cchiw 2646
25 :     val trAllTypes: TreeIL.Ty.ty list ->CLang.ty list
26 :     val trAllOpr: TreeFunc.oprator list ->CLang.Cfn list
27 : jhr 1117
28 : jhr 1370 (* vector indexing support. Arguments are: vector, index *)
29 :     val vecIndex : CLang.exp * int -> CLang.exp
30 : jhr 1117
31 :     end = struct
32 :    
33 :     structure CL = CLang
34 :     structure RN = RuntimeNames
35 :     structure IL = TreeIL
36 :     structure Op = IL.Op
37 :     structure Ty = IL.Ty
38 :     structure V = IL.Var
39 :    
40 : jhr 1370 datatype var = datatype CLang.typed_var
41 : jhr 1117
42 :     type env = var TreeIL.Var.Map.map
43 :    
44 :     fun lookup (env, x) = (case V.Map.find (env, x)
45 : jhr 1640 of SOME(V(_, x')) => x'
46 :     | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
47 :     (* end case *))
48 : jhr 1117
49 :     (* integer literal expression *)
50 : jhr 1370 fun intExp (i : int) = CL.mkInt(IntInf.fromInt i)
51 : jhr 1117
52 : jhr 1640 (* the type of an image-data pointer. *)
53 :     fun imageDataPtrTy rTy = CL.T_Qual("__global", CL.T_Ptr(CL.T_Num rTy))
54 :    
55 : jhr 1117 (* translate TreeIL types to CLang types *)
56 :     fun trType ty = (case ty
57 : jhr 1640 of Ty.BoolTy => CLang.T_Named "uint"
58 :     | Ty.StringTy => CL.charPtr
59 :     | Ty.IntTy => !RN.gIntTy
60 :     | Ty.TensorTy[] => !RN.gRealTy
61 :     | Ty.TensorTy[n] => CL.T_Named(RN.vecTy n)
62 :     | Ty.TensorTy[n, m] => CL.T_Named(RN.matTy(n,m))
63 :     | Ty.SeqTy(Ty.IntTy, n) => CL.T_Named(RN.ivecTy n)
64 :     | Ty.SeqTy(Ty.TensorTy[] , n) => CL.T_Named(RN.vecTy n)
65 : jhr 1671 | Ty.SeqTy(ty, n) => CL.T_Array(trType ty, SOME n)
66 : jhr 1640 | Ty.AddrTy(ImageInfo.ImgInfo{ty=(_, rTy), ...}) => imageDataPtrTy rTy
67 :     | Ty.ImageTy(ImageInfo.ImgInfo{dim, ...}) => CL.T_Named(RN.imageTy dim)
68 :     | _ => raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])
69 :     (* end case *))
70 : jhr 1117
71 :     (* generate new variables *)
72 :     local
73 :     val count = ref 0
74 :     fun freshName prefix = let
75 : jhr 1640 val n = !count
76 :     in
77 :     count := n+1;
78 :     concat[prefix, "_", Int.toString n]
79 :     end
80 : jhr 1117 in
81 :     fun tmpVar ty = freshName "tmp"
82 :     fun freshVar prefix = freshName prefix
83 :     end (* local *)
84 :    
85 :     (* translate IL basis functions *)
86 : jhr 1923 fun trApply (f, args) = CL.mkApply(MathFuns.toString f, args)
87 : jhr 1117
88 : jhr 1370 (* vector indexing support. Arguments are: vector, index *)
89 :     local
90 :     val fields = Vector.fromList [
91 :     "s0", "s1", "s2", "s3",
92 :     "s4", "s5", "s6", "s7",
93 :     "s8", "s9", "sa", "sb",
94 :     "sc", "sd", "se", "sf"
95 :     ]
96 :     in
97 :     fun vecIndex (v, ix) = CL.mkSelect(v, Vector.sub(fields, ix))
98 :     end
99 : jhr 1117
100 :     (* translate a variable use *)
101 :     fun trVar (env, x) = (case V.kind x
102 : jhr 1640 of IL.VK_Global => CL.mkIndirect(CL.E_Var RN.globalsVarName, lookup(env, x))
103 :     | IL.VK_Local => CL.mkVar(lookup(env, x))
104 :     (* end case *))
105 : jhr 1117
106 : jhr 1671 (* matrix indexing *)
107 :     fun matIndex (m, ix, jx) = CL.mkSelect(CL.mkSubscript(m, ix), concat["s",jx])
108 :    
109 : jhr 1640 (* translate a state-variable use *)
110 :     fun trStateVar (IL.SV{name, ...}) = CL.mkIndirect(CL.mkVar "selfIn", name)
111 :    
112 :     fun castArgs ty = List.map (fn e => CL.mkCast(ty, e))
113 :    
114 : jhr 1117 (* Translate a TreeIL operator application to a CLang expression *)
115 :     fun trOp (rator, args) = (case (rator, args)
116 : cchiw 2525 of (Op.IAdd , [a, b]) => CL.mkBinOp(a, CL.#+, b)
117 :     | (Op.ISub , [a, b]) => CL.mkBinOp(a, CL.#-, b)
118 :     | (Op.IMul , [a, b]) => CL.mkBinOp(a, CL.#*, b)
119 :     | (Op.IDiv , [a, b]) => CL.mkBinOp(a, CL.#/, b)
120 :     | (Op.INeg , [a]) => CL.mkUnOp(CL.%-, a)
121 : jhr 1640 | (Op.Abs(Ty.IntTy), args) => CL.mkApply("abs", args)
122 :     | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(RN.fabs, args)
123 :     | (Op.Abs(Ty.TensorTy[_]), args) => CL.mkApply(RN.fabs, args)
124 :     | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
125 :     | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
126 :     | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
127 :     | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
128 :     | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
129 :     | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
130 :     | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
131 :     | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
132 :     | (Op.Max, args) => CL.mkApply(RN.max, castArgs (!RN.gRealTy) args)
133 :     | (Op.Min, args) => CL.mkApply(RN.min, castArgs (!RN.gRealTy) args)
134 :     | (Op.Clamp ty, [lo, hi, x]) => CL.mkApply(RN.clamp, [x, lo, hi])
135 :     | (Op.Lerp ty, args) => (case ty
136 :     of Ty.TensorTy[] => CL.mkApply(RN.lerp, castArgs (!RN.gRealTy) args)
137 :     | Ty.TensorTy[n] => CL.mkApply(RN.lerp, castArgs (CL.T_Named(RN.vecTy n)) args)
138 :     | _ => raise Fail(concat[
139 :     "lerp<", Ty.toString ty, "> not supported"
140 :     ])
141 :     (* end case *))
142 : cchiw 2525
143 : jhr 1640 | (Op.Norm(Ty.TensorTy[n]), args) => CL.E_Apply(RN.length, args)
144 :     | (Op.Norm(Ty.TensorTy[m,n]), args) => CL.E_Apply(RN.norm(m,n), args)
145 :     | (Op.Normalize d, args) => CL.E_Apply(RN.normalize, args)
146 :     | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
147 :     | (Op.Select(Ty.TupleTy tys, i), [a]) => raise Fail "Select unimplemented"
148 :     | (Op.Index(Ty.SeqTy(Ty.IntTy, n), i), [a]) => vecIndex (a, i)
149 :     | (Op.Index(Ty.TensorTy[n], i), [a]) => vecIndex (a, i)
150 :     | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, CL.E_Int(ix, _)]) => vecIndex (v, Int.fromLarge ix)
151 :     | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, ix]) => let
152 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gIntSuffix, "_t"])
153 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
154 : jhr 1370 in
155 : jhr 1640 CL.mkSubscript(vecExp, ix)
156 :     end
157 : jhr 1891 | (Op.Subscript(Ty.SeqTy(Ty.TensorTy[], n)), [v, CL.E_Int(ix, _)]) => vecIndex (v, Int.fromLarge ix)
158 : jhr 1671 | (Op.Subscript(Ty.SeqTy(ty, n)), [v, ix]) => CL.mkSubscript(v, ix)
159 : jhr 1640 | (Op.Subscript(Ty.TensorTy[n]), [v, CL.E_Int(ix, _)]) => vecIndex (v, Int.fromLarge ix)
160 :     | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
161 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gRealSuffix, "_t"])
162 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
163 :     in
164 :     CL.mkSubscript(vecExp, ix)
165 :     end
166 :     | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, CL.E_Int(jx, _)]) =>
167 :     vecIndex(CL.mkSubscript(m, ix), Int.fromLarge jx)
168 :     | (Op.Subscript(Ty.TensorTy[_,n]), [m, ix, jx]) => let
169 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gRealSuffix, "_t"])
170 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, CL.mkSubscript(m, ix)), "r")
171 :     in
172 : jhr 1370 CL.mkSubscript(vecExp, jx)
173 :     end
174 : jhr 1640 | (Op.Subscript ty, t::(ixs as _::_)) =>
175 :     raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
176 :     | (Op.Ceiling d, args) => CL.mkApply("ceil", args)
177 :     | (Op.Floor d, args) => CL.mkApply("floor", args)
178 :     | (Op.Round d, args) => CL.mkApply("round", args)
179 :     | (Op.Trunc d, args) => CL.mkApply("trunc", args)
180 :     | (Op.IntToReal, [a]) => CL.mkCast(!RN.gRealTy, a)
181 :     | (Op.RealToInt 1, [a]) => CL.mkCast(!RN.gIntTy, a)
182 :     | (Op.RealToInt d, args) => CL.mkApply(RN.vecftoi d, args)
183 : jhr 1117 (* FIXME: need type info *)
184 : jhr 1640 | (Op.ImageAddress(ImageInfo.ImgInfo{ty=(_,rTy), ...}), [a as CL.E_Indirect(_,field)]) => let
185 :     val cTy = imageDataPtrTy rTy
186 :     in
187 :     CL.mkCast(cTy,
188 :     CL.mkSelect(CL.mkVar RN.globalImageDataName, RN.imageDataName field))
189 :     end
190 :     | (Op.LoadVoxels(info, 1), [a]) => let
191 :     val realTy as CL.T_Num rTy = !RN.gRealTy
192 :     val a = CL.E_UnOp(CL.%*, a)
193 :     in
194 :     if (rTy = ImageInfo.sampleTy info)
195 :     then a
196 :     else CL.E_Cast(realTy, a)
197 :     end
198 :     | (Op.LoadVoxels _, [a]) =>
199 :     raise Fail("impossible " ^ Op.toString rator)
200 : cchiw 2525 (*Deleted pos to world op*)
201 :    
202 : jhr 1640 | (Op.LoadImage info, [a]) =>
203 :     raise Fail("impossible " ^ Op.toString rator)
204 :     | (Op.Inside(ImageInfo.ImgInfo{dim, ...}, s), [pos, img]) =>
205 :     CL.mkApply(RN.inside dim, [pos, CL.mkUnOp(CL.%&,img), intExp s])
206 :     | (Op.Input(ty, name, desc), []) =>
207 :     raise Fail("impossible " ^ Op.toString rator)
208 :     | (Op.InputWithDefault(ty, name, desc), [a]) =>
209 :     raise Fail("impossible " ^ Op.toString rator)
210 :     | _ => raise Fail(concat[
211 :     "unknown or incorrect operator ", Op.toString rator
212 :     ])
213 :     (* end case *))
214 : jhr 1117
215 :     fun trExp (env, e) = (case e
216 : jhr 1640 of IL.E_State x => trStateVar x
217 :     | IL.E_Var x => trVar (env, x)
218 :     | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !RN.gIntTy)
219 :     | IL.E_Lit(Literal.Bool b) => CL.mkBool b
220 :     | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !RN.gRealTy)
221 :     | IL.E_Lit(Literal.String s) => CL.mkStr s
222 :     | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
223 :     | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
224 :     | IL.E_Cons(Ty.TensorTy[n], args) => CL.mkApply(RN.mkVec n, trExps(env, args))
225 :     | IL.E_Cons(ty, _) => raise Fail(concat["E_Cons(", Ty.toString ty, ", _) in expression"])
226 :     (* end case *))
227 : jhr 1117
228 :     and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
229 : jhr 1640
230 : jhr 1671 (* translate an expression to a variable form; return the variable and the
231 :     * (optional) declaration.
232 :     *)
233 :     fun expToVar (env, ty, name, exp) = (case trExp(env, exp)
234 :     of x as CL.E_Var _ => (x, [])
235 :     | exp => let
236 :     val x = freshVar name
237 :     in
238 :     (CL.mkVar x, [CL.mkDecl(ty, x, SOME(CL.I_Exp exp))])
239 :     end
240 :     (* end case *))
241 :    
242 : jhr 1640 fun trLHSVar (env, lhs) = (case V.kind lhs
243 :     of IL.VK_Global => CL.mkIndirect(CL.mkVar RN.globalsVarName, lookup(env, lhs))
244 :     | IL.VK_Local => CL.mkVar(lookup(env, lhs))
245 :     (* end case *))
246 : jhr 1117
247 : jhr 1640 fun trLHSStateVar (IL.SV{name, ...}) = CL.mkIndirect(CL.mkVar "selfOut", name)
248 : jhr 1117
249 : cchiw 2525
250 :     (*Since, Iadd, Isub, Ineg, IMul, all return intergers now, I removed form this list *)
251 : jhr 1640 fun trSet (env, lhs, rhs) = (
252 :     (* certain rhs forms, such as those that return a matrix,
253 :     * require a function call instead of an assignment
254 :     *)
255 :     case rhs
256 : cchiw 2525 of
257 :     (* | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
258 :     [CL.mkCall(RN.zeroMat(m,n), [lhs])]*)
259 :     IL.E_Op(Op.LoadVoxels(info, n), [a]) =>
260 : jhr 1640 if (n > 1)
261 :     then let
262 :     val stride = ImageInfo.stride info
263 :     val rTy = ImageInfo.sampleTy info
264 :     val vp = freshVar "vp"
265 :     val needsCast = (CL.T_Num rTy <> !RN.gRealTy)
266 :     fun mkLoad i = let
267 :     val e = CL.mkSubscript(CL.mkVar vp, intExp(i*stride))
268 :     in
269 :     if needsCast then CL.mkCast(!RN.gRealTy, e) else e
270 :     end
271 :     in [
272 :     CL.mkDecl(imageDataPtrTy rTy, vp, SOME(CL.I_Exp(trExp(env, a)))),
273 :     CL.mkAssign(lhs,
274 :     CL.mkApply(RN.mkVec n, List.tabulate (n, mkLoad)))
275 :     ] end
276 :     else [CL.mkAssign(lhs, trExp(env, rhs))]
277 : jhr 1671 | IL.E_Op(Op.EigenVals2x2, [m]) => let
278 :     val (m, stms) = expToVar (env, CL.T_Named(RN.matTy(2,2)), "m", m)
279 :     in
280 :     stms @ [CL.mkCall(RN.evals2x2, [
281 :     CL.mkUnOp(CL.%&,lhs),
282 :     matIndex (m, CL.mkInt 0, "0"),
283 :     matIndex (m, CL.mkInt 0, "1"),
284 :     matIndex (m, CL.mkInt 1, "1")
285 :     ])]
286 :     end
287 :     | IL.E_Op(Op.EigenVals3x3, [m]) => let
288 :     val (m, stms) = expToVar (env, CL.T_Named(RN.matTy(3,3)), "m", m)
289 :     in
290 :     stms @ [CL.mkCall(RN.evals3x3, [
291 :     CL.mkUnOp(CL.%&,lhs),
292 :     matIndex (m, CL.mkInt 0, "0"),
293 :     matIndex (m, CL.mkInt 0, "1"),
294 :     matIndex (m, CL.mkInt 0, "2"),
295 :     matIndex (m, CL.mkInt 1, "1"),
296 :     matIndex (m, CL.mkInt 1, "2"),
297 :     matIndex (m, CL.mkInt 2, "2")
298 :     ])]
299 :     end
300 :    
301 : jhr 1640 | IL.E_Cons(Ty.TensorTy[n,m], args) => let
302 :     (* matrices are represented as arrays of union<d><ty>_t vectors *)
303 :     fun doRows (_, []) = []
304 :     | doRows (i, e::es) =
305 :     CL.mkAssign(CL.mkSubscript(lhs, intExp i), e)
306 :     :: doRows (i+1, es)
307 :     in
308 :     doRows (0, trExps(env, args))
309 :     end
310 :     | IL.E_Var x => (case IL.Var.ty x
311 :     of Ty.TensorTy[n,m] => [CL.mkCall(RN.copyMat(n,m), [lhs, trVar(env, x)])]
312 :     | _ => [CL.mkAssign(lhs, trVar(env, x))]
313 :     (* end case *))
314 :     | _ => [CL.mkAssign(lhs, trExp(env, rhs))]
315 :     (* end case *))
316 :    
317 :     fun trAssign (env, lhs, rhs) = trSet (env, trLHSVar (env, lhs), rhs)
318 :    
319 : jhr 1671 fun trMultiAssign (env, lhs, IL.E_Op(rator, args)) = (case (lhs, rator, args)
320 :     of ([vals, vecs], Op.EigenVecs2x2, [m]) => let
321 :     val (m, stms) = expToVar (env, CL.T_Named(RN.matTy(2,2)), "m", m)
322 :     in
323 :     stms @ [CL.mkCall(RN.evecs2x2, [
324 :     CL.mkUnOp(CL.%&,vals), vecs,
325 :     matIndex (m, CL.mkInt 0, "0"),
326 :     matIndex (m, CL.mkInt 0, "1"),
327 :     matIndex (m, CL.mkInt 1, "1")
328 :     ])]
329 :     end
330 :     | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
331 :     val (m, stms) = expToVar (env, CL.T_Named(RN.matTy(3,3)), "m", m)
332 :     in
333 :     stms @ [CL.mkCall(RN.evecs3x3, [
334 :     CL.mkUnOp(CL.%&,vals), vecs,
335 :     matIndex (m, CL.mkInt 0, "0"),
336 :     matIndex (m, CL.mkInt 0, "1"),
337 :     matIndex (m, CL.mkInt 0, "2"),
338 :     matIndex (m, CL.mkInt 1, "1"),
339 :     matIndex (m, CL.mkInt 1, "2"),
340 :     matIndex (m, CL.mkInt 2, "2")
341 :     ])]
342 :     end
343 :     | _ => raise Fail "bogus multi-assignment"
344 :     (* end case *))
345 :     | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"
346 :    
347 : jhr 1370 fun trLocals (env : env, locals) =
348 : jhr 1640 List.foldl
349 :     (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
350 :     env locals
351 : jhr 1370
352 :     (* generate code to check the status of runtime-system calls *)
353 :     fun checkSts mkDecl = let
354 : jhr 1640 val sts = freshVar "sts"
355 :     in
356 :     mkDecl sts @
357 :     [CL.mkIfThen(
358 :     CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
359 :     CL.mkCall("exit", [intExp 1]))]
360 :     end
361 : jhr 1370
362 : jhr 1640 fun trStms (env, stms) = let
363 :     fun trStmt (env, stm) = (case stm
364 :     of IL.S_Comment text => [CL.mkComment text]
365 :     | IL.S_Assign([x], exp) => trAssign (env, x, exp)
366 : jhr 1671 | IL.S_Assign(xs, exp) =>
367 :     trMultiAssign (env, List.map (fn x => trVar (env, x)) xs, exp)
368 : jhr 1640 | IL.S_IfThen(cond, thenBlk) =>
369 :     [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))]
370 :     | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
371 :     [CL.mkIfThenElse(trExp(env, cond),
372 :     trBlk(env, thenBlk),
373 :     trBlk(env, elseBlk))]
374 :     | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
375 :     | IL.S_Save([x], exp) => trSet (env, trLHSStateVar x, exp)
376 : jhr 1370 (* FIXME: I think that S_LoadImage should never happen in OpenCL code [jhr] *)
377 : jhr 1640 | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
378 :     val lhs = lookup(env, lhs)
379 :     val name = trExp(env, name)
380 :     val imgTy = CL.T_Named(RN.imageTy dim)
381 :     val loadFn = RN.loadImage dim
382 :     in [
383 :     CL.mkDecl(
384 :     CL.T_Named RN.statusTy, sts,
385 :     SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, CL.E_Var lhs)]))))
386 :     ] end)
387 : jhr 1370 (* FIXME: I think that S_Input should never happen in OpenCL code [jhr] *)
388 : jhr 1671 | IL.S_Input(lhs, name, desc, optDflt) => checkSts (fn sts => let
389 : jhr 1640 val inputFn = RN.input(V.ty lhs)
390 :     val lhs = lookup(env, lhs)
391 :     val (initCode, hasDflt) = (case optDflt
392 :     of SOME e => ([CL.mkAssign(CL.E_Var lhs, trExp(env, e))], true)
393 :     | NONE => ([], false)
394 :     (* end case *))
395 :     val code = [
396 :     CL.mkDecl(
397 :     CL.T_Named RN.statusTy, sts,
398 :     SOME(CL.I_Exp(CL.E_Apply(inputFn, [
399 : jhr 1671 CL.mkStr name,
400 :     CL.mkUnOp(CL.%&, CL.mkIndirect(CL.mkVar RN.globalsVarName, lhs)),
401 :     CL.mkBool hasDflt
402 :     ]))))
403 : jhr 1640 ]
404 :     in
405 :     initCode @ code
406 :     end)
407 :     | IL.S_Exit args => [CL.mkReturn NONE]
408 :     | IL.S_Active => [CL.mkReturn(SOME(CL.mkVar RN.kActive))]
409 :     | IL.S_Stabilize => [CL.mkReturn(SOME(CL.mkVar RN.kStabilize))]
410 :     | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar RN.kDie))]
411 :     (* end case *))
412 :     in
413 :     List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
414 :     end
415 : jhr 1117
416 : jhr 1640 and trBlk (env, IL.Block{locals, body}) = let
417 :     val env = trLocals (env, locals)
418 :     val stms = trStms (env, body)
419 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
420 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
421 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
422 :     (* end case *))
423 :     val stms = List.foldr mkDecl stms locals
424 :     in
425 :     CL.mkBlock stms
426 :     end
427 : jhr 1370
428 :     fun trFragment (env, IL.Block{locals, body}) = let
429 : jhr 1640 val env = trLocals (env, locals)
430 :     val stms = trStms (env, body)
431 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
432 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
433 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
434 :     (* end case *))
435 :     val stms = List.foldr mkDecl stms locals
436 :     in
437 :     (env, stms)
438 :     end
439 : cchiw 2646
440 :     fun trAllTypes _=[]
441 :     fun trAllOpr e=[]
442 : jhr 1370
443 :     val trBlock = trBlk
444 :    
445 : jhr 1117 end

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