(* tree-to-c.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * Translate TreeIL to the C version of CLang.
 *)

signature TREE_VAR_TO_C =
  sig
    type env = CLang.typed_var TreeIL.Var.Map.map
  (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
    val lvalueVar : env * TreeIL.var -> CLang.exp
  (* translate a variable that occurs in a r-value context *)
    val rvalueVar : env * TreeIL.var -> CLang.exp
  (* translate a strand state variable that occurs in an l-value context *)
    val lvalueStateVar : TreeIL.state_var -> CLang.exp
  (* translate a strand state variable that occurs in a r-value context *)
    val rvalueStateVar : TreeIL.state_var -> CLang.exp
  end

functor TreeToCFn (VarToC : TREE_VAR_TO_C) : sig

    type env = CLang.typed_var TreeIL.Var.Map.map

    val empty : env

    val trType : TreeIL.Ty.ty -> CLang.ty

    val trBlock : env * TreeIL.block -> CLang.stm

    val trFree : env * TreeIL.block -> CLang.stm

    val trFragment : env * TreeIL.block -> env * CLang.stm list

    val trExp : env * TreeIL.exp -> CLang.exp

    val trAssign : env * CLang.exp * TreeIL.exp -> CLang.stm list

  (* vector indexing support.  Arguments are: vector, arity, index *)
    val ivecIndex : CLang.exp * int * int -> CLang.exp
    val vecIndex : CLang.exp * int * int -> CLang.exp

  end = struct

    structure CL = CLang
    structure N = CNames
    structure IL = TreeIL
    structure Op = IL.Op
    structure Ty = IL.Ty
    structure V = IL.Var

    datatype var = datatype CLang.typed_var
    type env = CLang.typed_var TreeIL.Var.Map.map

    val empty = TreeIL.Var.Map.empty

    fun lookup (env, x) = (case V.Map.find (env, x)
           of SOME(V(_, x')) => x'
            | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
          (* end case *))

  (* integer literal expression *)
    fun intExp (i : int) = CL.mkInt(IntInf.fromInt i)

    fun addrOf e = CL.mkUnOp(CL.%&, e)

  (* translate TreeIL types to CLang types *)
    val trType = CTyTranslate.toType

  (* generate new variables *)
    local
      val count = ref 0
      fun freshName prefix = let
            val n = !count
            in
              count := n+1;
              concat[prefix, "_", Int.toString n]
            end
    in
    fun tmpVar ty = freshName "tmp"
    fun freshVar prefix = freshName prefix
    end (* local *)

  (* translate IL basis functions *)
    local
      fun mkLookup suffix = let
            val tbl = MathFuns.Tbl.mkTable (16, Fail "basis table")
            fun ins f = MathFuns.Tbl.insert tbl (f, MathFuns.toString f ^ suffix)
            in
              List.app ins MathFuns.allFuns;
              MathFuns.Tbl.lookup tbl
            end
      val fLookup = mkLookup "f"
      val dLookup = mkLookup ""
    in
    fun trApply (f, args) = let
          val f' = if !N.doublePrecision then dLookup f else fLookup f
          in
            CL.mkApply(f', args)
          end
    end (* local *)

  (* vector indexing support.  Arguments are: vector, arity, index *)
    fun ivecIndex (v, n, ix) = let
          val e1 = CL.mkCast(CL.T_Named(N.iunionTy n), v)
          val e2 = CL.mkSelect(e1, "i")
          in
            CL.mkSubscript(e2, intExp ix)
          end

    fun vecIndex (v, n, ix) = let
          val e1 = CL.mkCast(CL.T_Named(N.unionTy n), v)
          val e2 = CL.mkSelect(e1, "r")
          in
            CL.mkSubscript(e2, intExp ix)
          end

  (* matrix indexing *)
    fun matIndex (m, ix, jx) =
          CL.mkSubscript(CL.mkSelect(CL.mkSubscript(m, ix), "r"), jx)

  (* Translate a TreeIL operator application to a CLang expression *)
    fun trOp (rator, args) = (case (rator, args)
           of (Op.Add ty, [a, b]) => CL.mkBinOp(a, CL.#+, b)
            | (Op.Sub ty, [a, b]) => CL.mkBinOp(a, CL.#-, b)
            | (Op.Mul ty, [a, b]) => CL.mkBinOp(a, CL.#*, b)
            | (Op.Div ty, [a, b]) => CL.mkBinOp(a, CL.#/, b)
            | (Op.Neg ty, [a]) => CL.mkUnOp(CL.%-, a)
            | (Op.Abs(Ty.IntTy), args) => CL.mkApply("abs", args)
            | (Op.Abs(Ty.TensorTy[]), args) => CL.mkApply(N.fabs(), args)
            | (Op.Abs ty, [a]) => raise Fail(concat["Abs<", Ty.toString ty, ">"])
            | (Op.LT ty, [a, b]) => CL.mkBinOp(a, CL.#<, b)
            | (Op.LTE ty, [a, b]) => 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(N.max(), args)
            | (Op.Min, args) => CL.mkApply(N.min(), args)
            | (Op.Clamp(Ty.TensorTy[]), args) => CL.mkApply(N.clamp 1, args)
            | (Op.Clamp(Ty.TensorTy[n]), args) => CL.mkApply(N.clamp n, args)
            | (Op.Lerp ty, args) => (case ty
                 of Ty.TensorTy[] => CL.mkApply(N.lerp 1, args)
                  | Ty.TensorTy[n] => CL.mkApply(N.lerp n, args)
                  | _ => raise Fail(concat[
                        "lerp<", Ty.toString ty, "> not supported"
                      ])
                (* end case *))
            | (Op.Dot d, args) => CL.E_Apply(N.dot d, args)
            | (Op.MulVecMat(m, n), args) =>
                if (1 < m) andalso (m <= 4) andalso (m = n)
                  then CL.E_Apply(N.mulVecMat(m,n), args)
                  else raise Fail "unsupported vector-matrix multiply"
            | (Op.MulMatVec(m, n), args) =>
                if (1 < m) andalso (m <= 4) andalso (m = n)
                  then CL.E_Apply(N.mulMatVec(m,n), args)
                  else raise Fail "unsupported matrix-vector multiply"
            | (Op.MulMatMat(m, n, p), args) =>
                if (1 < m) andalso (m <= 4) andalso (m = n) andalso (n = p)
                  then CL.E_Apply(N.mulMatMat(m,n,p), args)
                  else raise Fail "unsupported matrix-matrix multiply"
	    | (Op.ColonMul(Ty.TensorTy dd1, Ty.TensorTy dd2), args) =>
		CL.E_Apply(N.colonMul(dd1, dd2), args)
            | (Op.Cross, args) => CL.E_Apply(N.cross(), args)
            | (Op.Norm(Ty.TensorTy[n]), args) => CL.E_Apply(N.length n, args)
            | (Op.Norm(Ty.TensorTy[m,n]), args) => CL.E_Apply(N.normMat(m,n), args)
            | (Op.Norm(Ty.TensorTy[m,n,p]), args) => CL.E_Apply(N.normTen3(m,n,p), args)
            | (Op.Normalize d, args) => CL.E_Apply(N.normalize d, args)
            | (Op.Dist d, args) => CL.E_Apply(N.dist d, args)
            | (Op.Scale(Ty.TensorTy[n]), args) => CL.E_Apply(N.scale n, args)
            | (Op.PrincipleEvec ty, _) => raise Fail "PrincipleEvec unimplemented"
            | (Op.Select(Ty.TupleTy tys, i), [a]) => raise Fail "Select unimplemented"
            | (Op.Index(Ty.SeqTy(Ty.IntTy, n), i), [a]) => ivecIndex (a, n, i)
            | (Op.Index(Ty.TensorTy[n], i), [a]) => vecIndex (a, n, i)
            | (Op.Subscript(Ty.SeqTy(Ty.IntTy, n)), [v, ix]) => let
                val unionTy = CL.T_Named(N.iunionTy n)
                val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "i")
                in
                  CL.mkSubscript(vecExp, ix)
                end
            | (Op.Subscript(Ty.SeqTy(ty, n)), [v, ix]) => CL.mkSubscript(v, ix)
	    | (Op.Subscript(Ty.DynSeqTy ty), [v, ix]) => let
		val elemTy = trType ty
		in
		  CL.mkUnOp (CL.%*,
		    CL.mkCast(CL.T_Ptr elemTy,
		      CL.mkApply("Diderot_DynSeqAddr", [CL.mkSizeof elemTy, v, ix])))
		end
            | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
                val unionTy = CL.T_Named(N.unionTy n)
                val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
                in
                  CL.mkSubscript(vecExp, ix)
                end
            | (Op.Subscript(Ty.TensorTy[_,_]), [m, ix, jx]) => matIndex (m, ix, jx)
            | (Op.Subscript ty, t::(ixs as _::_)) =>
                raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
            | (Op.MkDynamic(ty, n), [seq]) => CL.mkApply("Diderot_DynSeqMk", [
                  CL.mkSizeof(trType ty), CL.mkInt(IntInf.fromInt n),
                  addrOf (CL.mkSubscript(seq, intExp 0))
                ])
            | (Op.Append ty, [seq, x]) => CL.mkApply("Diderot_DynSeqAppend", [
                  CL.mkSizeof(trType ty), seq, addrOf x
                ])
            | (Op.Prepend ty, [x, seq]) => CL.mkApply("Diderot_DynSeqPrepend", [
                  CL.mkSizeof(trType ty), addrOf x, seq
                ])
            | (Op.Concat ty, [seq1, seq2]) => CL.mkApply("Diderot_DynSeqConcat", [
                  CL.mkSizeof(trType ty), seq1, seq2
                ])
	    | (Op.Length _, [seq]) => CL.mkApply("Diderot_DynSeqLength", [seq])
            | (Op.Ceiling d, args) => CL.mkApply(N.addTySuffix("ceil", d), args)
            | (Op.Floor d, args) => CL.mkApply(N.addTySuffix("floor", d), args)
            | (Op.Round d, args) => CL.mkApply(N.addTySuffix("round", d), args)
            | (Op.Trunc d, args) => CL.mkApply(N.addTySuffix("trunc", d), args)
            | (Op.IntToReal, [a]) => CL.mkCast(!N.gRealTy, a)
            | (Op.RealToInt 1, [a]) => CL.mkCast(!N.gIntTy, a)
            | (Op.RealToInt d, args) => CL.mkApply(N.vecftoi d, args)        
            | (Op.ImageAddress info, [a]) => let
                val cTy = CL.T_Ptr(CL.T_Num(ImageInfo.sampleTy info))
                in
                  CL.mkCast(cTy, CL.mkIndirect(a, "data"))
                end
            | (Op.LoadVoxels(info, 1), [a]) => let
                val realTy as CL.T_Num rTy = !N.gRealTy
                val a = CL.E_UnOp(CL.%*, a)
                in
                  if (rTy = ImageInfo.sampleTy info)
                    then a
                    else CL.E_Cast(realTy, a)
                end
            | (Op.LoadVoxels _, [a]) =>
                raise Fail("impossible " ^ Op.toString rator)
            | (Op.PosToImgSpace info, [img, pos]) =>
                CL.mkApply(N.toImageSpace(ImageInfo.dim info), [img, pos])
            | (Op.TensorToWorldSpace(info, ty), [v, x]) =>
                CL.mkApply(N.toWorldSpace ty, [v, x])
            | (Op.Inside(info, s), [pos, img]) =>
                CL.mkApply(N.inside(ImageInfo.dim info), [pos, img, intExp s])
            | (Op.LoadSeq(ty, nrrd), []) =>
                raise Fail("impossible " ^ Op.toString rator)
            | (Op.LoadImage(ty, nrrd, info), []) =>
                raise Fail("impossible " ^ Op.toString rator)
            | (Op.Input _, []) => raise Fail("impossible " ^ Op.toString rator)
            | _ => raise Fail(concat[
                  "unknown or incorrect operator ", Op.toString rator
                ])
          (* end case *))

    fun trExp (env, e) = (case e
           of IL.E_State x => VarToC.rvalueStateVar x
            | IL.E_Var x => VarToC.rvalueVar (env, x)
            | IL.E_Selector (x,f) => CL.mkIndirect(trExp(env, x),Atom.toString f)
            | IL.E_Lit(Literal.Int n) => CL.mkIntTy(n, !N.gIntTy)
            | IL.E_Lit(Literal.Bool b) => CL.mkBool b
            | IL.E_Lit(Literal.Float f) => CL.mkFlt(f, !N.gRealTy)
            | IL.E_Lit(Literal.String s) => CL.mkStr s
            | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
            | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
            | IL.E_Cons(Ty.TensorTy[n], args) => CL.mkApply(N.mkVec n, trExps(env, args))
            | IL.E_Cons(ty, _) => raise Fail(concat["E_Cons(", Ty.toString ty, ", _) in expression"])
          (* end case *))

    and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps

  (* translate an expression to a variable form; return the variable and the
   * (optional) declaration.
   *)
    fun expToVar (env, ty, name, exp) = (case trExp(env, exp)
           of x as CL.E_Var _ => (x, [])
            | exp => let
                val x = freshVar name
                in
                  (CL.mkVar x, [CL.mkDecl(ty, x, SOME(CL.I_Exp exp))])
                end
          (* end case *))

  (* translate a print statement *)
    fun trPrint (env, tys, args) = let
        (* assemble the format string by analysing the types and argument expressions *)
          fun mkFmt (Ty.StringTy, IL.E_Lit(Literal.String s), (stms, fmt, args)) =
                (stms, s::fmt, args)
            | mkFmt (ty, exp, (stms, fmt, args)) = let
                fun mk (f, e) = (stms, f::fmt, e::args)
                in
                  case ty
                   of Ty.BoolTy => mk(
                        "%s",
                        CL.mkCond(trExp(env, exp), CL.mkStr "true", CL.mkStr "false"))
                    | Ty.StringTy => mk("%s", trExp(env, exp))
                    | Ty.IntTy => mk(!N.gIntFormat, trExp(env, exp))
                    | Ty.TensorTy[] => mk("%f", trExp(env, exp))
                    | Ty.TensorTy[n] => let
                        val (x, stm) = expToVar (env, trType ty, "vec", exp)
                        val elems = List.tabulate (n, fn i => vecIndex (x, n, i))
                        val (fmt, args) = mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
                        in
                          (stm@stms, fmt, args)
                        end
(*
                    | Ty.TensorTy[n, m] => 
*)
                    | Ty.SeqTy(elemTy, n) =>  let
                        val (x, stm) = expToVar (env, trType ty, "vec", exp)
                        val elems = List.tabulate (n, fn i => ivecIndex (x, n, i))
                        val (fmt, args) = mkSeqFmt (elemTy, elems, fmt, args)
                        in
                          (stm@stms, fmt, args)
                        end
                    | _ => raise Fail(concat["TreeToC.trPrint(", Ty.toString ty, ")"])
                  (* end case *)
                end
          and mkElemFmt (elemTy, elem, (fmt, args)) = (case elemTy
                 of Ty.BoolTy =>
                      ("%s"::fmt, CL.mkCond(elem, CL.mkStr "true", CL.mkStr "false")::args)
                  | Ty.StringTy => ("%s"::fmt, elem::args)
                  | Ty.IntTy => (!N.gIntFormat::fmt, elem::args)
                  | Ty.TensorTy[] => ("%f"::fmt, elem::args)
                  | Ty.TensorTy[n] => let
                      val elems = List.tabulate (n, fn i => vecIndex (elem, n, i))
                      in
                        mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
                      end
(*
                  | Ty.TensorTy[n, m] => 
*)
                  | Ty.SeqTy(elemTy, n) =>  let
                      val elems = List.tabulate (n, fn i => ivecIndex (elem, n, i))
                      in
                        mkSeqFmt (elemTy, elems, fmt, args)
                      end
                  | _ => raise Fail(concat["TreeToC.mkElemFmt(", Ty.toString elemTy, ")"])
                (* end case *))
          and mkSeqFmt (elemTy, elems, fmt, args) = let
                fun mk (elem, acc) = mkFmt(elemTy, elem, acc)
                val (seqFmt, args) =
                      List.foldr
                        (fn (elem, acc) => mkElemFmt(elemTy, elem, acc))
                          ([], args) elems
                in
                  ("<" :: String.concatWith "," seqFmt :: ">" :: fmt, args)
                end
          val (stms, fmt, args) = ListPair.foldr mkFmt ([], [], []) (tys, args)
          val stm = CL.mkCall("fprintf", CL.mkVar "stderr" :: CL.mkStr(String.concat fmt) :: args)
          in
            List.rev (stm :: stms)
          end

    fun trAssign (env, lhs, rhs) = (
        (* certain rhs forms, such as those that return a matrix,
         * require a function call instead of an assignment
         *)
          case rhs
           of IL.E_Op(Op.Add(Ty.TensorTy[m,n]), args) =>
                [CL.mkCall(N.addMat(m,n),  lhs :: trExps(env, args))]
            | IL.E_Op(Op.Sub(Ty.TensorTy[m,n]), args) =>
                [CL.mkCall(N.subMat(m,n),  lhs :: trExps(env, args))]
            | IL.E_Op(Op.Neg(Ty.TensorTy[m,n]), args) =>
                [CL.mkCall(N.scaleMat(m,n),  lhs :: intExp ~1 :: trExps(env, args))]
            | IL.E_Op(Op.Scale(Ty.TensorTy[m,n]), args) =>
                [CL.mkCall(N.scaleMat(m,n),  lhs :: trExps(env, args))]
            | IL.E_Op(Op.MulMatMat(m,n,p), args) =>
                [CL.mkCall(N.mulMatMat(m,n,p), lhs :: trExps(env, args))]
            | IL.E_Op(Op.SphereQuery(_),args)=>  let 
                    val [radius] =  trExps(env, args)
                    in 
                     [CL.mkAssign(lhs,CL.mkApply(N.sphereQuery,[CL.E_Var N.strandsName, 
                                                  CL.E_Var "selfIn",
                                                  CL.E_Var N.gridCxtName, 
                                                  CL.E_Var N.queryPoolName,    
                                                  radius]))]
                    end
            | IL.E_Op(Op.MulVecTen3(m, n, p), args) =>
                if (1 < m) andalso (m <= 4) andalso (m = n) andalso (n = p)
                  then [CL.mkCall(N.mulVecTen3(m,n,p), lhs :: trExps(env, args))]
                  else raise Fail "unsupported vector-tensor multiply"
            | IL.E_Op(Op.MulTen3Vec(m, n, p), args) =>
                if (1 < m) andalso (m <= 4) andalso (m = n) andalso (n = p)
                  then [CL.mkCall(N.mulTen3Vec(m,n,p), lhs :: trExps(env, args))]
                  else raise Fail "unsupported tensor-vector multiply"
	        | IL.E_Op(Op.ColonMul(Ty.TensorTy dd1, Ty.TensorTy dd2), args) =>
                if (length dd1 + length dd2 > 5)
                  then [CL.mkCall(N.colonMul(dd1, dd2), lhs :: trExps(env, args))]
                  else [CL.mkAssign(lhs, trExp(env, rhs))]
            | IL.E_Op(Op.EigenVals2x2, [m]) => let
                val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
                in
                  stms @ [CL.mkCall(N.evals2x2, [
                      lhs,
                      matIndex (m, CL.mkInt 0, CL.mkInt 0),
                      matIndex (m, CL.mkInt 0, CL.mkInt 1),
                      matIndex (m, CL.mkInt 1, CL.mkInt 1)
                    ])]
                end
            | IL.E_Op(Op.EigenVals3x3, [m]) => let
                val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
                in
                  stms @ [CL.mkCall(N.evals3x3, [
                      lhs,
                      matIndex (m, CL.mkInt 0, CL.mkInt 0),
                      matIndex (m, CL.mkInt 0, CL.mkInt 1),
                      matIndex (m, CL.mkInt 0, CL.mkInt 2),
                      matIndex (m, CL.mkInt 1, CL.mkInt 1),
                      matIndex (m, CL.mkInt 1, CL.mkInt 2),
                      matIndex (m, CL.mkInt 2, CL.mkInt 2)
                    ])]
                end
             | IL.E_Op(Op.R_And _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.S_Exp(CL.mkAssignOp(lhs,CL.&=, CL.mkGrp(trExp(env,arg1)))))] 
                 end
             | IL.E_Op(Op.R_Or _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.S_Exp(CL.mkAssignOp(lhs,CL.|=, CL.mkGrp(trExp(env,arg1)))))] 
                 end
             | IL.E_Op(Op.R_Xor _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.S_Exp(CL.mkAssignOp(lhs,CL.^=, CL.mkGrp(trExp(env,arg1)))))] 
                 end
             | IL.E_Op(Op.R_Max _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.mkAssign(lhs,CL.mkApply((N.max ()),[lhs,trExp(env,arg1)])))]
                 end 
             | IL.E_Op(Op.R_Min _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.mkAssign(lhs,CL.mkApply((N.min ()),[lhs,trExp(env,arg1)])))]
                 end     
             | IL.E_Op(Op.R_Sum _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.S_Exp(CL.mkAssignOp(lhs,CL.+=, trExp(env,arg1))))] 
                 end
             | IL.E_Op(Op.R_Product _ , [arg1,sx]) => let    
                 val cond = CL.mkBinOp(CL.mkSubscript(trExp(env,sx),CL.mkInt 0), CL.#!=, CL.mkInt(0)) 
                 in 
                     [CL.mkIfThen(cond,CL.S_Exp(CL.mkAssignOp(lhs,CL.+=, trExp(env,arg1))))] 
                 end
             | IL.E_Strand_Set set => let
               fun trStrandSet s = (case s 
                 of IL.SS_Active => N.kActive
                  | IL.SS_Stable =>  N.kStable 
                  | IL.SS_Dead =>  N.kStable
                 (* end case *))
                fun mkCond([]) =  raise Fail("impossible: strand set NULL.") 
                  | mkCond(s::[]) = CL.mkBinOp(CL.mkVar("selfInStatus"), CL.#==, CL.mkVar(trStrandSet(s)))
                  | mkCond(s::xs) = CL.mkBinOp(CL.mkBinOp(CL.mkVar("selfInStatus"), CL.#==, CL.mkVar(trStrandSet(s))), 
                      CL.#||, mkCond(xs)) 
                in 
                   [CL.mkIfThenElse(mkCond(set),CL.mkAssign(CL.mkSubscript(lhs,CL.mkInt 0),CL.mkVar("selfIn")), 
                                                CL.mkAssign(CL.mkSubscript(lhs,CL.mkInt 0),CL.mkInt(0)))]  
                end       
            | IL.E_Op(Op.Identity n, args) =>
                [CL.mkCall(N.identityMat n, [lhs])]
            | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
                [CL.mkCall(N.zeroMat(m,n), [lhs])]
            | IL.E_Op(Op.TensorToWorldSpace(info, ty as Ty.TensorTy(_::_::_)), args) =>
                [CL.mkCall(N.toWorldSpace ty, lhs :: trExps(env, args))]
            | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>
                if (n > 1)
                  then let
                    val stride = ImageInfo.stride info
                    val rTy = ImageInfo.sampleTy info
                    val vp = freshVar "vp"
                    val needsCast = (CL.T_Num rTy <> !N.gRealTy)
                    fun mkLoad i = let
                          val e = CL.mkSubscript(CL.mkVar vp, intExp(i*stride))
                          in
                            if needsCast then CL.mkCast(!N.gRealTy, e) else e
                          end
                    in [
                      CL.mkDecl(CL.T_Ptr(CL.T_Num rTy), vp, SOME(CL.I_Exp(trExp(env, a)))),
                      CL.mkAssign(lhs,
                        CL.mkApply(N.mkVec n, List.tabulate (n, mkLoad)))
                    ] end
                else [CL.mkAssign(lhs, trExp(env, rhs))]
            | IL.E_Cons(Ty.TensorTy[n,m], args) => let
              (* matrices are represented as arrays of union<d><ty>_t vectors *)
                fun doRows (_, []) = []
                  | doRows (i, e::es) =
                      CL.mkAssign(CL.mkSelect(CL.mkSubscript(lhs, intExp i), "v"), e)
                        :: doRows (i+1, es)
                in
                  doRows (0, trExps(env, args))
                end
            | IL.E_Cons(Ty.TensorTy[n,m,l], args) => let
              (* 3rd-order tensors are represented as 2D arrays of union<d><ty>_t vectors *)
                fun lp1 (i, [], code) = code
                  | lp1 (i, e::es, code) = let
                      val lhs_i = CL.mkSubscript(lhs, intExp i)
                      fun lp2 j = if (j < m)
                            then CL.mkAssign(
                                CL.mkSelect(CL.mkSubscript(lhs_i, intExp j), "v"),
                                CL.mkSelect(CL.mkSubscript (e, intExp j), "v")
                              ) :: lp2(j+1)
                            else code
                      in
                        lp1 (i+1, es, lp2 0)
                      end
                in
                  lp1 (0, trExps(env, args), [])
                end
            | IL.E_Cons(Ty.SeqTy(ty, n), args) => let
                fun doAssign (_, []) = []
                  | doAssign (i, arg::args) =
                      CL.mkAssign(CL.mkSubscript(lhs, intExp i), arg) :: doAssign(i+1, args)
                in
                  doAssign (0, trExps(env, args))
                end
	    | IL.E_State x => (case IL.StateVar.ty x
		 of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueStateVar x])]
		  | Ty.TensorTy[n,m,l] => [CL.mkCall(N.copyTen3(n,m,l), [lhs, VarToC.rvalueStateVar x])]
                  | _ => [CL.mkAssign(lhs, VarToC.rvalueStateVar x)]
		(* end case *))
            | IL.E_Var x => (case IL.Var.ty x
                 of Ty.TensorTy[n,m] => [CL.mkCall(N.copyMat(n,m), [lhs, VarToC.rvalueVar(env, x)])]
		  | Ty.TensorTy[n,m,l] => [CL.mkCall(N.copyTen3(n,m,l), [lhs, VarToC.rvalueVar(env, x)])]
                  | _ => [CL.mkAssign(lhs, VarToC.rvalueVar(env, x))]
                (* end case *))
            | _ => [CL.mkAssign(lhs, trExp(env, rhs))]
          (* end case *))

    fun trMultiAssign (env, lhs, IL.E_Op(rator, args)) = (case (lhs, rator, args)
           of ([vals, vecs], Op.EigenVecs2x2, [m]) => let
                val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
                in
                  stms @ [CL.mkCall(N.evecs2x2, [
                      vals, vecs,
                      matIndex (m, CL.mkInt 0, CL.mkInt 0),
                      matIndex (m, CL.mkInt 0, CL.mkInt 1),
                      matIndex (m, CL.mkInt 1, CL.mkInt 1)
                    ])]
                end
            | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
                val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
                in
                  stms @ [CL.mkCall(N.evecs3x3, [
                      vals, vecs,
                      matIndex (m, CL.mkInt 0, CL.mkInt 0),
                      matIndex (m, CL.mkInt 0, CL.mkInt 1),
                      matIndex (m, CL.mkInt 0, CL.mkInt 2),
                      matIndex (m, CL.mkInt 1, CL.mkInt 1),
                      matIndex (m, CL.mkInt 1, CL.mkInt 2),
                      matIndex (m, CL.mkInt 2, CL.mkInt 2)
                    ])]
                end
            | ([], Op.Print tys, args) => trPrint (env, tys, args)
            | _ => raise Fail "bogus multi-assignment"
          (* end case *))
      | trMultiAssign (env, lhs, rhs) = raise Fail "bogus multi-assignment"

    fun trLocals (env : env, locals) = 
          List.foldl
            (fn (x, env) => V.Map.insert(env, x, V(trType(V.ty x), V.name x)))
              env locals

  (* generate code to check the status of runtime-system calls; this code assumes that
   * we are in a function with a boolean return type
   *)
    fun checkSts mkDecl = let
          val sts = freshVar "sts"
          in
            mkDecl sts @
            [CL.mkIfThen(
              CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
              CL.mkReturn(SOME(CL.mkVar "true")))]
          end

  (* given the global initialization code, generate code to free the storage that is heap
   * allocated for globals.
   *)
    fun trFree (env, IL.Block{locals, body}) = let
          val env = trLocals (env, locals)
          fun trStmt (env, stm) = (case stm
                 of IL.S_Comment text => [CL.mkComment text]
(* DEPRECATED
                  | IL.S_LoadImage(lhs, dim, name) => checkSts (fn sts => let
                      val lhs = VarToC.lvalueVar (env, lhs)
                      val imgTy = CL.T_Named(N.imageTy dim)
                      val freeFn = N.freeImage dim
                      in [
                        CL.mkDecl(
                          CL.T_Named N.statusTy, sts,
                          SOME(CL.I_Exp(CL.E_Apply(freeFn, [
                              CL.mkCast(CL.T_Ptr(CL.T_Named "WorldPrefix_t"), CL.mkVar "wrld"),
                              addrOf lhs
                            ]))))
                      ] end)
*)
                  | IL.S_LoadNrrd _ => [] (* FIXME *)
                  | IL.S_InputNrrd _ => [] (* FIXME *)
                  | _ => []
                (* end case *))
          val stms = List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] body
          fun mkDecl (x, stms) = (case V.Map.find (env, x)
                 of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
                  | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
                (* end case *))
          val stms = List.foldr mkDecl stms locals
          in
            CL.mkBlock stms
          end

    fun trStms (env, stms) = let
          fun trStmt (env, stm) = (case stm
                 of IL.S_Comment text => [CL.mkComment text]
                  | IL.S_Assign([x], exp) => trAssign (env, VarToC.lvalueVar (env, x), exp)
                  | IL.S_Assign(xs, exp) =>
                      trMultiAssign (env, List.map (fn x => VarToC.lvalueVar (env, x)) xs, exp)
                  | IL.S_IfThen(cond, thenBlk) =>
                      [CL.mkIfThen(trExp(env, cond), trBlk(env, thenBlk))]
                  | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
                      [CL.mkIfThenElse(trExp(env, cond),
                        trBlk(env, thenBlk),
                        trBlk(env, elseBlk))]
                  | IL.S_Foreach(cond,block,_) =>trForeach(env,cond,block)
                  | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
                  | IL.S_Save([x], exp) => trAssign (env, VarToC.lvalueStateVar x, exp)
                  | IL.S_Save(xs, exp) =>
                      trMultiAssign (env, List.map VarToC.lvalueStateVar xs, exp)
                  | IL.S_LoadNrrd(lhs, Ty.DynSeqTy ty, nrrd) =>
		      [GenLoadNrrd.loadSeqFromFile (VarToC.lvalueVar (env, lhs), ty, CL.mkStr nrrd)]
                  | IL.S_LoadNrrd(lhs, Ty.ImageTy info, nrrd) =>
		      [GenLoadNrrd.loadImage (VarToC.lvalueVar (env, lhs), info, CL.E_Str nrrd)]
                  | IL.S_Input(_, _, _, NONE) => []
                  | IL.S_Input(lhs, name, _, SOME dflt) => [
                        CL.mkAssign(VarToC.lvalueVar(env, lhs), trExp(env, dflt))
                      ]
                  | IL.S_InputNrrd _ => []
                  | IL.S_Exit args => []
                  | IL.S_Active => [CL.mkReturn(SOME(CL.mkVar N.kActive))]
                  | IL.S_Stabilize => [CL.mkReturn(SOME(CL.mkVar N.kStabilize))]
                  | IL.S_Die => [CL.mkReturn(SOME(CL.mkVar N.kDie))]
                (* end case *))
          in
            List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
          end

    and trForeach(env,cond,b as IL.Block{locals,body}) = let 
           val foreachStms = trBlk(env,b)
           val condVar = trExp(env, cond)
           val iterVarName = freshVar "tmp" 
           val dynSeqSize = CL.mkIndirect(condVar,"nElems")
         in 
            [CL.mkFor([(CL.uint32, iterVarName, CL.mkInt(0))],
                        CL.mkBinOp(CL.mkVar(iterVarName), CL.#<, dynSeqSize),
                        [CL.mkPostOp(CL.mkVar(iterVarName), CL.^++)],
                        CL.mkBlock([foreachStms]))]
         end 
           

    and trBlk (env, IL.Block{locals, body}) = let
          val env = trLocals (env, locals)
          val stms = trStms (env, body)
          fun mkDecl (x, stms) = (case V.Map.find (env, x)
                 of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
                  | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
                (* end case *))
          val stms = List.foldr mkDecl stms locals
          in
            CL.mkBlock stms
          end

    fun trFragment (env, IL.Block{locals, body}) = let
          val env = trLocals (env, locals)
          val stms = trStms (env, body)
          fun mkDecl (x, stms) = (case V.Map.find (env, x)
                 of SOME(V(ty, x')) => CL.mkDecl(ty, x', NONE) :: stms
                  | NONE => raise Fail(concat["mkDecl(", V.name x, ", _)"])
                (* end case *))
          val stms = List.foldr mkDecl stms locals
          in
            (env, stms)
          end

    val trBlock = trBlk

  end

(* FIXME: once we can consolidate the OpenCL and C backends, then we can get rid of the
 * functor application.
 *)
local
  structure IL = TreeIL
  structure V = IL.Var
  structure CL = CLang
(* variable translation *)
  structure TrVar =
    struct
      type env = CL.typed_var V.Map.map
      fun lookup (env, x) = (case V.Map.find (env, x)
	     of SOME(CL.V(_, x')) => x'
	      | NONE => raise Fail(concat["lookup(_, ", V.name x, ")"])
	    (* end case *))
    (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
      fun lvalueVar (env, x) = CL.mkVar(lookup(env, x))
    (* translate a variable that occurs in an r-value context *)
      fun rvalueVar (env, x) = CL.mkVar(lookup(env, x))
    (* translate a variable that occurs in an l-value context (i.e., as the target of an assignment) *)
      fun lvalueVar (env, x) = (case V.kind x
	     of IL.VK_Local => CL.mkVar(lookup(env, x))
	      | _ => CL.mkIndirect(CL.mkVar "glob", lookup(env, x))
	    (* end case *))
    (* translate a variable that occurs in an r-value context *)
      fun rvalueVar (env, x) = (case V.kind x
	     of IL.VK_Local => CL.mkVar(lookup(env, x))
	      | _ => CL.mkIndirect(CL.mkVar "glob", lookup(env, x))
	    (* end case *))
    (* translate a strand state variable that occurs in an l-value context *)
      fun lvalueStateVar x = CL.mkIndirect(CL.mkVar "selfOut", IL.StateVar.name x)
    (* translate a strand state variable that occurs in an r-value context *)
      fun rvalueStateVar x = CL.mkIndirect(CL.mkVar "selfIn", IL.StateVar.name x)
    end
in
structure TreeToC = TreeToCFn (TrVar)
end