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

SCM Repository

[diderot] Annotation of /trunk/src/compiler/c-util/tree-to-c-fn.sml
ViewVC logotype

Annotation of /trunk/src/compiler/c-util/tree-to-c-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3349 - (view) (download)

1 : jhr 1640 (* tree-to-c.sml
2 :     *
3 : jhr 3349 * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2015 The University of Chicago
6 : jhr 1640 * All rights reserved.
7 :     *
8 :     * Translate TreeIL to the C version of CLang.
9 :     *)
10 :    
11 :     signature TREE_VAR_TO_C =
12 :     sig
13 :     type env = CLang.typed_var TreeIL.Var.Map.map
14 :     (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
15 :     val lvalueVar : env * TreeIL.var -> CLang.exp
16 :     (* translate a variable that occurs in a r-value context *)
17 :     val rvalueVar : env * TreeIL.var -> CLang.exp
18 :     (* translate a strand state variable that occurs in an l-value context *)
19 :     val lvalueStateVar : TreeIL.state_var -> CLang.exp
20 :     (* translate a strand state variable that occurs in a r-value context *)
21 :     val rvalueStateVar : TreeIL.state_var -> CLang.exp
22 :     end
23 :    
24 :     functor TreeToCFn (VarToC : TREE_VAR_TO_C) : sig
25 :    
26 :     type env = CLang.typed_var TreeIL.Var.Map.map
27 :    
28 :     val trType : TreeIL.Ty.ty -> CLang.ty
29 :    
30 :     val trBlock : env * TreeIL.block -> CLang.stm
31 :    
32 :     val trFragment : env * TreeIL.block -> env * CLang.stm list
33 :    
34 :     val trExp : env * TreeIL.exp -> CLang.exp
35 :    
36 :     (* vector indexing support. Arguments are: vector, arity, index *)
37 :     val ivecIndex : CLang.exp * int * int -> CLang.exp
38 :     val vecIndex : CLang.exp * int * int -> CLang.exp
39 :    
40 :     end = struct
41 :    
42 :     structure CL = CLang
43 :     structure N = CNames
44 :     structure IL = TreeIL
45 :     structure Op = IL.Op
46 :     structure Ty = IL.Ty
47 :     structure V = IL.Var
48 :    
49 :     datatype var = datatype CLang.typed_var
50 :     type env = CLang.typed_var TreeIL.Var.Map.map
51 :    
52 :     fun lookup (env, x) = (case V.Map.find (env, x)
53 :     of SOME(V(_, x')) => x'
54 :     | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
55 :     (* end case *))
56 :    
57 :     (* integer literal expression *)
58 :     fun intExp (i : int) = CL.mkInt(IntInf.fromInt i)
59 :    
60 : jhr 1923 fun addrOf e = CL.mkUnOp(CL.%&, e)
61 :    
62 : jhr 1640 (* translate TreeIL types to CLang types *)
63 :     fun trType ty = (case ty
64 :     of Ty.BoolTy => CLang.T_Named "bool"
65 :     | Ty.StringTy => CL.charPtr
66 :     | Ty.IntTy => !N.gIntTy
67 :     | Ty.TensorTy[] => !N.gRealTy
68 :     | Ty.TensorTy[n] => CL.T_Named(N.vecTy n)
69 :     | Ty.TensorTy[n, m] => CL.T_Named(N.matTy(n,m))
70 :     | Ty.SeqTy(Ty.IntTy, n) => CL.T_Named(N.ivecTy n)
71 :     | Ty.SeqTy(ty, n) => CL.T_Array(trType ty, SOME n)
72 : jhr 3156 | Ty.AddrTy info => CL.T_Ptr(CL.T_Num(ImageInfo.sampleTy info))
73 :     | Ty.ImageTy info => CL.T_Ptr(CL.T_Named(N.imageTy(ImageInfo.dim info)))
74 : jhr 1640 | _ => raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])
75 :     (* end case *))
76 :    
77 :     (* generate new variables *)
78 :     local
79 :     val count = ref 0
80 :     fun freshName prefix = let
81 :     val n = !count
82 :     in
83 :     count := n+1;
84 :     concat[prefix, "_", Int.toString n]
85 :     end
86 :     in
87 :     fun tmpVar ty = freshName "tmp"
88 :     fun freshVar prefix = freshName prefix
89 :     end (* local *)
90 :    
91 :     (* translate IL basis functions *)
92 :     local
93 :     fun mkLookup suffix = let
94 : jhr 1923 val tbl = MathFuns.Tbl.mkTable (16, Fail "basis table")
95 :     fun ins f = MathFuns.Tbl.insert tbl (f, MathFuns.toString f ^ suffix)
96 : jhr 1640 in
97 : jhr 1923 List.app ins MathFuns.allFuns;
98 :     MathFuns.Tbl.lookup tbl
99 : jhr 1640 end
100 :     val fLookup = mkLookup "f"
101 :     val dLookup = mkLookup ""
102 :     in
103 :     fun trApply (f, args) = let
104 :     val f' = if !N.doublePrecision then dLookup f else fLookup f
105 :     in
106 :     CL.mkApply(f', args)
107 :     end
108 :     end (* local *)
109 :    
110 :     (* vector indexing support. Arguments are: vector, arity, index *)
111 :     fun ivecIndex (v, n, ix) = let
112 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gIntSuffix, "_t"])
113 :     val e1 = CL.mkCast(unionTy, v)
114 :     val e2 = CL.mkSelect(e1, "i")
115 :     in
116 :     CL.mkSubscript(e2, intExp ix)
117 :     end
118 :    
119 :     fun vecIndex (v, n, ix) = let
120 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gRealSuffix, "_t"])
121 :     val e1 = CL.mkCast(unionTy, v)
122 :     val e2 = CL.mkSelect(e1, "r")
123 :     in
124 :     CL.mkSubscript(e2, intExp ix)
125 :     end
126 :    
127 :     (* matrix indexing *)
128 :     fun matIndex (m, ix, jx) =
129 :     CL.mkSubscript(CL.mkSelect(CL.mkSubscript(m, ix), "r"), jx)
130 :    
131 :     (* Translate a TreeIL operator application to a CLang expression *)
132 :     fun trOp (rator, args) = (case (rator, args)
133 :     of (Op.Add ty, [a, b]) => CL.mkBinOp(a, CL.#+, b)
134 :     | (Op.Sub ty, [a, b]) => CL.mkBinOp(a, CL.#-, b)
135 :     | (Op.Mul ty, [a, b]) => CL.mkBinOp(a, CL.#*, b)
136 :     | (Op.Div ty, [a, b]) => CL.mkBinOp(a, CL.#/, b)
137 :     | (Op.Neg ty, [a]) => CL.mkUnOp(CL.%-, a)
138 :     | (Op.Abs(Ty.IntTy), args) => CL.mkApply("abs", args)
139 :     | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(N.fabs(), args)
140 :     | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
141 :     | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
142 :     | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
143 :     | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
144 :     | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
145 :     | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
146 :     | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
147 :     | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
148 :     | (Op.Max, args) => CL.mkApply(N.max(), args)
149 :     | (Op.Min, args) => CL.mkApply(N.min(), args)
150 :     | (Op.Clamp(Ty.TensorTy[]), args) => CL.mkApply(N.clamp 1, args)
151 :     | (Op.Clamp(Ty.TensorTy[n]), args) => CL.mkApply(N.clamp n, args)
152 :     | (Op.Lerp ty, args) => (case ty
153 :     of Ty.TensorTy[] => CL.mkApply(N.lerp 1, args)
154 :     | Ty.TensorTy[n] => CL.mkApply(N.lerp n, args)
155 :     | _ => raise Fail(concat[
156 :     "lerp<", Ty.toString ty, "> not supported"
157 :     ])
158 :     (* end case *))
159 :     | (Op.Dot d, args) => CL.E_Apply(N.dot d, args)
160 :     | (Op.MulVecMat(m, n), args) =>
161 :     if (1 < m) andalso (m < 4) andalso (m = n)
162 :     then CL.E_Apply(N.mulVecMat(m,n), args)
163 :     else raise Fail "unsupported vector-matrix multiply"
164 :     | (Op.MulMatVec(m, n), args) =>
165 :     if (1 < m) andalso (m < 4) andalso (m = n)
166 :     then CL.E_Apply(N.mulMatVec(m,n), args)
167 :     else raise Fail "unsupported matrix-vector multiply"
168 :     | (Op.MulMatMat(m, n, p), args) =>
169 :     if (1 < m) andalso (m < 4) andalso (m = n) andalso (n = p)
170 :     then CL.E_Apply(N.mulMatMat(m,n,p), args)
171 :     else raise Fail "unsupported matrix-matrix multiply"
172 :     | (Op.Cross, args) => CL.E_Apply(N.cross(), args)
173 :     | (Op.Norm(Ty.TensorTy[n]), args) => CL.E_Apply(N.length n, args)
174 : jhr 2356 | (Op.Norm(Ty.TensorTy[m,n]), args) => CL.E_Apply(N.normMat(m,n), args)
175 : jhr 1640 | (Op.Normalize d, args) => CL.E_Apply(N.normalize d, args)
176 :     | (Op.Scale(Ty.TensorTy[n]), args) => CL.E_Apply(N.scale n, args)
177 :     | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
178 :     | (Op.Select(Ty.TupleTy tys, i), [a]) => raise Fail "Select unimplemented"
179 :     | (Op.Index(Ty.SeqTy(Ty.IntTy, n), i), [a]) => ivecIndex (a, n, i)
180 :     | (Op.Index(Ty.TensorTy[n], i), [a]) => vecIndex (a, n, i)
181 :     | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, ix]) => let
182 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gIntSuffix, "_t"])
183 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
184 :     in
185 :     CL.mkSubscript(vecExp, ix)
186 :     end
187 :     | (Op.Subscript(Ty.SeqTy(ty, n)), [v, ix]) => CL.mkSubscript(v, ix)
188 :     | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
189 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gRealSuffix, "_t"])
190 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
191 :     in
192 :     CL.mkSubscript(vecExp, ix)
193 :     end
194 :     | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, jx]) => matIndex (m, ix, jx)
195 :     | (Op.Subscript ty, t::(ixs as _::_)) =>
196 :     raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
197 :     | (Op.Ceiling d, args) => CL.mkApply(N.addTySuffix("ceil", d), args)
198 :     | (Op.Floor d, args) => CL.mkApply(N.addTySuffix("floor", d), args)
199 :     | (Op.Round d, args) => CL.mkApply(N.addTySuffix("round", d), args)
200 :     | (Op.Trunc d, args) => CL.mkApply(N.addTySuffix("trunc", d), args)
201 :     | (Op.IntToReal, [a]) => CL.mkCast(!N.gRealTy, a)
202 :     | (Op.RealToInt 1, [a]) => CL.mkCast(!N.gIntTy, a)
203 :     | (Op.RealToInt d, args) => CL.mkApply(N.vecftoi d, args)
204 : jhr 2636 | (Op.ImageAddress info, [a]) => let
205 :     val cTy = CL.T_Ptr(CL.T_Num(ImageInfo.sampleTy info))
206 : jhr 1640 in
207 :     CL.mkCast(cTy, CL.mkIndirect(a, "data"))
208 :     end
209 :     | (Op.LoadVoxels(info, 1), [a]) => let
210 :     val realTy as CL.T_Num rTy = !N.gRealTy
211 :     val a = CL.E_UnOp(CL.%*, a)
212 :     in
213 :     if (rTy = ImageInfo.sampleTy info)
214 :     then a
215 :     else CL.E_Cast(realTy, a)
216 :     end
217 :     | (Op.LoadVoxels _, [a]) =>
218 :     raise Fail("impossible " ^ Op.toString rator)
219 : jhr 2636 | (Op.PosToImgSpace info, [img, pos]) =>
220 :     CL.mkApply(N.toImageSpace(ImageInfo.dim info), [img, pos])
221 : jhr 1640 | (Op.TensorToWorldSpace(info, ty), [v, x]) =>
222 :     CL.mkApply(N.toWorldSpace ty, [v, x])
223 : jhr 3082 | (Op.Inside(info, s), [pos, img]) =>
224 :     CL.mkApply(N.inside(ImageInfo.dim info), [pos, img, intExp s])
225 : jhr 1640 | (Op.LoadImage info, [a]) =>
226 :     raise Fail("impossible " ^ Op.toString rator)
227 : jhr 2636 | (Op.LoadImage(ty, nrrd, info), []) =>
228 : jhr 1640 raise Fail("impossible " ^ Op.toString rator)
229 : jhr 2636 | (Op.Input _, []) => raise Fail("impossible " ^ Op.toString rator)
230 : jhr 1640 | _ => raise Fail(concat[
231 :     "unknown or incorrect operator ", Op.toString rator
232 :     ])
233 :     (* end case *))
234 :    
235 :     fun trExp (env, e) = (case e
236 :     of IL.E_State x => VarToC.rvalueStateVar x
237 :     | IL.E_Var x => VarToC.rvalueVar (env, x)
238 :     | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !N.gIntTy)
239 :     | IL.E_Lit(Literal.Bool b) => CL.mkBool b
240 :     | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !N.gRealTy)
241 :     | IL.E_Lit(Literal.String s) => CL.mkStr s
242 :     | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
243 :     | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
244 :     | IL.E_Cons(Ty.TensorTy[n], args) => CL.mkApply(N.mkVec n, trExps(env, args))
245 :     | IL.E_Cons(ty, _) => raise Fail(concat["E_Cons(", Ty.toString ty, ", _) in expression"])
246 :     (* end case *))
247 :    
248 :     and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
249 :    
250 :     (* translate an expression to a variable form; return the variable and the
251 :     * (optional) declaration.
252 :     *)
253 :     fun expToVar (env, ty, name, exp) = (case trExp(env, exp)
254 :     of x as CL.E_Var _ => (x, [])
255 :     | exp => let
256 :     val x = freshVar name
257 :     in
258 :     (CL.mkVar x, [CL.mkDecl(ty, x, SOME(CL.I_Exp exp))])
259 :     end
260 :     (* end case *))
261 :    
262 :     (* translate a print statement *)
263 :     fun trPrint (env, tys, args) = let
264 :     (* assemble the format string by analysing the types and argument expressions *)
265 :     fun mkFmt (Ty.StringTy, IL.E_Lit(Literal.String s), (stms, fmt, args)) =
266 :     (stms, s::fmt, args)
267 :     | mkFmt (ty, exp, (stms, fmt, args)) = let
268 :     fun mk (f, e) = (stms, f::fmt, e::args)
269 :     in
270 :     case ty
271 :     of Ty.BoolTy => mk(
272 :     "%s",
273 :     CL.mkCond(trExp(env, exp), CL.mkStr "true", CL.mkStr "false"))
274 :     | Ty.StringTy => mk("%s", trExp(env, exp))
275 :     | Ty.IntTy => mk(!N.gIntFormat, trExp(env, exp))
276 :     | Ty.TensorTy[] => mk("%f", trExp(env, exp))
277 :     | Ty.TensorTy[n] => let
278 :     val (x, stm) = expToVar (env, trType ty, "vec", exp)
279 :     val elems = List.tabulate (n, fn i => vecIndex (x, n, i))
280 :     val (fmt, args) = mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
281 :     in
282 :     (stm@stms, fmt, args)
283 :     end
284 :     (*
285 :     | Ty.TensorTy[n, m] =>
286 :     *)
287 :     | Ty.SeqTy(elemTy, n) => let
288 :     val (x, stm) = expToVar (env, trType ty, "vec", exp)
289 :     val elems = List.tabulate (n, fn i => ivecIndex (x, n, i))
290 :     val (fmt, args) = mkSeqFmt (elemTy, elems, fmt, args)
291 :     in
292 :     (stm@stms, fmt, args)
293 :     end
294 :     | _ => raise Fail(concat["TreeToC.trPrint(", Ty.toString ty, ")"])
295 :     (* end case *)
296 :     end
297 :     and mkElemFmt (elemTy, elem, (fmt, args)) = (case elemTy
298 :     of Ty.BoolTy =>
299 :     ("%s"::fmt, CL.mkCond(elem, CL.mkStr "true", CL.mkStr "false")::args)
300 :     | Ty.StringTy => ("%s"::fmt, elem::args)
301 :     | Ty.IntTy => (!N.gIntFormat::fmt, elem::args)
302 :     | Ty.TensorTy[] => ("%f"::fmt, elem::args)
303 :     | Ty.TensorTy[n] => let
304 :     val elems = List.tabulate (n, fn i => vecIndex (elem, n, i))
305 :     in
306 :     mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
307 :     end
308 :     (*
309 :     | Ty.TensorTy[n, m] =>
310 :     *)
311 :     | Ty.SeqTy(elemTy, n) => let
312 :     val elems = List.tabulate (n, fn i => ivecIndex (elem, n, i))
313 :     in
314 :     mkSeqFmt (elemTy, elems, fmt, args)
315 :     end
316 :     | _ => raise Fail(concat["TreeToC.mkElemFmt(", Ty.toString elemTy, ")"])
317 :     (* end case *))
318 :     and mkSeqFmt (elemTy, elems, fmt, args) = let
319 :     fun mk (elem, acc) = mkFmt(elemTy, elem, acc)
320 :     val (seqFmt, args) =
321 :     List.foldr
322 :     (fn (elem, acc) => mkElemFmt(elemTy, elem, acc))
323 :     ([], args) elems
324 :     in
325 :     ("<" :: String.concatWith "," seqFmt :: ">" :: fmt, args)
326 :     end
327 :     val (stms, fmt, args) = ListPair.foldr mkFmt ([], [], []) (tys, args)
328 :     val stm = CL.mkCall("fprintf", CL.mkVar "stderr" :: CL.mkStr(String.concat fmt) :: args)
329 :     in
330 :     List.rev (stm :: stms)
331 :     end
332 :    
333 :     fun trAssign (env, lhs, rhs) = (
334 :     (* certain rhs forms, such as those that return a matrix,
335 :     * require a function call instead of an assignment
336 :     *)
337 :     case rhs
338 :     of IL.E_Op(Op.Add(Ty.TensorTy[m,n]), args) =>
339 :     [CL.mkCall(N.addMat(m,n), lhs :: trExps(env, args))]
340 :     | IL.E_Op(Op.Sub(Ty.TensorTy[m,n]), args) =>
341 :     [CL.mkCall(N.subMat(m,n), lhs :: trExps(env, args))]
342 :     | IL.E_Op(Op.Neg(Ty.TensorTy[m,n]), args) =>
343 :     [CL.mkCall(N.scaleMat(m,n), lhs :: intExp ~1 :: trExps(env, args))]
344 :     | IL.E_Op(Op.Scale(Ty.TensorTy[m,n]), args) =>
345 :     [CL.mkCall(N.scaleMat(m,n), lhs :: trExps(env, args))]
346 :     | IL.E_Op(Op.MulMatMat(m,n,p), args) =>
347 :     [CL.mkCall(N.mulMatMat(m,n,p), lhs :: trExps(env, args))]
348 :     | IL.E_Op(Op.EigenVals2x2, [m]) => let
349 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
350 :     in
351 :     stms @ [CL.mkCall(N.evals2x2, [
352 :     lhs,
353 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
354 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
355 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
356 :     ])]
357 :     end
358 :     | IL.E_Op(Op.EigenVals3x3, [m]) => let
359 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
360 :     in
361 :     stms @ [CL.mkCall(N.evals3x3, [
362 :     lhs,
363 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
364 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
365 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
366 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
367 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
368 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
369 :     ])]
370 :     end
371 :     | IL.E_Op(Op.Identity n, args) =>
372 :     [CL.mkCall(N.identityMat n, [lhs])]
373 :     | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
374 :     [CL.mkCall(N.zeroMat(m,n), [lhs])]
375 :     | IL.E_Op(Op.TensorToWorldSpace(info, ty as Ty.TensorTy[_,_]), args) =>
376 :     [CL.mkCall(N.toWorldSpace ty, lhs :: trExps(env, args))]
377 :     | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>
378 :     if (n > 1)
379 :     then let
380 :     val stride = ImageInfo.stride info
381 :     val rTy = ImageInfo.sampleTy info
382 :     val vp = freshVar "vp"
383 :     val needsCast = (CL.T_Num rTy <> !N.gRealTy)
384 :     fun mkLoad i = let
385 :     val e = CL.mkSubscript(CL.mkVar vp, intExp(i*stride))
386 :     in
387 :     if needsCast then CL.mkCast(!N.gRealTy, e) else e
388 :     end
389 :     in [
390 :     CL.mkDecl(CL.T_Ptr(CL.T_Num rTy), vp, SOME(CL.I_Exp(trExp(env, a)))),
391 :     CL.mkAssign(lhs,
392 :     CL.mkApply(N.mkVec n, List.tabulate (n, mkLoad)))
393 :     ] end
394 :     else [CL.mkAssign(lhs, trExp(env, rhs))]
395 :     | IL.E_Cons(Ty.TensorTy[n,m], args) => let
396 :     (* matrices are represented as arrays of union<d><ty>_t vectors *)
397 :     fun doRows (_, []) = []
398 :     | doRows (i, e::es) =
399 :     CL.mkAssign(CL.mkSelect(CL.mkSubscript(lhs, intExp i), "v"), e)
400 :     :: doRows (i+1, es)
401 :     in
402 :     doRows (0, trExps(env, args))
403 :     end
404 :     | IL.E_Var x => (case IL.Var.ty x
405 :     of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueVar(env, x)])]
406 :     | _ => [CL.mkAssign(lhs, VarToC.rvalueVar(env, x))]
407 :     (* end case *))
408 :     | _ => [CL.mkAssign(lhs, trExp(env, rhs))]
409 :     (* end case *))
410 :    
411 :     fun trMultiAssign (env, lhs, IL.E_Op(rator, args)) = (case (lhs, rator, args)
412 :     of ([vals, vecs], Op.EigenVecs2x2, [m]) => let
413 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
414 :     in
415 :     stms @ [CL.mkCall(N.evecs2x2, [
416 :     vals, vecs,
417 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
418 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
419 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
420 :     ])]
421 :     end
422 :     | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
423 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
424 :     in
425 :     stms @ [CL.mkCall(N.evecs3x3, [
426 :     vals, vecs,
427 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
428 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
429 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
430 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
431 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
432 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
433 :     ])]
434 :     end
435 :     | ([], Op.Print tys, args) => trPrint (env, tys, args)
436 :     | _ => raise Fail "bogus multi-assignment"
437 :     (* end case *))
438 :     | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"
439 :    
440 : jhr 3082 fun trLocals (env : env, locals) =
441 : jhr 1640 List.foldl
442 :     (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
443 :     env locals
444 :    
445 :     (* generate code to check the status of runtime-system calls *)
446 :     fun checkSts mkDecl = let
447 :     val sts = freshVar "sts"
448 :     in
449 :     mkDecl sts @
450 :     [CL.mkIfThen(
451 :     CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
452 :     CL.mkCall("exit", [intExp 1]))]
453 :     end
454 :    
455 : jhr 3154 fun registerInput (env, lhs, name, optDesc, hasDflt) = let
456 : jhr 3156 val desc = Option.getOpt (optDesc, "")
457 :     val hasDflt = if hasDflt then "true" else "false"
458 :     in
459 :     CL.mkCall(N.input(V.ty lhs), [
460 :     CL.mkVar "opts", CL.mkStr name, CL.mkStr desc,
461 :     CL.mkUnOp(CL.%&, VarToC.lvalueVar(env, lhs)), CL.mkVar hasDflt
462 :     ])
463 :     end
464 : jhr 3154
465 : jhr 1640 fun trStms (env, stms) = let
466 :     fun trStmt (env, stm) = (case stm
467 :     of IL.S_Comment text => [CL.mkComment text]
468 :     | IL.S_Assign([x], exp) => trAssign (env, VarToC.lvalueVar (env, x), exp)
469 :     | IL.S_Assign(xs, exp) =>
470 :     trMultiAssign (env, List.map (fn x => VarToC.lvalueVar (env, x)) xs, exp)
471 :     | IL.S_IfThen(cond, thenBlk) =>
472 :     [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))]
473 :     | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
474 :     [CL.mkIfThenElse(trExp(env, cond),
475 :     trBlk(env, thenBlk),
476 :     trBlk(env, elseBlk))]
477 :     | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
478 :     | IL.S_Save([x], exp) => trAssign (env, VarToC.lvalueStateVar x, exp)
479 :     | IL.S_Save(xs, exp) =>
480 :     trMultiAssign (env, List.map VarToC.lvalueStateVar xs, exp)
481 : jhr 2636 | IL.S_LoadNrrd(lhs, Ty.ImageTy info, nrrd) =>
482 : jhr 3156 [GenLoadNrrd.loadImage (VarToC.lvalueVar (env, lhs), info, CL.E_Str nrrd)]
483 : jhr 3154 | IL.S_Input(lhs, name, optDesc, NONE) =>
484 : jhr 3156 [registerInput (env, lhs, name, optDesc, false)]
485 : jhr 3154 | IL.S_Input(lhs, name, optDesc, SOME dflt) => [
486 :     CL.mkAssign(VarToC.lvalueVar(env, lhs), trExp(env, dflt)),
487 : jhr 3156 registerInput (env, lhs, name, optDesc, true)
488 : jhr 2636 ]
489 :     | IL.S_InputNrrd _ => []
490 : jhr 1640 | IL.S_Exit args => [CL.mkReturn NONE]
491 :     | IL.S_Active => [CL.mkReturn(SOME(CL.mkVar N.kActive))]
492 :     | IL.S_Stabilize => [CL.mkReturn(SOME(CL.mkVar N.kStabilize))]
493 :     | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar N.kDie))]
494 :     (* end case *))
495 :     in
496 :     List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
497 :     end
498 :    
499 :     and trBlk (env, IL.Block{locals, body}) = let
500 :     val env = trLocals (env, locals)
501 :     val stms = trStms (env, body)
502 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
503 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
504 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
505 :     (* end case *))
506 :     val stms = List.foldr mkDecl stms locals
507 :     in
508 :     CL.mkBlock stms
509 :     end
510 :    
511 :     fun trFragment (env, IL.Block{locals, body}) = let
512 :     val env = trLocals (env, locals)
513 :     val stms = trStms (env, body)
514 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
515 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
516 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
517 :     (* end case *))
518 :     val stms = List.foldr mkDecl stms locals
519 :     in
520 :     (env, stms)
521 :     end
522 :    
523 :     val trBlock = trBlk
524 :    
525 :     end

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