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

SCM Repository

[diderot] View of /branches/pure-cfg/src/compiler/translate/translate.sml
ViewVC logotype

View of /branches/pure-cfg/src/compiler/translate/translate.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 621 - (download) (annotate)
Mon Mar 14 14:10:52 2011 UTC (8 years, 4 months ago) by jhr
File size: 11443 byte(s)
  Since initially only supports rectangular-shaped iteration, we can lift the range
  computation outside the iterations.  This allows us to determine the dimensions and
  to change the order of loop nesting.
(* translate.sml
 *
 * COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * Translate Simple-AST code into the IL representation.  This translation is based on the
 * algorithm described in
 *
 *	Single-pass generation of static single assignment form for structured languages
 *	ACM TOPLAS, Nov. 1994
 *	by Brandis and MossenBock.
 *)

structure Translate : sig

    val translate : Simple.program -> HighIL.program

  end = struct

    structure S = Simple
    structure Ty = Types
    structure VMap = Var.Map
    structure VSet = Var.Set
    structure IL = HighIL
    structure DstTy = HighILTypes
    structure Census = HighILCensus

    type env = IL.var VMap.map

    fun lookup env x = (case VMap.find (env, x)
	   of SOME x' => x'
	    | NONE => raise Fail(concat[
		  "no binding for ", Var.uniqueNameOf x, " in environment"
		])
	  (* end case *))

    fun cvtTy ty = (case TypeUtil.prune ty
	   of Ty.T_Bool => DstTy.BoolTy
	    | Ty.T_Int => DstTy.IntTy
	    | Ty.T_String => DstTy.StringTy
	    | Ty.T_Kernel _ => DstTy.KernelTy
	    | Ty.T_Tensor(Ty.Shape dd) => let
		fun cvtDim (Ty.DimConst 1) = NONE
		  | cvtDim (Ty.DimConst d) = SOME d
		in
		  DstTy.TensorTy(List.mapPartial cvtDim dd)
		end
	    | Ty.T_Image{dim=Ty.DimConst d, shape} => DstTy.ImageTy d
	    | Ty.T_Field fld => DstTy.FieldTy
	    | ty => raise Fail("cvtTy: unexpected " ^ TypeUtil.toString ty)
	  (* end case *))

  (* create a new instance of a variable *)
    fun newVar x = IL.Var.new (Var.nameOf x, cvtTy(Var.monoTypeOf x))

  (* generate fresh SSA variables and add them to the environment *)
    fun freshVars (env, xs) = let
	  fun cvtVar (x, (env, xs)) = let
		val x' = newVar x
		in
		  (VMap.insert(env, x, x'), x'::xs)
		end
	  val (env, xs) = List.foldl cvtVar (env, []) xs
	  in
	    (env, List.rev xs)
	  end

  (* a pending-join node tracks the phi nodes needed to join the assignments
   * that flow into the join node.
   *)
    datatype join = JOIN of {
	arity : int,			(* number of predecessors *)
	nd : IL.node,			(* the CFG node for this pending join *)
	phiMap : IL.phi VMap.map ref,	(* a mapping from Simple AST variables that are assigned *)
					(* to their phi nodes. *)
	predKill : int list ref		(* killed predecessor edges (because of DIE or STABILIZE *)
      }

  (* a stack of pending joins.  The first component specifies the path index of the current
   * path to the join.
   *)
    type pending_joins = (int * join) list

  (* create a new pending-join node *)
    fun newJoin arity = JOIN{
	    arity = arity, nd = IL.Node.mkJOIN [], phiMap = ref VMap.empty, predKill = ref []
	  }

    fun killPath ((i, JOIN{predKill, ...}) :: _) = predKill := i :: !predKill
      | killPath _ = ()

  (* record an assignment to the IL variable dstVar (corresponding to the Simple AST variable
   * srcVar) in the current pending-join node.  The predIndex specifies which path into the
   * JOIN node this assignment occurs on.
   *)
    fun recordAssign (_, [], _, _) = ()
      | recordAssign (env, (predIndex, JOIN{arity, phiMap, ...})::_, srcVar, dstVar) = let
	  val m = !phiMap
	  in
	    case VMap.find (env, srcVar)
	     of NONE => () (* local temporary *)
	      | SOME dstVar' => (case VMap.find (m, srcVar)
		   of NONE => let
			val lhs = newVar srcVar
			val rhs = List.tabulate (arity, fn i => if (i = predIndex) then dstVar else dstVar')
			in
			  phiMap := VMap.insert (m, srcVar, (lhs, rhs))
			end
		    | SOME(lhs, rhs) => let
			fun update (i, l as x::r) = if (i = predIndex)
			      then dstVar::r
			      else x::update(i+1, r)
			  | update _ = raise Fail "invalid predecessor index"
			in
			  phiMap := VMap.insert (m, srcVar, (lhs, update(0, rhs)))
			end
		  (* end case *))
	    (* end case *)
	  end

  (* complete a pending join operation by filling in the phi nodes from the phi map and
   * updating the environment.
   *)
    fun commitJoin (env, joinStk, JOIN{nd, phiMap, ...}) = let
	  val IL.ND{kind=IL.JOIN{phis, ...}, ...} = nd
	  fun doVar (srcVar, phi as (dstVar, _), (env, phis)) = (
		recordAssign (env, joinStk, srcVar, dstVar);
		(VMap.insert (env, srcVar, dstVar), phi::phis))
	  val (env, phis') = VMap.foldli doVar (env, []) (!phiMap)
	  in
(* FIXME: prune killed paths. *)
	    phis := phis';
	    (env, SOME nd)
	  end

  (* expression translation *)
    fun cvtExp (env : env, lhs, exp) = (case exp
	   of S.E_Var x => [(lhs, IL.VAR(lookup env x))]
	    | S.E_Lit lit => [(lhs, IL.LIT lit)]
	    | S.E_Tuple xs => raise Fail "E_Tuple not implemeted"
	    | S.E_Apply(f, tyArgs, args, ty) => let
		val args' = List.map (lookup env) args
		in
		  TranslateBasis.translate (lhs, f, tyArgs, args')
		end
	    | S.E_Cons args => [(lhs, IL.CONS(List.map (lookup env) args))]
	    | S.E_Slice(x, indices, ty) => let
		val x = lookup env x
		val mask = List.map isSome indices
		fun cvt NONE = NONE
		  | cvt (SOME x) = SOME(lookup env x)
		val indices = List.mapPartial cvt indices
		in
		  if List.all (fn b => b) mask
		    then [(lhs, IL.OP(HighOps.Subscript(IL.Var.ty x), x::indices))]
		    else [(lhs, IL.OP(HighOps.Slice(IL.Var.ty lhs, mask), x::indices))]
		end
	    | S.E_Input(_, name, NONE) =>
		[(lhs, IL.OP(HighOps.Input(IL.Var.ty lhs, name), []))]
	    | S.E_Input(_, name, SOME dflt) =>
		[(lhs, IL.OP(HighOps.InputWithDefault(IL.Var.ty lhs, name), [lookup env dflt]))]
	    | S.E_LoadImage(info, name) => [(lhs, IL.OP(HighOps.LoadImage info, [lookup env name]))]
	  (* end case *))

    fun cvtBlock (state, env : env, joinStk, S.Block stms) = let
	  fun cvt (env : env, cfg, []) = (cfg, env)
	    | cvt (env, cfg, stm::stms) = (case stm
		 of S.S_Assign(lhs, rhs) => let
		      val lhs' = newVar lhs
		      val assigns = cvtExp (env, lhs', rhs)
		      in
			recordAssign (env, joinStk, lhs, lhs');
			cvt (
			  VMap.insert(env, lhs, lhs'),
			  IL.CFG.concat(cfg, IL.CFG.mkBlock assigns),
			  stms)
		      end
		  | S.S_IfThenElse(x, b0, b1) => let
		      val x' = lookup env x
		      val join = newJoin 2
		      val (cfg0, _) = cvtBlock (state, env, (0, join)::joinStk, b0)
		      val (cfg1, _) = cvtBlock (state, env, (1, join)::joinStk, b1)
		      val cond = IL.Node.mkCOND {
			      cond = x',
			      trueBranch = IL.Node.dummy,
			      falseBranch = IL.Node.dummy
			    }
		      in
			IL.Node.addEdge (IL.CFG.exit cfg, cond);
			case commitJoin (env, joinStk, join)
			 of (env, SOME joinNd) => (
			      if IL.CFG.isEmpty cfg0
				then (
				  IL.Node.setTrueBranch (cond, joinNd);
				  IL.Node.setPred (joinNd, cond))
				else (
				  IL.Node.setTrueBranch (cond, IL.CFG.entry cfg0);
				  IL.Node.setPred (IL.CFG.entry cfg0, cond);
				  IL.Node.addEdge (IL.CFG.exit cfg0, joinNd));
			      if IL.CFG.isEmpty cfg1
				then (
				  IL.Node.setFalseBranch (cond, joinNd);
				  IL.Node.setPred (joinNd, cond))
				else (
				  IL.Node.setFalseBranch (cond, IL.CFG.entry cfg1);
				  IL.Node.setPred (IL.CFG.entry cfg1, cond);
				  IL.Node.addEdge (IL.CFG.exit cfg1, joinNd));
			      cvt (
				env,
				IL.CFG{entry = IL.CFG.entry cfg, exit = joinNd},
				stms))
			(* the join node has only zero predecessors, so
			 * it was killed.
			 *)
			  | (env, NONE) => raise Fail "unimplemented" (* FIXME *)
			(* end case *)
		      end
		  | S.S_New(strandId, args) => let
		      val nd = IL.Node.mkNEW{
			      strand = strandId,
			      args = List.map (lookup env) args
			    }
		      in
			cvt (env, IL.CFG.appendNode (cfg, nd), stms)
		      end
		  | S.S_Die => (
		      killPath joinStk;
		      (IL.CFG.appendNode (cfg, IL.Node.mkDIE ()), env))
		  | S.S_Stabilize => let
		      val stateOut = List.map (lookup env) state
		      in
			killPath joinStk;
			(IL.CFG.appendNode (cfg, IL.Node.mkSTABILIZE stateOut), env)
		      end
		(* end case *))
	  in
	    cvt (env, IL.CFG.empty, stms)
	  end

    fun cvtTopLevelBlock (env, blk) = let
	  val (cfg, env) = cvtBlock ([], env, [], blk)
	  val entry = IL.Node.mkENTRY ()
	  val exit = IL.Node.mkRETURN []
	  in
	    if IL.CFG.isEmpty cfg
	      then IL.Node.addEdge (entry, exit)
	      else (
		IL.Node.addEdge (entry, IL.CFG.entry cfg);
	      (* NOTE: this addEdge could fail if all control paths end in DIE or STABILIZE,
	       * so we wrap it in a handler
	       *)
		IL.Node.addEdge (IL.CFG.exit cfg, exit) handle _ => ());
	    (IL.CFG{entry = entry, exit = exit}, env)
	  end

    fun cvtMethod (env, name, state, blk) = let
	(* allocate fresh variables for the state variables *)
	  val (env, stateIn) = freshVars (env, state)
	(* convert the body of the method *)
	  val (cfg, env) = cvtBlock (state, env, [], blk)
	(* add the entry/exit nodes *)
	  val stateOut = List.map (lookup env) state
	  val entry = IL.Node.mkENTRY ()
	  val exit = IL.Node.mkACTIVE stateOut
	  in
	    if IL.CFG.isEmpty cfg
	      then IL.Node.addEdge (entry, exit)
	      else (
		IL.Node.addEdge (entry, IL.CFG.entry cfg);
	      (* NOTE: this addEdge could fail if all control paths end in DIE or STABILIZE,
	       * so we wrap it in a handler
	       *)
		IL.Node.addEdge (IL.CFG.exit cfg, exit) handle _ => ());
	    IL.Method{
		name = name,
		stateIn = stateIn,
		stateOut = stateOut,
		body = IL.CFG{entry = entry, exit = exit}
	      }
	  end

  (* convert the initially code *)
    fun cvtInitially (env, S.Initially{isArray, rangeInit, create, iters}) = let
	  val S.C_Create{argInit, name, args} = create
	  fun cvtIter ({param, lo, hi}, (env, iters)) = let
		val param' = newVar param
		val env = VMap.insert (env, param, param')
		val iter = (param', lookup env lo, lookup env hi)
		in
		  (env, iter::iters)
		end
	  val (cfg, env) = cvtTopLevelBlock (env, rangeInit)
	  val (env, iters) = List.foldl cvtIter (env, []) iters
	  val (argInitCFG, env) = cvtTopLevelBlock (env, argInit)
	  in
	    IL.Initially{
		isArray = isArray,
		rangeInit = cfg,
		iters = List.rev iters,
		create = (argInitCFG, name, List.map (lookup env) args)
	      }
	  end

    fun translate (S.Program{globals, globalInit, init, strands}) = let
	  val (globalInit, env) = cvtTopLevelBlock (VMap.empty, globalInit)
	(* get the SSA names for the globals and a reduced environment that just defines
	 * the globals.
	 *)
	  val (env, globs) = let
		val lookup = lookup env
		fun cvtVar (x, (env, globs)) = let
		      val x' = lookup x
		      in
			(VMap.insert(env, x, x'), x'::globs)
		      end
		val (env, globs) = List.foldl cvtVar (VMap.empty, []) globals
		in
		  (env, List.rev globs)
		end
	  val init = cvtInitially (env, init)
	  fun cvtStrand (S.Strand{name, params, state, stateInit, methods}) = let
		val (env, params) = let
		      fun cvtParam (x, (env, xs)) = let
			    val x' = newVar x
			    in
			      (VMap.insert(env, x, x'), x'::xs)
			    end
		      val (env, params) = List.foldl cvtParam (env, []) params
		      in
			(env, List.rev params)
		      end
		val (stateInit, env) = cvtTopLevelBlock (env, stateInit)
		val state' = List.map (lookup env) state
		fun cvtMeth (S.Method(name, blk)) =
		      cvtMethod (env, name, state, blk)
		in
		  IL.Strand{
		      name = name,
		      params = params,
		      state = state',
		      stateInit = stateInit,
		      methods = List.map cvtMeth methods
		    }
		end
	  val prog = IL.Program{
		  globals = globs,
		  globalInit = globalInit,
		  initially = init,
		  strands = List.map cvtStrand strands
		}
	  in
	    Census.init prog;
	    prog
	  end

  end

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