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

SCM Repository

[diderot] Diff of /trunk/src/compiler/cl-target/tree-to-cl.sml
ViewVC logotype

Diff of /trunk/src/compiler/cl-target/tree-to-cl.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1369, Wed Jun 22 20:58:57 2011 UTC revision 1370, Wed Jun 22 21:11:20 2011 UTC
# Line 1  Line 1 
1  (* tree-to-cl.sml  (* tree-to-c.sml
2   *   *
3   * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)   * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4   * All rights reserved.   * All rights reserved.
5   *   *
6   * Translate TreeIL to the OpenCL version of CLang.   * Translate TreeIL to the C version of CLang.
7   *)   *)
8    
9  structure TreeToCL : sig  structure TreeToCL : sig
# Line 16  Line 16 
16    
17      val trBlock : env * (env * TreeIL.exp list * CLang.stm -> CLang.stm list) * TreeIL.block -> CLang.stm      val trBlock : env * (env * TreeIL.exp list * CLang.stm -> CLang.stm list) * TreeIL.block -> CLang.stm
18    
19        val trFragment : env * TreeIL.block -> env * CLang.stm list
20    
21      val trAssign : env * TreeIL.var * TreeIL.exp -> CLang.stm list      val trAssign : env * TreeIL.var * TreeIL.exp -> CLang.stm list
22    
23      val trExp : env * TreeIL.exp -> CLang.exp      val trExp : env * TreeIL.exp -> CLang.exp
24    
25    (* vector indexing support.  Arguments are: vector, arity, index *)    (* vector indexing support.  Arguments are: vector, index *)
26      val ivecIndex : CLang.exp * int * int -> CLang.exp      val vecIndex : CLang.exp * int -> CLang.exp
     val vecIndex : CLang.exp * int * int -> CLang.exp  
27    
28    end = struct    end = struct
29    
# Line 33  Line 34 
34      structure Ty = IL.Ty      structure Ty = IL.Ty
35      structure V = IL.Var      structure V = IL.Var
36    
37      datatype var = V of (CLang.ty * CLang.var)      datatype var = datatype CLang.typed_var
38    
39      type env = var TreeIL.Var.Map.map      type env = var TreeIL.Var.Map.map
40    
# Line 43  Line 44 
44            (* end case *))            (* end case *))
45    
46    (* integer literal expression *)    (* integer literal expression *)
47      fun intExp (i : int) = CL.mkInt(IntInf.fromInt i, CL.int32)      fun intExp (i : int) = CL.mkInt(IntInf.fromInt i)
48    
49    (* translate TreeIL types to CLang types *)    (* translate TreeIL types to CLang types *)
50      fun trType ty = (case ty      fun trType ty = (case ty
# Line 54  Line 55 
55              | Ty.TensorTy[] => !RN.gRealTy              | Ty.TensorTy[] => !RN.gRealTy
56              | Ty.TensorTy[n] => CL.T_Named(RN.vecTy n)              | Ty.TensorTy[n] => CL.T_Named(RN.vecTy n)
57              | Ty.TensorTy[n, m] => CL.T_Named(RN.matTy(n,m))              | Ty.TensorTy[n, m] => CL.T_Named(RN.matTy(n,m))
58              | Ty.AddrTy(ImageInfo.ImgInfo{ty=([], rTy), ...}) => CL.T_Ptr(CL.T_Num rTy)              | Ty.AddrTy(ImageInfo.ImgInfo{ty=(_, rTy), ...}) => CL.T_Ptr(CL.T_Num rTy)
59              | Ty.ImageTy(ImageInfo.ImgInfo{dim, ...}) => CL.T_Ptr(CL.T_Named(RN.imageTy dim))  (* FIXME: concatenating "__global" is a hack.  Figure out a better way *)
60                | Ty.ImageTy(ImageInfo.ImgInfo{dim, ...}) => CL.T_Ptr(CL.T_Named("__global " ^ RN.imageTy dim))
61              | _ => raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])              | _ => raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])
62            (* end case *))            (* end case *))
63    
# Line 86  Line 88 
88        val dLookup = mkLookup ""        val dLookup = mkLookup ""
89      in      in
90      fun trApply (f, args) = let      fun trApply (f, args) = let
91            val f' = if !Controls.doublePrecision then dLookup f else fLookup f            val f' = if !RN.doublePrecision then dLookup f else fLookup f
92            in            in
93              CL.mkApply(f', args)              CL.mkApply(f', args)
94            end            end
95      end (* local *)      end (* local *)
96    
97    (* vector indexing support.  Arguments are: vector, arity, index *)    (* vector indexing support.  Arguments are: vector, index *)
98      fun ivecIndex (v, n, ix) = let      local
99            val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gIntSuffix, "_t"])        val fields = Vector.fromList [
100            val e1 = CL.mkCast(unionTy, v)                "s0", "s1", "s2", "s3",
101            val e2 = CL.mkSelect(e1, "i")                "s4", "s5", "s6", "s7",
102            in                "s8", "s9", "sa", "sb",
103              CL.mkSubscript(e2, intExp ix)                "sc", "sd", "se", "sf"
104            end              ]
   
     fun vecIndex (v, n, ix) = let  
           val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gRealSuffix, "_t"])  
           val e1 = CL.mkCast(unionTy, v)  
           val e2 = CL.mkSelect(e1, "r")  
