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 2687 - (view) (download)

1 : cchiw 2668
2 : jhr 1640 (* tree-to-c.sml
3 : cchiw 2668 *WQE
4 : jhr 1640 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
5 :     * All rights reserved.
6 :     *
7 :     * Translate TreeIL to the C version of CLang.
8 :     *)
9 :    
10 :     signature TREE_VAR_TO_C =
11 :     sig
12 :     type env = CLang.typed_var TreeIL.Var.Map.map
13 :     (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
14 :     val lvalueVar : env * TreeIL.var -> CLang.exp
15 :     (* translate a variable that occurs in a r-value context *)
16 :     val rvalueVar : env * TreeIL.var -> CLang.exp
17 :     (* translate a strand state variable that occurs in an l-value context *)
18 :     val lvalueStateVar : TreeIL.state_var -> CLang.exp
19 :     (* translate a strand state variable that occurs in a r-value context *)
20 :     val rvalueStateVar : TreeIL.state_var -> CLang.exp
21 :     end
22 :    
23 :     functor TreeToCFn (VarToC : TREE_VAR_TO_C) : sig
24 :    
25 :     type env = CLang.typed_var TreeIL.Var.Map.map
26 :    
27 :     val trType : TreeIL.Ty.ty -> CLang.ty
28 : cchiw 2668 (* val restType : TreeIL.Ty.ty -> CLang.ty*)
29 : jhr 1640
30 :     val trBlock : env * TreeIL.block -> CLang.stm
31 :    
32 :     val trFragment : env * TreeIL.block -> env * CLang.stm list
33 : cchiw 2668
34 : jhr 1640 val trExp : env * TreeIL.exp -> CLang.exp
35 : cchiw 2646
36 : cchiw 2662
37 : cchiw 2646
38 : cchiw 2662
39 : cchiw 2646
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 : cchiw 2671 val prntArr : CLang.exp * int -> CLang.exp
44 : jhr 1640
45 :     end = struct
46 :    
47 :     structure CL = CLang
48 :     structure N = CNames
49 :     structure IL = TreeIL
50 :     structure Op = IL.Op
51 :     structure Ty = IL.Ty
52 :     structure V = IL.Var
53 : cchiw 2664
54 : jhr 1640 datatype var = datatype CLang.typed_var
55 :     type env = CLang.typed_var TreeIL.Var.Map.map
56 : cchiw 2628
57 :     val testing =1
58 :     fun pntTest str=(case testing
59 :     of 1=> (print(str);1)
60 :     | _ =>1
61 :     (*end case*))
62 : cchiw 2680
63 :     val treetesting=0
64 :     fun pnttreeTest str=(case treetesting
65 :     of 1=> (print(str);1)
66 :     | _ =>1
67 :     (*end case*))
68 :    
69 :    
70 : jhr 1640 fun lookup (env, x) = (case V.Map.find (env, x)
71 :     of SOME(V(_, x')) => x'
72 :     | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
73 :     (* end case *))
74 :    
75 :     (* integer literal expression *)
76 :     fun intExp (i : int) = CL.mkInt(IntInf.fromInt i)
77 :    
78 : jhr 1923 fun addrOf e = CL.mkUnOp(CL.%&, e)
79 :    
80 : cchiw 2669
81 : jhr 1640 (* translate TreeIL types to CLang types *)
82 :     fun trType ty = (case ty
83 :     of Ty.BoolTy => CLang.T_Named "bool"
84 :     | Ty.StringTy => CL.charPtr
85 :     | Ty.IntTy => !N.gIntTy
86 :     | Ty.TensorTy[] => !N.gRealTy
87 : cchiw 2668 | Ty.TensorTy t =>CL.mkRealArr(N.tprog ,t)
88 : jhr 1640 | Ty.SeqTy(Ty.IntTy, n) => CL.T_Named(N.ivecTy n)
89 :     | Ty.SeqTy(ty, n) => CL.T_Array(trType ty, SOME n)
90 :     | Ty.AddrTy(ImageInfo.ImgInfo{ty=(_, rTy), ...}) => CL.T_Ptr(CL.T_Num rTy)
91 :     | Ty.ImageTy(ImageInfo.ImgInfo{dim, ...}) => CL.T_Ptr(CL.T_Named(N.imageTy dim))
92 : cchiw 2665 | Ty.unionTy n => CL.T_Named(N.unionTy n )
93 : cchiw 2680
94 :     | _ => (*raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])*) CL.T_Named "unknown"
95 : jhr 1640 (* end case *))
96 :    
97 : cchiw 2668 (*TypeDef Struct*)
98 :    
99 : jhr 1640 (* generate new variables *)
100 :     local
101 :     val count = ref 0
102 :     fun freshName prefix = let
103 :     val n = !count
104 :     in
105 :     count := n+1;
106 :     concat[prefix, "_", Int.toString n]
107 :     end
108 :     in
109 :     fun tmpVar ty = freshName "tmp"
110 :     fun freshVar prefix = freshName prefix
111 :     end (* local *)
112 :    
113 :     (* translate IL basis functions *)
114 :     local
115 :     fun mkLookup suffix = let
116 : jhr 1923 val tbl = MathFuns.Tbl.mkTable (16, Fail "basis table")
117 :     fun ins f = MathFuns.Tbl.insert tbl (f, MathFuns.toString f ^ suffix)
118 : jhr 1640 in
119 : jhr 1923 List.app ins MathFuns.allFuns;
120 :     MathFuns.Tbl.lookup tbl
121 : jhr 1640 end
122 :     val fLookup = mkLookup "f"
123 :     val dLookup = mkLookup ""
124 :     in
125 :     fun trApply (f, args) = let
126 :     val f' = if !N.doublePrecision then dLookup f else fLookup f
127 :     in
128 :     CL.mkApply(f', args)
129 :     end
130 :     end (* local *)
131 :    
132 :     (* vector indexing support. Arguments are: vector, arity, index *)
133 :     fun ivecIndex (v, n, ix) = let
134 : cchiw 2668 val unionTy = CL.T_Named(concat["kittenunion", Int.toString n, !N.gIntSuffix, "_t"])
135 : jhr 1640 val e1 = CL.mkCast(unionTy, v)
136 :     val e2 = CL.mkSelect(e1, "i")
137 :     in
138 :     CL.mkSubscript(e2, intExp ix)
139 :     end
140 :    
141 :     fun vecIndex (v, n, ix) = let
142 : cchiw 2668 val unionTy = CL.T_Named(concat["Yellowunion", Int.toString n, !N.gRealSuffix, "_t"])
143 : jhr 1640 val e1 = CL.mkCast(unionTy, v)
144 :     val e2 = CL.mkSelect(e1, "r")
145 :     in
146 :     CL.mkSubscript(e2, intExp ix)
147 :     end
148 :    
149 : cchiw 2668
150 :     (*prnt arrays *)
151 : cchiw 2671 fun prntArr(v,ix)= CL.mkSubscript(v, intExp ix)
152 :    
153 :     (*prnt Matrix*)
154 :     (*v[indexAtY,indexAtX]::Ty[argTyY,argTyX]*)
155 :     fun prntMat(v,indexAtY,indexAtX,argTyY, argTyX)=let
156 :     val ix=argTyX* indexAtY+indexAtX
157 :     in
158 : cchiw 2668 CL.mkSubscript(v, intExp ix)
159 : cchiw 2671 end
160 : cchiw 2668
161 :    
162 :    
163 : jhr 1640 (* matrix indexing *)
164 :     fun matIndex (m, ix, jx) =
165 : cchiw 2669 (* CL.mkSubscript(CL.mkSelect(CL.mkSubscript(m, ix), "r"), jx)*)
166 :    
167 :     CL.mkSubscript(CL.mkSubscript(m, ix), jx)
168 :    
169 : cchiw 2676
170 : cchiw 2667 fun matProj(m, ix) =
171 :     CL.mkSelect(CL.mkSubscript(m, ix), "r")
172 : jhr 1640
173 : cchiw 2680
174 :    
175 : jhr 1640 (* Translate a TreeIL operator application to a CLang expression *)
176 :     fun trOp (rator, args) = (case (rator, args)
177 : cchiw 2525 of (Op.IAdd , [a, b]) => CL.mkBinOp(a, CL.#+, b)
178 :     | (Op.ISub , [a, b]) => CL.mkBinOp(a, CL.#-, b)
179 :     | (Op.IMul , [a, b]) => CL.mkBinOp(a, CL.#*, b)
180 :     | (Op.IDiv , [a, b]) => CL.mkBinOp(a, CL.#/, b)
181 :     | (Op.INeg , [a]) => CL.mkUnOp(CL.%-, a)
182 : cchiw 2620 | (Op.addSca,[a,b]) => CL.mkBinOp(a, CL.#+, b)
183 :     | (Op.subSca, [a, b]) => CL.mkBinOp(a, CL.#-, b)
184 :     | (Op.prodSca, [a, b]) => CL.mkBinOp(a, CL.#*, b)
185 :     | (Op.divSca, [a, b]) => CL.mkBinOp(a, CL.#/, b)
186 : cchiw 2671 | (Op.subVec _,[a,b]) => CL.mkBinOp(a, CL.#-, b)
187 :     | (Op.addVec _,[a,b]) => CL.mkBinOp(a, CL.#+, b)
188 :     | (Op.prodVec _,[a, b]) => CL.mkBinOp(a, CL.#*, b)
189 :     | (Op.Sqrt ,[a]) => CL.E_Sqrt a
190 : cchiw 2623
191 : cchiw 2664 (*Vector functions*)
192 :     | (Op.prodScaV d,args) => CL.E_Apply(N.NameScaV d, args)
193 :     | (Op.sumVec d,args) => CL.E_Apply(N.NameSumV d, args)
194 : cchiw 2680 | (Op.dotVec d,args) => CL.E_Apply(N.NameDotV d, args)
195 : cchiw 2665
196 : cchiw 2680
197 : cchiw 2671 (*INDEX A VECTOR->SCALAR *)
198 : cchiw 2680 | (Op.IndexTensor(_,Ty.TensorTy [],Ty.indexTy [i], Ty.TensorTy [_]),[a])
199 : cchiw 2671 => prntArr(a,i) (*vecIndex (a, argTy, i)*)
200 : cchiw 2680 | (Op.IndexTensor(_,Ty.TensorTy [],Ty.indexTy [i], Ty.SeqTy _),[a])
201 :     => prntArr(a,i) (*vecIndex (a, argTy, i)*)
202 : cchiw 2671
203 : cchiw 2680
204 : cchiw 2671 (*INDEX A MATRIX-> VECTOR*)
205 : cchiw 2680 (* Is now removed at the Low-Tree-IL Stage*)
206 : cchiw 2671 | (Op.IndexTensor (_,Ty.TensorTy [_], Ty.indexTy [i], Ty.TensorTy[argTyY,argTyX]),[m])
207 : cchiw 2680 => matProj(m,intExp i)
208 :     (*=> CL.E_Str "s"*)
209 : cchiw 2671 (*INDEX A MATRIX ->SCALAR*)
210 :     | (Op.IndexTensor (_,Ty.TensorTy [], Ty.indexTy [i,j], Ty.TensorTy[argTyY,argTyX]),[m])
211 :     => prntMat(m,i,j,argTyY, argTyX) (* matIndex (m, intExp i, intExp j)*)
212 :    
213 : cchiw 2667 | (Op.IndexTensor (_,rstTy, Ty.indexTy indexAt, argTy),args)=> raise Fail"higer tensor "
214 : cchiw 2680
215 :    
216 :    
217 :     (*Image related operators*)
218 :     | (Op.baseAddr(ImageInfo.ImgInfo{ty=(_,rTy), ...}) ,[a])=> let
219 :     val cTy = CL.T_Ptr(CL.T_Num rTy)
220 :     in
221 :     CL.mkCast(cTy, CL.mkIndirect(a, "data"))
222 :     end
223 :     | (Op.baseAddr _,_)=> CL.mkBinOp(CL.E_Str"baseString", CL.#-, CL.E_Str"none")
224 :     | (Op.imgAddr(Vinfo,indexAtTy, dim), [base,a,b])=>
225 :    
226 :     CL.mkBinOp(base, CL.#+, CL.mkBinOp(b, CL.#+, CL.mkBinOp(CL.mkInt 77, CL.#*, a)))
227 :    
228 :     | (Op.imgLoad(Vinfo ,dim, nlength),[addr])=>
229 :    
230 :     (*CL.E_Indirect (addr,"shoud load image")*)
231 :     let
232 :     val realTy as CL.T_Num rTy = !N.gRealTy
233 :     val a = CL.E_UnOp(CL.%*, addr)
234 :     in
235 :     (*if (rTy = ImageInfo.sampleTy Vinfo)
236 :     then a
237 :     else CL.E_Cast(realTy, addr)*) a
238 :     end
239 :    
240 :     | (Op.Transform(ImageInfo.ImgInfo{ty=(_,rTy), ...}),[a])=> let
241 :    
242 :     val cTy = CL.T_Ptr(CL.T_Num rTy)
243 :     in
244 :     (*CL.mkCast(cTy, *)(CL.mkIndirect(a, "w2i"))
245 :     end
246 :     | (Op.Translate(ImageInfo.ImgInfo{ty=(_,rTy), ...}),[a])=> (* "Vinfo-Translate"*)
247 :     let
248 :    
249 :     val cTy = CL.T_Ptr(CL.T_Num rTy)
250 :     in
251 :     CL.mkCast(cTy, CL.mkIndirect(a, "tVec"))
252 :     end
253 :    
254 :    
255 :    
256 : jhr 1640 | (Op.Abs(Ty.IntTy), args) => CL.mkApply("abs", args)
257 :     | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(N.fabs(), args)
258 :     | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
259 :     | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
260 : cchiw 2628 | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
261 :     | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
262 : jhr 1640 | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
263 :     | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
264 :     | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
265 :     | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
266 :     | (Op.Max, args) => CL.mkApply(N.max(), args)
267 :     | (Op.Min, args) => CL.mkApply(N.min(), args)
268 :     | (Op.Clamp(Ty.TensorTy[]), args) => CL.mkApply(N.clamp 1, args)
269 :     | (Op.Clamp(Ty.TensorTy[n]), args) => CL.mkApply(N.clamp n, args)
270 :     | (Op.Lerp ty, args) => (case ty
271 :     of Ty.TensorTy[] => CL.mkApply(N.lerp 1, args)
272 :     | Ty.TensorTy[n] => CL.mkApply(N.lerp n, args)
273 :     | _ => raise Fail(concat[
274 :     "lerp<", Ty.toString ty, "> not supported"
275 :     ])
276 :     (* end case *))
277 : cchiw 2525
278 : jhr 1640 | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
279 :     | (Op.Select(Ty.TupleTy tys, i), [a]) => raise Fail "Select unimplemented"
280 :     | (Op.Index(Ty.SeqTy(Ty.IntTy, n), i), [a]) => ivecIndex (a, n, i)
281 : cchiw 2669 | (Op.Index(Ty.TensorTy[n], i), [a]) => vecIndex (a, n, i)
282 : jhr 1640 | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, ix]) => let
283 : cchiw 2668 val unionTy = CL.T_Named(concat["Squishunion", Int.toString n, !N.gIntSuffix, "_t"])
284 : jhr 1640 val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
285 :     in
286 :     CL.mkSubscript(vecExp, ix)
287 :     end
288 :     | (Op.Subscript(Ty.SeqTy(ty, n)), [v, ix]) => CL.mkSubscript(v, ix)
289 :     | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
290 : cchiw 2668 val unionTy = CL.T_Named(concat["Onionunion", Int.toString n, !N.gRealSuffix, "_t"])
291 : jhr 1640 val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
292 :     in
293 :     CL.mkSubscript(vecExp, ix)
294 :     end
295 :     | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, jx]) => matIndex (m, ix, jx)
296 :     | (Op.Subscript ty, t::(ixs as _::_)) =>
297 :     raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
298 :     | (Op.Ceiling d, args) => CL.mkApply(N.addTySuffix("ceil", d), args)
299 : cchiw 2680 | (Op.Floor d, args) => CL.mkApply(N.NameFloorV d, args)
300 : jhr 1640 | (Op.Round d, args) => CL.mkApply(N.addTySuffix("round", d), args)
301 :     | (Op.Trunc d, args) => CL.mkApply(N.addTySuffix("trunc", d), args)
302 :     | (Op.IntToReal, [a]) => CL.mkCast(!N.gRealTy, a)
303 :     | (Op.RealToInt 1, [a]) => CL.mkCast(!N.gIntTy, a)
304 :     | (Op.RealToInt d, args) => CL.mkApply(N.vecftoi d, args)
305 :     (* FIXME: need type info *)
306 : cchiw 2680
307 :     (*Replaced with baseAddr operator
308 : jhr 1640 | (Op.ImageAddress(ImageInfo.ImgInfo{ty=(_,rTy), ...}), [a]) => let
309 :     val cTy = CL.T_Ptr(CL.T_Num rTy)
310 :     in
311 :     CL.mkCast(cTy, CL.mkIndirect(a, "data"))
312 :     end
313 : cchiw 2680 *)
314 : jhr 1640 | (Op.LoadVoxels(info, 1), [a]) => let
315 :     val realTy as CL.T_Num rTy = !N.gRealTy
316 :     val a = CL.E_UnOp(CL.%*, a)
317 :     in
318 :     if (rTy = ImageInfo.sampleTy info)
319 :     then a
320 :     else CL.E_Cast(realTy, a)
321 :     end
322 :     | (Op.LoadVoxels _, [a]) =>
323 :     raise Fail("impossible " ^ Op.toString rator)
324 : cchiw 2680
325 :    
326 :    
327 : cchiw 2525
328 : cchiw 2680
329 : jhr 1640 | (Op.Inside(ImageInfo.ImgInfo{dim, ...}, s), [pos, img]) =>
330 :     CL.mkApply(N.inside dim, [pos, img, intExp s])
331 :     | (Op.Input(ty, desc, name), []) =>
332 :     raise Fail("impossible " ^ Op.toString rator)
333 :     | (Op.InputWithDefault(ty, desc, name), [a]) =>
334 :     raise Fail("impossible " ^ Op.toString rator)
335 :     | _ => raise Fail(concat[
336 : cchiw 2680 "---yyy--unknown or incorrect operator ", Op.toString rator
337 : jhr 1640 ])
338 :     (* end case *))
339 : cchiw 2680
340 : cchiw 2664 fun trExp (env, e) = let
341 : cchiw 2680 val _= pnttreeTest( String.concat["\n \t ********calling tr exp ",IL.toString e,"end tr exp\n "])
342 : cchiw 2664 val CLExp=(case e
343 : jhr 1640 of IL.E_State x => VarToC.rvalueStateVar x
344 :     | IL.E_Var x => VarToC.rvalueVar (env, x)
345 :     | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !N.gIntTy)
346 :     | IL.E_Lit(Literal.Bool b) => CL.mkBool b
347 :     | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !N.gRealTy)
348 : cchiw 2668 (*used for cons *)
349 : jhr 1640 | IL.E_Lit(Literal.String s) => CL.mkStr s
350 :     | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
351 :     | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
352 : cchiw 2666
353 : cchiw 2668 (* N.mkVec n,N.NameConsVec n*)
354 :    
355 : cchiw 2646 | IL.E_Cons(Ty.TensorTy e, args) => CL.mkApply(N.tenTy e,trExps(env, args))
356 : cchiw 2669
357 : cchiw 2680
358 : jhr 1640 | IL.E_Cons(ty, _) => raise Fail(concat["E_Cons(", Ty.toString ty, ", _) in expression"])
359 : cchiw 2676
360 : cchiw 2680 | IL.E_LoadArr(aligned,n, orig, v,arg) =>
361 : cchiw 2681 CL.mkApply(N.NameLd(aligned,n,orig,true), trExps(env, [v,arg]))
362 : cchiw 2687 | IL.E_Mux(pieces,ops,_)=> CL.mkApply(N.NameMux , trExps(env, ops))
363 :    
364 : cchiw 2681
365 :    
366 :     (* | _=>raise Fail (String.concat["un matched expression",(IL.toString e)])*)
367 : cchiw 2664 (* end case *))
368 : cchiw 2680 val _=pntTest(CL.expToString CLExp)
369 : cchiw 2664 in
370 :     CLExp
371 :     end
372 : cchiw 2662
373 : cchiw 2628
374 : jhr 1640 and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
375 :    
376 : cchiw 2680
377 : cchiw 2681 fun storeVec(env,x',A, rty, orig,indexAt,pieces,args,isArr)=let
378 : cchiw 2680 (*val x' =VarToC.lvalueVar (env, x)*)
379 :     fun sort([],_,_)=[]
380 :     | sort(p::ps,e::es,offset)=
381 : cchiw 2681 [CL.mkApply(N.NameMkVec(A,p,orig,isArr), [x']@trExps(env, [IL.E_Lit(Literal.Int offset),e]))]
382 : cchiw 2680 @ sort(ps, es,offset + IntInf.fromInt p)
383 :     val exp =sort(pieces,args,indexAt)
384 :     in
385 :     List.map (fn e=> CL.S_Exp e ) exp
386 :     end
387 :    
388 :    
389 :    
390 : jhr 1640 (* translate an expression to a variable form; return the variable and the
391 :     * (optional) declaration.
392 :     *)
393 : cchiw 2628 fun expToVar (env, ty, name, exp) =let
394 : cchiw 2680 val _=pnttreeTest "ExptoVar"
395 : cchiw 2628 in (case trExp(env, exp)
396 : jhr 1640 of x as CL.E_Var _ => (x, [])
397 :     | exp => let
398 :     val x = freshVar name
399 :     in
400 :     (CL.mkVar x, [CL.mkDecl(ty, x, SOME(CL.I_Exp exp))])
401 :     end
402 :     (* end case *))
403 : cchiw 2628 end
404 : jhr 1640
405 :     (* translate a print statement *)
406 :     fun trPrint (env, tys, args) = let
407 :     (* assemble the format string by analysing the types and argument expressions *)
408 :     fun mkFmt (Ty.StringTy, IL.E_Lit(Literal.String s), (stms, fmt, args)) =
409 :     (stms, s::fmt, args)
410 :     | mkFmt (ty, exp, (stms, fmt, args)) = let
411 :     fun mk (f, e) = (stms, f::fmt, e::args)
412 : cchiw 2680
413 : jhr 1640 in
414 :     case ty
415 :     of Ty.BoolTy => mk(
416 :     "%s",
417 :     CL.mkCond(trExp(env, exp), CL.mkStr "true", CL.mkStr "false"))
418 :     | Ty.StringTy => mk("%s", trExp(env, exp))
419 :     | Ty.IntTy => mk(!N.gIntFormat, trExp(env, exp))
420 :     | Ty.TensorTy[] => mk("%f", trExp(env, exp))
421 :     | Ty.TensorTy[n] => let
422 : cchiw 2668 val (x, stm) = expToVar (env, trType ty , "vec", exp)
423 :     val elems = List.tabulate (n, fn i => (*vecIndex (x, n, i)*) CL.E_Str "cow2" )
424 :     (*val (fmt, args) = mkSeqFmt (Ty.TensorTy[], elems, fmt, args)*)
425 : cchiw 2680 val (fmt, args) = mkSeqFmt (Ty.TensorTy[],[CL.E_Str "cow88"], fmt, args)
426 : jhr 1640 in
427 :     (stm@stms, fmt, args)
428 :     end
429 : cchiw 2676
430 :     | Ty.TensorTy[n, m] => let
431 :     val (x, stm) = expToVar (env, trType ty , "vec", exp)
432 :     val elems = List.tabulate (15, fn i => CL.E_Str "cow2" )
433 :     val (fmt, args) = mkSeqFmt (Ty.TensorTy[],elems, fmt, args)
434 :     in
435 :     (stm@stms, fmt, args)
436 :     end
437 :    
438 :    
439 : jhr 1640 | Ty.SeqTy(elemTy, n) => let
440 : cchiw 2669 val (x, stm) = expToVar (env, trType ty , "vec", exp)
441 : jhr 1640 val elems = List.tabulate (n, fn i => ivecIndex (x, n, i))
442 :     val (fmt, args) = mkSeqFmt (elemTy, elems, fmt, args)
443 :     in
444 :     (stm@stms, fmt, args)
445 :     end
446 :     | _ => raise Fail(concat["TreeToC.trPrint(", Ty.toString ty, ")"])
447 :     (* end case *)
448 :     end
449 :     and mkElemFmt (elemTy, elem, (fmt, args)) = (case elemTy
450 :     of Ty.BoolTy =>
451 :     ("%s"::fmt, CL.mkCond(elem, CL.mkStr "true", CL.mkStr "false")::args)
452 :     | Ty.StringTy => ("%s"::fmt, elem::args)
453 :     | Ty.IntTy => (!N.gIntFormat::fmt, elem::args)
454 : cchiw 2668
455 :    
456 : jhr 1640 | Ty.TensorTy[] => ("%f"::fmt, elem::args)
457 :     | Ty.TensorTy[n] => let
458 : cchiw 2671 val elems = List.tabulate (n, fn i => prntArr (elem, i) (*vecIndex (elem, n, i)*))
459 : jhr 1640 in
460 :     mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
461 :     end
462 : cchiw 2676
463 :     (*called by printResults*)
464 :     | Ty.TensorTy[n, m] => let
465 :     val d=n*m
466 :     val elems = List.tabulate (989, fn i => prntArr (elem, i))
467 :     in
468 :     mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
469 :     end
470 :    
471 : jhr 1640 | Ty.SeqTy(elemTy, n) => let
472 :     val elems = List.tabulate (n, fn i => ivecIndex (elem, n, i))
473 :     in
474 :     mkSeqFmt (elemTy, elems, fmt, args)
475 :     end
476 :     | _ => raise Fail(concat["TreeToC.mkElemFmt(", Ty.toString elemTy, ")"])
477 :     (* end case *))
478 :     and mkSeqFmt (elemTy, elems, fmt, args) = let
479 :     fun mk (elem, acc) = mkFmt(elemTy, elem, acc)
480 :     val (seqFmt, args) =
481 :     List.foldr
482 :     (fn (elem, acc) => mkElemFmt(elemTy, elem, acc))
483 :     ([], args) elems
484 :     in
485 :     ("<" :: String.concatWith "," seqFmt :: ">" :: fmt, args)
486 :     end
487 :     val (stms, fmt, args) = ListPair.foldr mkFmt ([], [], []) (tys, args)
488 :     val stm = CL.mkCall("fprintf", CL.mkVar "stderr" :: CL.mkStr(String.concat fmt) :: args)
489 :     in
490 :     List.rev (stm :: stms)
491 :     end
492 : cchiw 2525 (*Removed IADD, ISUB, INED, scale, MULT since they now only work on intergers*)
493 : jhr 1640 fun trAssign (env, lhs, rhs) = (
494 :     (* certain rhs forms, such as those that return a matrix,
495 :     * require a function call instead of an assignment
496 :     *)
497 :     case rhs
498 : cchiw 2525 of IL.E_Op(Op.EigenVals2x2, [m]) => let
499 : jhr 1640 val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
500 :     in
501 :     stms @ [CL.mkCall(N.evals2x2, [
502 :     lhs,
503 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
504 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
505 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
506 :     ])]
507 :     end
508 :     | IL.E_Op(Op.EigenVals3x3, [m]) => let
509 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
510 :     in
511 :     stms @ [CL.mkCall(N.evals3x3, [
512 :     lhs,
513 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
514 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
515 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
516 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
517 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
518 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
519 :     ])]
520 :     end
521 : cchiw 2628 | IL.E_Op(Op.Zero(Ty.TensorTy[n]), args) =>
522 :     [CL.mkCall(N.zeroVec(n), [lhs])]
523 :     | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
524 :     [CL.mkCall(N.zeroMat(m,n), [lhs])]
525 : cchiw 2680 (* | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>*)
526 :     | IL.E_Op(Op.imgLoad(info ,dim, n),[a])=>
527 : jhr 1640 if (n > 1)
528 :     then let
529 :     val stride = ImageInfo.stride info
530 :     val rTy = ImageInfo.sampleTy info
531 :     val vp = freshVar "vp"
532 :     val needsCast = (CL.T_Num rTy <> !N.gRealTy)
533 :     fun mkLoad i = let
534 :     val e = CL.mkSubscript(CL.mkVar vp, intExp(i*stride))
535 :     in
536 :     if needsCast then CL.mkCast(!N.gRealTy, e) else e
537 :     end
538 : cchiw 2680 val _= pnttreeTest "load image "
539 : jhr 1640 in [
540 :     CL.mkDecl(CL.T_Ptr(CL.T_Num rTy), vp, SOME(CL.I_Exp(trExp(env, a)))),
541 : cchiw 2680 (* CL.mkAssign(lhs,*)
542 :     CL.S_Exp(CL.mkApply(N.NameConsArray[n], [lhs]@ List.tabulate (n, mkLoad)))
543 : jhr 1640 ] end
544 : cchiw 2680 else (pnttreeTest" img lod "; [CL.mkAssign(lhs, trExp(env, rhs))])
545 : cchiw 2669 | IL.E_Cons _ => raise Fail "Cons-caught it here"
546 :     (*| IL.E_Cons(Ty.TensorTy[n,m], args) => let
547 : jhr 1640 (* matrices are represented as arrays of union<d><ty>_t vectors *)
548 :     fun doRows (_, []) = []
549 :     | doRows (i, e::es) =
550 :     CL.mkAssign(CL.mkSelect(CL.mkSubscript(lhs, intExp i), "v"), e)
551 :     :: doRows (i+1, es)
552 :     in
553 :     doRows (0, trExps(env, args))
554 : cchiw 2669 end*)
555 : jhr 1640 | IL.E_Var x => (case IL.Var.ty x
556 :     of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueVar(env, x)])]
557 :     | _ => [CL.mkAssign(lhs, VarToC.rvalueVar(env, x))]
558 :     (* end case *))
559 : cchiw 2681 | _ => (pnttreeTest(String.concat["\n mk assign ",IL.toString rhs, "\n ---end make assign-- \n "]) ; let
560 : cchiw 2680 val ii=[CL.mkAssign(lhs, trExp(env, rhs))]
561 :     val _= pnttreeTest "post make assign" in ii end )
562 : jhr 1640 (* end case *))
563 :    
564 :     fun trMultiAssign (env, lhs, IL.E_Op(rator, args)) = (case (lhs, rator, args)
565 :     of ([vals, vecs], Op.EigenVecs2x2, [m]) => let
566 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
567 :     in
568 :     stms @ [CL.mkCall(N.evecs2x2, [
569 :     vals, vecs,
570 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
571 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
572 :     matIndex (m, CL.mkInt 1, CL.mkInt 1)
573 :     ])]
574 :     end
575 :     | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
576 :     val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
577 :     in
578 :     stms @ [CL.mkCall(N.evecs3x3, [
579 :     vals, vecs,
580 :     matIndex (m, CL.mkInt 0, CL.mkInt 0),
581 :     matIndex (m, CL.mkInt 0, CL.mkInt 1),
582 :     matIndex (m, CL.mkInt 0, CL.mkInt 2),
583 :     matIndex (m, CL.mkInt 1, CL.mkInt 1),
584 :     matIndex (m, CL.mkInt 1, CL.mkInt 2),
585 :     matIndex (m, CL.mkInt 2, CL.mkInt 2)
586 :     ])]
587 :     end
588 :     | ([], Op.Print tys, args) => trPrint (env, tys, args)
589 :     | _ => raise Fail "bogus multi-assignment"
590 :     (* end case *))
591 :     | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"
592 :    
593 :     fun trLocals (env : env, locals) =
594 :     List.foldl
595 :     (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
596 : cchiw 2668 (*Here-for local vars*)
597 : jhr 1640 env locals
598 :    
599 :     (* generate code to check the status of runtime-system calls *)
600 :     fun checkSts mkDecl = let
601 :     val sts = freshVar "sts"
602 :     in
603 :     mkDecl sts @
604 :     [CL.mkIfThen(
605 :     CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
606 :     CL.mkCall("exit", [intExp 1]))]
607 :     end
608 :    
609 :     fun trStms (env, stms) = let
610 : cchiw 2680 val _= pnttreeTest "tr stmts "
611 : cchiw 2669 val bug=CL.E_Var"sunflower"
612 : cchiw 2637
613 : jhr 1640 fun trStmt (env, stm) = (case stm
614 :     of IL.S_Comment text => [CL.mkComment text]
615 : cchiw 2668 | IL.S_Assign([x],IL.E_Cons(Ty.TensorTy[n], args)) =>let
616 :     val x' =VarToC.lvalueVar (env, x)
617 : cchiw 2669 val exp= CL.mkApply(N.NameConsArray [n], [x']@trExps(env, args))
618 : cchiw 2628 in
619 : cchiw 2668 [CL.S_Exp exp]
620 :     end
621 : cchiw 2669 | IL.S_Assign([x],IL.E_Cons(Ty.TensorTy[i,j], args)) =>let
622 : cchiw 2671 val x' =VarToC.lvalueVar (env, x)
623 :     val exp= CL.mkApply(N.NameConsArray [i,j], [x']@trExps(env, args))
624 :     in
625 :     [CL.S_Exp exp]
626 :     end
627 : cchiw 2668
628 : cchiw 2669
629 :     | IL.S_Assign([x], IL.E_Cons _ ) =>raise Fail "Cons not written yet "
630 : cchiw 2668
631 : cchiw 2680
632 :     | IL.S_Assign([x], exp) =>(pnttreeTest(String.concat["\n base",IL.toString exp,"end base\n "]);
633 : cchiw 2669 trAssign (env, VarToC.lvalueVar (env, x) , exp))
634 :    
635 : cchiw 2668
636 : jhr 1640 | IL.S_Assign(xs, exp) =>
637 : cchiw 2680 (pnttreeTest(String.concat[ "multiAssign",IL.toString exp]);trMultiAssign (env, List.map (fn x => VarToC.lvalueVar (env, x)) xs, exp))
638 : jhr 1640 | IL.S_IfThen(cond, thenBlk) =>
639 : cchiw 2680 (pnttreeTest"if then "; [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))])
640 : jhr 1640 | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
641 : cchiw 2680 (pnttreeTest "if thenelse "; [CL.mkIfThenElse(trExp(env, cond),
642 : jhr 1640 trBlk(env, thenBlk),
643 : cchiw 2680 trBlk(env, elseBlk))])
644 : jhr 1640 | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
645 : cchiw 2669 | IL.S_Save([x],IL.E_Cons _) =>
646 :     raise Fail "roses"
647 :    
648 : cchiw 2680 | IL.S_Save([x],exp) =>(pnttreeTest "save";
649 : cchiw 2669
650 : cchiw 2680 trAssign (env, VarToC.lvalueStateVar x, exp))
651 : cchiw 2669
652 : jhr 1640 | IL.S_Save(xs, exp) =>
653 :     trMultiAssign (env, List.map VarToC.lvalueStateVar xs, exp)
654 : cchiw 2680
655 :     | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
656 :     val _= pnttreeTest "ld image "
657 : jhr 1640 val lhs = VarToC.lvalueVar (env, lhs)
658 :     val name = trExp(env, name)
659 :     val imgTy = CL.T_Named(N.imageTy dim)
660 :     val loadFn = N.loadImage dim
661 :     in [
662 :     CL.mkDecl(
663 :     CL.T_Named N.statusTy, sts,
664 :     SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, lhs)]))))
665 :     ] end)
666 :     | IL.S_Input(lhs, name, desc, optDflt) => let
667 : cchiw 2680 val _= pnttreeTest "input "
668 : jhr 1640 val inputFn = N.input(V.ty lhs)
669 :     val lhs = VarToC.lvalueVar (env, lhs)
670 :     val (initCode, hasDflt) = (case optDflt
671 :     of SOME e => ([CL.mkAssign(lhs, trExp(env, e))], true)
672 :     | NONE => ([], false)
673 :     (* end case *))
674 :     val code = [CL.mkCall(inputFn, [
675 :     CL.mkVar "opts",
676 :     CL.mkStr name,
677 :     CL.mkStr desc,
678 :     CL.mkUnOp(CL.%&, lhs),
679 :     CL.mkBool hasDflt])]
680 :     in
681 :     initCode @ code
682 :     end
683 :     | IL.S_Exit args => [CL.mkReturn NONE]
684 :     | IL.S_Active => [CL.mkReturn(SOME(CL.mkVar N.kActive))]
685 :     | IL.S_Stabilize => [CL.mkReturn(SOME(CL.mkVar N.kStabilize))]
686 :     | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar N.kDie))]
687 : cchiw 2681 | IL.S_StoreVec(x,A, rty, orig, IL.E_Lit(Literal.Int indexAt),Ty.vectorLength pieces,args,isArr)=>
688 :     storeVec(env,VarToC.lvalueVar (env, x),A, rty, orig,indexAt,pieces,args,isArr)
689 : cchiw 2680
690 : jhr 1640 (* end case *))
691 : cchiw 2628
692 :    
693 :     val r=List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
694 : cchiw 2637 (* val _= gT.prnTy("FinalTypes",!items)
695 :     *)
696 : cchiw 2628 in r
697 : jhr 1640 end
698 :    
699 :     and trBlk (env, IL.Block{locals, body}) = let
700 : cchiw 2628
701 : jhr 1640 val env = trLocals (env, locals)
702 :     val stms = trStms (env, body)
703 :     fun mkDecl (x, stms) = (case V.Map.find (env, x)
704 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
705 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
706 :     (* end case *))
707 : cchiw 2628
708 : jhr 1640 val stms = List.foldr mkDecl stms locals
709 : cchiw 2628
710 : jhr 1640 in
711 :     CL.mkBlock stms
712 :     end
713 :    
714 :     fun trFragment (env, IL.Block{locals, body}) = let
715 :     val env = trLocals (env, locals)
716 : cchiw 2680 val _=pnttreeTest "\n tree Fragment"
717 : jhr 1640 val stms = trStms (env, body)
718 : cchiw 2628
719 : jhr 1640 fun mkDecl (x, stms) = (case V.Map.find (env, x)
720 :     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
721 :     | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
722 :     (* end case *))
723 :     val stms = List.foldr mkDecl stms locals
724 :     in
725 :     (env, stms)
726 :     end
727 :    
728 : cchiw 2662
729 :    
730 : jhr 1640 val trBlock = trBlk
731 :    
732 :     end

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