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

Parent Directory | Revision Log

---

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

---

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