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

SCM Repository

[diderot] View of /branches/charisee/src/compiler/c-util/tree-to-c-fn.sml
ViewVC logotype

View of /branches/charisee/src/compiler/c-util/tree-to-c-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3706 - (download) (annotate)
Fri Apr 1 00:15:53 2016 UTC (3 years, 6 months ago) by cchiw
File size: 35744 byte(s)
added c-target-basevis for merge
(* tree-to-c.sml
 *
 * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
 *
 * COPYRIGHT (c) 2015 The University of Chicago
 * 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 trType : TreeIL.Ty.ty -> CLang.ty
 
    val tyTransform : TreeIL.Ty.ty -> CLang.ty

    val trBlock : env * TreeIL.block * (int -> bool) -> CLang.stm

    val trFragment : env * TreeIL.block * (int -> bool) -> env * CLang.stm list

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

  (* vector indexing support.  Arguments are: vector, arity, index *)
    val ivecIndex : CLang.exp * int * int -> CLang.exp
    val vecIndex : CLang.exp * int * int -> CLang.exp
    val prntArr1 : CLang.exp *  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
    structure StV = IL.StateVar

    datatype var = datatype CLang.typed_var
    type env = CLang.typed_var TreeIL.Var.Map.map
 
    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 *)

    fun trType ty = 
        (case ty
            of Ty.BoolTy => CLang.T_Named "bool"
            | Ty.StringTy => CL.charPtr
            | Ty.IntTy => !N.gIntTy
            | Ty.TensorTy[] => !N.gRealTy
            | Ty.TensorTy t => CL.mkRealArr(N.tprog ,t)
            | Ty.SeqTy(Ty.IntTy, n) => CL.T_Named(N.ivecTy n)
            | Ty.SeqTy(ty, n) => let
                in  CL.T_Array(trType ty, SOME n)
                end 
            | Ty.AddrTy info => CL.T_Ptr(CL.T_Num(ImageInfo.sampleTy info))
            | Ty.ImageTy info => CL.T_Ptr(CL.T_Named(N.imageTy(ImageInfo.dim info)))
            | _ => raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])
          (* end case *))
 
 fun tyTransform ty =
    (case ty
        of Ty.TensorTy[2] => CLang.T_Named(N.LocalTy [2])
        | Ty.TensorTy[3] => CLang.T_Named(N.LocalTy [3])
        | Ty.TensorTy[4] => CLang.T_Named(N.LocalTy [4])
        | _ => trType ty
     (* end case *))
 
 (*creates global var if it's not a vector type*)
    fun localType(ty,isVecTy) = (case ty
            of Ty.TensorTy[]=> !N.gRealTy
            | Ty.TensorTy[1]=> !N.gRealTy
 (*
            | Ty.TensorTy [3]=>CLang.T_Named(N.LocalTy [4])
 *)
 | Ty.TensorTy[2] => CLang.T_Named(N.LocalTy [2])
 | Ty.TensorTy[3] => CLang.T_Named(N.LocalTy [3])
 | Ty.TensorTy[4] => CLang.T_Named(N.LocalTy [4])

 
            | Ty.TensorTy [t] =>(case (isVecTy t)
                of true => CLang.T_Named(N.LocalTy [t])
                | _ => trType ty
                (* end case *))
            | Ty.SeqTy(Ty.TensorTy[3], 3) => let    (*added for evecs 3x3*)
                in 
                    CL.T_Array(CLang.T_Named(N.LocalTy [4]), SOME 4)
                end
            | Ty.SeqTy(Ty.TensorTy[2], 2) => let    (*added for evecs 2x2*)
                in 
                    CL.T_Array(CLang.T_Named(N.LocalTy [2]), SOME 2)
                end
            | _ => trType ty
          (* end case *))

  (* 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 unionTy = CL.T_Named(concat["Diderot_",!N.gIntSuffix,"union", Int.toString n, "_t"])
          val e1 = CL.mkCast(unionTy, v)
          val e2 = CL.mkSelect(e1, "i")
          in
            CL.mkSubscript(e2, intExp ix)
          end

    fun vecIndex (v, n, ix) = let
          val unionTy = CL.T_Named(concat["Diderot_union", Int.toString n(*, !N.gRealSuffix*), "_t"])
          val e1 = CL.mkCast(unionTy, v)
          val e2 = CL.mkSelect(e1, "r")
          in
            CL.mkSubscript(e2, intExp ix)
          end

    (*prnt arrays *)
    fun prntArr1(v,ix)= CL.mkSubscript(v, intExp ix)
    fun prntArr2(v,ix)= CL.mkSubscript(v,CL.mkInt ix)


   (* matrix indexing *)
    fun matIndex (m, ix, jx) = CL.mkSubscript(CL.mkSubscript(m, ix), jx)
(*
    fun dumpStore ([])=[]
    | dumpStore (IL.E_Mux(_,_,_,_,ops)::es)=ops@dumpStore es
    | dumpStore (e1::es)=[e1] @dumpStore es
*)
    fun dumpStore args =args
    
    (*Indextensor:TreeIL.OP(bool*indexTy*ty))*TreeIL.Var->CL
    *isLocalVar, IndexTy, ArgTy
    *decides if there needs to be a cast
    *)
    fun indexTensor  e=(case e
        of (Op.IndexTensor(true, [0],Ty.TensorTy[1]),[a])=> a
        | (Op.IndexTensor(true, [i],Ty.TensorTy[n]),[a])=> vecIndex (a,n,i) (*Index Local Vector*)(*Same as Op.Index _ *)
        | (Op.IndexTensor(_, [i],Ty.SeqTy (_,n)),[a])=> ivecIndex (a,n,i) (*Same as Op.Index _ *)
        | (Op.IndexTensor(false, [i],Ty.TensorTy[_]),[a])=>prntArr1(a,i)   (*Index Global Vector *)
        | (Op.IndexTensor(_,[i,j] ,Ty.TensorTy[_,m]),[a])=>prntArr1(a,m*i+j)
        | (Op.IndexTensor(_,[i,j,k] ,Ty.TensorTy[_,m,n]),[a])=>prntArr1(a,(m*i*n)+n*j+k)
        | (Op.IndexTensor(_,[i,j,k,l] ,Ty.TensorTy[_,m,n,p]),[a])=>prntArr1(a,(m*i*n*p)+(n*j*p)+(p*k)+l)
        | (rator,_) => raise Fail(concat[
            "--unknown how to index tensor", Op.toString rator
            ])
        (*end case*))

  (* Translate a TreeIL operator application to a CLang expression *)
    fun trOp (rator, args) = (case (rator, args)
           of (Op.IAdd , [a, b]) => CL.mkBinOp(a, CL.#+, b)
            | (Op.ISub , [a, b]) => CL.mkBinOp(a, CL.#-, b)
            | (Op.IMul , [a, b]) => CL.mkBinOp(a, CL.#*, b)
            | (Op.IDiv , [a, b]) => CL.mkBinOp(a, CL.#/, b)
            | (Op.INeg , [a]) => CL.mkUnOp(CL.%-, a)
            | (Op.addSca,[a,b])      => CL.mkBinOp(a, CL.#+, b)
            | (Op.subSca, [a, b])    => CL.mkBinOp(a, CL.#-, b)
            | (Op.prodSca, [a, b])   => CL.mkBinOp(a, CL.#*, b)
            | (Op.divSca, [a, b])    => CL.mkBinOp(a, CL.#/,b)
                (* CL.mkBinOp(CL.mkCast(!N.gRealTy,a), CL.#/,CL.mkCast(!N.gRealTy,b))*)
            | (Op.subVec _ ,[a,b])    =>  CL.mkBinOp(a, CL.#-, b)
            | (Op.addVec _ ,[a,b])    => CL.mkBinOp(a, CL.#+, b)
            | (Op.prodVec _ ,[a, b])  => CL.mkBinOp(a, CL.#*, b)
            | (Op.clampVec n, args) => CL.mkApply(N.NameClampV n, args)
            | (Op.lerpVec n, args) =>  CL.mkApply(N.NameLerpV n, args)
            | (Op.prodScaV 1,[a,b])   =>  CL.mkBinOp(a, CL.#*, b)
            | (Op.prodScaV d,args)   => CL.E_Apply(N.NameScaV d, args)
            | (Op.sumVec ([1],_),[a])     => a
            | (Op.sumVec (_,oSize),args)     => CL.E_Apply(N.NameSumV oSize, args)
            | (Op.IndexTensor _,_ )=>  indexTensor(rator,args)
            | (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.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.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, args) =>raise Fail(concat["Clamp<", Ty.toString ty, "> not supported"])
            | (Op.Lerp (Ty.TensorTy[]) , args) => CL.mkApply(N.lerp 1, args)
            | (Op.Lerp ty , args) => raise Fail(concat["lerp<", Ty.toString ty, "> not supported" ])
            | (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(concat["union", Int.toString n, !N.gIntSuffix, "_t"])
                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.SeqTy(ty, n)), [v, CL.E_Int(ix,_)]) =>  prntArr2(v,  ix)
            (*| (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
                val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gRealSuffix, "_t"])
                val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
                in
                    CL.mkSubscript(vecExp, ix)
                end*)
             | (Op.Subscript(Ty.TensorTy[n]), [v, CL.E_Int(ix,_)]) => prntArr2 (v,ix)
           
            | (Op.Subscript ty0, [a, CL.E_Int(ix,_), CL.E_Int(jx,_)] ) =>
                indexTensor (Op.IndexTensor(false,[IntInf.toInt ix,IntInf.toInt jx] ,ty0),[a])
            | (Op.Subscript ty0, [a, CL.E_Int(ix,_), CL.E_Int(jx,_),CL.E_Int(kx,_)] ) =>
                indexTensor (Op.IndexTensor(false,[IntInf.toInt ix,IntInf.toInt jx,IntInf.toInt kx] ,ty0),[a])
            | (Op.Subscript ty, t::(ixs as _::_)) =>
                raise Fail(concat["Subscript<", Ty.toString ty, "> unsupported"])
            | (Op.Ceiling d, args) => CL.mkApply(N.addTySuffix("ceil", d), args)
            | (Op.Floor 1, args) => CL.mkApply(N.NameFloor , args)
            | (Op.Floor d, args) => CL.mkApply(N.NameFloorV 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.Sqrt,[a])=>CL.mkApply(N.NameSqrt,[a])
            | (Op.Cosine,[a])=>CL.mkApply(N.NameCosine,[a])
            | (Op.ArcCosine,[a])=>CL.mkApply(N.NameArcCosine,[a])
            | (Op.Sine,[a])=>CL.mkApply(N.NameSine,[a])
            | (Op.ArcSine,[a])=>CL.mkApply(N.NameArcSine,[a])
            | (Op.Tangent,[a])=>CL.mkApply(N.NameTangent,[a])
            | (Op.ArcTangent,[a])=>CL.mkApply(N.NameArcTangent,[a])
            | (Op.Exp,[a])=>CL.mkApply(N.NameExp,[a])
            | (Op.powInt,[a,b])=>CL.mkApply(N.NamePowInt,[a,b])
            | (Op.powSca,[a,b])=>CL.mkApply(N.NamePowReal,[a,b])
            | (Op.Normalize d,args) => CL.mkApply(N.normalize d, args)
            | (Op.baseAddr img, [a] ) =>
                CL.E_Cast(CL.T_Ptr(CL.T_Num(ImageInfo.sampleTy img)), CL.mkIndirect(a, "data"))
            | (Op.Transform(v,i),[a]) =>(case (ImageInfo.dim v)
                of 1=>CL.mkIndirect(a, "s")
                | _ =>CL.mkIndirect(a, "w2i["^(Int.toString i)^"].v")
                (*end case*))
            | (Op.Translate v, [a]) => (case (ImageInfo.dim v)
                 of 1 => CL.mkIndirect(a, "t")
                  | _ => CL.mkIndirect(a, "tVec")
                (*end case*))
                (*Replaced with baseAddr operator*)
            | (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.Inside(info, s), [pos, img]) =>
                CL.mkApply(N.inside(ImageInfo.dim info), [pos, img, intExp s])
            | (Op.LoadImage info, [a]) =>
                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 trSubscript(rator, args) = (case (rator, args)
        of (Op.Subscript(Ty.SeqTy(ty, n)), [v, CL.E_Int(ix,_)]) =>  prntArr2(v,  ix)
        | (Op.Subscript(Ty.TensorTy[n]), [v, ix]) => let
                val unionTy = CL.T_Named(concat["union", Int.toString n, !N.gRealSuffix, "_t"])
                val vecExp = CL.mkSelect(CL.mkCast(unionTy, v), "r")
                in
                    CL.mkSubscript(vecExp, ix)
                end
        (*end case*))
                    
    fun trExp (env, e) = (("\nExp: "^(IL.toString e) );case e
           of IL.E_State x => VarToC.rvalueStateVar x
            | IL.E_Var x => VarToC.rvalueVar (env, x)
            | 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(Op.Subscript(Ty.TensorTy[2]),[IL.E_Op(Op.Subscript(Ty.SeqTy(Ty.TensorTy[2],2)),[v,i]),arg1])=>
                    let 
                    val arg0=(Op.Subscript(Ty.SeqTy(Ty.TensorTy[2],2)), trExps(env,[v,i]))
                    val exp0=trSubscript arg0
                    val exp1=trExp(env,arg1)
                    val rator=Op.Subscript(Ty.TensorTy[2])
                    val b=trSubscript(rator,[exp0,exp1])
                    in b
                    end
            | IL.E_Op(Op.Subscript(Ty.TensorTy[3]),[IL.E_Op(Op.Subscript(Ty.SeqTy(Ty.TensorTy[3],3)),[v,i]),arg1])=>
                    let
                    val arg0=(Op.Subscript(Ty.SeqTy(Ty.TensorTy[3],3)), trExps(env,[v,i]))
                    val exp0=trSubscript arg0
                    val exp1=trExp(env,arg1)
                    val rator=Op.Subscript(Ty.TensorTy[3])
                    val b=trSubscript(rator,[exp0,exp1])
                    in b
                    end
              *)
            | IL.E_Op(Op.IndexTensor(e1,ty0,ty1) , [IL.E_LoadArr(_,_,_, v,IL.E_Lit(Literal.Int 0))])=>
                    let
                    val _ =("\n\n****** 1-"^IL.toString e)
                    in
                         (*prntArr1(trExp(env,v),IntInf.toInt i+ x)*)
                        trOp(Op.IndexTensor (false,ty0,ty1), [trExp(env,v)])
                    end
            | IL.E_Op(rator, args) => trOp (rator, trExps(env, args))
            | IL.E_Apply(f, args) => trApply(f, trExps(env, args))
            | IL.E_Cons(nSize,1,args) => (case (dumpStore args)
                of [a1]=>  trExp(env, a1)
                | a=>CL.mkApply(N.NameConsVec nSize, trExps(env, a))
                (*end case*))
            | IL.E_Cons(nSize,oSize,args) =>  CL.mkApply(N.NameConsVec nSize, trExps(env, dumpStore args))
            | IL.E_LoadArr(_,1, _, v,IL.E_Lit(Literal.Int i)) =>
                    ( ("\n\n****** 2-"^IL.toString e);CL.mkSubscript(trExp(env,v),CL.mkIntTy(i,!N.gIntTy)))
            | IL.E_LoadArr(aligned,n, orig, v,arg) =>(
                    ("\n\n****** 3-"^IL.toString e);
                    (CL.mkApply(N.NameLdArr(aligned,n,orig), trExps(env, [v,arg]))))
           | IL.E_Mux (_,_,_,_,[a1]) => trExp(env,a1)
           | IL.E_Mux (_,_,n,_,args) => (*raise Fail "Mux in tree-il stage, try trExp()"*)
                    CL.mkApply(N.NameMux n, trExps(env, args))
          (* 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) =let
    
        in (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 *))
        end 

  (* 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 _ => let

                        val (x, stm) = expToVar (env, tyTransform ty , "vec", exp)
                        val (fmt, args) =  mkElemFmt (ty, x, (fmt, args))
                    in
                        (stm@stms, fmt, args)
                    end
                    | Ty.SeqTy(elemTy,  n) =>  let
                        val (x, stm) = expToVar (env, trType ty, "vec", exp)
                        val (fmt, args) =  mkElemFmt (ty, x, (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 => prntArr1 (elem,  i))
                      in
                        mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
                      end
                        (*called by printResults*)
                  | Ty.TensorTy[n, m] =>  let
                    val d=n*m

                    val elems = List.tabulate (d, fn i => prntArr1 (elem,  i))
                    in
                    mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
                    end

                  | 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
(*Removed IADD, ISUB, INED, scale, MULT  since they now only work on intergers*)
    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.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.EigenVals2x2, [m]) => let
                      val (m, stms) = expToVar (env, CL.T_Named(N.matTy(2,2)), "m", m)
                      in
                      stms @ [CL.mkCall(N.evals2x2, [lhs,prntArr1(m,0),prntArr1(m,1),prntArr1(m,3)])]
                      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,
                      prntArr1(m,0), prntArr1(m,1),prntArr1(m,2),
                      prntArr1(m,4), prntArr1(m,5),prntArr1(m,8)
                      ])]
                      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.Zero(Ty.TensorTy ty),args)=> [CL.mkCall(N.NameZeroV ty, [lhs])]
            | IL.E_Var x => let
                    val _= (String.concat["\n ** Tree-IL","=>",IL.toString rhs])
                    fun reg () = [CL.mkAssign(lhs, VarToC.rvalueVar(env, x))]
                    fun copy alpha= [CL.mkCall(N.NameCopyTensor alpha, [lhs,VarToC.rvalueVar(env, x),CL.mkInt 0])]
                    in (case (IL.Var.ty x, IL.Var.kind x)
                        of (Ty.TensorTy [],_)               => ("A";reg())
                        | (Ty.TensorTy [_],IL.VK_Local)     => ("B";reg())
                        (*
                        | (Ty.TensorTy [3],_)               =>
                                [CL.mkAssign(lhs,(CL.mkApply(N.NameLdArr(false,4,3), [VarToC.rvalueVar(env, x),CL.mkInt 0])))]*)
                        | (Ty.TensorTy [i,j],_)             => ("D"; copy [i,j])
                        (*|(Ty.SeqTy(Ty.TensorTy _,j),_)    => ("E"; copy [j])*)
                        | (_ ,_)=> reg()
                        (* end case *))
                    end
            | _ => [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.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,prntArr1(m,0),prntArr1(m,1),prntArr1(m,3)])]
                end
                      
            | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
                val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
                    (*vecs is the one with the "wrong" type, what should it be?*)

                in
                  stms @ [CL.mkCall(N.evecs3x3, [
                      vals, vecs,
                      prntArr1(m,0), prntArr1(m,1),prntArr1(m,2),
                      prntArr1(m,4), prntArr1(m,5),prntArr1(m,8)
                    ])]
                end
                      (* original
            | ([vals, vecs], Op.EigenVecs3x3, [m]) => let
                      val (m, stms) = expToVar (env, CL.T_Named(N.matTy(3,3)), "m", m)
                      (*vecs is the one with the "wrong" type, what should it be?*)
                      
                      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,isVecTy) =
          List.foldl
            (fn (x, env) => V.Map.insert(env, x, V(localType(V.ty x,isVecTy), V.name x)))
                        (*Here-for local vars*)
              env locals

  (* generate code to check the status of runtime-system calls *)
    fun checkSts mkDecl = let
          val sts = freshVar "sts"
          in
            mkDecl sts @
            [CL.mkIfThen(
              CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
              CL.mkCall("exit", [intExp 1]))]
          end

    fun registerInput (env, lhs, name, optDesc, hasDflt) = let
          val desc = Option.getOpt (optDesc, "")
          val hasDflt = if hasDflt then "true" else "false"
          val isCArray = (case V.ty lhs
                 of Ty.TensorTy(_::_) => true
                  | Ty.SeqTy _ => true
                  | _ => false
                (* end case *))
          val lhs' = VarToC.lvalueVar(env, lhs)
          in
            CL.mkCall(N.input(V.ty lhs), [
                CL.mkVar "opts", CL.mkStr name, CL.mkStr desc,
                if isCArray then lhs' else CL.mkUnOp(CL.%&, lhs'),
                CL.mkVar hasDflt
              ])
          end

    fun trStms (env, stms, isVecTy) = let
          fun getVar v = (case v
                 of IL.E_Var x => VarToC.lvalueVar (env, x)
                  | IL.E_State x => VarToC.lvalueStateVar x
                  | _ => raise Fail "NonVar in exp"
                (* end case *))            
          fun trStmt (env, stm) = (("\nHI****"^(IL.toStringS stm));(case stm
                 of IL.S_Comment text => [CL.mkComment text]
                  | IL.S_Assign([x],IL.E_Mux(A,isFill, oSize,splitTy,[a]))=> (("from S.S_assign MUX");trAssign (env,VarToC.lvalueVar (env, x),a))
                  | IL.S_Assign([x], exp) =>
                        ("from S.S_assign 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,isVecTy))]
                  | IL.S_IfThenElse(cond, thenBlk, elseBlk) =>
                     [CL.mkIfThenElse(trExp(env, cond),
                        trBlk(env, thenBlk, isVecTy),
                        trBlk(env, elseBlk, isVecTy))]
                  | IL.S_New _ => raise Fail "new not supported yet" (* FIXME *)
                  | IL.S_Copy( IL.E_State  x,exp,_,1)=> ("from S.S_assign copy_1";trAssign (env, VarToC.lvalueStateVar x, exp))
                  | IL.S_Copy(x,exp,offset,n)=>
                        [CL.S_Exp (CL.mkApply(N.NameCopyTensor [n],[getVar x,trExp(env,exp),CL.mkIntTy(IntInf.fromInt offset, !N.gIntTy)]))]
                  | IL.S_Save([x],exp) => ("from S.save 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.ImageTy info, nrrd) =>
                      [GenLoadNrrd.loadImage (VarToC.lvalueVar (env, lhs), info, CL.E_Str nrrd)]
                  | IL.S_Input(lhs, name, optDesc, NONE) =>
                      [registerInput (env, lhs, name, optDesc, false)]
(* FIXME: it may be best to just use the Inputs.initializer type in the TreeIL!!! *)
                  | IL.S_Input(lhs, name, optDesc, SOME(IL.E_Mux(_, _, _, _, args))) => let
		      val args = List.concat(List.map (fn (IL.E_Cons(_, n, es)) => List.take(es, n)) args)
		      val lhs' = VarToC.lvalueVar(env, lhs)
		      fun mk (_, [], stms) = List.revAppend(stms, [registerInput (env, lhs, name, optDesc, true)])
			| mk (i, e::es, stms) = let
			    val stm = CL.mkAssign(CL.mkSubscript(lhs', CL.mkInt i), trExp(env, e))
			    in
			      mk (i+1, es, stm::stms)
			    end
		      in
			mk (0, args, [])
		      end
                  | IL.S_Input(lhs, name, optDesc, SOME dflt) => [
                        CL.mkAssign(VarToC.lvalueVar(env, lhs), trExp(env, dflt)),
                        registerInput (env, lhs, name, optDesc, true)
                      ]
                  | IL.S_InputNrrd _ => []
                  | IL.S_Exit args => [CL.mkReturn NONE]
                  | 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))]
                  | IL.S_StoreVec(v, offset, A, isFill,  oSize, _, [_], [IL.E_Cons(_ , _ , args)]) =>
                    let
                        val x =  getVar v
                        fun iter(0, e0::consargs) =
                            [CL.mkAssign(prntArr1(x, offset), trExp (env, e0))]
                          | iter(n, e0::consargs) =
                            CL.mkAssign(prntArr1(x, offset+n), trExp (env, e0))::iter(n-1, consargs)
                    in (case oSize
                        of 2 => List.rev (iter(oSize-1, List.rev(List.take(args, oSize))))
                        | 3 => List.rev  (iter(oSize-1, List.rev(List.take(args, oSize))))
                        | 4 => List.rev (iter(oSize-1, List.rev(List.take(args, oSize))))
                        | _  => raise Fail "Should be more than one piece here"
                        (* end case*))
                    end
                  | IL.S_StoreVec(v, offset, A, true, oSize, _, pieces, args) =>
                    let  (*isFilled used*)
                        val x=  getVar v
                        fun sort([], _, _) = []
                        | sort(nSize::ps, e1::es, offset) =
                            CL.mkApply(N.NameStoreVec(A, nSize, oSize), x::trExps(env, [IL.E_Lit(Literal.Int offset), e1]))
                            ::sort(ps, es, offset + IntInf.fromInt oSize)
                        | sort _ = raise Fail"Not the right number of Arguments"
                        val exp = sort(pieces, args, IntInf.fromInt offset)
                        in
                            List.map (fn e=> CL.S_Exp e ) exp
                        end
                  | IL.S_StoreVec(v, offset, A, false, oSize, _, pieces, args) =>
                    let
                        val x=  getVar v
                        fun sort([], _, _)=[]
                        | sort(nSize::ps, e1::es, offset)=
                            CL.mkApply(N.NameStoreVec(A, nSize, oSize), x::trExps(env, [IL.E_Lit(Literal.Int offset), e1]))
                            ::sort(ps, es, offset + IntInf.fromInt nSize)
                        | sort _=raise Fail("Not the right number of Arguments")
                        val exp = sort(pieces, args, IntInf.fromInt offset)
                        in
                            List.map (fn e=> CL.S_Exp e ) exp
                        end
                  | IL.S_Cons(x,n,args)=>  [CL.S_Exp (CL.mkApply(N.NameConsArray n, [VarToC.lvalueVar (env, x)]@trExps(env, args)))]
                (* end case *)))
          in
            List.foldr (fn (stm, stms) => trStmt(env, stm)@stms) [] stms
          end

    and trBlk (env, IL.Block{locals, body}, isVecTy) = let
          val env = trLocals (env, locals, isVecTy)
          val stms = trStms (env, body, isVecTy)
          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}, isVecTy) = let
          val env = trLocals (env, locals, isVecTy)
          val stms = trStms (env, body, isVecTy)
          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

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