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

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