105            in            in
106              CL.mkSubscript(e2, intExp ix)      fun vecIndex (v, ix) = CL.mkSelect(v, Vector.sub(fields, ix))
107            end            end
108    
109    (* translate a variable use *)    (* translate a variable use *)
110      fun trVar (env, x) = (case V.kind x      fun trVar (env, x) = (case V.kind x
111             of IL.VK_Global => CL.mkVar(lookup(env, x))             of IL.VK_Global => CL.mkIndirect(CL.E_Var RN.globalsVarName, lookup(env, x))
112              | IL.VK_State strand => CL.mkIndirect(CL.mkVar "selfIn", lookup(env, x))              | IL.VK_State strand => CL.mkIndirect(CL.mkVar "selfIn", lookup(env, x))
113              | IL.VK_Local => CL.mkVar(lookup(env, x))              | IL.VK_Local => CL.mkVar(lookup(env, x))
114            (* end case *))            (* end case *))
115    
116    (* Translate a TreeIL operator application to a CLang expression *)    (* Translate a TreeIL operator application to a CLang expression *)
117      fun trOp (rator, args) = (case (rator, args)      fun trOp (rator, args) = (case (rator, args)
118             of (Op.Add ty, [a, b]) =>             of (Op.Add ty, [a, b]) => CL.mkBinOp(a, CL.#+, b)
119                  CL.mkBinOp(a, CL.#+, b)              | (Op.Sub ty, [a, b]) => CL.mkBinOp(a, CL.#-, b)
120              | (Op.Sub ty, [a, b]) =>              | (Op.Mul ty, [a, b]) => CL.mkBinOp(a, CL.#*, b)
121                  CL.mkBinOp(a, CL.#-, b)              | (Op.Div ty, [a, b]) => CL.mkBinOp(a, CL.#/, b)
122              | (Op.Mul ty, [a, b]) =>              | (Op.Neg ty, [a]) => CL.mkUnOp(CL.%-, a)
123                  CL.mkBinOp(a, CL.#*, b)              | (Op.Abs(Ty.IVecTy 1), args) => CL.mkApply("abs", args)
124              | (Op.Div ty, [a, b]) =>              | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(RN.fabs, args)
125                  CL.mkBinOp(a, CL.#/, b)              | (Op.Abs(Ty.TensorTy[_]), args) => CL.mkApply(RN.fabs, args)
126              | (Op.Neg ty, [a]) =>              | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
127                  CL.mkUnOp(CL.%-, a)              | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
128              | (Op.Abs(Ty.IVecTy 1), args) =>              | (Op.LTE ty, [a, b]) => CL.mkBinOp(a, CL.#<=, b)
129                  CL.mkApply("abs", args)              | (Op.EQ ty, [a, b]) => CL.mkBinOp(a, CL.#==, b)
130              | (Op.Abs(Ty.TensorTy[]), args) =>              | (Op.NEQ ty, [a, b]) => CL.mkBinOp(a, CL.#!=, b)
131                  CL.mkApply(RN.fabs(), args)              | (Op.GTE ty, [a, b]) => CL.mkBinOp(a, CL.#>=, b)
132              | (Op.Abs ty, [a]) =>              | (Op.GT ty, [a, b]) => CL.mkBinOp(a, CL.#>, b)
133                  raise Fail(concat["Abs<", Ty.toString ty, ">"])              | (Op.Not, [a]) => CL.mkUnOp(CL.%!, a)
134              | (Op.LT ty, [a, b]) =>              | (Op.Max, args) => CL.mkApply(RN.max, args)
135                  CL.mkBinOp(a, CL.#<, b)              | (Op.Min, args) => CL.mkApply(RN.min, args)
136              | (Op.LTE ty, [a, b]) =>              | (Op.Clamp ty, [lo, hi, x]) => CL.mkApply(RN.clamp, [x, lo, hi])
                 CL.mkBinOp(a, CL.#<=, b)  
             | (Op.EQ ty, [a, b]) =>  
                 CL.mkBinOp(a, CL.#==, b)  
             | (Op.NEQ ty, [a, b]) =>  
                 CL.mkBinOp(a, CL.#!=, b)  
             | (Op.GTE ty, [a, b]) =>  
                 CL.mkBinOp(a, CL.#>=, b)  
             | (Op.GT ty, [a, b]) =>  
                 CL.mkBinOp(a, CL.#>, b)  
             | (Op.Not, [a]) =>  
                 CL.mkUnOp(CL.%!, a)  
             | (Op.Max, args) =>  
                 CL.mkApply(RN.max(), args)  
             | (Op.Min, args) =>  
                 CL.mkApply(RN.min(), args)  
137              | (Op.Lerp ty, args) => (case ty              | (Op.Lerp ty, args) => (case ty
138                   of Ty.TensorTy[] => CL.mkApply(RN.lerp 1, args)                   of Ty.TensorTy[] => CL.mkApply(RN.lerp, args)
139                    | Ty.TensorTy[n] => CL.mkApply(RN.lerp n, args)                    | Ty.TensorTy[n] => CL.mkApply(RN.lerp, args)
140                    | _ => raise Fail(concat[                    | _ => raise Fail(concat[
141                          "lerp<", Ty.toString ty, "> not supported"                          "lerp<", Ty.toString ty, "> not supported"
142                        ])                        ])
143                  (* end case *))                  (* end case *))
144              | (Op.Dot d, args) =>              | (Op.Dot d, args) => CL.E_Apply(RN.dot, args)
                 CL.E_Apply(RN.dot d, args)  
145              | (Op.MulVecMat(m, n), args) =>              | (Op.MulVecMat(m, n), args) =>
146                  if (1 < m) andalso (m < 4) andalso (m = n)                  if (1 < m) andalso (m < 4) andalso (m = n)
147                    then CL.E_Apply(RN.mulVecMat(m,n), args)                    then CL.E_Apply(RN.mulVecMat(m,n), args)
# Line 173  Line 154 
154                  if (1 < m) andalso (m < 4) andalso (m = n) andalso (n = p)                  if (1 < m) andalso (m < 4) andalso (m = n) andalso (n = p)
155                    then CL.E_Apply(RN.mulMatMat(m,n,p), args)                    then CL.E_Apply(RN.mulMatMat(m,n,p), args)
156                    else raise Fail "unsupported matrix-matrix multiply"                    else raise Fail "unsupported matrix-matrix multiply"
157              | (Op.Cross, args) =>              | (Op.Cross, args) => CL.E_Apply(RN.cross, args)
158                  CL.E_Apply(RN.cross(), args)              | (Op.Select(Ty.IVecTy n, i), [a]) => vecIndex (a, i)
159              | (Op.Select(Ty.IVecTy n, i), [a]) =>              | (Op.Select(Ty.TensorTy[n], i), [a]) => vecIndex (a, i)
160                  ivecIndex (a, n, i)              | (Op.Norm(Ty.TensorTy[n]), args) => CL.E_Apply(RN.length, args)
161              | (Op.Select(Ty.TensorTy[n], i), [a]) =>              | (Op.Norm(Ty.TensorTy[m,n]), args) => CL.E_Apply(RN.norm(m,n), args)
162                  vecIndex (a, n, i)              | (Op.Normalize d, args) => CL.E_Apply(RN.normalize, args)
163              | (Op.Norm(Ty.TensorTy[n]), args) =>              | (Op.Trace n, args) => CL.E_Apply(RN.trace n, args)
164                  CL.E_Apply(RN.length n, args)              | (Op.Scale(Ty.TensorTy[n]), [s, v]) => CL.mkBinOp(s, CL.#*, v)
165              | (Op.Norm(Ty.TensorTy[m,n]), args) =>              | (Op.CL, _) => raise Fail "CL unimplemented"
166                  CL.E_Apply(RN.norm(m,n), args)              | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
167              | (Op.Normalize d, args) =>              | (Op.Subscript(Ty.IVecTy n), [v, CL.E_Int(ix, _)]) => vecIndex (v, Int.fromLarge ix)
                 CL.E_Apply(RN.normalize d, args)  
             | (Op.Trace n, args) =>  
                 CL.E_Apply(RN.trace n, args)  
             | (Op.Scale(Ty.TensorTy[n]), args) =>  
                 CL.E_Apply(RN.scale n, args)  
             | (Op.CL, _) =>  
                 raise Fail "CL unimplemented"  
             | (Op.PrincipleEvec ty, _) =>  
                 raise Fail "PrincipleEvec unimplemented"  
168              | (Op.Subscript(Ty.IVecTy n), [v, ix]) => let              | (Op.Subscript(Ty.IVecTy n), [v, ix]) => let
169                  val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gIntSuffix, "_t"])                  val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gIntSuffix, "_t"])
170                  val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")                  val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
171                  in                  in
172                    CL.mkSubscript(vecExp, ix)                    CL.mkSubscript(vecExp, ix)
173                  end                  end
174                | (Op.Subscript(Ty.TensorTy[n]), [v, CL.E_Int(ix, _)]) => vecIndex (v, Int.fromLarge ix)
175              | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let              | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
176                  val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gRealSuffix, "_t"])                  val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gRealSuffix, "_t"])
177                  val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")                  val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
178                  in                  in
179                    CL.mkSubscript(vecExp, ix)                    CL.mkSubscript(vecExp, ix)
180                  end                  end
181              | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, jx]) =>              | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, CL.E_Int(jx, _)]) =>
182                  CL.mkSubscript(CL.mkSelect(CL.mkSubscript(m, ix), "r"), jx)                  vecIndex(CL.mkSubscript(m, ix), Int.fromLarge jx)
183                | (Op.Subscript(Ty.TensorTy[_,n]), [m, ix, jx]) => let
184                    val unionTy = CL.T_Named(concat["union", Int.toString n, !RN.gRealSuffix, "_t"])
185                    val vecExp = CL.mkSelect(CL.mkCast(unionTy, CL.mkSubscript(m, ix)), "r")
186                    in
187                      CL.mkSubscript(vecExp, jx)
188                    end
189              | (Op.Subscript ty, t::(ixs as _::_)) =>              | (Op.Subscript ty, t::(ixs as _::_)) =>
190                  raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])                  raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
191              | (Op.Ceiling d, args) =>              | (Op.Ceiling d, args) => CL.mkApply("ceil", args)
192                  CL.mkApply(RN.addTySuffix("ceil", d), args)              | (Op.Floor d, args) => CL.mkApply("floor", args)
193              | (Op.Floor d, args) =>              | (Op.Round d, args) => CL.mkApply("round", args)
194                  CL.mkApply(RN.addTySuffix("floor", d), args)              | (Op.Trunc d, args) => CL.mkApply("trunc", args)
195              | (Op.Round d, args) =>              | (Op.IntToReal, [a]) => CL.mkCast(!RN.gRealTy, a)
196                  CL.mkApply(RN.addTySuffix("round", d), args)              | (Op.RealToInt 1, [a]) => CL.mkCast(!RN.gIntTy, a)
             | (Op.Trunc d, args) =>  
                 CL.mkApply(RN.addTySuffix("trunc", d), args)  
             | (Op.IntToReal, [a]) =>  
                 CL.mkCast(!RN.gRealTy, a)  
             | (Op.RealToInt 1, [a]) =>  
                 CL.mkCast(!RN.gIntTy, a)  
197              | (Op.RealToInt d, args) =>              | (Op.RealToInt d, args) =>
198                  CL.mkApply(RN.vecftoi d, args)                  CL.mkApply(RN.vecftoi d, args)
199  (* FIXME: need type info *)  (* FIXME: need type info *)
# Line 242  Line 215 
215              | (Op.PosToImgSpace(ImageInfo.ImgInfo{dim, ...}), [img, pos]) =>              | (Op.PosToImgSpace(ImageInfo.ImgInfo{dim, ...}), [img, pos]) =>
216                  CL.mkApply(RN.toImageSpace dim, [img, pos])                  CL.mkApply(RN.toImageSpace dim, [img, pos])
217              | (Op.TensorToWorldSpace(info, ty), [v, x]) =>              | (Op.TensorToWorldSpace(info, ty), [v, x]) =>
218                  raise Fail "TensorToWorldSpace unimplemented"                  CL.mkApply(RN.toWorldSpace ty, [v, x])
219              | (Op.LoadImage info, [a]) =>              | (Op.LoadImage info, [a]) =>
220                  raise Fail("impossible " ^ Op.toString rator)                  raise Fail("impossible " ^ Op.toString rator)
221              | (Op.Inside(ImageInfo.ImgInfo{dim, ...}, s), [pos, img]) =>              | (Op.Inside(ImageInfo.ImgInfo{dim, ...}, s), [pos, img]) =>
222                  CL.mkApply(RN.inside dim, [pos, img, intExp s])                  CL.mkApply(RN.inside dim, [pos, img, intExp s])
223              | (Op.Input(ty, name), []) =>              | (Op.Input(ty, name, desc), []) =>
224                  raise Fail("impossible " ^ Op.toString rator)                  raise Fail("impossible " ^ Op.toString rator)
225              | (Op.InputWithDefault(ty, name), [a]) =>              | (Op.InputWithDefault(ty, name, desc), [a]) =>
226                  raise Fail("impossible " ^ Op.toString rator)                  raise Fail("impossible " ^ Op.toString rator)
227              | _ => raise Fail(concat[              | _ => raise Fail(concat[
228                    "unknown or incorrect operator ", Op.toString rator                    "unknown or incorrect operator ", Op.toString rator
# Line 258  Line 231 
231    
232      fun trExp (env, e) = (case e      fun trExp (env, e) = (case e
233             of IL.E_Var x => trVar (env, x)             of IL.E_Var x => trVar (env, x)
234              | IL.E_Lit(Literal.Int n) => CL.mkInt(n, !RN.gIntTy)              | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !RN.gIntTy)
235              | IL.E_Lit(Literal.Bool b) => CL.mkBool b              | IL.E_Lit(Literal.Bool b) => CL.mkBool b
236              | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !RN.gRealTy)              | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !RN.gRealTy)
237              | IL.E_Lit(Literal.String s) => CL.mkStr s              | IL.E_Lit(Literal.String s) => CL.mkStr s
# Line 272  Line 245 
245    
246      fun trAssign (env, lhs, rhs) = let      fun trAssign (env, lhs, rhs) = let
247            val lhs = (case V.kind lhs            val lhs = (case V.kind lhs
248                   of IL.VK_Global => CL.mkVar(lookup(env, lhs))                   of IL.VK_Global => CL.mkIndirect(CL.E_Var (RN.globalsVarName),lookup(env, lhs))
249                    | IL.VK_State strand => CL.mkIndirect(CL.mkVar "selfOut", lookup(env, lhs))                    | IL.VK_State strand => CL.mkIndirect(CL.mkVar "selfOut", lookup(env, lhs))
250                    | IL.VK_Local => CL.mkVar(lookup(env, lhs))                    | IL.VK_Local => CL.mkVar(lookup(env, lhs))
251                  (* end case *))                  (* end case *))
# Line 293  Line 266 
266                    [CL.mkCall(RN.mulMatMat(m,n,p), lhs :: trExps(env, args))]                    [CL.mkCall(RN.mulMatMat(m,n,p), lhs :: trExps(env, args))]
267                | IL.E_Op(Op.Identity n, args) =>                | IL.E_Op(Op.Identity n, args) =>
268                    [CL.mkCall(RN.identityMat n, [lhs])]                    [CL.mkCall(RN.identityMat n, [lhs])]
269                | IL.E_Op(Op.Zero(Ty.TensorTy[n,m]), args) =>                | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
270                    [CL.mkCall(RN.zeroMat(m,n), [lhs])]                    [CL.mkCall(RN.zeroMat(m,n), [lhs])]
271                  | IL.E_Op(Op.TensorToWorldSpace(info, ty as Ty.TensorTy[_,_]), args) =>
272                      [CL.mkCall(RN.toWorldSpace ty, lhs :: trExps(env, args))]
273                | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>                | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>
274                    if (n > 1)                    if (n > 1)
275                      then let                      then let
# Line 317  Line 292 
292                  (* matrices are represented as arrays of union<d><ty>_t vectors *)                  (* matrices are represented as arrays of union<d><ty>_t vectors *)
293                    fun doRows (_, []) = []                    fun doRows (_, []) = []
294                      | doRows (i, e::es) =                      | doRows (i, e::es) =
295                          CL.mkAssign(CL.mkSelect(CL.mkSubscript(lhs, intExp i), "v"), e)                          CL.mkAssign(CL.mkSubscript(lhs, intExp i), e)
296                            :: doRows (i+1, es)                            :: doRows (i+1, es)
297                    in                    in
298                      doRows (0, trExps(env, args))                      doRows (0, trExps(env, args))
# Line 330  Line 305 
305              (* end case *)              (* end case *)
306            end            end
307    
308      fun trBlock (env : env, saveState, blk) = let      fun trLocals (env : env, locals) =
309              List.foldl
310                (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
311                  env locals
312    
313          (* generate code to check the status of runtime-system calls *)          (* generate code to check the status of runtime-system calls *)
314            fun checkSts mkDecl = let            fun checkSts mkDecl = let
315                  val sts = freshVar "sts"                  val sts = freshVar "sts"
# Line 340  Line 319 
319                      CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),                      CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
320                      CL.mkCall("exit", [intExp 1]))]                      CL.mkCall("exit", [intExp 1]))]
321                  end                  end
322    
323        fun trStms (env, saveState, stms) = let
324            fun trStmt (env, stm) = (case stm            fun trStmt (env, stm) = (case stm
325                   of IL.S_Comment text => [CL.mkComment text]                   of IL.S_Comment text => [CL.mkComment text]
326                    | IL.S_Assign(x, exp) => trAssign (env, x, exp)                    | IL.S_Assign(x, exp) => trAssign (env, x, exp)
327                    | IL.S_IfThen(cond, thenBlk) =>                    | IL.S_IfThen(cond, thenBlk) =>
328                        [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))]                        [CL.mkIfThen(trExp(env, cond), trBlk(env, saveState, thenBlk))]
329                    | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>                    | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
330                        [CL.mkIfThenElse(trExp(env, cond),                        [CL.mkIfThenElse(trExp(env, cond),
331                          trBlk(env, thenBlk),                          trBlk(env, saveState, thenBlk),
332                          trBlk(env, elseBlk))]                          trBlk(env, saveState, elseBlk))]
333                      | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
334    (* FIXME: I think that S_LoadImage should never happen in OpenCL code [jhr] *)
335                    | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let                    | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
336                        val lhs = lookup(env, lhs)                        val lhs = lookup(env, lhs)
337                        val name = trExp(env, name)                        val name = trExp(env, name)
# Line 359  Line 342 
342                            CL.T_Named RN.statusTy, sts,                            CL.T_Named RN.statusTy, sts,
343                            SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, CL.E_Var lhs)]))))                            SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, CL.E_Var lhs)]))))
344                        ] end)                        ] end)
345                    | IL.S_Input(lhs, name, optDflt) => checkSts (fn sts => let  (* FIXME: I think that S_Input should never happen in OpenCL code [jhr] *)
346                      | IL.S_Input(lhs, name, desc, optDflt) => checkSts (fn sts => let
347                        val inputFn = RN.input(V.ty lhs)                        val inputFn = RN.input(V.ty lhs)
348                        val lhs = lookup(env, lhs)                        val lhs = lookup(env, lhs)
349                        val lhs = CL.E_Var lhs                        val lhs = CL.E_Var lhs
# Line 377  Line 361 
361                        in                        in
362                          initCode @ code                          initCode @ code
363                        end)                        end)
364  (* FIXME: what about the args? *)                    | IL.S_Exit args =>
365                    | IL.S_Exit args => [CL.mkReturn NONE]                        saveState (env, args, CL.mkReturn NONE)
366                    | IL.S_Active args =>                    | IL.S_Active args =>
367                        saveState (env, args, CL.mkReturn(SOME(CL.mkVar RN.kActive)))                        saveState (env, args, CL.mkReturn(SOME(CL.mkVar RN.kActive)))
368                    | IL.S_Stabilize args =>                    | IL.S_Stabilize args =>
369                        saveState (env, args, CL.mkReturn(SOME(CL.mkVar RN.kStabilize)))                        saveState (env, args, CL.mkReturn(SOME(CL.mkVar RN.kStabilize)))
370                    | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar RN.kDie))]                    | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar RN.kDie))]
371                  (* end case *))                  (* end case *))
372            and trBlk (env, IL.Block{locals, body}) = let            in
373                  val env = List.foldl              List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
374                        (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))            end
375                          env locals  
376                  val stms = List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] body      and trBlk (env, saveState, IL.Block{locals, body}) = let
377              val env = trLocals (env, locals)
378              val stms = trStms (env, saveState, body)
379                  fun mkDecl (x, stms) = (case V.Map.find (env, x)                  fun mkDecl (x, stms) = (case V.Map.find (env, x)
380                         of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms                         of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
381                          | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])                          | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
# Line 398  Line 384 
384                  in                  in
385                    CL.mkBlock stms                    CL.mkBlock stms
386                  end                  end
387    
388        fun trFragment (env, IL.Block{locals, body}) = let
389              val env = trLocals (env, locals)
390              val stms = trStms (env, fn _ => raise Fail "exit in fragment", body)
391              fun mkDecl (x, stms) = (case V.Map.find (env, x)
392                     of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
393                      | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
394                    (* end case *))
395              val stms = List.foldr mkDecl stms locals
396            in            in
397              trBlk (env, blk)              (env, stms)
398            end            end
399    
400        val trBlock = trBlk
401    
402    end    end

Legend:
Removed from v.1369  
changed lines
  Added in v.1370

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