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 2795 - (download) (annotate)
Tue Nov 4 21:58:11 2014 UTC (4 years, 11 months ago) by cchiw
File size: 30467 byte(s)
field problem
(* tree-to-c.sml
 *WQE
 * 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 trType : TreeIL.Ty.ty -> CLang.ty
   (* val restType : 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 prntArr : 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
    structure Dst = TreeIL
    structure DstV = Dst.Var

    datatype var = datatype CLang.typed_var
    type env = CLang.typed_var TreeIL.Var.Map.map
      
    val testing =0
    fun pntTest str=(case testing
        of 1=> (print(str);1)
        | _ =>1
    (*end case*))

    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) => CL.T_Array(trType ty, SOME n)
            | Ty.AddrTy(ImageInfo.ImgInfo{ty=(_, rTy), ...}) => CL.T_Ptr(CL.T_Num rTy)
            | Ty.ImageTy(ImageInfo.ImgInfo{dim, ...}) => CL.T_Ptr(CL.T_Named(N.imageTy dim))
            | Ty.unionTy n => CL.T_Named(N.unionTy n )
            
            | _ => (*raise Fail(concat["TreeToC.trType(", Ty.toString ty, ")"])*) CL.T_Named "unknown"
          (* end case *))

    (*creates global var if it's not a vector type*)
    fun localType(ty,isVecTy) = (case ty
        of Ty.TensorTy [t] =>(case (isVecTy t) 
            of true => CLang.T_Named(N.LocalTy [t])
            | _ => trType ty
            (* end case *))
        | _ => 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["kittenunion", Int.toString n, !N.gIntSuffix, "_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 prntArr(v,ix)= CL.mkSubscript(v, intExp ix)

    (*prnt Matrix*)
    (*v[indexAtY,indexAtX]::Ty[argTyY,argTyX]*)
    fun prntMat(v,indexAtY,indexAtX,argTyY, argTyX)=let
        val ix=argTyX* indexAtY+indexAtX
    in
        CL.mkSubscript(v, intExp ix)
    end



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

        CL.mkSubscript(CL.mkSubscript(m, ix), jx)


    fun matProj(m, ix) =
     CL.mkSelect(CL.mkSubscript(m, ix), "r")



  (* 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)
            | (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.Sqrt ,[a])         =>       CL.E_Sqrt a
 
             (*Vector functions*)
            | (Op.prodScaV d,args)   => CL.E_Apply(N.NameScaV d, args)
            | (Op.sumVec (nSize,oSize),args)     => CL.E_Apply(N.NameSumV oSize, args)
            | (Op.dotVec d,args)     => CL.E_Apply(N.NameDotV d, args)


                    (*INDEX A VECTOR->SCALAR *)
            | (Op.IndexTensor(_,Ty.indexTy [i],  Ty.TensorTy [n]),[a])
                => prntArr(a,i)(* vecIndex (a,n,i)*)
            | (Op.IndexTensor(_,Ty.indexTy [i],  Ty.SeqTy _),[a])
                => prntArr(a,i)  

                   (*INDEX A MATRIX ->SCALAR*)
            | (Op.IndexTensor (_,Ty.indexTy [i,j], Ty.TensorTy[argTyY,argTyX]),[m])
                =>prntMat(m,i,j,argTyY, argTyX)
            | (Op.IndexTensor (_, Ty.indexTy indexAt, argTy),args)=>  raise Fail"higer tensor "


                (*INDEX A MATRIX-> VECTOR*)
            (* Is now removed at the Low-Tree-IL Stage*)
            | (Op.ProjectTensor (rstTy ,j ),args)  =>
                CL.E_Apply(N.NameProj rstTy , args@[CL.mkInt (IntInf.fromInt j)])


                (*Image related operators*)
             | (Op.baseAddr(ImageInfo.ImgInfo{ty=(_,rTy), ...}) ,[a])=> let
                val cTy = CL.T_Ptr(CL.T_Num rTy)
                in
                    CL.mkCast(cTy, CL.mkIndirect(a, "data"))
                end
            | (Op.baseAddr _,_)=> CL.mkBinOp(CL.E_Str"baseString", CL.#-, CL.E_Str"none")
            | (Op.imgAddr(Vinfo,indexAtTy, dim), [base,a,b])=>

                CL.mkBinOp(base, CL.#+, CL.mkBinOp(b, CL.#+,  CL.mkBinOp(CL.mkInt 77, CL.#*, a)))

            | (Op.imgLoad(Vinfo ,dim, nlength),[addr])=>

(*CL.E_Indirect (addr,"shoud load image")*)
let
                val realTy as CL.T_Num rTy = !N.gRealTy
                val a = CL.E_UnOp(CL.%*, addr)
                in
                    (*if (rTy = ImageInfo.sampleTy Vinfo)
                    then a
                    else CL.E_Cast(realTy, addr)*) a
                end

            | (Op.Transform(ImageInfo.ImgInfo{ty=(_,rTy), ...}),[a])=> let
     
val cTy = CL.T_Ptr(CL.T_Num rTy)
in
(*CL.mkCast(cTy, *)(CL.mkIndirect(a, "w2i"))
end
            | (Op.Translate(ImageInfo.ImgInfo{ty=(_,rTy), ...}),[a])=> (* "Vinfo-Translate"*)
let

val cTy = CL.T_Ptr(CL.T_Num rTy)
in
CL.mkCast(cTy, CL.mkIndirect(a, "tVec"))
end



            | (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.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["Squishunion", 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.TensorTy[n]), [v, ix]) => let
                val unionTy = CL.T_Named(concat["Onionunion", 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[_,_]), [m, ix, jx]) => matIndex (m, ix, jx)
            | (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 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)
(* FIXME: need type info *)
                    
                    (*Replaced with baseAddr operator
            | (Op.ImageAddress(ImageInfo.ImgInfo{ty=(_,rTy), ...}), [a]) => let
                val cTy = CL.T_Ptr(CL.T_Num rTy)
                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(ImageInfo.ImgInfo{dim, ...}, s), [pos, img]) =>
                CL.mkApply(N.inside dim, [pos, img, intExp s])
            | (Op.Input(ty, desc, name), []) =>
                raise Fail("impossible " ^ Op.toString rator)
            | (Op.InputWithDefault(ty, desc, name), [a]) =>
                raise Fail("impossible " ^ Op.toString rator)
            | _ => raise Fail(concat[
                  "---yyy--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_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(nSize,oSize,args) =>  CL.mkApply(N.NameConsVec nSize, trExps(env, args))
            | IL.E_LoadArr(aligned,n, orig, v,arg) =>
                    CL.mkApply(N.NameLdArr(aligned,n,orig), trExps(env, [v,arg]))
                    | IL.E_Mux (_,_,_,_,[a1]) => trExp(env,a1)
                    
            | IL.E_Mux (_,_,_,_,args) => (*raise Fail "Mux in tree-il stage"*)
                    CL.mkApply(N.NameMux, trExps(env, args))
             | IL.E_Holder (x,_) => CL.mkStr ("Holder for "^(V.name x))
                    (*VarToC.rvalueVar (env, x)*)

          (* end case *))
    and trExps (env, exps) = List.map (fn exp => trExp(env, exp)) exps
         
                    
    fun storeVec(env,x',A, isFill, oSize,ty,pieces,args)=let
                    
        fun dumpStore ([])=[]
          | dumpStore (Dst.E_Mux(_,_,_,_,ops)::es)=ops@dumpStore es
          | dumpStore (e1::es)=[e1] @dumpStore es
        val args'=dumpStore args
                    
        val exp= if(isFill) then (*isFilled used*)
            let
                fun sort([],_,_)=[]
                | sort(nSize::ps,e::es,offset)= [CL.mkApply(N.NameMkVec(A,nSize,oSize),
                    [x']@trExps(env, [IL.E_Lit(Literal.Int offset),e]))]  @ sort(ps, es,offset + IntInf.fromInt oSize)
            in sort(pieces,args',0) end 
            else let
                fun sort([],_,_)=[]
                | sort(nSize::ps,e::es,offset)= [CL.mkApply(N.NameMkVec(A,nSize,oSize),
                    [x']@trExps(env, [IL.E_Lit(Literal.Int offset),e]))]  @ sort(ps, es,offset + IntInf.fromInt nSize)
            in sort(pieces,args',0) end
        in
            List.map (fn e=> CL.S_Exp e ) exp
        end
                    
                    
                    
  (* 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[n] => let
                        val (x, stm) = expToVar (env, trType ty , "vec", exp)
                        val elems = List.tabulate (n, fn i => (*vecIndex (x, n, i)*) CL.E_Str "cow2" )
                        (*val (fmt, args) = mkSeqFmt (Ty.TensorTy[], elems, fmt, args)*)
                            val (fmt, args) = mkSeqFmt (Ty.TensorTy[],[CL.E_Str "cow88"], fmt, args)
                        in
                          (stm@stms, fmt, args)
                        end

                    | Ty.TensorTy[n, m] => let
                        val (x, stm) = expToVar (env, trType ty , "vec", exp)
                        val elems = List.tabulate (15, fn i =>  CL.E_Str "cow2" )
                        val (fmt, args) = mkSeqFmt (Ty.TensorTy[],elems, fmt, args)
                    in
                    (stm@stms, fmt, args)
                    end


                    | 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 => (*prntArr (elem,  i)*) CL.E_Str "cow2" )
                      val elems=[CL.E_Str "cow2"]
                      in
                        mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
                      end

                        (*called by printResults*)
                  | Ty.TensorTy[n, m] =>  let
                    val d=n*m
                    val elems = List.tabulate (989, fn i => prntArr (elem,  i))
                    val elems=[CL.E_Str "cow2"]
                    in
                    mkSeqFmt (Ty.TensorTy[], elems, fmt, args)
                    end

                  | Ty.SeqTy(elemTy, n) =>  let
                      val elems = List.tabulate (n, fn i => ivecIndex (elem, n, i))
                        val elems=[CL.E_Str "cow2"]
                      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.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[n]), args) =>
                      [CL.mkCall(N.zeroVec(n), [lhs])]
            | IL.E_Op(Op.Zero(Ty.TensorTy[m,n]), args) =>
                [CL.mkCall(N.zeroMat(m,n), [lhs])]
          (*  | IL.E_Op(Op.LoadVoxels(info, n), [a]) =>*)
              | IL.E_Op(Op.imgLoad(info ,dim, 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.S_Exp(CL.mkApply(N.NameConsArray n, [lhs]@ List.tabulate (n, mkLoad)))
                    ] end
                        else   [CL.mkAssign(lhs, trExp(env, rhs))]
            | 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)])]
                  | _ => [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 getCount (x )= let
            val n = !(V.useCnt x)
            in
                print (String.concat["\n",(V.name x),"--",Int.toString n])
            end*)
                  
        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 trStms (env, stms,isVecTy) = 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,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([x],exp,n)=>
                        [CL.S_Exp (CL.mkApply(N.NameCopyTensor [n],[VarToC.lvalueStateVar x,trExp(env,exp)]))]
                  | IL.S_Save([x],exp as IL.E_Var v)=>( case (V.kind v,V.rTy v)
                    of (IL.VK_Global,Ty.TensorTy [n]) => let
                        val expS=  CL.mkApply(N.NameCopyTensor [n] ,
                            [VarToC.lvalueStateVar x,trExp(env,exp)])
                        in
                            [CL.S_Exp expS]
                        end
                    | _ => (trAssign (env, VarToC.lvalueStateVar x, exp))
                    (*end case*))
                  
                  | 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_LoadImage(lhs, dim, name) => checkSts (fn sts => let
                  
                      val lhs = VarToC.lvalueVar (env, lhs)
                      val name = trExp(env, name)
                      val imgTy = CL.T_Named(N.imageTy dim)
                      val loadFn = N.loadImage dim
                      in [
                        CL.mkDecl(
                          CL.T_Named N.statusTy, sts,
                          SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, lhs)]))))
                      ] end)
                  | IL.S_Input(lhs, name, desc, optDflt) => let
                      
                      val inputFn = N.input(V.ty lhs)
                      val lhs = VarToC.lvalueVar (env, lhs)
                      val (initCode, hasDflt) = (case optDflt
                             of SOME e => ([CL.mkAssign(lhs, trExp(env, e))], true)
                              | NONE => ([], false)
                            (* end case *))
                      val code = [CL.mkCall(inputFn, [
                              CL.mkVar "opts",
                              CL.mkStr name,
                              CL.mkStr desc,
                              CL.mkUnOp(CL.%&, lhs),
                              CL.mkBool hasDflt])]
                      in
                        initCode @ code
                      end
                  | 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,A, isFill, orig, ty,Ty.vectorLength pieces,args)=>let 
                    val v'=(case v
                        of IL.E_Var x=>VarToC.lvalueVar (env, x)
                        | IL.E_State x =>VarToC.lvalueStateVar (x)
                        |_ => raise Fail "nonvar in storeVec"
                        (*end case *))
                    in
                        storeVec(env,v',A, isFill,orig,ty,pieces,args)
                    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