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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2820 - (view) (download)

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

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