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

SCM Repository

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

View of /branches/charisee/src/compiler/tree-il/low-to-tree-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2669 - (download) (annotate)
Fri Jun 13 02:08:31 2014 UTC (5 years, 4 months ago) by cchiw
File size: 28145 byte(s)
represent tensors with arrays
(* low-to-tree-fn.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * This module translates the LowIL representation of a program (i.e., a pure CFG) to
 * a block-structured AST with nested expressions.
 *
 * NOTE: this translation is pretty dumb about variable coalescing (i.e., it doesn't do any).
 *)

functor LowToTreeFn (Target : sig

    val supportsPrinting : unit -> bool (* does the target support the Print op? *)

  (* tests for whether various expression forms can appear inline *)
    val inlineCons : int -> bool        (* can n'th-order tensor construction appear inline *)
    val inlineMatrixExp : bool          (* can matrix-valued expressions appear inline? *)
    val isHwVec :  int -> bool
    val isVecTy :  int -> bool
 val getPieces :   int -> int list

  end) : sig

    val translate : LowIL.program -> TreeIL.program

  end = struct

 
    structure Src = LowIL
    structure SrcOp = LowOps
    structure V = LowIL.Var
    structure StV = LowIL.StateVar
    structure Dst = TreeIL
    structure DstOp = TreeOps
    structure LowOpToTreeOp  = LowOpToTreeOp
    structure gT=getTypes
    structure VA = VarAnalysis
    structure Ty = LowILTypes
    structure Nd = LowIL.Node
    structure CFG = LowIL.CFG
    structure TySet=TreeFunc.TySet
    structure OprSet=TreeFunc.OprSet
 
  (* create new tree IL variables *)
    local
      val newVar = Dst.Var.new
      val cnt = ref 0
      fun genName prefix = let
            val n = !cnt
            in
              cnt := n+1;
              String.concat[prefix, "_", Int.toString n]
            end
    in
    val testing=1
    fun pntTest str=(case testing
        of 1=> (print(str);1)
        | _ =>1
    (*end case*))

    fun newGlobal x = newVar (genName("G_" ^ V.name x), Dst.VK_Global, V.ty x)
    fun newParam x = newVar (genName("p_" ^ V.name x), Dst.VK_Local, V.ty x)
    fun newLocal x = newVar (genName("l_" ^ V.name x), Dst.VK_Local, V.ty x)
    fun newIter x = newVar (genName("i_" ^ V.name x), Dst.VK_Local, V.ty x)
    end

  (* associate Tree IL state variables with Low IL variables using properties *)
    local
      fun mkStateVar x = Dst.SV{
              name = StV.name x,
              id = Stamp.new(),
              ty = StV.ty x,
              varying = VA.isVarying x,
              output = StV.isOutput x
            }
    in
    val {getFn = getStateVar, ...} = StV.newProp mkStateVar
    end

    fun mkBlock stms = Dst.Block{locals=[], body=stms}
    fun mkIf (x, stms, []) = Dst.S_IfThen(x, mkBlock stms)
      | mkIf (x, stms1, stms2) = Dst.S_IfThenElse(x, mkBlock stms1, mkBlock stms2)

  (* an environment that tracks bindings of variables to target expressions and the list
   * of locals that have been defined.
   *)
    local
      structure VT = V.Tbl
      fun decCount ( Src.V{useCnt, ...}) = let
            val n = !useCnt - 1
            in
              useCnt := n;  (n <= 0)
            end
      datatype target_binding
        = GLOB of Dst.var         (* variable is global *)
        | TREE of Dst.exp         (* variable bound to target expression tree *)
        | DEF of Dst.exp          (* either a target variable or constant for a defined variable *)
                  
                  
    fun insert (key, value) d =fn s =>
        if s = key then SOME value
        else d s
                  
    fun lookup k d = d k

                  
    structure ListSetOfInts = ListSetFn (struct
        type ord_key = int
        val compare = Int.compare
        end)
    
                  
      datatype env = E of {
          tbl : target_binding VT.hash_table,
          types:  TySet.set,
	  functs : OprSet.set,
          locals : Dst.var list
        }
                  
                  
    in
(* DEBUG *)
                  
 
      fun peelEnv(E{tbl, types, functs ,locals})=(types,functs)
      fun setEnv(E{tbl, types,functs,locals},types1,functs1)=
                  E{tbl=tbl, types=types1, functs= functs1 ,locals=locals}
                  
       fun peelEnvLoc(E{tbl, types, functs ,locals})=locals
                  
fun bindToString binding = (case binding
       of GLOB y => "GLOB " ^ Dst.Var.name y
        | TREE e => "TREE"
        | DEF(Dst.E_Var y) => "DEF " ^ Dst.Var.name y
        | DEF e => "DEF"
      (* end case *))
fun dumpEnv (E{tbl, ...}) = let
      fun prEntry (x, binding) =
            print(concat["  ", Src.Var.toString x, " --> ", bindToString binding, "\n"])
      in
        print "*** dump environment\n";
        VT.appi prEntry tbl;
        print "***\n"
      end
(* DEBUG *)

    fun newEnv () = E{tbl = VT.mkTable (512, Fail "tbl"),  types=TySet.empty, functs=OprSet.empty, locals=[]}

  (* use a variable.  If it is a pending expression, we remove it from the table *)
    fun useVar (env as E{tbl, ...}) x = (case VT.find tbl x
           of SOME(GLOB x') => Dst.E_Var x'
            | SOME(TREE e) => (
(*print(concat["useVar ", V.toString x, " ==> TREE\n"]);*)
                ignore(VT.remove tbl x);
                e)
            | SOME(DEF e) => (
(*print(concat["useVar ", V.toString x, " ==> ", bindToString(DEF e), "; use count = ", Int.toString(V.useCount x), "\n"]);*)
              (* if this is the last use of x, then remove it from the table *)
                if (decCount x) then ignore(VT.remove tbl x) else ();
                e)
            | NONE => (
dumpEnv env;
raise Fail(concat ["useVar(", V.toString x, ")"])
)
          (* end case *))

  (* record a local variable *)
    fun addLocal (E{tbl, types,functs,locals}, x) = E{tbl=tbl,types=types, functs=functs,locals=x::locals}

    fun global (E{tbl, ...}, x, x') = VT.insert tbl (x, GLOB x')

  (* insert a pending expression into the table.  Note that x should only be used once! *)
    fun insert (env as E{tbl, ...}, x, exp) = (
          VT.insert tbl (x, TREE exp);
          env)

    fun rename (env as E{tbl, ...}, x, x') = (
          VT.insert tbl (x, DEF(Dst.E_Var x'));
          env)

    fun peekGlobal (E{tbl, ...}, x) = (case VT.find tbl x
           of SOME(GLOB x') => SOME x'
            | _ => NONE
          (* end case *))

    fun bindLocal (env, lhs, rhs) = if (V.useCount lhs = 1)
          then (insert(env, lhs, rhs), [])
          else let
            val t = newLocal lhs
            in
              (rename(addLocal(env, t), lhs, t), [Dst.S_Assign([t], rhs)])
            end

    fun bind (env, lhs, rhs) = (case peekGlobal (env, lhs)
           of SOME x => (env, [Dst.S_Assign([x], rhs)])
            | NONE => bindLocal (env, lhs, rhs)
          (* end case *))

  (* set the definition of a variable, where the RHS is either a literal constant or a variable *)
    fun bindSimple (env as E{tbl, ...}, lhs, rhs) = (
          case peekGlobal (env, lhs)
           of SOME x => (env, [Dst.S_Assign([x], rhs)])
            | NONE => (VT.insert tbl (lhs, DEF rhs); (env, []))
          (* end case *))

  (* at the end of a block, we need to assign any pending expressions to locals.  The
   * blkStms list and the resulting statement list are in reverse order.
   *)
    fun flushPending (E{tbl,types, functs,locals}, blkStms) = let
          fun doVar (x, TREE e, (locals, stms)) = let
                val t = newLocal x
                in
                  VT.insert tbl (x, DEF(Dst.E_Var t));
                  (t::locals, Dst.S_Assign([t], e)::stms)
                end
            | doVar (_, _, acc) = acc
          val (locals, stms) = VT.foldi doVar (locals, blkStms) tbl
          in
            (E{tbl=tbl, types=types,functs=functs,locals=locals}, stms)
          end

    fun doPhi ((lhs, rhs), (env, predBlks : Dst.stm list list)) = let
        (* t will be the variable in the continuation of the JOIN *)
          val t = newLocal lhs
          val predBlks = ListPair.map
                (fn (x, stms) => Dst.S_Assign([t], useVar env x)::stms)
                  (rhs, predBlks)
          in
            (rename (addLocal(env, t), lhs, t), predBlks)
          end
(*
    fun endScope (E{locals, ...}, stms) = Dst.Block{
            locals = List.rev locals,
            body = stms
          }
*)
        fun endScope (env, stms) = let
                val (types,opr)=peelEnv(env)
                
             in    Dst.Pink{
               
                  locals= List.rev(peelEnvLoc env),
                  types= types,
                  opr=opr,
                  body = stms
                  }
            end 
    end

  (* Certain IL operators cannot be compiled to inline expressions.  Return
   * false for those and true for all others.
   *)
    fun isInlineOp rator = let
          fun chkTensorTy (Ty.TensorTy[]) = true
            | chkTensorTy (Ty.TensorTy[_]) = true
            | chkTensorTy (Ty.TensorTy[_, _]) = Target.inlineMatrixExp
            | chkTensorTy _ = false
          in
           case rator
             of  SrcOp.LoadVoxels(_, 1) => true
              |  SrcOp.LoadVoxels _ => false

                  (*not removed add, sub, neg, scal, mul*)

              |  SrcOp.EigenVecs2x2 => false
              |  SrcOp.EigenVecs3x3 => false
              |  SrcOp.EigenVals2x2 => false
              |  SrcOp.EigenVals3x3 => false

(*              | SrcOp.Zero _ => Target.inlineMatrixExp*)

              | _ => true
            (* end case *)
          end

    (*HERE- since we are using arrays, nothing can be inline
    Fix later if it needs to be fixed*)
  (* is a CONS inline? *)
    fun isInlineCons ty = (*(case ty
           of Ty.SeqTy(Ty.IntTy, _) => true
            | Ty.TensorTy dd => Target.inlineCons(List.length dd)
            | Ty.SeqTy _ => false
   (*CCCC-? DO we have this type*)
           (* | Ty.DynSeqTy ty => false*)
            | _ => raise Fail(concat["invalid CONS<", Ty.toString ty, ">"])
          (* end case *))*) false

  (* translate a LowIL assignment to a list of zero or more target statements in reverse
   * order.
   *)
    fun doAssign (env, (lhs, rhs)) = let
          fun doLHS () = (case peekGlobal(env, lhs)
                 of SOME lhs' => (env, lhs')
                  | NONE => let
                      val t = newLocal lhs
                      in
                        (rename (addLocal(env, t), lhs, t), t)
                      end
                (* end case *))
        (* for expressions that are going to be compiled to a call statement *)
          fun assignExp (env, exp) = let
              (* operations that return matrices may not be supported inline *)
                val (env, t) = doLHS()
                in
                  (env, [Dst.S_Assign([t], exp)])
                end


          val isHwVec=Target.isHwVec
          val getPieces= Target.getPieces
          val isVecTy= Target.isVecTy

        (*foundVec: Found low-IL vector*)
         fun foundVec(lhs,rator,n,argsS, argsV)= let

            (*Looks for next largest length supported*)
            fun fillVec vn =(case (isVecTy vn)
                of true => (true,vn,[vn])
                | false => fillVec(vn+1))
            val (aligned,newSize,Pieces)= (case (isVecTy n)
                of true=> (false,n,[n])
                | false=>(case isHwVec n
                    of false=> (false,n,(getPieces n))
                    | true=> fillVec (n+1)
                    (*end case*))
                (*end case*))
            val _=(case testing
                of 1=>(print(String.concat["\n ***********\n ",DstOp.toString(rator n) ,"\n \t =>"]);1)
                | _=>1)
            in
                LowOpToTreeOp.creatLd(lhs,rator,newSize,n,Pieces,argsS,argsV,aligned)
            end


        (* force an argument to be stored in something that will be mapped to an l-value *)
          fun bindVar (env, x) = (case useVar env x
                 of x' as Dst.E_State _ => (env, x', [])
                  | x' as Dst.E_Var _ => (env, x', [])
                  | e => let
                      val x' = newLocal x
                      in
                        (addLocal(env, x'), Dst.E_Var x', [Dst.S_Assign([x'], e)])
                      end
                (* end case *))

          in
            case rhs
             of Src.STATE x => bindSimple (env, lhs, Dst.E_State(getStateVar x))
              | Src.VAR x => bindSimple (env, lhs, useVar env x)
              | Src.LIT lit => bindSimple (env, lhs, Dst.E_Lit lit)

                (*| Src.OP( SrcOp.Prepend ty, [item, seq]) => let
                  val (env, t) = doLHS()
                  val (env, item', stms) = bindVar (env, item)
                  val exp = Dst.E_Op( DstOp.Prepend ty, [item', useVar env seq])
                  in
                    (env, Dst.S_Assign([t], exp) :: stms)
                  end
              | Src.OP( SrcOpp.Append ty, [seq, item]) => let
                  val (env, t) = doLHS()
                  val (env, item', stms) = bindVar (env, item)
                  val exp = Dst.E_Op( DstOp.Append ty, [useVar env seq, item'])
                  in
                    (env, Dst.S_Assign([t], exp) :: stms)
                  end*)
           (*
              | Src.OP( SrcOp.LoadImage(ty, nrrd, info), []) => let
                  val (env, t) = doLHS()
                  in
                    (env, [Dst.S_LoadNrrd(t, ty, nrrd)])
                  end*)
              | Src.OP(rator,args) =>let
                    (*Target.isHwVec*)
                val args'=List.map (useVar env) args
                val (env, t) = doLHS()
                in (case rator
                     of SrcOp.addVec n   => (env, foundVec(t,DstOp.addVec,n,[],args'))
                     | SrcOp.subVec n    => (env, foundVec(t,DstOp.subVec,n,[],args'))
                     | SrcOp.prodScaV n  => (env, foundVec(t,DstOp.prodScaV ,n, [hd(args')], tl(args')))
                     | SrcOp.prodVec n   => (env, foundVec(t,DstOp.prodVec,n,[],args'))
                     | SrcOp.sumVec n    => (env, foundVec(t,DstOp.sumVec ,n,[],args'))
                     | _ => let
                        val Trator = LowOpToTreeOp.expandOp rator
                        val exp = Dst.E_Op(Trator,  args')
                        in
                            if isInlineOp rator then bind (env, lhs, exp)
                            else assignExp (env, exp)
                        end
                    (*end case*))
                 end

              | Src.APPLY(f, args) =>
                  bind (env, lhs, Dst.E_Apply(f, List.map (useVar env) args))
              | Src.CONS(ty, args) => let
                  val exp = Dst.E_Cons(ty, List.map (useVar env) args)
                  in
                    if isInlineCons ty
                      then bind (env, lhs, exp)
                      else assignExp (env, exp)
                  end
             | Src.EINAPP _=> raise Fail "EINAPP in Low-IL to Tree-IL"
            (* end case *)
          end

  (* In order to reconstruct the block-structure from the CFG, we keep a stack of open ifs.
   * the items on this stack distinguish between when we are processing the then and else
   * branches of the if.
   *)
    datatype open_if
    (* working on the "then" branch.  The fields are statments that preceed the if, the condition,
     * and the else-branch node.
     *)
      = THEN_BR of Dst.stm list * Dst.exp * Src.node
    (* working on the "else" branch.  The fields are statments that preceed the if, the condition,
     * the "then" branch statements, and the node that terminated the "then" branch (will be
     * a JOIN, DIE, or STABILIZE).
     *)
      | ELSE_BR of Dst.stm list * Dst.exp * Dst.stm list * Src.node_kind


    fun mkBlockOrig(Dst.Pink{ locals ,types,opr,body})=Dst.Block{locals=locals ,body=body}
    fun peelBlockOrig(env,Dst.Pink{ locals ,types,opr,body})=let
            val env= setEnv(env,types,opr)
            in
                (env,Dst.Block{locals=locals ,body=body})
             end
                
    fun trCFG (env, prefix, finish, cfg) = let
   
                
          fun join (env, [], _, Src.JOIN _) = raise Fail "JOIN with no open if"
            | join (env, [], stms, _) = endScope (env, prefix @ List.rev stms)
            | join (env, THEN_BR(stms1, cond, elseBr)::stk, thenBlk, k) = let
                val (env, thenBlk) = flushPending (env, thenBlk)
                in
                  doNode (env, ELSE_BR(stms1, cond, thenBlk, k)::stk, [], elseBr)
                end
            | join (env, ELSE_BR(stms, cond, thenBlk, k1)::stk, elseBlk, k2) = let
                val (env, elseBlk) = flushPending (env, elseBlk)
                in
                  case (k1, k2)
                   of ( Src.JOIN{phis, succ, ...}, Src.JOIN _) => let
                        val (env, [thenBlk, elseBlk]) =
                              List.foldl doPhi (env, [thenBlk, elseBlk]) (!phis)
                        val stm = mkIf(cond, List.rev thenBlk, List.rev elseBlk)
                        in
                          doNode (env, stk, stm::stms, !succ)
                        end
                    | ( Src.JOIN{phis, succ, ...}, _) => let
                        val (env, [thenBlk]) = List.foldl doPhi (env, [thenBlk]) (!phis)
                        val stm = mkIf(cond, List.rev thenBlk, List.rev elseBlk)
                        in
                          doNode (env, stk, stm::stms, !succ)
                        end
                    | (_, Src.JOIN{phis, succ, ...}) => let
                        val (env, [elseBlk]) = List.foldl doPhi (env, [elseBlk]) (!phis)
                        val stm = mkIf(cond, List.rev thenBlk, List.rev elseBlk)
                        in
                          doNode (env, stk, stm::stms, !succ)
                        end
                    | (_, _) => raise Fail "no path to exit unimplemented" (* FIXME *)
                  (* end case *)
                end
          and doNode (env, ifStk : open_if list, stms, nd) = (
                case Nd.kind nd
                 of Src.NULL => raise Fail "unexpected NULL"
                  | Src.ENTRY{succ} => doNode (env, ifStk, stms, !succ)
                  | k as Src.JOIN{phis, succ, ...} => join (env, ifStk, stms, k)
                  | Src.COND{cond, trueBranch, falseBranch, ...} => let
                      val cond = useVar env cond
                      val (env, stms) = flushPending (env, stms)
                      in
                        doNode (env, THEN_BR(stms, cond, !falseBranch)::ifStk, [], !trueBranch)
                      end
                  | Src.COM {text, succ, ...} =>
                      doNode (env, ifStk, Dst.S_Comment text :: stms, !succ)
                  | Src.ASSIGN{stm, succ, ...} => let
                      val (env, stms') = doAssign (env, stm)
                        (*Printing out types*)
                        val (typesAll,oprAll)= peelEnv(env)
          
                        val t1=(typesAll,oprAll)
                        val (ty2,opr2)= List.foldr (fn(e1,e2) => gT.getTypesFiltered (e2,e1)) t1 stms'
                         val env'=setEnv(env, ty2,opr2)
                      in
                            doNode (env', ifStk, stms' @ stms, !succ)
                      end
                  | Src.MASSIGN{stm=(ys, rator, xs), succ, ...} => let
                      fun doit () = let
                            fun doLHSVar (y, (env, ys)) = (case peekGlobal(env, y)
                                   of SOME y' => (env, y'::ys)
                                    | NONE => let
                                        val t = newLocal y
                                        in
                                          (rename (addLocal(env, t), y, t), t::ys)
                                        end
                                  (* end case *))
                            val (env, ys) = List.foldr doLHSVar (env, []) ys
                             val Trator =  LowOpToTreeOp.expandOp rator
                            val exp = Dst.E_Op(Trator, List.map (useVar env) xs)
                            val stm = Dst.S_Assign(ys, exp)
                            in
                              doNode (env, ifStk, stm :: stms, !succ)
                            end
                      in
                        case rator
                         of SrcOp.Print _ => if Target.supportsPrinting()
                              then doit ()
                              else doNode (env, ifStk, stms, !succ)
                          | _ => doit()
                        (* end case *)
                      end
                  | Src.NEW{strand, args, succ, ...} => raise Fail "NEW unimplemented"
                  | Src.SAVE{lhs, rhs, succ, ...} => let
                      val stm = Dst.S_Save([getStateVar lhs], useVar env rhs)
                      in
                        doNode (env, ifStk, stm::stms, !succ)
                      end
                  | k as Src.EXIT{kind, live, ...} => (case kind
                       of ExitKind.FRAGMENT =>
                            endScope (env, prefix @ List.revAppend(stms, finish env))
                        | ExitKind.SINIT => let
(* FIXME: we should probably call flushPending here! *)
                            val suffix = finish env @ [Dst.S_Exit[]]
                            in
                              endScope (env, prefix @ List.revAppend(stms, suffix))
                            end
                        | ExitKind.RETURN => let
(* FIXME: we should probably call flushPending here! *)
                            val suffix = finish env @ [Dst.S_Exit(List.map (useVar env) live)]
                            in
                              endScope (env, prefix @ List.revAppend(stms, suffix))
                            end
                        | ExitKind.ACTIVE => let
(* FIXME: we should probably call flushPending here! *)
                            val suffix = finish env @ [Dst.S_Active]
                            in
                              endScope (env, prefix @ List.revAppend(stms, suffix))
                            end
                        | ExitKind.STABILIZE => let
(* FIXME: we should probably call flushPending here! *)
                            val stms = Dst.S_Stabilize :: stms
                            in
(* FIXME: we should probably call flushPending here! *)
                              join (env, ifStk, stms, k)
                            end
                        | ExitKind.DIE => join (env, ifStk, Dst.S_Die :: stms, k)
                      (* end case *))
                (* end case *))

          val Y=doNode (env, [], [], CFG.entry cfg)
            
          in Y
          end

    fun trInitially (env, Src.Initially{isArray, rangeInit, iters, create=(createInit, strand, args)}) =
          let
          val iterPrefix = mkBlockOrig(trCFG (env, [], fn _ => [], rangeInit))
          fun cvtIter ((param, lo, hi), (env, iters)) = let
                val param' = newIter param
                val env = rename (env, param, param')
                in
                  (env, (param', useVar env lo, useVar env hi)::iters)
                end
          val (env, iters) = List.foldr cvtIter (env, []) iters
          val (env,createPrefix) = peelBlockOrig(env,trCFG (env, [], fn _ => [], createInit))
          in (env,{
            isArray = isArray,
            iterPrefix = iterPrefix,
            iters = iters,
            createPrefix = createPrefix,
            strand = strand,
            args = List.map (useVar env) args
          }) end

    fun trMethod env ( Src.Method{name, body}) = Dst.Method{
            name = name,
            body = mkBlockOrig(trCFG (env, [], fn _ => [], body))
          }
      
                
        fun trStrand(globalEnv, [],rest)=(globalEnv,rest)
          | trStrand(globalEnv ,( Src.Strand{name, params, state, stateInit, methods})::es,rest) = let
                val params' = List.map newParam params
                val env = ListPair.foldlEq (fn (x, x', env) => rename(env, x, x')) globalEnv (params, params')
                val (env',sInit) = peelBlockOrig(env,trCFG (env, [], fn _ => [], stateInit))
               
                val strand'=Dst.Strand{
                    name = name,
                    params = params',
                    state = List.map getStateVar state,
                    stateInit =sInit,
                    methods = List.map (trMethod env) methods
                    }
                in trStrand(env', es, rest@[strand'])
                end
                
                

  (* split the globalInit into the part that specifies the inputs and the rest of
   * the global initialization.
   *)
    fun splitGlobalInit globalInit = let
(* FIXME: can split as soon as we see a non-Input statement! *)
          fun walk (nd, lastInput, live) = (case Nd.kind nd
                 of Src.ENTRY{succ} => walk (!succ, lastInput, live)
                  | Src.COM{succ, ...} => walk (!succ, lastInput, live)
                  | Src.ASSIGN{stm=(lhs, rhs), succ, ...} => (case rhs
                       of Src.OP(SrcOp.Input _, _) => walk (!succ, nd, lhs::live)
                        | _ => walk (!succ, lastInput, live)
                      (* end case *))
                  | _ => if Nd.isNULL lastInput
                      then let (* no inputs *)
                        val entry = Nd.mkENTRY()
                        val exit = Nd.mkEXIT(ExitKind.RETURN, [])
                        in
                          Nd.addEdge (entry, exit);
                          {inputInit = Src.CFG{entry=entry, exit=exit}, globalInit = globalInit}
                        end
                      else let (* split at lastInput *)
                        val inputExit = Nd.mkEXIT(ExitKind.RETURN, live)
                        val globalEntry = Nd.mkENTRY()
                        val [gFirst] = Nd.succs lastInput
                        in
                          Nd.replaceInEdge {src = lastInput, oldDst = gFirst, dst = inputExit};
                          Nd.replaceOutEdge {oldSrc = lastInput, src = globalEntry, dst = gFirst};
                          {
                            inputInit = Src.CFG{entry = Src.CFG.entry globalInit, exit = inputExit},
                            globalInit = Src.CFG{entry = globalEntry, exit = Src.CFG.exit globalInit}
                          }
                        end
                (* end case *))
                
          in
            walk ( Src.CFG.entry globalInit, Nd.dummy, [])
          end
    fun getInfo(env,Init)=let
        val inputInit' = trCFG (env, [], fn _ => [], Init)
        in
            peelBlockOrig(env,inputInit')
        end
                
    fun translate prog = let
        (* first we do a variable analysis pass on the Low IL *)
          val prog as Src.Program{props, globalInit, initially, strands} = VA.optimize prog
(* FIXME: here we should do a contraction pass to eliminate unused variables that VA may have created *)
          val _ = (* DEBUG *)
                LowPP.output (Log.logFile(), "LowIL after variable analysis", prog)
          val envOrig = newEnv()
          val globals = List.map
                (fn x => let val x' = newGlobal x in global(envOrig, x, x'); x' end)
                  ( Src.CFG.liveAtExit globalInit)
          val {inputInit, globalInit} = splitGlobalInit globalInit
                
          val (env,inputInit)=getInfo(envOrig,inputInit)
          val (env,globalInit)=getInfo(env, globalInit)
          val (env,strands) = trStrand (env, strands,[])
          val (env, initially) = trInitially (env, initially)
                
          val (typs,opr)= peelEnv(env)
          val typsList=TySet.listItems(typs);
          val oprList=OprSet.listItems(opr);
          val _=print(gT.prnTyFinal(typsList,oprList,"--FinalPostStrands--"))
    
          in  Dst.Program{
		  props = props,
                  types=typsList,
                  oprations = oprList,
		  globals = globals,
		  inputInit = inputInit,
		  globalInit = globalInit,
		  strands = strands,
		  initially = initially
		}
          end

  end

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