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

SCM Repository

[diderot] Annotation of /branches/vis12-cl/src/compiler/c-util/tree-to-c.sml
ViewVC logotype

Annotation of /branches/vis12-cl/src/compiler/c-util/tree-to-c.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2048 - (view) (download)
Original Path: branches/vis12/src/compiler/c-util/tree-to-c-fn.sml

1 : jhr 1640 (* tree-to-c.sml
2 :     *
3 :     * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     * All rights reserved.
5 :     *
6 :     * Translate TreeIL to the C version of CLang.
7 :     *)
8 :    
9 :     signature TREE_VAR_TO_C =
10 :     sig
11 :     type env = CLang.typed_var TreeIL.Var.Map.map
12 :     (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
13 :     val lvalueVar : env * TreeIL.var -> CLang.exp
14 :     (* translate a variable that occurs in a r-value context *)
15 :     val rvalueVar : env * TreeIL.var -> CLang.exp
16 :     (* translate a strand state variable that occurs in an l-value context *)
17 :     val lvalueStateVar : TreeIL.state_var -> CLang.exp
18 :     (* translate a strand state variable that occurs in a r-value context *)
19 :     val rvalueStateVar : TreeIL.state_var -> CLang.exp
20 :     end
21 :    
22 :     functor TreeToCFn (VarToC : TREE_VAR_TO_C) : sig
23 :    
24 :     type env = CLang.typed_var TreeIL.Var.Map.map
25 :    
26 :     val trType : TreeIL.Ty.ty -> CLang.ty
27 :    
28 :     val trBlock : env * TreeIL.block -> CLang.stm
29 :    
30 : nseltzer 1870 val trFree : env * TreeIL.block -> CLang.stm
31 :    
32 : jhr 1640 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 1691 fun addrOf e = CL.mkUnOp(CL.%&, e)
61 :    
62 : jhr 1640 (* translate TreeIL types to CLang types *)
63 : jhr 1820 val trType = CTyTranslate.toType
64 : jhr 1640
65 :     (* generate new variables *)
66 :     local
67 :     val count = ref 0
68 :     fun freshName prefix = let
69 :     val n = !count
70 :     in
71 :     count := n+1;
72 :     concat[prefix, "_", Int.toString n]
73 :     end
74 :     in
75 :     fun tmpVar ty = freshName "tmp"
76 :     fun freshVar prefix = freshName prefix
77 :     end (* local *)
78 :    
79 :     (* translate IL basis functions *)
80 :     local
81 :     fun mkLookup suffix = let
82 : jhr 1922 val tbl = MathFuns.Tbl.mkTable (16, Fail "basis table")
83 :     fun ins f = MathFuns.Tbl.insert tbl (f, MathFuns.toString f ^ suffix)
84 : jhr 1640 in
85 : jhr 1922 List.app ins MathFuns.allFuns;
86 :     MathFuns.Tbl.lookup tbl
87 : jhr 1640 end
88 :     val fLookup = mkLookup "f"
89 :     val dLookup = mkLookup ""
90 :     in
91 :     fun trApply (f, args) = let
92 :     val f' = if !N.doublePrecision then dLookup f else fLookup f
93 :     in
94 :     CL.mkApply(f', args)
95 :     end
96 :     end (* local *)
97 :    
98 :     (* vector indexing support. Arguments are: vector, arity, index *)
99 :     fun ivecIndex (v, n, ix) = let
100 : jhr 1858 val e1 = CL.mkCast(CL.T_Named(N.iunionTy n), v)
101 : jhr 1640 val e2 = CL.mkSelect(e1, "i")
102 :     in
103 :     CL.mkSubscript(e2, intExp ix)
104 :     end
105 :    
106 :     fun vecIndex (v, n, ix) = let
107 : jhr 1858 val e1 = CL.mkCast(CL.T_Named(N.unionTy n), v)
108 : jhr 1640 val e2 = CL.mkSelect(e1, "r")
109 :     in
110 :     CL.mkSubscript(e2, intExp ix)
111 :     end
112 :    
113 :     (* matrix indexing *)
114 :     fun matIndex (m, ix, jx) =
115 :     CL.mkSubscript(CL.mkSelect(CL.mkSubscript(m, ix), "r"), jx)
116 :    
117 :     (* Translate a TreeIL operator application to a CLang expression *)
118 :     fun trOp (rator, args) = (case (rator, args)
119 :     of (Op.Add ty, [a, b]) => CL.mkBinOp(a, CL.#+, b)
120 :     | (Op.Sub ty, [a, b]) => CL.mkBinOp(a, CL.#-, b)
121 :     | (Op.Mul ty, [a, b]) => CL.mkBinOp(a, CL.#*, b)
122 :     | (Op.Div ty, [a, b]) => CL.mkBinOp(a, CL.#/, b)
123 :     | (Op.Neg ty, [a]) => CL.mkUnOp(CL.%-, a)
124 :     | (Op.Abs(Ty.IntTy), args) => CL.mkApply("abs", args)
125 :     | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(N.fabs(), args)
126 :     | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
127 :     | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
128 :     | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
129 :     | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
130 :     | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
131 :     | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
132 :     | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
133 :     | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
134 :     | (Op.Max, args) => CL.mkApply(N.max(), args)
135 :     | (Op.Min, args) => CL.mkApply(N.min(), args)
136 :     | (Op.Clamp(Ty.TensorTy[]), args) => CL.mkApply(N.clamp 1, args)
137 :     | (Op.Clamp(Ty.TensorTy[n]), args) => CL.mkApply(N.clamp n, args)
138 :     | (Op.Lerp ty, args) => (case ty
139 :     of Ty.TensorTy[] => CL.mkApply(N.lerp 1, args)
140 :     | Ty.TensorTy[n] => CL.mkApply(N.lerp n, args)
141 :     | _ => raise Fail(concat[
142 :     "lerp<", Ty.toString ty, "> not supported"
143 :     ])
144 :     (* end case *))
145 :     | (Op.Dot d, args) => CL.E_Apply(N.dot d, args)
146 :     | (Op.MulVecMat(m, n), args) =>
147 : jhr 1939 if (1 < m) andalso (m <= 4) andalso (m = n)
148 : jhr 1640 then CL.E_Apply(N.mulVecMat(m,n), args)
149 :     else raise Fail "unsupported vector-matrix multiply"
150 :     | (Op.MulMatVec(m, n), args) =>
151 : jhr 1939 if (1 < m) andalso (m <= 4) andalso (m = n)
152 : jhr 1640 then CL.E_Apply(N.mulMatVec(m,n), args)
153 :     else raise Fail "unsupported matrix-vector multiply"
154 :     | (Op.MulMatMat(m, n, p), args) =>
155 : jhr 1939 if (1 < m) andalso (m <= 4) andalso (m = n) andalso (n = p)
156 : jhr 1640 then CL.E_Apply(N.mulMatMat(m,n,p), args)
157 :     else raise Fail "unsupported matrix-matrix multiply"
158 : jhr 1945 | (Op.ColonMul(Ty.TensorTy dd1, Ty.TensorTy dd2), args) =>
159 :     CL.E_Apply(N.colonMul(dd1, dd2), args)
160 : jhr 1640 | (Op.Cross, args) => CL.E_Apply(N.cross(), args)
161 :     | (Op.Norm(Ty.TensorTy[n]), args) => CL.E_Apply(N.length n, args)
162 : jhr 1939 | (Op.Norm(Ty.TensorTy[m,n]), args) => CL.E_Apply(N.normMat(m,n), args)
163 :     | (Op.Norm(Ty.TensorTy[m,n,p]), args) => CL.E_Apply(N.normTen3(m,n,p), args)
164 : jhr 1640 | (Op.Normalize d, args) => CL.E_Apply(N.normalize d, args)
165 :     | (Op.Scale(Ty.TensorTy[n]), args) => CL.E_Apply(N.scale n, args)
166 :     | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
167 :     | (Op.Select(Ty.TupleTy tys, i), [a]) => raise Fail "Select unimplemented"
168 :     | (Op.Index(Ty.SeqTy(Ty.IntTy, n), i), [a]) => ivecIndex (a, n, i)
169 :     | (Op.Index(Ty.TensorTy[n], i), [a]) => vecIndex (a, n, i)
170 :     | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, ix]) => let
171 : jhr 1858 val unionTy = CL.T_Named(N.iunionTy n)
172 : jhr 1640 val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
173 :     in
174 :     CL.mkSubscript(vecExp, ix)
175 :     end
176 :     | (Op.Subscript(Ty.SeqTy(ty, n)), [v, ix]) => CL.mkSubscript(v, ix)
177 : jhr 2024 | (Op.Subscript(Ty.DynSeqTy ty), [v, ix]) => let
178 :     val elemTy = trType ty
179 :     in
180 :     CL.mkUnOp (CL.%*,
181 :     CL.mkCast(CL.T_Ptr elemTy,
182 :     CL.mkApply("Diderot_DynSeqAddr", [CL.mkSizeof elemTy, v, ix])))
183 :     end
184 : jhr 1640 | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
185 : jhr 1858 val unionTy = CL.T_Named(N.unionTy n)
186 : jhr 1640 val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
187 :     in
188 :     CL.mkSubscript(vecExp, ix)
189 :     end
190 :     | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, jx]) => matIndex (m, ix, jx)
191 :     | (Op.Subscript ty, t::(ixs as _::_)) =>
192 :     raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
193 : jhr 1691 | (Op.MkDynamic(ty, n), [seq]) => CL.mkApply("Diderot_DynSeqMk", [
194 :     CL.mkSizeof(trType ty), CL.mkInt(IntInf.fromInt n),
195 :     addrOf (CL.mkSubscript(seq, intExp 0))
196 : jhr 1690 ])
197 : jhr 1691 | (Op.Append ty, [seq, x]) => CL.mkApply("Diderot_DynSeqAppend", [
198 :     CL.mkSizeof(trType ty), seq, addrOf x
199 : jhr 1690 ])
200 : jhr 1691 | (Op.Prepend ty, [x, seq]) => CL.mkApply("Diderot_DynSeqPrepend", [
201 :     CL.mkSizeof(trType ty), addrOf x, seq
202 : jhr 1690 ])
203 : jhr 1691 | (Op.Concat ty, [seq1, seq2]) => CL.mkApply("Diderot_DynSeqConcat", [
204 : jhr 1690 CL.mkSizeof(trType ty), seq1, seq2
205 :     ])
206 : jhr 1925 | (Op.Length _, [seq]) => CL.mkApply("Diderot_DynSeqLength", [seq])
207 : jhr 1640 | (Op.Ceiling d, args) => CL.mkApply(N.addTySuffix("ceil", d), args)
208 :     | (Op.Floor d, args) => CL.mkApply(N.addTySuffix("floor", d), args)
209 :     | (Op.Round d, args) => CL.mkApply(N.addTySuffix("round", d), args)
210 :     | (Op.Trunc d, args) => CL.mkApply(N.addTySuffix("trunc", d), args)
211 :     | (Op.IntToReal, [a]) => CL.mkCast(!N.gRealTy, a)
212 :     | (Op.RealToInt 1, [a]) => CL.mkCast(!N.gIntTy, a)
213 :     | (Op.RealToInt d, args) => CL.mkApply(N.vecftoi d, args)
214 : jhr 1793 | (Op.ImageAddress info, [a]) => let
215 :     val cTy = CL.T_Ptr(CL.T_Num(ImageInfo.sampleTy info))
216 : jhr 1640 in
217 :     CL.mkCast(cTy, CL.mkIndirect(a, "data"))
218 :     end
219 :     | (Op.LoadVoxels(info, 1), [a]) => let
220 :     val realTy as CL.T_Num rTy = !N.gRealTy
221 :     val a = CL.E_UnOp(CL.%*, a)
222 :     in
223 :     if (rTy = ImageInfo.sampleTy info)
224 :     then a
225 :     else CL.E_Cast(realTy, a)
226 :     end
227 :     | (Op.LoadVoxels _, [a]) =>
228 :     raise Fail("impossible " ^ Op.toString rator)
229 : jhr 1793 | (Op.PosToImgSpace info, [img, pos]) =>
230 :     CL.mkApply(N.toImageSpace(ImageInfo.dim info), [img, pos])
231 : jhr 1640 | (Op.TensorToWorldSpace(info, ty), [v, x]) =>
232 :     CL.mkApply(N.toWorldSpace ty, [v, x])
233 : jhr 1793 | (Op.Inside(info, s), [pos, img]) =>
234 :     CL.mkApply(N.inside(ImageInfo.dim info), [pos, img, intExp s])
235 : jhr 2029 | (Op.LoadSeq(ty, nrrd), []) =>
236 :     raise Fail("impossible " ^ Op.toString rator)
237 :     | (Op.LoadImage(ty, nrrd, info), []) =>
238 :     raise Fail("impossible " ^ Op.toString rator)
239 : jhr 2012 | (Op.Input _, []) => raise Fail("impossible " ^ Op.toString rator)
240 : jhr 1640 | _ => raise Fail(concat[
241 :     "unknown or incorrect operator ", Op.toString rator
242 :     ])
243 :     (* end case *))
244 :    
245 :     fun trExp (env, e) = (case e
246 :     of IL.E_State x => VarToC.rvalueStateVar x
247 :     | IL.E_Var x => VarToC.rvalueVar (env, x)
248 :     | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !N.gIntTy)
249 :     | IL.E_Lit(Literal.Bool b) => CL.mkBool b
250 :     | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !N.gRealTy)
251 :     | IL.E_Lit(Literal.String s) => CL.mkStr s
252 :     | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
253 :     | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
254 :     | IL.E_Cons(Ty.TensorTy[n], args) => CL.mkApply(N.mkVec n, trExps(env, args))
255 :     | IL.E_Cons(ty, _) => raise Fail(concat["E_Cons(", Ty.toString ty, ", _) in expression"])
256 :     (* end case *))
257 :    
258 :     and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
259 :    
260 :     (* translate an expression to a variable form; return the variable and the
261 :     * (optional) declaration.
262 :     *)
263 :     fun expToVar (env, ty, name, exp) = (case trExp(env, exp)
264 :     of x as CL.E_Var _ => (x, [])
265 :     | exp => let
266 :     val x = freshVar name
267 :     in
268 :     (CL.mkVar x, [CL.mkDecl(ty, x, SOME(CL.I_Exp exp))])
269 :     end
270 :     (* end case *))
271 :    
272 :     (* translate a print statement *)
273 :     fun trPrint (env, tys, args) = let
274 :     (* assemble the format string by analysing the types and argument expressions *)
275 :     fun mkFmt (Ty.StringTy, IL.E_Lit(Literal.String s), (stms, fmt, args)) =
276 :     (stms, s::fmt, args)
277 :     | mkFmt (ty, exp, (stms, fmt, args)) = let
278 :     fun mk (f, e) = (stms, f::fmt, e::args)
279 :     in
280 :     case ty
281 :     of Ty.BoolTy => mk(
282 :     "%s",
283 :     CL.mkCond(trExp(env, exp), CL.mkStr "true", CL.mkStr "false"))
284 :     | Ty.StringTy => mk("%s", trExp(env, exp))
285 :     | Ty.IntTy => mk(!N.gIntFormat, trExp(env, exp))
286 :     | Ty.TensorTy[] => mk("%f", trExp(env, exp))
287 :     | Ty.TensorTy[n] => let
288 :     val (x, stm) = expToVar (env, trType ty, "vec", exp)
289 :     val elems = List.tabulate (n, fn i => vecIndex (x, n, i))
290 :     val (fmt, args) = mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
291 :     in
292 :     (stm@stms, fmt, args)
293 :     end
294 :     (*
295 :     | Ty.TensorTy[n, m] =>
296 :     *)
297 :     | Ty.SeqTy(elemTy, n) => let
298 :     val (x, stm) = expToVar (env, trType ty, "vec", exp)
299 :     val elems = List.tabulate (n, fn i => ivecIndex (x, n, i))
300 :     val (fmt, args) = mkSeqFmt (elemTy, elems, fmt, args)
301 :     in
302 :     (stm@stms, fmt, args)
303 :     end
304 :     | _ => raise Fail(concat["TreeToC.trPrint(", Ty.toString ty, ")"])
305 :     (* end case *)
306 :     end
307 :     and mkElemFmt (elemTy, elem, (fmt, args)) = (case elemTy
308 :     of Ty.BoolTy =>
309 :     ("%s"::fmt, CL.mkCond(elem, CL.mkStr "true", CL.mkStr "false")::args)
310 :     | Ty.StringTy => ("%s"::fmt, elem::args)
311 :     | Ty.IntTy => (!N.gIntFormat::fmt, elem::args)
312 :     | Ty.TensorTy[] => ("%f"::fmt, elem::args)
313 :     | Ty.TensorTy[n] => let
314 :     val elems = List.tabulate (n, fn i => vecIndex (elem, n, i))
315 :     in
316 :     mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
317 :     end
318 :     (*
319 :     | Ty.TensorTy[n, m] =>
320 :     *)
321 :     | Ty.SeqTy(elemTy, n) => let
322 :     val elems = List.tabulate (n, fn i => ivecIndex (elem, n, i))
323 :     in
324 :     mkSeqFmt (elemTy, elems, fmt, args)
325 :     end
326 :     | _ => raise Fail(concat["TreeToC.mkElemFmt(", Ty.toString elemTy, ")"])
327 :     (* end case *))
328 :     and mkSeqFmt (elemTy, elems, fmt, args) = let
329 :     fun mk (elem, acc) = mkFmt(elemTy, elem, acc)
330 :     val (seqFmt, args) =
331 :     List.foldr
332 :     (fn (elem, acc) => mkElemFmt(elemTy, elem, acc))
333 :     ([], args) elems
334 :     in
335 :     ("<" :: String.concatWith "," seqFmt :: ">" :: fmt, args)
336 :     end
337 :     val (stms, fmt, args) = ListPair.foldr mkFmt ([], [], []) (tys, args)
338 :     val stm = CL.mkCall("fprintf", CL.mkVar "stderr" :: CL.mkStr(String.concat fmt) :: args)
339 :     in
340 :     List.rev (stm :: stms)
341 :     end
342 :    
343 :     fun trAssign (env, lhs, rhs) = (
344 :     (* certain rhs forms, such as those that return a matrix,
345 :     * require a function call instead of an assignment
346 :     *)
347 :     case rhs
348 :     of IL.E_Op(Op.Add(Ty.TensorTy[m,n]), args) =>
349 :     [CL.mkCall(N.addMat(m,n), lhs :: trExps(env, args))]
350 :     | IL.E_Op(Op.Sub(Ty.TensorTy[m,n]), args) =>
351 :     [CL.mkCall(N.subMat(m,n), lhs :: trExps(env, args))]
352 :     | IL.E_Op(Op.Neg(Ty.TensorTy[m,n]), args) =>
353 :     [CL.mkCall(N.scaleMat(m,n), lhs :: intExp ~1 :: trExps(env, args))]
354 :     | IL.E_Op(Op.Scale(Ty.TensorTy[m,n]), args) =>
355 :     [CL.mkCall(N.scaleMat(m,n), lhs :: trExps(env, args))]
356 :     | IL.E_Op(Op.MulMatMat(m,n,p), args) =>
357 :     [CL.mkCall(N.mulMatMat(m,n,p), lhs :: trExps(env, args))]
358 : jhr 1939 | IL.E_Op(Op.MulVecTen3(m, n, p), args) =>
359 :     if (1 < m) andalso (m <= 4) andalso (m = n) andalso (n = p)
360 :     then [CL.mkCall(N.mulVecTen3(m,n,p), lhs :: trExps(env, args))]
361 :     else raise Fail "unsupported vector-tensor multiply"
362 :     | IL.E_Op(Op.MulTen3Vec(m, n, p), args) =>
363 :     if (1 < m) andalso (m <= 4) andalso (m = n) andalso (n = p)
364 :     then [CL.mkCall(N.mulTen3Vec(m,n,p), lhs :: trExps(env, args))]
365 :     else raise Fail "unsupported tensor-vector multiply"
366 : jhr 1945 | IL.E_Op(Op.ColonMul(Ty.TensorTy dd1, Ty.TensorTy dd2), args) =>
367 : jhr 1958 if (length dd1 + length dd2 > 5)
368 :     then [CL.mkCall(N.colonMul(dd1, dd2), lhs :: trExps(env, args))]
369 :     else [CL.mkAssign(lhs, trExp(env, rhs))]
370 : jhr 1640 | IL.E_Op(Op.EigenVals2x2, [m]) => let
371 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
372 :     in
373 :     stms @ [CL.mkCall(N.evals2x2, [
374 :     lhs,
375 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
376 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
377 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
378 :     ])]
379 :     end
380 :     | IL.E_Op(Op.EigenVals3x3, [m]) => let
381 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
382 :     in
383 :     stms @ [CL.mkCall(N.evals3x3, [
384 :     lhs,
385 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
386 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
387 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
388 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
389 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
390 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
391 :     ])]
392 :     end
393 :     | IL.E_Op(Op.Identity n, args) =>
394 :     [CL.mkCall(N.identityMat n, [lhs])]
395 :     | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
396 :     [CL.mkCall(N.zeroMat(m,n), [lhs])]
397 : jhr 1958 | IL.E_Op(Op.TensorToWorldSpace(info, ty as Ty.TensorTy(_::_::_)), args) =>
398 : jhr 1640 [CL.mkCall(N.toWorldSpace ty, lhs :: trExps(env, args))]
399 :     | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>
400 :     if (n > 1)
401 :     then let
402 :     val stride = ImageInfo.stride info
403 :     val rTy = ImageInfo.sampleTy info
404 :     val vp = freshVar "vp"
405 :     val needsCast = (CL.T_Num rTy <> !N.gRealTy)
406 :     fun mkLoad i = let
407 :     val e = CL.mkSubscript(CL.mkVar vp, intExp(i*stride))
408 :     in
409 :     if needsCast then CL.mkCast(!N.gRealTy, e) else e
410 :     end
411 :     in [
412 :     CL.mkDecl(CL.T_Ptr(CL.T_Num rTy), vp, SOME(CL.I_Exp(trExp(env, a)))),
413 :     CL.mkAssign(lhs,
414 :     CL.mkApply(N.mkVec n, List.tabulate (n, mkLoad)))
415 :     ] end
416 :     else [CL.mkAssign(lhs, trExp(env, rhs))]
417 :     | IL.E_Cons(Ty.TensorTy[n,m], args) => let
418 :     (* matrices are represented as arrays of union<d><ty>_t vectors *)
419 :     fun doRows (_, []) = []
420 :     | doRows (i, e::es) =
421 :     CL.mkAssign(CL.mkSelect(CL.mkSubscript(lhs, intExp i), "v"), e)
422 :     :: doRows (i+1, es)
423 :     in
424 :     doRows (0, trExps(env, args))
425 :     end
426 : jhr 1797 | IL.E_Cons(Ty.TensorTy[n,m,l], args) => let
427 :     (* 3rd-order tensors are represented as 2D arrays of union<d><ty>_t vectors *)
428 :     fun lp1 (i, [], code) = code
429 :     | lp1 (i, e::es, code) = let
430 :     val lhs_i = CL.mkSubscript(lhs, intExp i)
431 :     fun lp2 j = if (j < m)
432 :     then CL.mkAssign(
433 :     CL.mkSelect(CL.mkSubscript(lhs_i, intExp j), "v"),
434 :     CL.mkSelect(CL.mkSubscript (e, intExp j), "v")
435 :     ) :: lp2(j+1)
436 :     else code
437 :     in
438 :     lp1 (i+1, es, lp2 0)
439 :     end
440 :     in
441 :     lp1 (0, trExps(env, args), [])
442 :     end
443 : jhr 1691 | IL.E_Cons(Ty.SeqTy(ty, n), args) => let
444 :     fun doAssign (_, []) = []
445 :     | doAssign (i, arg::args) =
446 :     CL.mkAssign(CL.mkSubscript(lhs, intExp i), arg) :: doAssign(i+1, args)
447 :     in
448 :     doAssign (0, trExps(env, args))
449 :     end
450 : jhr 1754 | IL.E_State x => (case IL.StateVar.ty x
451 :     of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueStateVar x])]
452 : jhr 1945 | Ty.TensorTy[n,m,l] => [CL.mkCall(N.copyTen3(n,m,l), [lhs, VarToC.rvalueStateVar x])]
453 : jhr 1754 | _ => [CL.mkAssign(lhs, VarToC.rvalueStateVar x)]
454 :     (* end case *))
455 : jhr 1640 | IL.E_Var x => (case IL.Var.ty x
456 :     of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueVar(env, x)])]
457 : jhr 1945 | Ty.TensorTy[n,m,l] => [CL.mkCall(N.copyTen3(n,m,l), [lhs, VarToC.rvalueVar(env, x)])]
458 : jhr 1640 | _ => [CL.mkAssign(lhs, VarToC.rvalueVar(env, x))]
459 :     (* end case *))
460 :     | _ => [CL.mkAssign(lhs, trExp(env, rhs))]
461 :     (* end case *))
462 :    
463 :     fun trMultiAssign (env, lhs, IL.E_Op(rator, args)) = (case (lhs, rator, args)
464 :     of ([vals, vecs], Op.EigenVecs2x2, [m]) => let
465 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
466 :     in
467 :     stms @ [CL.mkCall(N.evecs2x2, [
468 :     vals, vecs,
469 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
470 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
471 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
472 :     ])]
473 :     end
474 :     | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
475 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
476 :     in
477 :     stms @ [CL.mkCall(N.evecs3x3, [
478 :     vals, vecs,
479 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
480 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
481 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
482 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
483 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
484 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
485 :     ])]
486 :     end
487 :     | ([], Op.Print tys, args) => trPrint (env, tys, args)
488 :     | _ => raise Fail "bogus multi-assignment"
489 :     (* end case *))
490 :     | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"
491 :    
492 :     fun trLocals (env : env, locals) =
493 :     List.foldl
494 :     (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
495 :     env locals
496 :    
497 : jhr 1807 (* generate code to check the status of runtime-system calls; this code assumes that
498 :     * we are in a function with a boolean return type
499 :     *)
500 : jhr 1640 fun checkSts mkDecl = let
501 :     val sts = freshVar "sts"
502 :     in
503 :     mkDecl sts @
504 :     [CL.mkIfThen(
505 :     CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
506 : jhr 1807 CL.mkReturn(SOME(CL.mkVar "true")))]
507 : jhr 1640 end
508 :    
509 : jhr 1872 (* given the global initialization code, generate code to free the storage that is heap
510 :     * allocated for globals.
511 :     *)
512 :     fun trFree (env, IL.Block{locals, body}) = let
513 :     val env = trLocals (env, locals)
514 : nseltzer 1870 fun trStmt (env, stm) = (case stm
515 :     of IL.S_Comment text => [CL.mkComment text]
516 : jhr 2029 (* DEPRECATED
517 : nseltzer 1870 | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
518 :     val lhs = VarToC.lvalueVar (env, lhs)
519 :     val imgTy = CL.T_Named(N.imageTy dim)
520 :     val freeFn = N.freeImage dim
521 :     in [
522 :     CL.mkDecl(
523 :     CL.T_Named N.statusTy, sts,
524 :     SOME(CL.I_Exp(CL.E_Apply(freeFn, [
525 :     CL.mkCast(CL.T_Ptr(CL.T_Named "WorldPrefix_t"), CL.mkVar "wrld"),
526 :     addrOf lhs
527 :     ]))))
528 :     ] end)
529 : jhr 2007 *)
530 : jhr 2029 | IL.S_LoadNrrd _ => [] (* FIXME *)
531 : jhr 2023 | IL.S_InputNrrd _ => [] (* FIXME *)
532 : nseltzer 1870 | _ => []
533 :     (* end case *))
534 : jhr 1872 val stms = List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] body
535 : nseltzer 1870 fun mkDecl (x, stms) = (case V.Map.find (env, x)
536 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
537 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
538 :     (* end case *))
539 :     val stms = List.foldr mkDecl stms locals
540 :     in
541 :     CL.mkBlock stms
542 :     end
543 :    
544 : jhr 1640 fun trStms (env, stms) = let
545 :     fun trStmt (env, stm) = (case stm
546 :     of IL.S_Comment text => [CL.mkComment text]
547 :     | IL.S_Assign([x], exp) => trAssign (env, VarToC.lvalueVar (env, x), exp)
548 :     | IL.S_Assign(xs, exp) =>
549 :     trMultiAssign (env, List.map (fn x => VarToC.lvalueVar (env, x)) xs, exp)
550 :     | IL.S_IfThen(cond, thenBlk) =>
551 :     [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))]
552 :     | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
553 :     [CL.mkIfThenElse(trExp(env, cond),
554 :     trBlk(env, thenBlk),
555 :     trBlk(env, elseBlk))]
556 :     | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
557 :     | IL.S_Save([x], exp) => trAssign (env, VarToC.lvalueStateVar x, exp)
558 :     | IL.S_Save(xs, exp) =>
559 :     trMultiAssign (env, List.map VarToC.lvalueStateVar xs, exp)
560 : jhr 2007 (* DEPRECATED
561 : jhr 1640 | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
562 :     val lhs = VarToC.lvalueVar (env, lhs)
563 :     val name = trExp(env, name)
564 :     val imgTy = CL.T_Named(N.imageTy dim)
565 :     val loadFn = N.loadImage dim
566 :     in [
567 :     CL.mkDecl(
568 :     CL.T_Named N.statusTy, sts,
569 : jhr 1807 SOME(CL.I_Exp(CL.E_Apply(loadFn, [
570 :     CL.mkCast(CL.T_Ptr(CL.T_Named "WorldPrefix_t"), CL.mkVar "wrld"),
571 :     name, addrOf lhs
572 :     ]))))
573 : jhr 1640 ] end)
574 : jhr 2007 *)
575 : jhr 2033 | IL.S_LoadNrrd(lhs, Ty.DynSeqTy ty, nrrd) => let
576 :     val lhs = VarToC.lvalueVar (env, lhs)
577 :     val (nDims, dimInit, dimExp, elemTy) = (case ty
578 :     of Ty.TensorTy(dims as _::_) => let
579 :     val nDims = List.length dims
580 :     fun lp (_, [], init) = CL.I_Array(List.rev init)
581 :     | lp (i, d::dd, init) =
582 :     lp(i+1, dd, (i, CL.I_Exp(CL.mkInt(IntInf.fromInt d)))::init)
583 :     val dimInit = CL.mkDecl(
584 :     CL.T_Ptr(CL.T_Named "unsigned int"), "_dims",
585 :     SOME(lp(0, dims, [])))
586 :     in
587 :     (nDims, [dimInit], CL.mkVar "_dims", Ty.TensorTy[])
588 :     end
589 :     | Ty.SeqTy ty' => raise Fail "type not supported yet"
590 :     | _ => (0, [], CL.mkInt 0, ty)
591 :     (* end case *))
592 :     val loadFn = N.loadDynSeqFromFile elemTy
593 :     in [CL.mkBlock (
594 : jhr 2037 dimInit @ [
595 :     CL.mkAssign(
596 :     lhs,
597 :     CL.E_Apply(loadFn, [
598 :     CL.mkCast(CL.T_Ptr(CL.T_Named "WorldPrefix_t"), CL.mkVar "wrld"),
599 :     CL.mkStr nrrd,
600 :     CL.mkInt(IntInf.fromInt nDims),
601 :     dimExp
602 :     ])),
603 :     CL.mkIfThen(
604 :     CL.mkBinOp(lhs, CL.#==, CL.mkInt 0),
605 :     CL.mkReturn(SOME(CL.mkVar "true")))
606 :     ]
607 : jhr 2033 )] end
608 : jhr 2029 | IL.S_LoadNrrd(lhs, Ty.ImageTy info, nrrd) => checkSts (fn sts => let
609 :     val lhs = VarToC.lvalueVar (env, lhs)
610 :     val name = CL.E_Str nrrd
611 :     val dim = ImageInfo.dim info
612 :     val imgTy = CL.T_Named(N.imageTy dim)
613 :     val loadFn = N.loadImage dim
614 :     in [
615 :     CL.mkDecl(
616 :     CL.T_Named N.statusTy, sts,
617 :     SOME(CL.I_Exp(CL.E_Apply(loadFn, [
618 :     CL.mkCast(CL.T_Ptr(CL.T_Named "WorldPrefix_t"), CL.mkVar "wrld"),
619 :     name, addrOf lhs
620 :     ]))))
621 :     ] end)
622 : jhr 1803 | IL.S_Input(_, _, _, NONE) => []
623 :     | IL.S_Input(lhs, name, _, SOME dflt) => [
624 :     CL.mkAssign(VarToC.lvalueVar(env, lhs), trExp(env, dflt))
625 :     ]
626 : jhr 2023 | IL.S_InputNrrd _ => []
627 : jhr 1807 | IL.S_Exit args => []
628 : jhr 1640 | IL.S_Active => [CL.mkReturn(SOME(CL.mkVar N.kActive))]
629 :     | IL.S_Stabilize => [CL.mkReturn(SOME(CL.mkVar N.kStabilize))]
630 :     | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar N.kDie))]
631 :     (* end case *))
632 :     in
633 :     List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
634 :     end
635 :    
636 :     and trBlk (env, IL.Block{locals, body}) = let
637 :     val env = trLocals (env, locals)
638 :     val stms = trStms (env, body)
639 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
640 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
641 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
642 :     (* end case *))
643 :     val stms = List.foldr mkDecl stms locals
644 :     in
645 :     CL.mkBlock stms
646 :     end
647 :    
648 :     fun trFragment (env, IL.Block{locals, body}) = let
649 :     val env = trLocals (env, locals)
650 :     val stms = trStms (env, body)
651 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
652 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
653 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
654 :     (* end case *))
655 :     val stms = List.foldr mkDecl stms locals
656 :     in
657 :     (env, stms)
658 :     end
659 :    
660 :     val trBlock = trBlk
661 :    
662 :     end
663 : jhr 2048
664 :     (* FIXME: once we can consolidate the OpenCL and C backends, then we can get rid of the
665 :     * functor application.
666 :     *)
667 :     local
668 :     structure IL = TreeIL
669 :     structure V = IL.Var
670 :     structure CL = CLang
671 :     (* variable translation *)
672 :     structure TrVar =
673 :     struct
674 :     type env = CL.typed_var V.Map.map
675 :     fun lookup (env, x) = (case V.Map.find (env, x)
676 :     of SOME(CL.V(_, x')) => x'
677 :     | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
678 :     (* end case *))
679 :     (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
680 :     fun lvalueVar (env, x) = CL.mkVar(lookup(env, x))
681 :     (* translate a variable that occurs in an r-value context *)
682 :     fun rvalueVar (env, x) = CL.mkVar(lookup(env, x))
683 :     (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
684 :     fun lvalueVar (env, x) = (case V.kind x
685 :     of IL.VK_Local => CL.mkVar(lookup(env, x))
686 :     | _ => CL.mkIndirect(CL.mkVar "glob", lookup(env, x))
687 :     (* end case *))
688 :     (* translate a variable that occurs in an r-value context *)
689 :     fun rvalueVar (env, x) = (case V.kind x
690 :     of IL.VK_Local => CL.mkVar(lookup(env, x))
691 :     | _ => CL.mkIndirect(CL.mkVar "glob", lookup(env, x))
692 :     (* end case *))
693 :     (* translate a strand state variable that occurs in an l-value context *)
694 :     fun lvalueStateVar x = CL.mkIndirect(CL.mkVar "selfOut", IL.StateVar.name x)
695 :     (* translate a strand state variable that occurs in an r-value context *)
696 :     fun rvalueStateVar x = CL.mkIndirect(CL.mkVar "selfIn", IL.StateVar.name x)
697 :     end
698 :     in
699 :     structure TreeToC = TreeToCFn (TrVar)
700 :     end

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