(* simplify.sml
 *
 * COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * Simplify the AST representation.
 *)

structure Simplify : sig

    val transform : Error.err_stream * AST.program -> Simple.program

  end = struct

    structure Ty = Types
    structure S = Simple

    local
      val tempName = Atom.atom "_t"
    in
    fun newTemp ty = Var.new (tempName, AST.LocalVar, ty)
    end

  (* make a block out of a list of statements that are in reverse order *)
    fun mkBlock stms = S.Block(List.rev stms)

  (* convert an AST expression to an input initialization.  Note that the Diderot grammar
   * limits the forms of expression that we might encounter in this context.
   *)
    fun expToInit exp = (case exp
	   of AST.E_Lit(Literal.Int n) => Inputs.Int n
	    | AST.E_Lit(Literal.Float f) => Inputs.Real f
	    | AST.E_Lit(Literal.String s) => Inputs.String s
	    | AST.E_Lit(Bool b) => Inputs.Bool b
	    | AST.E_Tuple es => raise Fail "E_Tuple not yet implemented"
	    | AST.E_Cons es => let
		fun toReal (AST.E_Lit(Literal.Int n)) = FloatLit.fromInt n
		  | toReal (AST.E_Lit(Literal.Float f)) = f
		  | toReal (AST.E_Coerce{e, ...}) = toReal e
		  | toReal _ = raise Fail "impossible"
		fun toTensor [e] = ??
		  | toTensor (es as e1::_) = (case e1
		       of AST.E_Cons _ => let
			    val (shp, vs) = ??
			    in
			      (List.length es :: shp, List.concat vs)
			    end
			| _ => ([List.length es], List.map toReal (e1::es))
		      (* end case *))
		in
		  Inputs.Tensor(shp, Vector.fromList vs)
		end
	    | AST.E_Seq es => ??
	    | AST.E_Coerce{srcTy, dstTy, e} => ??
	    | _ => raise Fail "impossible initialization expression"
	  (* end case *))

    fun simplifyProgram (AST.Program dcls) = let
	  val inputs = ref []
	  val globals = ref []
	  val globalInit = ref []
	  val initially = ref NONE
	  val strands = ref []
	  fun setInitially init = (case !initially
		 of NONE => initially := SOME init
(* FIXME: the check for multiple initially decls should happen in type checking *)
		  | SOME _ => raise Fail "multiple initially declarations"
		(* end case *))
	  fun simplifyDecl dcl = (case dcl
		 of AST.D_Input(x, desc, NONE) => let
                      val (ty, init) = (case Var.monoTypeOf x
                             of ty as Ty.T_Image{dim, shape} =>
				  (ty, SOME(Inputs.Image(ImageInfo.fromNrrd(NrrdInfo.getInfo nrrd, ?, ?))))
                              | ty => (ty, NONE)
                            (* end case *))
		      val inp = Inputs.INP{
			      ty = ty,
			      name = Var.nameOf x,
			      desc = desc,
			      init = init
			    }
		      in
			inputs := (x, inp) :: !inputs
		      end
                  | AST.D_Input(x, desc, SOME(AST.E_LoadNrrd(tvs, nrrd, ty))) => let
                    (* load the nrrd proxy here *)
                      val info = NrrdInfo.getInfo nrrd
                      val (ty, init) = (case Var.monoTypeOf x
                             of ty as Ty.T_DynSequence _ => (ty, Inputs.DynSeq nrrd)
                              | ty as Ty.T_Image{dim, shape} =>
				  (ty, Inputs.Proxy(nrrd, ImageInfo.fromNrrd(NrrdInfo.getInfo nrrd, ?, ?)))
                              | _ => raise Fail "impossible"
                            (* end case *))
		      val inp = Inputs.INP{
			      ty = ty,
			      name = Var.nameOf x,
			      desc = desc,
			      init = SOME init
			    }
                      in
			inputs := (x, inp) :: !inputs
                      end
		  | AST.D_Input(x, desc, SOME e) => let
		      val inp = Inputs.INP{
			      ty = Var.monoTypeOf x,
			      name = Var.nameOf x,
			      desc = desc,
			      init = SOME(expToInit e)
			    }
		      in
			inputs := (x, inp) :: !inputs
		      end
		  | AST.D_Var(AST.VD_Decl(x, e)) => let
		      val (stms, e') = simplifyExp (e, [])
		      in
			globals := x :: !globals;
			globalInit := S.S_Assign(x, e') :: (stms @ !globalInit) 
		      end
		  | AST.D_Strand info => strands := simplifyStrand info :: !strands
		  | AST.D_InitialArray(creat, iters) =>
		      setInitially (simplifyInit(true, creat, iters))
		  | AST.D_InitialCollection(creat, iters) =>
		      setInitially (simplifyInit(false, creat, iters))
		(* end case *))
	  in
	    List.app simplifyDecl dcls;
	    S.Program{
		inputs = List.rev(!inputs),
		globals = List.rev(!globals),
		globalInit = mkBlock (!globalInit),
		init = (case !initially
(* FIXME: the check for the initially block should really happen in typechecking *)
		   of NONE => raise Fail "missing initially declaration"
		    | SOME blk => blk
		  (* end case *)),
		strands = List.rev(!strands)
	      }
	  end

    and simplifyInit (isArray, AST.C_Create(strand, exps), iters) = let
	  val (stms, xs) = simplifyExpsToVars (exps, [])
	  val creat = S.C_Create{
		  argInit = mkBlock stms,
		  name = strand,
		  args = xs
		}
	  fun simplifyIter (AST.I_Range(x, e1, e2), (iters, stms)) = let
		val (stms, lo) = simplifyExpToVar (e1, stms)
		val (stms, hi) = simplifyExpToVar (e2, stms)
		in
		  ({param=x, lo=lo, hi=hi}::iters, stms)
		end
	  val (iters, stms) = List.foldl simplifyIter ([], []) iters
	  in
	    S.Initially{
		isArray = isArray,
		rangeInit = mkBlock stms,
		iters = List.rev iters,
		create = creat
	      }
	  end

    and simplifyStrand {name, params, state, methods} = let
	  fun simplifyState ([], xs, stms) = (List.rev xs, mkBlock stms)
	    | simplifyState (AST.VD_Decl(x, e) :: r, xs, stms) = let
		val (stms, e') = simplifyExp (e, stms)
		in
		  simplifyState (r, x::xs, S.S_Assign(x, e') :: stms)
		end
	  val (xs, stm) = simplifyState (state, [], [])
	  in
	    S.Strand{
		name = name,
		params = params,
		state = xs, stateInit = stm,
		methods = List.map simplifyMethod methods
	      }
	  end

    and simplifyMethod (AST.M_Method(name, body)) =
	  S.Method(name, simplifyBlock body)

  (* simplify a statement into a single statement (i.e., a block if it expands
   * into more than one new statement).
   *)
    and simplifyBlock stm = mkBlock (simplifyStmt (stm, []))

    and simplifyStmt (stm, stms) = (case stm
	   of AST.S_Block body => let
		fun simplify ([], stms) = stms
		  | simplify (stm::r, stms) = simplify (r, simplifyStmt (stm, stms))
		in
		  simplify (body, stms)
		end
	    | AST.S_Decl(AST.VD_Decl(x, e)) => let
		val (stms, e') = simplifyExp (e, stms)
		in
		  S.S_Assign(x, e') :: stms
		end
	    | AST.S_IfThenElse(e, s1, s2) => let
		val (stms, x) = simplifyExpToVar (e, stms)
		val s1 = simplifyBlock s1
		val s2 = simplifyBlock s2
		in
		  S.S_IfThenElse(x, s1, s2) :: stms
		end
	    | AST.S_Assign(x, e) => let
		val (stms, e') = simplifyExp (e, stms)
		in
		  S.S_Assign(x, e') :: stms
		end
	    | AST.S_New(name, args) => let
		val (stms, xs) = simplifyExpsToVars (args, stms)
		in
		  S.S_New(name, xs) :: stms
		end
	    | AST.S_Die => S.S_Die :: stms
	    | AST.S_Stabilize => S.S_Stabilize :: stms
            | AST.S_Print args => let
		val (stms, xs) = simplifyExpsToVars (args, stms)
                in
                  S.S_Print xs :: stms
                end
	  (* end case *))

    and simplifyExp (exp, stms) = (
	  case exp
	   of AST.E_Var x => (case Var.kindOf x
		 of Var.BasisVar => let
		      val ty = Var.monoTypeOf x
		      val x' = newTemp ty
		      val stm = S.S_Assign(x', S.E_Apply(x, [], [], ty))
		      in
			(stm::stms, S.E_Var x')
		      end
		  | _ => (stms, S.E_Var x)
		(* end case *))
	    | AST.E_Lit lit => (stms, S.E_Lit lit)
	    | AST.E_Tuple es => raise Fail "E_Tuple not yet implemented"
	    | AST.E_Apply(f, tyArgs, args, ty) => let
		val (stms, xs) = simplifyExpsToVars (args, stms)
		in
		  (stms, S.E_Apply(f, tyArgs, xs, ty))
		end
	    | AST.E_Cons es => let
		val (stms, xs) = simplifyExpsToVars (es, stms)
		in
		  (stms, S.E_Cons xs)
		end
	    | AST.E_Seq es => let
		val (stms, xs) = simplifyExpsToVars (es, stms)
		in
		  (stms, S.E_Seq xs)
		end
	    | AST.E_Slice(e, indices, ty) => let (* tensor slicing *)
		val (stms, x) = simplifyExpToVar (e, stms)
		fun f ([], ys, stms) = (stms, List.rev ys)
		  | f (NONE::es, ys, stms) = f (es, NONE::ys, stms)
		  | f (SOME e::es, ys, stms) = let
		      val (stms, y) = simplifyExpToVar (e, stms)
		      in
			f (es, SOME y::ys, stms)
		      end
		val (stms, indices) = f (indices, [], stms)
		in
		  (stms, S.E_Slice(x, indices, ty))
		end
	    | AST.E_Cond(e1, e2, e3, ty) => let
	      (* a conditional expression gets turned into an if-then-else statememt *)
		val result = newTemp ty
		val (stms, x) = simplifyExpToVar (e1, S.S_Var result :: stms)
		fun simplifyBranch e = let
		      val (stms, e) = simplifyExp (e, [])
		      in
			mkBlock (S.S_Assign(result, e)::stms)
		      end
		val s1 = simplifyBranch e2
		val s2 = simplifyBranch e3
		in
		  (S.S_IfThenElse(x, s1, s2) :: stms, S.E_Var result)
		end
            | AST.E_LoadNrrd _ => raise Fail "unexpected E_LoadNrrd" (* should be handled by simplifyDecl *)
            | AST.E_Coerce{srcTy, dstTy, e} => let
                val (stms, x) = simplifyExpToVar (e, stms)
		val result = newTemp dstTy
                in
                  (S.S_Assign(result, S.E_Coerce{srcTy=srcTy, dstTy=dstTy, x=x})::stms, S.E_Var result)
                end
	  (* end case *))

    and simplifyExpToVar (exp, stms) = let
	  val (stms, e) = simplifyExp (exp, stms)
	  in
	    case e
	     of S.E_Var x => (stms, x)
	      | _ => let
		  val x = newTemp (S.typeOf e)
		  in
		    (S.S_Assign(x, e)::stms, x)
		  end
	    (* end case *)
	  end

    and simplifyExpsToVars (exps, stms) = let
	  fun f ([], xs, stms) = (stms, List.rev xs)
	    | f (e::es, xs, stms) = let
		val (stms, x) = simplifyExpToVar (e, stms)
		in
		  f (es, x::xs, stms)
		end
	  in
	    f (exps, [], stms)
	  end

    fun transform (errStrm, ast) = let
	  val simple = simplifyProgram ast
	  val _ = SimplePP.output (Log.logFile(), simple)	(* DEBUG *)
(*
	  val simple = Lift.transform simple
		handle Eval.Error msg => (Error.error(errStrm, msg); simple)
*)
	  in
	    simple
	  end

  end