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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2667 - (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 :     val trType : TreeIL.Ty.ty -> CLang.ty
27 :    
28 :     val trBlock : env * TreeIL.block -> CLang.stm
29 :    
30 :     val trFragment : env * TreeIL.block -> env * CLang.stm list
31 : cchiw 2646
32 : jhr 1640 val trExp : env * TreeIL.exp -> CLang.exp
33 : cchiw 2646
34 : cchiw 2662
35 : cchiw 2646
36 : cchiw 2662
37 : cchiw 2646
38 : jhr 1640 (* vector indexing support. Arguments are: vector, arity, index *)
39 :     val ivecIndex : CLang.exp * int * int -> CLang.exp
40 :     val vecIndex : CLang.exp * int * int -> CLang.exp
41 :    
42 :     end = struct
43 :    
44 :     structure CL = CLang
45 :     structure N = CNames
46 :     structure IL = TreeIL
47 :     structure Op = IL.Op
48 :     structure Ty = IL.Ty
49 :     structure V = IL.Var
50 : cchiw 2664
51 : jhr 1640 datatype var = datatype CLang.typed_var
52 :     type env = CLang.typed_var TreeIL.Var.Map.map
53 : cchiw 2628
54 :     val testing =1
55 :     fun pntTest str=(case testing
56 :     of 1=> (print(str);1)
57 :     | _ =>1
58 :     (*end case*))
59 :    
60 : jhr 1640 fun lookup (env, x) = (case V.Map.find (env, x)
61 :     of SOME(V(_, x')) => x'
62 :     | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
63 :     (* end case *))
64 :    
65 :     (* integer literal expression *)
66 :     fun intExp (i : int) = CL.mkInt(IntInf.fromInt i)
67 :    
68 : jhr 1923 fun addrOf e = CL.mkUnOp(CL.%&, e)
69 :    
70 : jhr 1640 (* translate TreeIL types to CLang types *)
71 :     fun trType ty = (case ty
72 :     of Ty.BoolTy => CLang.T_Named "bool"
73 :     | Ty.StringTy => CL.charPtr
74 :     | Ty.IntTy => !N.gIntTy
75 :     | Ty.TensorTy[] => !N.gRealTy
76 :     | Ty.TensorTy[n] => CL.T_Named(N.vecTy n)
77 :     | Ty.TensorTy[n, m] => CL.T_Named(N.matTy(n,m))
78 : cchiw 2646 | Ty.TensorTy e => CL.T_Named(N.tenTy e)
79 : jhr 1640 | Ty.SeqTy(Ty.IntTy, n) => CL.T_Named(N.ivecTy n)
80 :     | Ty.SeqTy(ty, n) => CL.T_Array(trType ty, SOME n)
81 :     | Ty.AddrTy(ImageInfo.ImgInfo{ty=(_, rTy), ...}) => CL.T_Ptr(CL.T_Num rTy)
82 :     | Ty.ImageTy(ImageInfo.ImgInfo{dim, ...}) => CL.T_Ptr(CL.T_Named(N.imageTy dim))
83 : cchiw 2665 | Ty.unionTy n => CL.T_Named(N.unionTy n )
84 : jhr 1640 | _ => raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])
85 :     (* end case *))
86 :    
87 :     (* generate new variables *)
88 :     local
89 :     val count = ref 0
90 :     fun freshName prefix = let
91 :     val n = !count
92 :     in
93 :     count := n+1;
94 :     concat[prefix, "_", Int.toString n]
95 :     end
96 :     in
97 :     fun tmpVar ty = freshName "tmp"
98 :     fun freshVar prefix = freshName prefix
99 :     end (* local *)
100 :    
101 :     (* translate IL basis functions *)
102 :     local
103 :     fun mkLookup suffix = let
104 : jhr 1923 val tbl = MathFuns.Tbl.mkTable (16, Fail "basis table")
105 :     fun ins f = MathFuns.Tbl.insert tbl (f, MathFuns.toString f ^ suffix)
106 : jhr 1640 in
107 : jhr 1923 List.app ins MathFuns.allFuns;
108 :     MathFuns.Tbl.lookup tbl
109 : jhr 1640 end
110 :     val fLookup = mkLookup "f"
111 :     val dLookup = mkLookup ""
112 :     in
113 :     fun trApply (f, args) = let
114 :     val f' = if !N.doublePrecision then dLookup f else fLookup f
115 :     in
116 :     CL.mkApply(f', args)
117 :     end
118 :     end (* local *)
119 :    
120 :     (* vector indexing support. Arguments are: vector, arity, index *)
121 :     fun ivecIndex (v, n, ix) = let
122 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gIntSuffix, "_t"])
123 :     val e1 = CL.mkCast(unionTy, v)
124 :     val e2 = CL.mkSelect(e1, "i")
125 :     in
126 :     CL.mkSubscript(e2, intExp ix)
127 :     end
128 :    
129 :     fun vecIndex (v, n, ix) = let
130 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gRealSuffix, "_t"])
131 :     val e1 = CL.mkCast(unionTy, v)
132 :     val e2 = CL.mkSelect(e1, "r")
133 :     in
134 :     CL.mkSubscript(e2, intExp ix)
135 :     end
136 :    
137 :     (* matrix indexing *)
138 :     fun matIndex (m, ix, jx) =
139 :     CL.mkSubscript(CL.mkSelect(CL.mkSubscript(m, ix), "r"), jx)
140 : cchiw 2667
141 :     fun matProj(m, ix) =
142 :     CL.mkSelect(CL.mkSubscript(m, ix), "r")
143 : jhr 1640
144 :     (* Translate a TreeIL operator application to a CLang expression *)
145 :     fun trOp (rator, args) = (case (rator, args)
146 : cchiw 2525 of (Op.IAdd , [a, b]) => CL.mkBinOp(a, CL.#+, b)
147 :     | (Op.ISub , [a, b]) => CL.mkBinOp(a, CL.#-, b)
148 :     | (Op.IMul , [a, b]) => CL.mkBinOp(a, CL.#*, b)
149 :     | (Op.IDiv , [a, b]) => CL.mkBinOp(a, CL.#/, b)
150 :     | (Op.INeg , [a]) => CL.mkUnOp(CL.%-, a)
151 : cchiw 2620 | (Op.addSca,[a,b]) => CL.mkBinOp(a, CL.#+, b)
152 :     | (Op.subSca, [a, b]) => CL.mkBinOp(a, CL.#-, b)
153 :     | (Op.prodSca, [a, b]) => CL.mkBinOp(a, CL.#*, b)
154 :     | (Op.divSca, [a, b]) => CL.mkBinOp(a, CL.#/, b)
155 : cchiw 2624 | (Op.subVec n,[a,b]) => CL.mkBinOp(a, CL.#-, b)
156 :     | (Op.addVec n,[a,b]) => CL.mkBinOp(a, CL.#+, b)
157 : cchiw 2664 | (Op.prodVec n,[a, b]) => CL.mkBinOp(a, CL.#*, b)
158 : cchiw 2623
159 : cchiw 2667 |(Op.Sqrt ,[a])=> CL.E_Sqrt a
160 :    
161 : cchiw 2664 (*Vector functions*)
162 :     | (Op.prodScaV d,args) => CL.E_Apply(N.NameScaV d, args)
163 :     | (Op.sumVec d,args) => CL.E_Apply(N.NameSumV d, args)
164 : cchiw 2665 | (Op.IndexTensor(_,Ty.TensorTy [], Ty.indexTy [i], Ty.TensorTy [argTy]),[a])=>
165 :     vecIndex (a, argTy, i)
166 : cchiw 2623
167 : cchiw 2667 | (Op.IndexTensor (_,Ty.TensorTy [_], Ty.indexTy [i],
168 :     Ty.TensorTy[_,_]),[m])=>matProj(m,intExp i)
169 :     | (Op.IndexTensor (_,Ty.TensorTy [], Ty.indexTy [i,j],
170 :     Ty.TensorTy[_,_]),[m])=>
171 :     matIndex (m, intExp i, intExp j)
172 : cchiw 2665
173 : cchiw 2667 | (Op.IndexTensor (_,rstTy, Ty.indexTy indexAt, argTy),args)=> raise Fail"higer tensor "
174 : cchiw 2665 (*
175 : cchiw 2615 | (Op.imgAddr of ImageInfo.info * ty * int
176 :     | (Op.imgLoad of ImageInfo.info * int * int
177 :    
178 :     *)
179 :    
180 : jhr 1640 | (Op.Abs(Ty.IntTy), args) => CL.mkApply("abs", args)
181 :     | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(N.fabs(), args)
182 :     | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
183 :     | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
184 : cchiw 2628 | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
185 :     | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
186 : jhr 1640 | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
187 :     | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
188 :     | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
189 :     | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
190 :     | (Op.Max, args) => CL.mkApply(N.max(), args)
191 :     | (Op.Min, args) => CL.mkApply(N.min(), args)
192 :     | (Op.Clamp(Ty.TensorTy[]), args) => CL.mkApply(N.clamp 1, args)
193 :     | (Op.Clamp(Ty.TensorTy[n]), args) => CL.mkApply(N.clamp n, args)
194 :     | (Op.Lerp ty, args) => (case ty
195 :     of Ty.TensorTy[] => CL.mkApply(N.lerp 1, args)
196 :     | Ty.TensorTy[n] => CL.mkApply(N.lerp n, args)
197 :     | _ => raise Fail(concat[
198 :     "lerp<", Ty.toString ty, "> not supported"
199 :     ])
200 :     (* end case *))
201 : cchiw 2525
202 :    
203 : cchiw 2667 (*
204 :     | (Op.Norm(Ty.TensorTy[n]), args) =>raise Fail "Norm Vector:should have been removed in mid-to-low"
205 :     | (Op.Norm(Ty.TensorTy[m,n]), args) => raise Fail "Norm Mat:should have been removed in mid-to-low"
206 : jhr 1640 | (Op.Normalize d, args) => CL.E_Apply(N.normalize d, args)
207 : cchiw 2667
208 :     *)
209 : cchiw 2525
210 : jhr 1640 | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
211 :     | (Op.Select(Ty.TupleTy tys, i), [a]) => raise Fail "Select unimplemented"
212 :     | (Op.Index(Ty.SeqTy(Ty.IntTy, n), i), [a]) => ivecIndex (a, n, i)
213 :     | (Op.Index(Ty.TensorTy[n], i), [a]) => vecIndex (a, n, i)
214 :     | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, ix]) => let
215 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gIntSuffix, "_t"])
216 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
217 :     in
218 :     CL.mkSubscript(vecExp, ix)
219 :     end
220 :     | (Op.Subscript(Ty.SeqTy(ty, n)), [v, ix]) => CL.mkSubscript(v, ix)
221 :     | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
222 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gRealSuffix, "_t"])
223 :     val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
224 :     in
225 :     CL.mkSubscript(vecExp, ix)
226 :     end
227 :     | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, jx]) => matIndex (m, ix, jx)
228 :     | (Op.Subscript ty, t::(ixs as _::_)) =>
229 :     raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
230 :     | (Op.Ceiling d, args) => CL.mkApply(N.addTySuffix("ceil", d), args)
231 :     | (Op.Floor d, args) => CL.mkApply(N.addTySuffix("floor", d), args)
232 :     | (Op.Round d, args) => CL.mkApply(N.addTySuffix("round", d), args)
233 :     | (Op.Trunc d, args) => CL.mkApply(N.addTySuffix("trunc", d), args)
234 :     | (Op.IntToReal, [a]) => CL.mkCast(!N.gRealTy, a)
235 :     | (Op.RealToInt 1, [a]) => CL.mkCast(!N.gIntTy, a)
236 :     | (Op.RealToInt d, args) => CL.mkApply(N.vecftoi d, args)
237 :     (* FIXME: need type info *)
238 :     | (Op.ImageAddress(ImageInfo.ImgInfo{ty=(_,rTy), ...}), [a]) => let
239 :     val cTy = CL.T_Ptr(CL.T_Num rTy)
240 :     in
241 :     CL.mkCast(cTy, CL.mkIndirect(a, "data"))
242 :     end
243 :     | (Op.LoadVoxels(info, 1), [a]) => let
244 :     val realTy as CL.T_Num rTy = !N.gRealTy
245 :     val a = CL.E_UnOp(CL.%*, a)
246 :     in
247 :     if (rTy = ImageInfo.sampleTy info)
248 :     then a
249 :     else CL.E_Cast(realTy, a)
250 :     end
251 :     | (Op.LoadVoxels _, [a]) =>
252 :     raise Fail("impossible " ^ Op.toString rator)
253 : cchiw 2525
254 : jhr 1640 | (Op.LoadImage info, [a]) =>
255 :     raise Fail("impossible " ^ Op.toString rator)
256 :     | (Op.Inside(ImageInfo.ImgInfo{dim, ...}, s), [pos, img]) =>
257 :     CL.mkApply(N.inside dim, [pos, img, intExp s])
258 :     | (Op.Input(ty, desc, name), []) =>
259 :     raise Fail("impossible " ^ Op.toString rator)
260 :     | (Op.InputWithDefault(ty, desc, name), [a]) =>
261 :     raise Fail("impossible " ^ Op.toString rator)
262 :     | _ => raise Fail(concat[
263 :     "unknown or incorrect operator ", Op.toString rator
264 :     ])
265 :     (* end case *))
266 :    
267 : cchiw 2664 fun trExp (env, e) = let
268 :     val CLExp=(case e
269 : jhr 1640 of IL.E_State x => VarToC.rvalueStateVar x
270 :     | IL.E_Var x => VarToC.rvalueVar (env, x)
271 :     | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !N.gIntTy)
272 :     | IL.E_Lit(Literal.Bool b) => CL.mkBool b
273 :     | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !N.gRealTy)
274 :     | IL.E_Lit(Literal.String s) => CL.mkStr s
275 :     | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
276 :     | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
277 : cchiw 2666 | IL.E_Cons(Ty.TensorTy[n], args) => CL.mkApply(N.mkVec n, trExps(env, args))
278 :     (*| IL.E_Cons(Ty.TensorTy[n], args) => CL.mkApply(N.NameConsVec n, trExps(env, args))*)
279 :    
280 : cchiw 2646 | IL.E_Cons(Ty.TensorTy e, args) => CL.mkApply(N.tenTy e,trExps(env, args))
281 : jhr 1640 | IL.E_Cons(ty, _) => raise Fail(concat["E_Cons(", Ty.toString ty, ", _) in expression"])
282 : cchiw 2664 | IL.E_mkVec( _, orig,_,args) =>
283 :     CL.mkApply(N.NameMkVec orig, trExps(env, args))
284 : cchiw 2665 | IL.E_LoadVec(n, orig, v,arg) =>
285 :     CL.mkApply(N.NameLdVec(n, orig), trExps(env, [v,arg]))
286 :     | IL.E_mkVecAligned( _, orig,_,args) =>
287 : cchiw 2666 CL.mkApply(N.NameMkVecA orig, trExps(env, args))
288 : cchiw 2665 | IL.E_LoadVecAligned(n, orig, v,arg) =>
289 : cchiw 2666 CL.mkApply(N.NameLdVecA(n, orig), trExps(env, [v,arg]) )
290 : cchiw 2665
291 : cchiw 2664 (* end case *))
292 : cchiw 2665 val _=print(CL.expToString CLExp)
293 : cchiw 2664 in
294 :     CLExp
295 :     end
296 : cchiw 2662
297 : cchiw 2628
298 : jhr 1640 and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
299 :    
300 :     (* translate an expression to a variable form; return the variable and the
301 :     * (optional) declaration.
302 :     *)
303 : cchiw 2628 fun expToVar (env, ty, name, exp) =let
304 :     val _=print "ExptoVar"
305 :     in (case trExp(env, exp)
306 : jhr 1640 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 : cchiw 2628 end
314 : jhr 1640
315 :     (* translate a print statement *)
316 :     fun trPrint (env, tys, args) = let
317 :     (* assemble the format string by analysing the types and argument expressions *)
318 :     fun mkFmt (Ty.StringTy, IL.E_Lit(Literal.String s), (stms, fmt, args)) =
319 :     (stms, s::fmt, args)
320 :     | mkFmt (ty, exp, (stms, fmt, args)) = let
321 :     fun mk (f, e) = (stms, f::fmt, e::args)
322 :     in
323 :     case ty
324 :     of Ty.BoolTy => mk(
325 :     "%s",
326 :     CL.mkCond(trExp(env, exp), CL.mkStr "true", CL.mkStr "false"))
327 :     | Ty.StringTy => mk("%s", trExp(env, exp))
328 :     | Ty.IntTy => mk(!N.gIntFormat, trExp(env, exp))
329 :     | Ty.TensorTy[] => mk("%f", trExp(env, exp))
330 :     | Ty.TensorTy[n] => let
331 :     val (x, stm) = expToVar (env, trType ty, "vec", exp)
332 :     val elems = List.tabulate (n, fn i => vecIndex (x, n, i))
333 :     val (fmt, args) = mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
334 :     in
335 :     (stm@stms, fmt, args)
336 :     end
337 :     (*
338 :     | Ty.TensorTy[n, m] =>
339 :     *)
340 :     | Ty.SeqTy(elemTy, n) => let
341 :     val (x, stm) = expToVar (env, trType ty, "vec", exp)
342 :     val elems = List.tabulate (n, fn i => ivecIndex (x, n, i))
343 :     val (fmt, args) = mkSeqFmt (elemTy, elems, fmt, args)
344 :     in
345 :     (stm@stms, fmt, args)
346 :     end
347 :     | _ => raise Fail(concat["TreeToC.trPrint(", Ty.toString ty, ")"])
348 :     (* end case *)
349 :     end
350 :     and mkElemFmt (elemTy, elem, (fmt, args)) = (case elemTy
351 :     of Ty.BoolTy =>
352 :     ("%s"::fmt, CL.mkCond(elem, CL.mkStr "true", CL.mkStr "false")::args)
353 :     | Ty.StringTy => ("%s"::fmt, elem::args)
354 :     | Ty.IntTy => (!N.gIntFormat::fmt, elem::args)
355 :     | Ty.TensorTy[] => ("%f"::fmt, elem::args)
356 :     | Ty.TensorTy[n] => let
357 :     val elems = List.tabulate (n, fn i => vecIndex (elem, n, i))
358 :     in
359 :     mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
360 :     end
361 :     (*
362 :     | Ty.TensorTy[n, m] =>
363 :     *)
364 :     | Ty.SeqTy(elemTy, n) => let
365 :     val elems = List.tabulate (n, fn i => ivecIndex (elem, n, i))
366 :     in
367 :     mkSeqFmt (elemTy, elems, fmt, args)
368 :     end
369 :     | _ => raise Fail(concat["TreeToC.mkElemFmt(", Ty.toString elemTy, ")"])
370 :     (* end case *))
371 :     and mkSeqFmt (elemTy, elems, fmt, args) = let
372 :     fun mk (elem, acc) = mkFmt(elemTy, elem, acc)
373 :     val (seqFmt, args) =
374 :     List.foldr
375 :     (fn (elem, acc) => mkElemFmt(elemTy, elem, acc))
376 :     ([], args) elems
377 :     in
378 :     ("<" :: String.concatWith "," seqFmt :: ">" :: fmt, args)
379 :     end
380 :     val (stms, fmt, args) = ListPair.foldr mkFmt ([], [], []) (tys, args)
381 :     val stm = CL.mkCall("fprintf", CL.mkVar "stderr" :: CL.mkStr(String.concat fmt) :: args)
382 :     in
383 :     List.rev (stm :: stms)
384 :     end
385 : cchiw 2525 (*Removed IADD, ISUB, INED, scale, MULT since they now only work on intergers*)
386 : jhr 1640 fun trAssign (env, lhs, rhs) = (
387 :     (* certain rhs forms, such as those that return a matrix,
388 :     * require a function call instead of an assignment
389 :     *)
390 :     case rhs
391 : cchiw 2525 of IL.E_Op(Op.EigenVals2x2, [m]) => let
392 : jhr 1640 val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
393 :     in
394 :     stms @ [CL.mkCall(N.evals2x2, [
395 :     lhs,
396 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
397 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
398 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
399 :     ])]
400 :     end
401 :     | IL.E_Op(Op.EigenVals3x3, [m]) => let
402 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
403 :     in
404 :     stms @ [CL.mkCall(N.evals3x3, [
405 :     lhs,
406 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
407 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
408 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
409 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
410 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
411 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
412 :     ])]
413 :     end
414 : cchiw 2628 | IL.E_Op(Op.Zero(Ty.TensorTy[n]), args) =>
415 :     [CL.mkCall(N.zeroVec(n), [lhs])]
416 :     | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
417 :     [CL.mkCall(N.zeroMat(m,n), [lhs])]
418 : jhr 1640 | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>
419 :     if (n > 1)
420 :     then let
421 :     val stride = ImageInfo.stride info
422 :     val rTy = ImageInfo.sampleTy info
423 :     val vp = freshVar "vp"
424 :     val needsCast = (CL.T_Num rTy <> !N.gRealTy)
425 :     fun mkLoad i = let
426 :     val e = CL.mkSubscript(CL.mkVar vp, intExp(i*stride))
427 :     in
428 :     if needsCast then CL.mkCast(!N.gRealTy, e) else e
429 :     end
430 :     in [
431 :     CL.mkDecl(CL.T_Ptr(CL.T_Num rTy), vp, SOME(CL.I_Exp(trExp(env, a)))),
432 :     CL.mkAssign(lhs,
433 :     CL.mkApply(N.mkVec n, List.tabulate (n, mkLoad)))
434 :     ] end
435 :     else [CL.mkAssign(lhs, trExp(env, rhs))]
436 :     | IL.E_Cons(Ty.TensorTy[n,m], args) => let
437 :     (* matrices are represented as arrays of union<d><ty>_t vectors *)
438 :     fun doRows (_, []) = []
439 :     | doRows (i, e::es) =
440 :     CL.mkAssign(CL.mkSelect(CL.mkSubscript(lhs, intExp i), "v"), e)
441 :     :: doRows (i+1, es)
442 :     in
443 :     doRows (0, trExps(env, args))
444 :     end
445 :     | IL.E_Var x => (case IL.Var.ty x
446 :     of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueVar(env, x)])]
447 :     | _ => [CL.mkAssign(lhs, VarToC.rvalueVar(env, x))]
448 :     (* end case *))
449 :     | _ => [CL.mkAssign(lhs, trExp(env, rhs))]
450 :     (* end case *))
451 :    
452 :     fun trMultiAssign (env, lhs, IL.E_Op(rator, args)) = (case (lhs, rator, args)
453 :     of ([vals, vecs], Op.EigenVecs2x2, [m]) => let
454 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
455 :     in
456 :     stms @ [CL.mkCall(N.evecs2x2, [
457 :     vals, vecs,
458 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
459 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
460 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
461 :     ])]
462 :     end
463 :     | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
464 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
465 :     in
466 :     stms @ [CL.mkCall(N.evecs3x3, [
467 :     vals, vecs,
468 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
469 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
470 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
471 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
472 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
473 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
474 :     ])]
475 :     end
476 :     | ([], Op.Print tys, args) => trPrint (env, tys, args)
477 :     | _ => raise Fail "bogus multi-assignment"
478 :     (* end case *))
479 :     | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"
480 :    
481 :     fun trLocals (env : env, locals) =
482 :     List.foldl
483 :     (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
484 :     env locals
485 :    
486 :     (* generate code to check the status of runtime-system calls *)
487 :     fun checkSts mkDecl = let
488 :     val sts = freshVar "sts"
489 :     in
490 :     mkDecl sts @
491 :     [CL.mkIfThen(
492 :     CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
493 :     CL.mkCall("exit", [intExp 1]))]
494 :     end
495 :    
496 :     fun trStms (env, stms) = let
497 : cchiw 2631 val _= pntTest "\n tree Stmt"
498 : cchiw 2637
499 :    
500 : jhr 1640 fun trStmt (env, stm) = (case stm
501 :     of IL.S_Comment text => [CL.mkComment text]
502 : cchiw 2666 | IL.S_Assign([x], exp) =>
503 :     trAssign (env, VarToC.lvalueVar (env, x), exp)
504 :     | IL.S_Mk(x, IL.E_mkVec( _, orig,_,args)) =>let
505 :     val CL.E_Var x' =VarToC.lvalueVar (env, x)
506 :     val exp=CL.mkApply(N.NameMkVec orig, [CL.E_Var (x')]@trExps(env, args))
507 :     in
508 :     [CL.S_Exp exp]
509 :     end
510 : cchiw 2631
511 : cchiw 2666 | IL.S_Mk(x, IL.E_mkVecAligned( _, orig,_,args)) =>let
512 :     val CL.E_Var x' =VarToC.lvalueVar (env, x)
513 : cchiw 2637
514 : cchiw 2666 val exp=CL.mkApply(N.NameMkVecA orig, [CL.E_Var( x')]@trExps(env, args))
515 :     val s=CL.S_Exp exp
516 :    
517 : cchiw 2628 in
518 : cchiw 2666 [s]
519 : cchiw 2628 end
520 : jhr 1640 | IL.S_Assign(xs, exp) =>
521 : cchiw 2628 (trMultiAssign (env, List.map (fn x => VarToC.lvalueVar (env, x)) xs, exp))
522 : jhr 1640 | IL.S_IfThen(cond, thenBlk) =>
523 :     [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))]
524 :     | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
525 :     [CL.mkIfThenElse(trExp(env, cond),
526 :     trBlk(env, thenBlk),
527 :     trBlk(env, elseBlk))]
528 :     | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
529 :     | IL.S_Save([x], exp) => trAssign (env, VarToC.lvalueStateVar x, exp)
530 :     | IL.S_Save(xs, exp) =>
531 :     trMultiAssign (env, List.map VarToC.lvalueStateVar xs, exp)
532 :     | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
533 :     val lhs = VarToC.lvalueVar (env, lhs)
534 :     val name = trExp(env, name)
535 :     val imgTy = CL.T_Named(N.imageTy dim)
536 :     val loadFn = N.loadImage dim
537 :     in [
538 :     CL.mkDecl(
539 :     CL.T_Named N.statusTy, sts,
540 :     SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, lhs)]))))
541 :     ] end)
542 :     | IL.S_Input(lhs, name, desc, optDflt) => let
543 :     val inputFn = N.input(V.ty lhs)
544 :     val lhs = VarToC.lvalueVar (env, lhs)
545 :     val (initCode, hasDflt) = (case optDflt
546 :     of SOME e => ([CL.mkAssign(lhs, trExp(env, e))], true)
547 :     | NONE => ([], false)
548 :     (* end case *))
549 :     val code = [CL.mkCall(inputFn, [
550 :     CL.mkVar "opts",
551 :     CL.mkStr name,
552 :     CL.mkStr desc,
553 :     CL.mkUnOp(CL.%&, lhs),
554 :     CL.mkBool hasDflt])]
555 :     in
556 :     initCode @ code
557 :     end
558 :     | IL.S_Exit args => [CL.mkReturn NONE]
559 :     | IL.S_Active => [CL.mkReturn(SOME(CL.mkVar N.kActive))]
560 :     | IL.S_Stabilize => [CL.mkReturn(SOME(CL.mkVar N.kStabilize))]
561 :     | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar N.kDie))]
562 :     (* end case *))
563 : cchiw 2628
564 :    
565 :     val r=List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
566 : cchiw 2637 (* val _= gT.prnTy("FinalTypes",!items)
567 :     *)
568 : cchiw 2628 in r
569 : jhr 1640 end
570 :    
571 :     and trBlk (env, IL.Block{locals, body}) = let
572 : cchiw 2628
573 : jhr 1640 val env = trLocals (env, locals)
574 :     val stms = trStms (env, body)
575 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
576 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
577 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
578 :     (* end case *))
579 : cchiw 2628
580 : jhr 1640 val stms = List.foldr mkDecl stms locals
581 : cchiw 2628
582 : jhr 1640 in
583 :     CL.mkBlock stms
584 :     end
585 :    
586 :     fun trFragment (env, IL.Block{locals, body}) = let
587 :     val env = trLocals (env, locals)
588 : cchiw 2628 val _= print "\n tree Fragment"
589 : jhr 1640 val stms = trStms (env, body)
590 : cchiw 2628
591 : jhr 1640 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 :     (env, stms)
598 :     end
599 :    
600 : cchiw 2662
601 :    
602 : jhr 1640 val trBlock = trBlk
603 :    
604 :     end

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