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

SCM Repository

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

Annotation of /branches/vis15/src/compiler/cxx-util/tree-to-cxx.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4348 - (view) (download)

1 : jhr 3866 (* tree-to-cxx.sml
2 : jhr 3768 *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2016 The University of Chicago
6 :     * All rights reserved.
7 :     *
8 : jhr 3866 * Translate TreeIR to the C++ version of CLang.
9 : jhr 3768 *)
10 :    
11 :    
12 : jhr 3866 structure TreeToCxx : sig
13 : jhr 3768
14 : jhr 3886 val trType : CodeGenEnv.t * TreeTypes.t -> CLang.ty
15 : jhr 3768
16 : jhr 3873 val trBlock : CodeGenEnv.t * TreeIR.block -> CLang.stm
17 : jhr 3768
18 : jhr 3924 val trWithLocals : CodeGenEnv.t * TreeVar.t list * (CodeGenEnv.t -> CLang.stm list) -> CLang.stm
19 :    
20 : jhr 3927 val trStms : CodeGenEnv.t * TreeIR.stm list -> CodeGenEnv.t * CLang.stm list
21 : jhr 3924
22 : jhr 3873 val trExp : CodeGenEnv.t * TreeIR.exp -> CLang.exp
23 : jhr 3768
24 : jhr 3866 (* translate an expression to a variable form; return the variable (as an expression)
25 : jhr 3768 * and the (optional) declaration.
26 :     *)
27 : jhr 3876 val trExpToVar : CodeGenEnv.t * CLang.ty * string * TreeIR.exp -> CLang.exp * CLang.stm list
28 : jhr 3768
29 : jhr 3900 (* generate code to register an error message (require that a world pointer "wrld" is in scope) *)
30 : jhr 3927 val errorMsgAdd : CodeGenEnv.t * CLang.exp -> CLang.stm
31 : jhr 3900
32 : jhr 3927 val trParam : CodeGenEnv.t * TreeIR.var -> CodeGenEnv.t * CLang.param
33 : jhr 3917
34 : jhr 4071 (* `loadNrrd (obj, arg)`
35 :     * returns code to load data from a nrrd. The `obj` specifies either an image or dynamic
36 :     * sequence object, and the `arg` specifies either a nrrd or nrrd file.
37 :     * The generated code checks the status of the load attempt and will return "true"
38 :     * (i.e., error) if the load fails.
39 :     *)
40 :     val loadNrrd : CLang.exp * CLang.exp -> CLang.stm
41 :    
42 : jhr 3768 end = struct
43 :    
44 :     structure CL = CLang
45 :     structure IR = TreeIR
46 :     structure Op = TreeOps
47 :     structure Ty = TreeTypes
48 : jhr 3866 structure V = TreeVar
49 : jhr 3873 structure Env = CodeGenEnv
50 : jhr 3918 structure RN = CxxNames
51 : jhr 3768
52 : jhr 3988 val trType = TypeToCxx.trType
53 :     val dynseqTy = TypeToCxx.dynseqTy
54 : jhr 3768
55 : jhr 3866 (* translate a local variable that occurs in an l-value context *)
56 : jhr 3873 fun lvalueVar (env, x) = CL.mkVar(Env.lookup(env, x))
57 : jhr 3866 (* translate a variable that occurs in an r-value context *)
58 : jhr 3873 fun rvalueVar (env, x) = CL.mkVar(Env.lookup(env, x))
59 : jhr 3768
60 : jhr 3866 (* translate a global variable that occurs in an l-value context *)
61 : jhr 3924 fun lvalueGlobalVar (env, x) = CL.mkIndirect(CL.mkVar(Env.global env), TreeGlobalVar.qname x)
62 : jhr 3866 (* translate a global variable that occurs in an r-value context *)
63 :     val rvalueGlobalVar = lvalueGlobalVar
64 :    
65 :     (* translate a strand state variable that occurs in an l-value context *)
66 : jhr 3924 fun lvalueStateVar (env, x) = CL.mkIndirect(CL.mkVar(Env.selfOut env), TreeStateVar.qname x)
67 : jhr 3866 (* translate a strand state variable that occurs in an r-value context *)
68 : jhr 3924 fun rvalueStateVar (env, x) = CL.mkIndirect(CL.mkVar(Env.selfIn env), TreeStateVar.qname x)
69 : jhr 3866
70 : jhr 3927 fun worldVar env = CL.mkVar(Env.world env)
71 :    
72 : jhr 3866 (* generate new variables *)
73 : jhr 3926 val freshVar = CodeGenUtil.freshVar
74 : jhr 3866
75 :     (* integer literal expression *)
76 : jhr 3982 fun mkInt (i : int) = CL.mkInt(IntInf.fromInt i)
77 : jhr 3866
78 : jhr 3893 val zero = CL.mkInt 0
79 :    
80 : jhr 3866 fun addrOf e = CL.mkUnOp(CL.%&, e)
81 :    
82 :     (* make an application of a function from the "std" namespace *)
83 :     fun mkStdApply (f, args) = CL.mkApply("std::" ^ f, args)
84 :    
85 :     (* make an application of a function from the "diderot" namespace *)
86 :     fun mkDiderotApply (f, args) = CL.mkApply("diderot::" ^ f, args)
87 : jhr 3872 fun mkDiderotCall (f, args) = CL.mkCall("diderot::" ^ f, args)
88 : jhr 4065 fun mkDynseqApply (env, ty, f, args) =
89 : jhr 4317 CL.mkQApply([CL.SC_Type(dynseqTy(env, ty))], f, args)
90 : jhr 3866
91 : jhr 4071 fun loadNrrd (obj, arg) =
92 : jhr 4317 CL.mkIfThen(CL.mkDispatch(obj, "load", [CL.mkVar "wrld", arg]),
93 :     CL.mkReturn(SOME(CL.mkVar "true")))
94 : jhr 4071
95 : jhr 3810 (* Translate a TreeIR operator application to a CLang expression *)
96 : jhr 3886 fun trOp (env, rator, args) = (case (rator, args)
97 : jhr 4317 of (Op.IAdd, [a, b]) => CL.mkBinOp(a, CL.#+, b)
98 :     | (Op.ISub, [a, b]) => CL.mkBinOp(a, CL.#-, b)
99 :     | (Op.IMul, [a, b]) => CL.mkBinOp(a, CL.#*, b)
100 :     | (Op.IDiv, [a, b]) => CL.mkBinOp(a, CL.#/, b)
101 :     | (Op.IMod, [a, b]) => CL.mkBinOp(a, CL.#%, b)
102 :     | (Op.INeg, [a]) => CL.mkUnOp(CL.%-, a)
103 :     | (Op.RAdd, [a, b]) => CL.mkBinOp(a, CL.#+, b)
104 :     | (Op.RSub, [a, b]) => CL.mkBinOp(a, CL.#-, b)
105 :     | (Op.RMul, [a, b]) => CL.mkBinOp(a, CL.#*, b)
106 :     | (Op.RDiv, [a, b]) => CL.mkBinOp(a, CL.#/, b)
107 :     | (Op.RNeg, [a]) => CL.mkUnOp(CL.%-, a)
108 :     | (Op.RClamp, [a, b, c]) => CL.mkApply("clamp", [a, b, c])
109 :     | (Op.RLerp, [a, b, c]) => CL.mkApply("lerp", [a, b, c])
110 :     | (Op.RCeiling, [a]) => mkStdApply("ceil", [a])
111 :     | (Op.RFloor, [a]) => mkStdApply("floor", [a])
112 :     | (Op.RRound, [a]) => mkStdApply("round", [a])
113 :     | (Op.RTrunc, [a]) => mkStdApply("trunc", [a])
114 :     | (Op.RealToInt, [a]) => mkStdApply("lround", [a])
115 : jhr 3768 | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
116 :     | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
117 :     | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
118 :     | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
119 :     | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
120 :     | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
121 :     | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
122 : jhr 4317 | (Op.Abs ty, args) => mkStdApply("abs", args)
123 :     | (Op.Max ty, args) => mkStdApply("max", args)
124 :     | (Op.Min ty, args) => mkStdApply("min", args)
125 :     | (Op.VAdd d, [a, b]) => CL.mkBinOp(a, CL.#+, b)
126 :     | (Op.VSub d, [a, b]) => CL.mkBinOp(a, CL.#-, b)
127 :     | (Op.VScale(w, _), [a, b]) => CL.mkApply(RN.vscale w, [a, b])
128 :     | (Op.VMul d, [a, b]) => CL.mkBinOp(a, CL.#*, b)
129 :     | (Op.VNeg d, [a]) => CL.mkUnOp(CL.%-, a)
130 :     | (Op.VSum(w, _), [a]) => CL.mkApply(RN.vsum w, [a])
131 :     | (Op.VDot(w, _), [a, b]) => CL.mkApply(RN.vdot w, [a, b])
132 :     | (Op.VIndex(w, p, i), [a]) => CL.mkSubscript(a, mkInt i)
133 :     | (Op.VClamp(w, _), [a, b, c]) => CL.mkApply(RN.vclamp w, [a, b, c])
134 :     | (Op.VMapClamp(w, _), [a, b, c]) => CL.mkApply(RN.vclamp w, [a, b, c])
135 :     | (Op.VLerp(w, _), [a, b, c]) => CL.mkApply(RN.vlerp w, [a, b, c])
136 :     | (Op.VCeiling(w, _), [a]) => CL.mkApply(RN.vceiling w, [a])
137 :     | (Op.VFloor(w, _), [a]) => CL.mkApply(RN.vfloor w, [a])
138 :     | (Op.VRound(w, _), [a]) => CL.mkApply(RN.vround w, [a])
139 :     | (Op.VTrunc(w, _), [a]) => CL.mkApply(RN.vtrunc w, [a])
140 :     | (Op.TensorIndex(ty, idxs), [a]) => let
141 :     val dd = (case ty
142 :     of Ty.TensorTy(_::dd) => dd
143 :     | Ty.TensorRefTy(_::dd) => dd
144 :     | _ => raise Fail "bogus type for TensorIndex"
145 :     (* end case *))
146 :     (* dimensions/indices are slowest to fastest *)
147 :     fun index ([], [i], acc) = acc + i
148 :     | index (d::dd, i::ii, acc) = index (dd, ii, d * (acc + i))
149 :     in
150 :     CL.mkSubscript(a, mkInt(index (dd, idxs, 0)))
151 :     end
152 :     | (Op.ProjectLast(ty, idxs), [a]) => let
153 :     val dd = (case ty
154 :     of Ty.TensorTy(_::dd) => dd
155 :     | Ty.TensorRefTy(_::dd) => dd
156 :     | _ => raise Fail "bogus type for ProjectLast"
157 :     (* end case *))
158 :     (* dimensions/indices are slowest to fastest *)
159 :     fun index ([], [], acc) = acc
160 :     | index (d::dd, i::ii, acc) = index (dd, ii, d * (acc + i))
161 :     in
162 :     CL.mkDispatch(a, "last", [mkInt(index (dd, idxs, 0))])
163 :     end
164 :     (* NOTE: since C++ will do the coercion automatically, we don't really need
165 :     * to generate the constructor application for TensorRef!
166 :     *)
167 :     | (Op.TensorRef shp, [a]) => CL.mkCons(RN.tensorRefTy shp, [a])
168 :     | (Op.Select(ty, i), [a]) => raise Fail "FIXME: Select"
169 : jhr 4277 (* FIXME: if this is a sequence of tensors, then the result should be a TensorRef *)
170 : jhr 4317 | (Op.Subscript ty, [a, b]) => CL.mkSubscript(a, b)
171 :     | (Op.MkDynamic(ty, n), [a]) => CL.mkCons(dynseqTy(env, ty), [mkInt n, a])
172 : jhr 3982 (* FIXME: eventually we should do some kind of liveness analysis to enable in situ operations *)
173 : jhr 4317 | (Op.Append ty, [a, b]) => mkDynseqApply (env, ty, "append", [a, b])
174 :     | (Op.Prepend ty, [a, b]) => mkDynseqApply (env, ty, "prepend", [a, b])
175 :     | (Op.Concat ty, [a, b]) => mkDynseqApply (env, ty, "concat", [a, b])
176 :     | (Op.Range, [a, b]) => CL.mkCons(dynseqTy(env, Ty.IntTy), [a, b])
177 :     | (Op.Length ty, [a]) => CL.mkDispatch(a, "length", [])
178 :     | (Op.SphereQuery(ty1, ty2), []) => raise Fail "FIXME: SphereQuery"
179 :     | (Op.Sqrt, [a]) => mkStdApply("sqrt", [a])
180 :     | (Op.Cos, [a]) => mkStdApply("cos", [a])
181 :     | (Op.ArcCos, [a]) => mkStdApply("acos", [a])
182 :     | (Op.Sin, [a]) => mkStdApply("sin", [a])
183 :     | (Op.ArcSin, [a]) => mkStdApply("asin", [a])
184 :     | (Op.Tan, [a]) => mkStdApply("tan", [a])
185 :     | (Op.ArcTan, [a]) => mkStdApply("atan", [a])
186 :     | (Op.Exp, [a]) => mkStdApply("exp", [a])
187 :     | (Op.IntToReal, [a]) => CL.mkStaticCast(Env.realTy env, a)
188 : jhr 4337 | (Op.StrandStatus set, [a]) => raise Fail "FIXME: StrandStatus"
189 : jhr 4317 | (Op.Transform info, [img]) => CL.mkApply("world2image", [img])
190 :     | (Op.Translate info, [img]) => CL.mkApply("translate", [img])
191 :     | (Op.BaseAddress info, [img]) => CL.mkDispatch(img, "base_addr", [])
192 :     | (Op.ControlIndex(info, ctl, d), [img, idx]) =>
193 :     CL.mkDispatch(img, IndexCtl.toString ctl, [mkInt d, idx])
194 :     | (Op.LoadVoxel info, [addr, offp]) => let
195 :     val voxel = CL.mkSubscript(addr, offp)
196 :     in
197 :     case ImageInfo.sampleTy info
198 :     of NONE => voxel (* no proxy, so we are using the default real type *)
199 :     | SOME rty => if RawTypes.same(rty, Env.rawRealTy env)
200 :     then voxel
201 :     else CL.mkStaticCast(Env.realTy env, voxel)
202 :     (* end case *)
203 :     end
204 :     | (Op.Inside(layout, _, s), args) =>
205 :     CL.mkApply (RN.inside(#wid layout, s), args)
206 :     | (Op.IndexInside(info, s), [pos, img]) => CL.mkDispatch(img, "inside", [pos, mkInt s])
207 :     | (Op.ImageDim(info, i), [img]) => CL.mkDispatch(img, "size", [mkInt i])
208 :     | (Op.MathFn f, args) => mkStdApply(MathFns.toString f, args)
209 :     | _ => raise Fail(concat[
210 :     "unknown or incorrect operator ", Op.toString rator
211 :     ])
212 :     (* end case *))
213 : jhr 3768
214 : jhr 3866 fun trExp (env, e) = (case e
215 :     of IR.E_Global x => rvalueGlobalVar (env, x)
216 : jhr 3872 | IR.E_State(NONE, x) => rvalueStateVar (env, x)
217 :     | IR.E_State(SOME e, x) => CL.mkIndirect(trExp(env, e), TreeStateVar.name x)
218 : jhr 3866 | IR.E_Var x => rvalueVar (env, x)
219 : jhr 3876 | IR.E_Lit(Literal.Int n) => CL.mkIntTy(n, Env.intTy env)
220 : jhr 3866 | IR.E_Lit(Literal.Bool b) => CL.mkBool b
221 : jhr 3876 | IR.E_Lit(Literal.Real f) => CL.mkFlt(f, Env.realTy env)
222 : jhr 3866 | IR.E_Lit(Literal.String s) => CL.mkStr s
223 : jhr 3886 | IR.E_Op(rator, args) => trOp (env, rator, trExps(env, args))
224 : jhr 4317 | IR.E_Apply(f, args) => let
225 :     val args = trExps (env, args)
226 :     val args = if TreeFunc.hasGlobals f
227 :     then CL.mkVar(Env.global env) :: args
228 :     else args
229 :     val args = if TreeFunc.needsWorld f
230 :     then CL.mkVar(Env.world env) :: args
231 :     else args
232 :     in
233 :     CL.mkApply(TreeFunc.qname f, args)
234 :     end
235 :     | IR.E_Vec(w, pw, args) => CL.mkApply(RN.vcons w, trExps (env, args))
236 : jhr 3893 | IR.E_Cons(args, Ty.TensorTy shape) => raise Fail "unexpected E_Cons"
237 :     | IR.E_Seq(args, ty) => raise Fail "unexpected E_Seq"
238 : jhr 4317 | IR.E_Pack(layout, args) => raise Fail "unexpected E_Pack"
239 : jhr 3894 (* FIXME: check if e is aligned and use "vload_aligned" in that case *)
240 : jhr 4317 | IR.E_VLoad(layout, e, i) =>
241 :     CL.mkApply(RN.vload(Ty.nthWidth(layout, i)),
242 :     [CL.mkDispatch(trExp(env, e), "addr", [mkInt(Ty.offsetOf(layout, i))])])
243 :     | _ => raise Fail "trExp"
244 : jhr 3866 (* end case *))
245 :    
246 :     and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
247 :    
248 : jhr 3873 (* QUESTION: not sure that we need this function? *)
249 : jhr 3872 fun trExpToVar (env, ty, name, exp) = (case trExp (env, exp)
250 : jhr 4317 of e as CL.E_Var _ => (e, [])
251 :     | e => let
252 :     val x = freshVar name
253 :     in
254 :     (CL.mkVar x, [CL.mkDeclInit(ty, x, e)])
255 :     end
256 :     (* end case *))
257 : jhr 3872
258 : jhr 3955 (* FIXME: trAssign and trDecl do the same analysis of the rhs; we should factor that out *)
259 : jhr 3977 (* translate the assignment `lhs = rhs` and add the code to the stms list. Note that the
260 :     * stms list is reverse order!
261 :     *)
262 : jhr 4067 fun trAssign env = let
263 : jhr 4317 fun tr (lhs, rhs, stms) = (case rhs
264 :     of IR.E_Op(Op.VToInt(w, _), [a]) =>
265 :     CL.mkCall (RN.vtoi w, [lhs, trExp(env, a)]) :: stms
266 :     | IR.E_Op(Op.TensorCopy shp, [a]) => CL.mkAssign(lhs, trExp (env, a)) :: stms
267 :     | IR.E_Op(Op.EigenVals2x2, [a]) =>
268 :     CL.mkCall("eigenvals", [trExp (env, a), lhs]) :: stms
269 :     | IR.E_Op(Op.EigenVals3x3, [a]) =>
270 :     CL.mkCall("eigenvals", [trExp (env, a), lhs]) :: stms
271 :     | IR.E_Pack({wid, ...}, args) =>
272 :     CL.mkCall (RN.vpack wid, lhs :: List.map (fn e => trExp(env, e)) args) :: stms
273 :     | IR.E_Cons(args, _) => let
274 :     fun trArg (i, arg, stms) = tr (CL.mkSubscript(lhs, mkInt i), arg, stms)
275 :     in
276 :     List.foldli trArg stms args
277 :     end
278 :     | IR.E_Seq(args, _) => let
279 :     fun trArg (i, arg, stms) = tr (CL.mkSubscript(lhs, mkInt i), arg, stms)
280 :     in
281 :     List.foldli trArg stms args
282 :     end
283 :     | _ => CL.mkAssign(lhs, trExp (env, rhs)) :: stms
284 :     (* end case *))
285 :     in
286 :     tr
287 :     end
288 : jhr 3872
289 : jhr 4004 fun trDecl (env, ty, lhs, rhs, stms) = let
290 : jhr 4317 fun trArgs args = CL.mkDecl(
291 :     ty, lhs, SOME(CL.I_Exps(List.map (fn arg => CL.I_Exp(trExp (env, arg))) args)))
292 :     in
293 :     case rhs
294 :     of IR.E_Op(Op.VToInt(w, _), [a]) => (* NOTE: reverse order! *)
295 :     CL.mkCall (RN.vtoi w, [CL.mkVar lhs, trExp(env, a)]) ::
296 :     CL.mkDecl(ty, lhs, NONE) :: stms
297 : jhr 3999 (*
298 : jhr 4317 | IR.E_Op(Op.TensorCopy shp, [a]) => [ (* NOTE: reverse order! *)
299 :     CL.mkCall (RN.tensorCopy shp, [CL.mkVar lhs, trExp(env, a)]),
300 :     CL.mkDecl(ty, lhs, NONE)
301 :     ]
302 : jhr 3999 *)
303 : jhr 4317 | IR.E_Op(Op.TensorCopy shp, [a]) => CL.mkDeclInit(ty, lhs, trExp(env, a)) :: stms
304 :     | IR.E_Op(Op.EigenVals2x2, [a]) =>
305 :     CL.mkCall("eigenvals", [trExp (env, a), CL.mkVar lhs]) ::
306 :     CL.mkDecl(ty, lhs, NONE) :: stms
307 :     | IR.E_Op(Op.EigenVals3x3, [a]) =>
308 :     CL.mkCall("eigenvals", [trExp (env, a), CL.mkVar lhs]) ::
309 :     CL.mkDecl(ty, lhs, NONE) :: stms
310 :     | IR.E_Pack({wid, ...}, args) =>
311 :     CL.mkCall (RN.vpack wid, CL.mkVar lhs :: List.map (fn e => trExp(env, e)) args) ::
312 :     CL.mkDecl(ty, lhs, NONE) :: stms
313 :     | IR.E_Cons(args, _) => let
314 :     val init = List.map (fn arg => CL.I_Exp(trExp(env, arg))) args
315 :     in
316 :     CL.mkDecl(ty, lhs, SOME(CL.I_Exps init)) :: stms
317 :     end
318 :     | IR.E_Seq(args, _) => let
319 :     val dcl = CL.mkDecl(ty, lhs, NONE)
320 :     val trAssign = trAssign env
321 :     fun trArg (i, arg, stms) =
322 :     trAssign (CL.mkSubscript(CL.mkVar lhs, mkInt i), arg, stms)
323 :     in
324 :     List.foldli trArg (dcl :: stms) args
325 :     end
326 :     | _ => CL.mkDeclInit(ty, lhs, trExp (env, rhs)) :: stms
327 :     (* end case *)
328 :     end
329 : jhr 3872
330 : jhr 3870 fun trMultiAssign (env, lhs, IR.E_Op(rator, args)) = (case (lhs, rator, args)
331 : jhr 3876 of ([vals, vecs], Op.EigenVecs2x2, [exp]) =>
332 : jhr 4317 CL.mkCall("eigenvecs", [trExp (env, exp), vals, vecs])
333 : jhr 3876 | ([vals, vecs], Op.EigenVecs3x3, [exp]) =>
334 : jhr 4317 CL.mkCall("eigenvecs", [trExp (env, exp), vals, vecs])
335 : jhr 3870 | _ => raise Fail "bogus multi-assignment"
336 :     (* end case *))
337 :     | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"
338 : jhr 3866
339 : jhr 3918 fun trPrintStm (outS, tys, args) = let
340 : jhr 4317 fun mkExp (lhs, [], []) = CL.mkBinOp(lhs, CL.#<<, CL.mkVar "std::flush")
341 :     | mkExp (lhs, ty::tys, e::es) = let
342 :     (* if necessary, wrap the argument so that the correct "<<" instance is used *)
343 :     val e = (case ty
344 :     of Ty.TensorTy shape => CL.mkApply(RN.tensorRefStruct shape, [e])
345 :     | _ => e
346 :     (* end case *))
347 :     in
348 :     mkExp (CL.mkBinOp(lhs, CL.#<<, e), tys, es)
349 :     end
350 :     | mkExp _ = raise Fail "trPrintStm: arity mismatch"
351 :     in
352 :     CL.mkExpStm (mkExp (outS, tys, args))
353 :     end
354 : jhr 3918
355 : jhr 3872 fun trStms (env, stms : TreeIR.stm list) = let
356 : jhr 3870 fun trStm (stm, (env, stms : CL.stm list)) = (case stm
357 :     of IR.S_Comment text => (env, CL.mkComment text :: stms)
358 : jhr 3872 | IR.S_Assign(true, x, exp) => let
359 : jhr 4317 val ty = trType (env, V.ty x)
360 :     val x' = V.name x
361 :     val env = Env.insert (env, x, x')
362 :     in
363 :     (env, trDecl (env, ty, x', exp, stms))
364 :     end
365 : jhr 3977 | IR.S_Assign(false, x, exp) =>
366 : jhr 4317 (env, trAssign env (lvalueVar (env, x), exp, stms))
367 :     | IR.S_MAssign(xs, exp) =>
368 : jhr 3886 (env, trMultiAssign (env, List.map (fn x => lvalueVar (env, x)) xs, exp) :: stms)
369 : jhr 3866 | IR.S_GAssign(x, exp) =>
370 : jhr 4317 (env, trAssign env (lvalueGlobalVar (env, x), exp, stms))
371 : jhr 3866 | IR.S_IfThen(cond, thenBlk) =>
372 : jhr 3870 (env, CL.mkIfThen(trExp(env, cond), trBlock(env, thenBlk)) :: stms)
373 : jhr 3866 | IR.S_IfThenElse(cond, thenBlk, elseBlk) => let
374 : jhr 4317 val stm = CL.mkIfThenElse(trExp(env, cond),
375 :     trBlock(env, thenBlk),
376 :     trBlock(env, elseBlk))
377 :     in
378 :     (env, stm :: stms)
379 :     end
380 :     | IR.S_For(x, lo, hi, blk) => let
381 :     val x' = V.name x
382 :     val env' = Env.insert (env, x, x')
383 :     val (hi', hiInit) = if CodeGenUtil.isSimple hi
384 :     then (trExp(env, hi), [])
385 :     else let
386 :     val hi' = freshVar "hi"
387 :     in
388 :     (CL.mkVar hi', [CL.mkDeclInit(CL.int32, hi', trExp(env, hi))])
389 :     end
390 :     val loop = CL.mkFor(
391 :     CL.int32, [( x', trExp(env, lo))],
392 :     CL.mkBinOp(CL.mkVar x', CL.#<=, hi'),
393 :     [CL.mkUnOp(CL.%++, CL.mkVar x')],
394 :     trBlock (env', blk))
395 :     in
396 :     (env, hiInit @ loop :: stms)
397 :     end
398 : jhr 4344 | IR.S_Foreach(x, e, blk) => let
399 :     val seq = trExp(env, e)
400 :     val x' = V.name x
401 :     val env' = Env.insert (env, x, x')
402 :     val blk' = trBlock (env', blk)
403 :     val loop = (case TreeTypeOf.exp e
404 :     of Ty.SeqTy(_, SOME n) => let
405 :     val ix = freshVar "ix"
406 :     val defx = CL.mkDeclInit(CL.T_Named "auto", x',
407 :     CL.mkSubscript(seq, CL.mkVar ix))
408 :     in
409 :     CL.mkFor(
410 :     CL.int32, [(ix, CL.mkInt 0)],
411 :     CL.mkBinOp(CL.mkVar ix, CL.#<, mkInt n),
412 :     [CL.mkUnOp(CL.%++, CL.mkVar ix)],
413 :     CL.prependStm(defx, blk'))
414 :     end
415 : jhr 4348 | Ty.SeqTy(_, NONE) => let
416 :     val ix = freshVar "it"
417 :     val defx = CL.mkDeclInit(CL.T_Named "auto", x',
418 :     CL.mkUnOp(CL.%*, CL.mkVar ix))
419 :     in
420 :     CL.mkFor(
421 :     CL.T_Named "auto", [(ix, CL.mkDispatch(seq, "cbegin", []))],
422 :     CL.mkBinOp(CL.mkVar ix, CL.#!=, CL.mkDispatch(seq, "cend", [])),
423 :     [CL.mkUnOp(CL.%++, CL.mkVar ix)],
424 :     CL.prependStm(defx, blk'))
425 :     end
426 : jhr 4344 | _ => raise Fail "impossible"
427 :     (* end case *))
428 :     in
429 :     (env, loop :: stms)
430 :     end
431 : jhr 3927 | IR.S_New(strand, args) => let
432 : jhr 4317 val args = List.map (fn e => trExp(env, e)) args
433 :     val stm = CL.mkCall(
434 :     Atom.toString strand ^ "_new",
435 :     worldVar env :: args)
436 :     in
437 :     (env, stm :: stms)
438 :     end
439 : jhr 3977 | IR.S_Save(x, exp) =>
440 : jhr 4317 (env, trAssign env (lvalueStateVar(env, x), exp, stms))
441 : jhr 3894 | IR.S_LoadNrrd(lhs, ty, nrrd) => let
442 : jhr 4317 val stm = loadNrrd (lvalueVar (env, lhs), CL.mkStr nrrd)
443 :     in
444 :     (env, stm :: stms)
445 :     end
446 : jhr 3870 | IR.S_Input(_, _, _, NONE) => (env, stms)
447 :     | IR.S_Input(gv, name, _, SOME dflt) =>
448 :     (env, CL.mkAssign(lvalueGlobalVar (env, gv), trExp(env, dflt)) :: stms)
449 : jhr 3866 | IR.S_InputNrrd _ => (env, stms)
450 : jhr 4168 | IR.S_Return e => (env, CL.mkReturn(SOME(trExp(env, e))) :: stms)
451 : jhr 4317 | IR.S_Print(tys, args) => let
452 :     val args = List.map (fn e => trExp(env, e)) args
453 :     val stm = trPrintStm (
454 :     CL.mkIndirectDispatch(worldVar env, "output", []),
455 :     tys, args)
456 :     in
457 :     (env, stm::stms)
458 :     end
459 : jhr 3876 | IR.S_Active => (env, CL.mkReturn(SOME(CL.mkVar "diderot::kActive")) :: stms)
460 :     | IR.S_Stabilize => (env, CL.mkReturn(SOME(CL.mkVar "diderot::kStabilize")) :: stms)
461 :     | IR.S_Die => (env, CL.mkReturn(SOME(CL.mkVar "diderot::kDie")) :: stms)
462 : jhr 3866 (* end case *))
463 : jhr 4317 val (env, stms) = List.foldl trStm (env, []) stms
464 : jhr 3866 in
465 : jhr 4317 (env, List.rev stms)
466 : jhr 3866 end
467 :    
468 :     and trBlock (env, IR.Block{locals, body}) = let
469 : jhr 4317 fun trLocal (x, (env, dcls)) = let
470 :     val x' = V.name x
471 :     val dcl = CL.mkDecl(trType(env, V.ty x), x', NONE)
472 :     in
473 :     (Env.insert(env, x, x'), dcl :: dcls)
474 :     end
475 :     val (env, dcls) = List.foldl trLocal (env, []) (!locals)
476 :     val (_, stms) = trStms (env, body)
477 : jhr 3866 in
478 : jhr 3927 CL.mkBlock (dcls @ stms)
479 : jhr 3866 end
480 :    
481 : jhr 3924 and trWithLocals (env, locals, trBody) = let
482 : jhr 4317 fun trLocal (x, (env, dcls)) = let
483 :     val x' = V.name x
484 :     val dcl = CL.mkDecl(trType(env, V.ty x), x', NONE)
485 :     in
486 :     (Env.insert(env, x, x'), dcl :: dcls)
487 :     end
488 :     val (env, dcls) = List.foldl trLocal (env, []) locals
489 : jhr 3924 in
490 :     CL.mkBlock (dcls @ trBody env)
491 :     end
492 :    
493 : jhr 3927 fun errorMsgAdd (env, msg) =
494 :     CL.mkCall("biffMsgAdd", [CL.mkIndirect(worldVar env, "_errors"), msg])
495 : jhr 3900
496 : jhr 3927 fun trParam (env, x)= let
497 : jhr 4317 val x' = V.name x
498 :     in
499 :     (Env.insert (env, x, x'), CL.PARAM([], trType(env, V.ty x), x'))
500 :     end
501 : jhr 3917
502 : jhr 3768 end

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