(**********************************************************************)
(* (c) Greg Morrisett, Neal Glew, Chris Hawblitzel, Dan Grossman,     *)
(*     Frederick Smith                                                *)
(*     June 1998, all rights reserved.                                *)
(**********************************************************************)

(* Assumes that any function assigned to a var is escaping and therefore
 * will use stack calling convention
 *)

(* For non-escaping, return register is called <label>0, input argument i
 * passed in register called <label>i
 * Must change if do sophisticated non-escaping analysis
 *)

(* Chars converted to ints at compile time *)

(*** File table of contents:
 * 0. flags, opens, exceptions, and constants
 * 1. Global environment (from Poptype) access
 * 2. Local environment definition/access
 * 3. TAL shortcuts
 * 4. Helpers for building static data
 * 5. Attributes synthesized during code gen
 * 6. Simple code gen helper values
 * 7. Gunk
 * 8. Heart of Code Generation (compileFun)
 *    a. Helpers, including mutable state
 *    b. compileExpression
 *    c. compileTest
 *    d. compileStatement
 *    e. initialization
 * 9. Preprocess, postprocess, and entry point
 ***)

let allocateregs   = ref true
let optimize       = ref true

let debug          = ref false
let doTailcallElim = ref false

let allFunsEscape  = ref true
let noFunsEscape   = ref false (* Except main, if there is one *)

open Numtypes
open Identifier
open Popsyntax
open Poptype
open Tal
open Regalloc
open Cfg

exception NoSuchGlobal   of type_name
exception NoSuchTypeName of type_name
exception NoSuchField    of field_name

let numRegisters = 7

let impossible () = failwith "code gen: allegedly impossible case"
let deopt opt = 
  match opt with
    Some t -> t
  | None   -> failwith "bug: code gen thought an option would be Some" 
let dereg r   =
  match r with
    Reg  r -> r
  | _      -> failwith "bug: code gen thought a genop would be Reg"

let dummyIvec  = [|Nop|]
let dummyBlock = make_block (id_new "") None (id_new "") dummyIvec 

(* Change code to use an env to avoid re-building identifiers! *)
     (* Can this main hack be avoided? *)
let varToLab  v = if (v = "main") 
                  then id_of_string "__main$"
                  else id_of_string ("_" ^ v)
let typeToLab v = id_of_string ("_" ^ v  ^ "$")
let typeVarToLab v = id_of_string (v ^ "?")

(*** Global environment access ***)
type cg_struct = { 
    s_name:          identifier;
    s_possibly_null: bool;
    fieldoffsets:    (field_name, int32) Dict.dict;
    fieldcons:       con; (* cprod (cfield list) *)
    mallocarg:       mallocarg;
    initTypes:       con Lazy.t list
  } 
type cg_union =  { 
    u_name:           identifier;
    u_possibly_null:  bool;
    void_fields:      (field_name, int32)          Dict.dict;
    value_fields:     (field_name, 
		       int32             (* tag *)
			 * (con Lazy.t)  (* refined sum type *)
			 * (con Lazy.t)  (* field type *)
			 * mallocarg)    (* for NewUnion *)
                        Dict.dict;
    num_void_fields:  int;
    num_value_fields: int;
    talcon:           con
  } 
type cg_env = { 
    cg_structs:   (type_name, cg_struct) Dict.dict;
    cg_unions:    (type_name, cg_union)  Dict.dict;
    cg_abstracts: (type_name, var list * bool) Dict.dict;
    cg_globals:   (var,       typ)       Dict.dict
  }	

let findInGlobalEnv dict id = 
  try  Dict.lookup dict id
  with Dict.Absent -> raise (NoSuchGlobal id)
let findStruct   env id = findInGlobalEnv env.cg_structs   id 
let findUnion    env id = findInGlobalEnv env.cg_unions    id 
let findAbstract env id = findInGlobalEnv env.cg_abstracts id 
let findGlobal   env id = findInGlobalEnv env.cg_globals   id
let findFunction env id = findInGlobalEnv env.cg_globals   id 
let hasFunction  env id = Dict.member     env.cg_globals   id

    (* hack for the moment *)
let funEscapes v = (not !noFunsEscape) &
                   (!allFunsEscape or (v = "new_array") or (v = "main"))
(* Level 0 coarseness -- every function uses stack calling convention *)
let funExpEscapes exp = 
  match exp.raw_exp with
    Var v -> funEscapes v
  | _     -> true
   
(*** Local environment definition/access ***)
type cg_local_env = 
    {           
     var_to_reg  : (var, reg)     Dict.dict; (* map vars to reg      *)
     reg_to_type : register_state Lazy.t;    (* map reg to TAL type  *)
     loopEnv     : cf_block * cf_block;      (* break, continue here *)
     tyvars      : var list                  (* free type variables  *)
    } 
let addRegType locEnv r lt =
  lazy (rs_set_reg (Lazy.force locEnv.reg_to_type) r (Lazy.force lt))
let emptyLocalEnv = 
    {
     var_to_reg  = Dict.empty compare; 
     reg_to_type = lazy rs_empty;
     loopEnv     = (dummyBlock, dummyBlock);
     tyvars      = []
    }
let addToMap  locEnv v r lt = 
    {
     var_to_reg  = Dict.insert locEnv.var_to_reg  v r;
     reg_to_type = addRegType locEnv r lt;
     loopEnv     = locEnv.loopEnv;
     tyvars      = locEnv.tyvars
    }
let addTempToMap locEnv r lt =
    {
     var_to_reg  = locEnv.var_to_reg;
     reg_to_type = addRegType locEnv r lt;
     loopEnv     = locEnv.loopEnv;
     tyvars      = locEnv.tyvars
    }
let newLoopEnv locEnv brkBlock cntBlock =
    {
     var_to_reg  = locEnv.var_to_reg;
     reg_to_type = locEnv.reg_to_type;
     loopEnv     = (brkBlock, cntBlock);
     tyvars      = locEnv.tyvars
    }                               
let addTyvars locEnv ts =
    {
     var_to_reg = locEnv.var_to_reg;
     reg_to_type = locEnv.reg_to_type;
     loopEnv = locEnv.loopEnv;
     tyvars  = ts
    }     
let getBreakBlock    locEnv = fst         locEnv.loopEnv
let getContinueBlock locEnv = snd         locEnv.loopEnv
let varToReg locEnv v       = Dict.lookup locEnv.var_to_reg  v
let varLocal locEnv v       = Dict.member locEnv.var_to_reg  v
let currRegs locEnv         = Lazy.force  locEnv.reg_to_type
let currTyvars locEnv       = locEnv.tyvars

(* TAL shortcuts *)

let callerStackVar   = id_new "r"
let eltVar           = id_new "t"
let callee           = id_new "a"
let arraySizeVar     = id_new "size"
let arrayArgVar      = id_new "c"
let arrayAbbrevVar   = id_new "arr"
let stringAbbrevVar  = id_new "string"
let callerStackCvar  = cvar callerStackVar
let arrayRealCon c   = carray_s arraySizeVar (cfield c ReadWrite)
let stringRealCon    = arrayRealCon (pcbytes Byte1)
let arrayAbbrev      = clam arrayArgVar k4byte (arrayRealCon (cvar arrayArgVar))
let stringAbbrev     = stringRealCon
let jumpCoercion     = [Tapp callerStackCvar]
let fallthruCoercion = [callerStackCvar]

let intCon     = cbyte4
let boolCon    = chptr [i32_0;i32_1] None
let charCon    = intCon
let arrayCon c = capp (cvar arrayAbbrevVar) c
let stringCon  = cvar stringAbbrevVar
let nameCon    = clab

(*** Helpers for building static data ***)
let string_list : (identifier * string) list ref = ref [] (* STATE *)
let add_string s = 
  let l = id_new "cstr" in
  string_list := (l,s) :: (!string_list); l
let stringsToData () =
  let con = stringCon in
  List.map 
    (fun (l,s) -> 
      let len = String.length s in
      (l, None, 
       ([ D4bytes (int_to_int32 len,[]); Dup; Dbytes s ],
	[ Pack (pcint (int_to_int32 len), stringCon);
	  Toarray (i32_4,0,cfield (pcbytes Byte1) ReadWrite) ])))
    !string_list

(*** Attributes synthesized during code gen ***)
(* Note: returnees and returners are maintained imperatively in compileFun
 *       because threading the synthesis is unnecessarily complicated
 * returnees  : (block * var) list;   blocks returned to, by fun 
 * returners  : block list;           blocks which return 
 * tailCallees: var list;             functions tail called
 *)

type cg_stmt_synth =
  {
    must_exit    : bool;  (* always returns, breaks, or continues *) 
    may_break    : bool;  (* has a break    *)
    may_continue : bool   (* has a continue *)
  }
let synth_none      = {must_exit=false; may_break=false; may_continue=false}
let synth_returns   = {must_exit=true;  may_break=false; may_continue=false}
let synth_breaks    = {must_exit=true;  may_break=true;  may_continue=false}
let synth_continues = {must_exit=true;  may_break=false; may_continue=true }
let synth_merge s1 s2 =
  {
    must_exit    = s1.must_exit    &  s2.must_exit;
    may_break    = s1.may_break    or s2.may_break;
    may_continue = s1.may_continue or s2.may_continue
  } 

(*** Simple code gen helper values ***)
let newReg ()    = Reg(Virt (id_new "t"))
let paramReg s i = Virt (id_make s i)
(* FMS: temporarily removed.
   let funRetReg s  = if funEscapes s then Eax else paramReg s 0*)

(* FMS: Steve and I are experimenting with a simple reg. alloc. *)
let newReg1 () = Reg(Virt (id_new "one"))
let newReg0 () = Reg(Virt (id_new "zero"))
let newRegInf () = Reg(Virt (id_new "inf"))
let paramRegInf s i = Virt (id_make ("inf_" ^ s) i)
let paramReg1 s i = Virt (id_make ("one_" ^ s) i)
let funRetReg s = if funEscapes s then Eax else paramReg1 s 0

let move dest src            = Mov(dest, (src, []))
let moveCoerce dest src cl   = Mov(dest, (src, cl))
let prjr reg offset          = Prjr((reg,[]), offset)
let prjrCoerce reg offset cl = Prjr((reg,cl), offset)

let convertCondition p =
  match p with 
    Popsyntax.Eq -> Eq
  | Neq          -> NotEq
  | Gt           -> Greater
  | Lt           -> Less
  | Gte          -> GreaterEq
  | Lte          -> LessEq 
  | _   -> impossible() 
let negateCondition c = (* This should be provided by TAL *)
  match c with
    Eq        -> NotEq
  | NotEq     -> Eq
  | Greater   -> LessEq
  | LessEq    -> Greater
  | GreaterEq -> Less
  | Less      -> GreaterEq
  | _ -> impossible()

(* Interfaces can't use abbrevs (yet) *)
let rec realTypeCon useAbbrevs tau =
  let rec applyCons c cs = 
    match cs with 
      [] -> c 
    | (c'::cs) -> applyCons (capp c c') cs
  in
  match tau with
    IntType        -> intCon
  | BooleanType    -> boolCon
  | VoidType       -> failwith "code_gen: VoidType encountered in typeCon"
  | Evar r         -> 
      begin match !r with
	Some t -> realTypeCon useAbbrevs t
      |	None   -> (r:= Some(IntType); intCon)
      end
  | OptionEvar r   ->
      begin match !r with
	Some t -> realTypeCon useAbbrevs t
      |	None   -> failwith "code_gen: uninstantiated ?evars unimpl. in typeCon"
      end
  | VarType v      -> cvar (typeVarToLab v)
  | StringType     -> if useAbbrevs then stringCon else stringRealCon
  | ArrayType c    -> if useAbbrevs then arrayCon (realTypeCon useAbbrevs c)
	               else arrayRealCon (realTypeCon useAbbrevs c)
  | FnType (tyvs, t, tl) ->  
      (* assumes escaping -- else this wouldn't be called!! *)
      realLabelState useAbbrevs tyvs
 	Eax t rs_empty (List.map (realTypeCon useAbbrevs) tl)
  | NamedType (s,tyargs) -> (applyCons (clab (typeToLab !s)) 
			       (realTypeCons useAbbrevs tyargs))
  | CharType       -> charCon
  | TupleType ts   -> cprod_b 
	(List.map (fun t -> cfield (realTypeCon useAbbrevs t) Read) ts)
  | ExnType -> failwith "code_gen: exception types unimplemented."

and realOnStack useAbbrevs retReg retType stackVals =
  let stackcons = 
    List.fold_right (fun tau typeSoFar -> ccons tau typeSoFar)
      stackVals callerStackCvar in
  let returnRegisters = 
    match retType with
      VoidType -> rs_empty
    | _        -> rs_set_reg rs_empty retReg (realTypeCon useAbbrevs retType) in
  let topOfStack = ccode (rs_set_reg returnRegisters Esp (csptr stackcons))   in
  ccons topOfStack stackcons

and realLabelState useAbbrevs typeVars retReg retType currentRegs stackVals =
  let baseCon = 
    ccode (rs_set_reg currentRegs Esp 
	     (csptr (realOnStack useAbbrevs retReg retType stackVals))) in
  let preCon = 
    List.fold_right (fun v c -> cforall (typeVarToLab v) k4byte c) 
      typeVars baseCon in
  (cforall callerStackVar Kstack preCon)

and realTypeCons useAbbrevs taus = List.map (realTypeCon useAbbrevs) taus

let labelState = realLabelState true 
let typeCon    = realTypeCon    true
let typeCons   = realTypeCons   true
let onStack    = realOnStack    true

let rec getNamedType tau =
  match tau with
    NamedType (n,ts) -> (!n,ts)
  | Evar r -> getNamedType (deopt !r)
  | OptionEvar r -> getNamedType (deopt !r)
  | _ -> impossible ()

(*** Gunk ***)
let pop_exit_label  = varToLab     "tal_exit"
let null_exn_label  = varToLab     "pop_never_null"
let new_array_label = id_of_string "_new_array"
let tal_main_label  = varToLab     "tal_main"
let mainFunId       = "main"
let main_label      = varToLab     "_main$"

let null_exn_con   = ccode rs_empty
let new_array_con  = 
  let arr_typ   = (id_new "a") in
  let arr_typ_v = cvar arr_typ in
  let stackVals = ccons intCon (ccons arr_typ_v callerStackCvar) in
  cforall callerStackVar Kstack   
    (cforall arr_typ k4byte
       (ccode_l
	  [(Esp, csptr (ccons 
			  (ccode_l [ (Eax, arrayRealCon arr_typ_v);
				     (Esp, csptr stackVals) ])
			  stackVals))]))

let tal_main_con   = ccode_l [(Esp, csptr cempty)]
let tal_main_code  = [|Call (Addr main_label,[Tapp cempty]);
		       Push (Immed i32_0,[]);
		       Jmp  (Addr pop_exit_label, [Tapp cempty])
		     |]
(* Perhaps add pop_exit as well? *)
let startctxt = 
  Talctxt.add_abbrev
    (Talctxt.add_abbrev
       (Talctxt.add_val 
	  Talctxt.empty_ctxt
	  null_exn_label 
	  (Some(snd (Talcon.check Talctxt.empty_ctxt null_exn_con))))
       arrayAbbrevVar arrayAbbrev)
    stringAbbrevVar stringAbbrev

(*** Heart of Code Generation ***)
let compileFun (cfg, env, decl) =

  (*** Helpers, including mutable state ***)
  let static      = decl.fn_static   in
  let funId       = decl.fn_name     in
  let funTypeVars = decl.fn_tyvars   in
  let retTau      = decl.fn_ret_type in
  let ts          = decl.fn_body     in
  let declList    = decl.fn_args     in
  let funLabel    = varToLab funId   in 
  let thisEscapes = funEscapes funId in
  
  let stackVals = 
    if thisEscapes then (List.map (fun x -> typeCon(snd x)) declList) else [] 
  in

  let returnees   = ref ([] : (cf_block * var) list)               in(* STATE *)
  let returners   = ref ([] : cf_block list)                       in(* STATE *)
  let tailCallees = ref ([] : var list)                            in(* STATE *)
  let addReturnee (blk,str)= returnees := (blk, str)::!returnees   in
  let addReturner      blk = returners := blk::!returners          in
  let addTailCallee    str = if not (List.mem str !tailCallees)
                             then tailCallees := str::!tailCallees in

  let currentBlock  = ref (get_block cfg funLabel) in (* STATE *)
  let currentIvec   = ref (Xarray.create 1 Nop)    in (* STATE *)
  let emit inst = Xarray.add (!currentIvec) inst   in

(* FMS: added - probably in the wrong place. *)
  let killReg r = 
    match r with
      Reg(Virt(i)) -> emit (Comment ("kill " ^ (id_to_string i))) 
    | _ -> failwith "code_gen: killReg requires a virtual reg."
  in

  let varToGenop locEnv v = (* Assumes global exists if not local *)
    try (Reg (varToReg locEnv v))
    with Dict.Absent -> (Addr (varToLab v)) in
  
  let funTypeCons = List.map (fun v -> cvar (typeVarToLab v)) funTypeVars in
  let fallthruCoercion = (callerStackCvar :: funTypeCons) in
  let jumpCoercion = List.rev (List.map (fun x -> Tapp x) fallthruCoercion) in

  let add_edge edgeType toBlock = 
    add_edge_bb cfg !currentBlock edgeType toBlock in
  let sequence toBlock =
    add_edge Sequence toBlock                      in
  let fallthru toBlock = 
    (emit (Fallthru fallthruCoercion); 
     add_edge Sequence toBlock)                    in
  let btagi r i cond toBlock = 
    (emit (Btagi (r, i, (toBlock.lab, jumpCoercion), cond)); 
     add_edge Branch toBlock)                      in
  let jcc cond toBlock =
    (emit (Jcc (cond, (toBlock.lab, jumpCoercion)));
     add_edge Branch toBlock)                      in
  let knownjump toBlock =
    (emit (Jmp (Addr toBlock.lab, jumpCoercion));
     add_edge Jump toBlock)                        in
  
  let makeBlockType locEnv = 
    labelState funTypeVars (funRetReg funId) retTau (currRegs locEnv) stackVals
  in
  let createBlockAux str con =
    let b = make_block (id_new str) con funLabel dummyIvec in
    add_block cfg b; b in
  let createBlock locEnv str = createBlockAux str (Some(makeBlockType locEnv))in
  let createSeqBlock     str = createBlockAux str None                        in
  let typeBlock locEnv block = set_con block (Some (makeBlockType locEnv))    in

  let replaceCurrBlock nextBlock =
    set_code !currentBlock (Xarray.to_array (!currentIvec));
    if !optimize then Cfgopt.blockOptimize !currentBlock;
    currentIvec  := Xarray.create 1 Nop;
    currentBlock := nextBlock in
  
  let funCallCoercion = onStack (funRetReg funId) retTau stackVals in

  (*** compileExpression ***)
  let rec compileExpression (texp, resultReg, locEnv, tailpos) =
    let typ = deopt texp.exp_typ in
    let exp = texp.raw_exp       in
    
    (*** Helpers for compileExpression ***)
    let doBasicSubexp (te, subResultReg) = 
      compileExpression(te, subResultReg, locEnv, false) in

    let doBinOp (p, leftReg, rightExp) = (* used by PrimOp and AssignOp *)
      let rightReg = newReg1() in
      doBasicSubexp(rightExp, rightReg);
      match p with
      | (Popsyntax.Div | Popsyntax.Mod) ->
	  let result =  match p with  Popsyntax.Div -> Eax
	                            | Popsyntax.Mod -> Edx
				    | _ -> impossible () in 
	  emit (move (Reg Eax) leftReg);
	  emit (Conv Cdq);
	  emit (ArithMD(Tal.Idiv, rightReg));
	  emit (move leftReg  (Reg result))
      | (Times | Plus | Minus | Bitand | Bitor | Bitxor) ->
	  let binop =   match p with Times  -> Imul2
       	                           | Plus   -> Add
				   | Minus  -> Sub
				   | Bitand -> And
				   | Bitor  -> Or
				   | Bitxor -> Xor
				   | _ -> impossible() in
	  emit (ArithBin (binop, leftReg, rightReg))
      | (Bitlshift | Bitlrshift | Bitarshift) ->
	  let shiftop = match p with Bitlshift  -> Shl
	                           | Bitlrshift -> Shr
				   | Bitarshift -> Sar
				   | _ -> impossible() in
	  emit (move (Reg Ecx) rightReg);
	  emit (ArithSR (shiftop, leftReg, None))
      |	_ -> failwith "code gen -- unknown binary operator" in
                                         (* used by Assign and AssignOp *)
    let structMemberLhs (stExp, fieldName, stReg) = 
      (* put base address in stReg, 
	 return (offset, coercion to load/store the member) *)
      doBasicSubexp(stExp, stReg);
      let (tn,_) = getNamedType (deopt stExp.exp_typ) in 
      let structInfo = findStruct env tn in
      let offset = Dict.lookup structInfo.fieldoffsets fieldName in
      if structInfo.s_possibly_null
      then 
	(let r = dereg stReg in
	emit (Coerce (r, [Unroll]));
	emit (Btagi (r, i32_0, (null_exn_label,  []), Eq));
	(offset, Fromsum))
      else
      	(offset, Unroll) in

    
    let subexp1    = newReg1() in let subexp1r = dereg subexp1 in
    let subexp2    = newReg1() in let subexp2r = dereg subexp2 in
    let subexp3    = newReg1() in let subexp3r = dereg subexp3 in
    let resultRegr = dereg resultReg in

    (*** Main match for compileExpression ***)
    match exp with
      Const e ->
	(match e with 
	  Popsyntax.Int  i -> emit (move resultReg (Immed i))
        | Popsyntax.Char c -> emit (move resultReg 
				      (Immed (int_to_int32 (Char.code c))))
    	| String s         -> emit (move resultReg (Addr (add_string s)))
	| Bool b           -> 
	    emit(moveCoerce resultReg 
		   (Immed(if b then i32_1 else i32_0)) [Tosum boolCon])
	| Null             -> 
	    emit(moveCoerce resultReg 
		   (Immed i32_0) [RollTosum (typeCon typ)]));
	false
    | ConstArray(el, topt) -> (* Doing this efficiently in TAL is a pain *)
	let t = typeCon 
	    (match topt with
	      Some t -> t
	    | None   -> deopt ((List.hd el).exp_typ)) in
	let len      = List.length el    in
	let size_con = csing (pcint (int_to_int32 len)) in
	let mallocarg = 
	  Mprod [ Mfield size_con;
		  malloc_prod (Utilities.replicate t len)] in 
	let initIndType    = cfield t ReadWrite in
	let uninitIndType  = cfield t Uninit    in
	let subexp1 = newRegInf() in  (* FMS : Added for experiment. *)
	let subexp1r = dereg subexp1 in
	let makeLazyType i = 
	  (lazy
	     (cprod_b
	     	[ cfield size_con ReadWrite;
		  cprod 
		    ((Utilities.replicate initIndType (i-1)) @
		     (Utilities.replicate uninitIndType (len-i+1))) ])) in

	emit (Malloc (int_to_int32 (4*(len+1)), mallocarg));           (* get memory *)
	emit (move subexp1 (Reg Eax));
	emit (move (prjr subexp1r i32_0) (Immed (int_to_int32 len)));(* store length *)

	List.fold_left (* compute/store values *)
	  (fun i te ->
	    let nr = newReg1() in
	    compileExpression(te, nr, 	                (* compute one value *)
			      addTempToMap locEnv subexp1r (makeLazyType i),
			      false);
	    emit (move (prjr subexp1r (int_to_int32 (4*i))) nr); (* store one value   *)
	    i+1)
	  1 el;
	emit (moveCoerce resultReg subexp1
		[ Pack (pcint (int_to_int32 len), arrayCon t); 
		  Toarray(i32_4,0,initIndType)]);
	killReg subexp1;
	false
    | Var v -> (* Does local vars and global vars *)
	let g = varToGenop locEnv v in
	let reg = newReg1() in
	let regr = dereg reg in
	(match g with
	  Addr _ -> emit (move reg g);
	            emit (move resultReg (prjr regr i32_0))
	| Reg  _ -> emit (move resultReg g)
	| _      -> impossible());
	false
    | Primop (p, el) -> 
	(match p  with (* switch on arity *)
	  (Popsyntax.Not | Bitnot | Size) ->
	    doBasicSubexp(List.hd el, subexp1);
	    (match p with 
	      Popsyntax.Not ->
       		emit (moveCoerce resultReg (Immed i32_0) [Tosum boolCon]);
		emit (Cmp (subexp1, resultReg));
      		emit (Setcc(Eq, resultReg))
	    | Bitnot -> 
		emit (ArithUn (Tal.Not, subexp1)); (* FMS: XXX *)
	    	emit (move resultReg subexp1)
	    | Size -> (* requires string or array type according to poptype *)
		let eltSize = 
		  match deopt (List.hd el).exp_typ with 
		    StringType  -> Byte1
		  | ArrayType _ -> Byte4 
		  | _           -> impossible() in
		emit (Unpack (arraySizeVar,subexp2r,(subexp1,[])));
		emit (move   resultReg (prjr subexp2r i32_0));
		emit (Coerce (resultRegr, [Subsume cbyte4]))
	    |  _ -> impossible());
	    false
	| (Popsyntax.Eq | Neq | Gt | Lt | Gte | Lte) ->
	    let ic = convertCondition p in
	    doBasicSubexp(List.hd el,           subexp1);
	    doBasicSubexp(List.hd (List.tl el), subexp2);
	    emit (Cmp (subexp1, subexp2));
	    emit (moveCoerce resultReg (Immed i32_0) [Tosum boolCon]);
	    emit (Setcc(ic, resultReg));
	    false
    	| (Plus | Times | Minus | Popsyntax.Div | Popsyntax.Mod |  Bitand | 
	  Bitor | Bitxor  | Bitlshift | Bitlrshift | Bitarshift) ->
	    doBasicSubexp(List.hd el, subexp1);
	    doBinOp(p, subexp1, List.hd (List.tl el)); (* FMS: XXX *)
	    emit (move resultReg subexp1);
	    false
	| (Ord | Chr) -> 
	    compileExpression(List.hd el, resultReg, locEnv, tailpos))

    | Conditional (e1, e2, e3) ->
	let trueStartBlock  = createSeqBlock     "ifTrue"  in
	let falseStartBlock = createBlock locEnv "ifFalse" in
	let mergeBlock      = createBlock 
	    (match typ with
	      VoidType -> locEnv
	    | _        ->
	    	addTempToMap locEnv resultRegr (lazy (typeCon typ)))
	    "ifMerge"                                      in

	compileTest(e1, locEnv, trueStartBlock, falseStartBlock, false);

	replaceCurrBlock trueStartBlock;
	let fst_tail_call = compileExpression(e2, resultReg, locEnv, tailpos) in
	if not fst_tail_call then knownjump mergeBlock;

	replaceCurrBlock falseStartBlock;
	let snd_tail_call = compileExpression(e3, resultReg, locEnv, tailpos) in
	if not snd_tail_call then fallthru mergeBlock;

	replaceCurrBlock mergeBlock;
	fst_tail_call & snd_tail_call
    
    | Assign (e1, e2) -> (* FMS : resultReg def'd and used.... *)
        (* Only handles cases allowed by poptype.check_valid_lhs *)
	(match e1.raw_exp with
    	| Var v -> 
	    let regOut = newReg1 () in
	    doBasicSubexp(e2, regOut);
	    let g = varToGenop locEnv v in
	    (match g with
	      Reg  _ -> emit (move g regOut) 
	    | Addr _ -> emit (move subexp1 g);
		        emit (move (prjr subexp1r i32_0) regOut)
	    | _      -> impossible());
	    emit (move resultReg regOut)
	| StructMember (stExp, fn) ->
	    let (offset, co) = structMemberLhs(stExp, fn, subexp1) in
	    doBasicSubexp(e2, subexp2);
	    emit (move (prjrCoerce subexp1r offset [co]) subexp2);
	    emit (move resultReg subexp2)
	| Subscript (arrExp, indExp) ->
	    let scale = 
	      match deopt arrExp.exp_typ with
		StringType -> i32_1
	      |	_          -> i32_4 in
	    doBasicSubexp(arrExp, subexp1);
	    doBasicSubexp(indExp, subexp3);
	    doBasicSubexp(e2,     subexp2);
	    emit (Unpack (arraySizeVar, subexp1r, (subexp1,[])));
	    emit (Aupd (prjr subexp1r i32_4, scale, subexp3r, subexp2r,
			prjr subexp1r i32_0));
	    emit (move resultReg subexp2)
    	| _ -> impossible());
	false
    | AssignOp(e1, p, e2) -> (* FMS: resultReg def'd and used. *)
	(* Only handles cases allowed by poptype.check_valid_lhs *)
	(match e1.raw_exp with
    	| Var v -> 
	    let g = varToGenop locEnv v in
	    (match g with
	      Reg  _ -> doBinOp (p, g, e2);
            	        emit (move resultReg g)
	    | Addr _ -> emit (move subexp1 g);
		        emit (move resultReg (prjr subexp1r i32_0));
		        doBinOp (p, resultReg, e2);
		        emit (move (prjr subexp1r i32_0) resultReg)
	    | _      -> impossible())
    	| StructMember (stExp, fn) ->
	    let (offset, co) = structMemberLhs(stExp, fn, subexp1) in
	    emit (move subexp2 (prjrCoerce subexp1r offset [co]));
	    doBinOp (p, subexp2, e2);
	    emit (move (prjrCoerce subexp1r offset [co]) subexp2);
	    emit (move resultReg subexp2)
    	| Subscript (arrExp, indExp) -> 
	    let scale = 
	      match deopt arrExp.exp_typ with
		StringType -> i32_1
	      |	_          -> i32_4 in
	    doBasicSubexp(arrExp, subexp1);
	    doBasicSubexp(indExp, subexp2);
	    emit (Unpack (arraySizeVar, subexp1r, (subexp1,[])));
	    emit (Asub (resultRegr, prjr subexp1r i32_4, scale, subexp2r,
			prjr subexp1r i32_0));
	    doBinOp(p, resultReg, e2);
	    emit (Aupd (prjr subexp1r i32_4, scale, subexp3r, resultRegr,
			prjr subexp1r i32_0))
	| _ -> impossible());
	false
    | FunCall(fexp,typeArgs,arglist) -> 
      (* Messy b/c of escaping and tail-call elim *)
      (* Assumes non-var must be escaping! *)
	let typeArgs = deopt !typeArgs in
	let conArgs = List.map (fun x -> Tapp x) (typeCons typeArgs) in
	let (f, fid, escapes, callLoc, retReg) = 
	  let doEscaping () = 
	    let f = "fnptr" in 
	    doBasicSubexp(fexp, subexp1);
	    (f, varToLab f, true, subexp1, Eax) in
	  (match fexp.raw_exp with 
	    Var f -> 
	      let fid = varToLab f in
	      if varLocal locEnv f
	      then doEscaping()
	      else (f, fid, funEscapes f, Addr fid, funRetReg f)
	  | _    -> doEscaping()) in
	let returns = match (deopt fexp.exp_typ) with
	               FnType (_, VoidType, _) -> false
	             | FnType (_, _, _)        -> true 
	             | _                       -> impossible() in

	List.fold_left 
	  (fun i exp -> doBasicSubexp(exp, Reg (paramReg1 f i)); i+1) 1 arglist;

	let isSelfCall     = (id_compare funLabel fid = 0)            in
	let isTailCall     = !doTailcallElim & 
	                     tailpos & (not escapes or isSelfCall)    in
	let callInst       = if isTailCall 
	                     then fun x -> Jmp x else fun x -> Call x in
	let callCoercion   = if isTailCall
	                     then callerStackCvar else funCallCoercion in

        (* For register allocator *)
	let callstartInst  = Xarray.length !currentIvec in
	emit(Comment "callstart"); 
	let callstartBlock = !currentBlock in
	let coercion = List.rev ((Tapp callCoercion) :: conArgs) in
	
	if escapes 
	then 
	  (let passArg = 
	    (if isTailCall (* bang stack frame -- messes up reg alloc? *)
	                    (* okay to bang because already in regs *)
	    then fun i -> move (prjr Esp (int_to_int32 (4*i))) 
		(Reg (paramReg1 f i))
	    else fun i -> Push (Reg (paramReg1 f i), [])) in
	  (List.fold_right
	    (fun e i -> emit (passArg i); i-1) arglist (List.length arglist));
	  ());
	  
	emit (callInst (callLoc, coercion));
	        
	let callBlock = !currentBlock              in 
	let retBlock  = createSeqBlock "afterCall" in
	replaceCurrBlock retBlock;

	if isTailCall
	then 
	  let edgeType = if isSelfCall then SelfTailCall else TailCall in
	  let calleeBlock  = get_block cfg fid in
	  (add_edge_bb cfg callBlock edgeType calleeBlock;
	   if not isSelfCall then addTailCallee f)
	else
	  (if escapes
	    then
	    (let l = List.length arglist in
	     if (l > 0)
	     then  emit(ArithBin(Add, Reg Esp, Immed (int_to_int32 (4*l))));
	     
	    add_edge_bb cfg callBlock 
	      (UnknownCall (typeCon (deopt fexp.exp_typ)))
	      retBlock)
	    
	    else 
	    (let calleeBlock  = get_block cfg fid in
  	    add_edge_bb cfg callBlock CallEdge calleeBlock;
	    add_edge_bb cfg callBlock   
	      (CallSequence (Set.singleton compare_regs (funRetReg f)))
	      retBlock;
	    addReturnee (retBlock, f)));
	   
	emit (Comment "callend"); (* For register allocator *)
        add_call_site callstartBlock callstartInst !currentBlock;

	if returns
	then emit(move resultReg (Reg retReg));
	
	isTailCall

    | NewStruct (tn, _, el) -> (* subexpr1 has long lifetime *)
	let st = findStruct env tn in
	let subexp1 = newRegInf () in
	let subexp1r = dereg subexp1 in
	emit (Malloc ((int_to_int32 (4*(List.length el))), st.mallocarg));
	emit (move subexp1 (Reg Eax));
	List.fold_left2
	  (fun i e lt ->
	    let r = newReg1() in
	    compileExpression
	      (e, r, addTempToMap locEnv subexp1r lt, false);
	    emit (move (prjr subexp1r (int_to_int32 (4*i))) r);
	    i+1)
	  0 el st.initTypes;
	let coercion =
	  let con = typeCon typ in
	  (* Before FMS: let con = clab st.s_name in *)
	  [if st.s_possibly_null then RollTosum con else Roll con]
	in
  	emit (moveCoerce resultReg subexp1 coercion);
	killReg(subexp1);
	false
    | StructMember(e, fn) -> (* FMS: structMemberLhs defs/uses subexp1 *)
	let (offset, co) = structMemberLhs(e, fn, subexp1) in
	emit (move resultReg (prjrCoerce subexp1r offset [co]));
	false
    | NewUnion(tn, _, fn, eopt) -> (* FMS: subexp2 has 3 uses. *)
	let un = findUnion env tn in
	let coercion = [RollTosum (typeCon typ)] in
	(match eopt with
	  None   ->
	    let tag = Dict.lookup un.void_fields fn in
	    emit(moveCoerce resultReg (Immed tag) coercion)
	| Some e ->
	    let (tag,_,_,mallocarg) = Dict.lookup un.value_fields fn in
	    let subexp2 = newRegInf () in (* FMS: experiment *)
	    let subexp2r = dereg subexp2 in
	    doBasicSubexp(e, subexp1);
	    emit(Malloc(i32_8, mallocarg));
	    emit(move subexp2 (Reg Eax));
	    emit(move (prjr subexp2r i32_4) subexp1);
	    emit(move (prjr subexp2r i32_0) (Immed tag));
	    emit(moveCoerce resultReg subexp2 coercion);
	    killReg(subexp2));	    
	false
    | NewTuple el -> (* similar to ConstArray *)
	(* FMS : subexp1 has long lifetime. *)
	let len = List.length el in
  	let tl  = List.map (fun e -> typeCon (deopt e.exp_typ)) el in

	let mallocarg = malloc_prod tl in
	let subexp1 = newRegInf () in (* FMS : experiment *)
	let subexp1r = dereg subexp1 in
	emit (Malloc (int_to_int32 (4*len), mallocarg));
	emit (move subexp1 (Reg Eax));
	List.fold_left
	  (fun i te ->
	    let nr = newReg1() in
	    compileExpression
	      (te, nr,
	       addTempToMap locEnv subexp1r
		 (lazy
		    (cprod (fst (List.fold_right
				   (fun c (l,j) ->
				     let s = if j < i then Read else Uninit in
				     ((cfield c s)::l, j-1))
				   tl
				   ([],len-1))))),
	       false);
	    emit (move (prjr subexp1r (int_to_int32 (4*i))) nr);
	    i+1)
	  0 el;
	emit (move resultReg subexp1);
	killReg(subexp1);
	false
    | TupleMember(e, i) -> 
	doBasicSubexp(e, subexp1);
	emit (move resultReg (prjr subexp1r (int_to_int32 (4*(i-1)))));
	false
    | Subscript(arrExp, indExp) -> 
	let scale = 
	  match deopt arrExp.exp_typ with
	    StringType -> i32_1
	  | _          -> i32_4 in
 	doBasicSubexp(arrExp, subexp1);
	doBasicSubexp(indExp, subexp2);
	emit (Unpack (arraySizeVar, subexp1r, (subexp1,[])));
	emit (Asub (resultRegr, prjr subexp1r i32_4, scale, subexp2r,
		    prjr subexp1r i32_0));
	false
    | NewArray(e1, e2) -> (* newarray is part of the runtime *)
	doBasicSubexp(e1, subexp1);
	doBasicSubexp(e2, subexp2);

	let eltType       = deopt e2.exp_typ            in
	let callee        = Addr (varToLab "new_array") in
	let c             = typeCon eltType             in
	let callstartInst = Xarray.length !currentIvec  in

	emit (Comment "callstart");
	emit (Push (subexp2, []));
	emit (Push (subexp1, [])); 
	emit (Call (callee, [Tapp c; Tapp funCallCoercion]));

	let afterBlock  = createSeqBlock "afterNewArray" in
 	add_call_site   !currentBlock callstartInst               afterBlock;
	add_edge_bb cfg !currentBlock (UnknownCall new_array_con) afterBlock;
	replaceCurrBlock afterBlock;

	emit (ArithBin(Add, Reg Esp, Immed i32_8));
	emit (Comment "callend");
	emit (move resultReg (Reg Eax));
	false
(* Cyclone *)
    | Codegen f -> failwith "unfinished code gen"
    | Fill e -> failwith "unfinished code gen"
(* End Cyclone *)
    | Raise _   -> failwith "unfinished code gen"
    | NewExn _  -> failwith "unfinished code gen"

  (*** compileTest -- more efficient than using compileExpression ***)
  and compileTest(exp, locEnv, trueBlk, falseBlk, falseSeq) =
    let r1 = newReg1() in
    let r2 = newReg1() in
    let seqBlock = if falseSeq then falseBlk else trueBlk in
    let seqEdge  = match seqBlock.con with None -> sequence
                                         | _    -> fallthru
    in
    match exp.raw_exp with
      Const(Bool true)  -> 
	if falseSeq then knownjump trueBlk else seqEdge trueBlk
    | Const(Bool false) -> 
	if falseSeq then seqEdge falseBlk  else knownjump falseBlk 
    | Var v             -> 
	let g = varToGenop locEnv v in
	(match g with
	  Addr _ -> 
	    let r1' = newReg1 () in (* FMS : experiment *)
	    emit (move r1' g);
	    emit (move r1 (prjr (dereg r1') i32_0));
	| Reg  _ -> emit (move r1 g)
	| _ -> impossible());
	if falseSeq 
	then (btagi (dereg r1) i32_1 Eq trueBlk;  seqEdge falseBlk)
	else (btagi (dereg r1) i32_0 Eq falseBlk; seqEdge trueBlk)
    | Primop(p, el) ->
	(match p with
	  Popsyntax.Not -> 
	    compileTest(List.hd el, locEnv, falseBlk, trueBlk, falseSeq)
	| (Popsyntax.Eq | Neq | Gt | Lt | Gte | Lte)  -> 
	    let cond = convertCondition p in	    
	    compileExpression(List.hd el,          r1, locEnv, false);
	    compileExpression(List.hd(List.tl el), r2, locEnv, false);
	    emit (Cmp (r1, r2));
	    if falseSeq
	    then (jcc cond                    trueBlk; seqEdge falseBlk)
	    else (jcc (negateCondition cond) falseBlk; seqEdge trueBlk)
	| _ -> impossible())
		(* With perfect jump-threading, the and,or special-cases are
		   technically unnecessary, but they are the common cases *)
    | Conditional(and1, and2, {raw_exp = Const(Bool false)}) ->
	let sndBlk = createSeqBlock "andTest" in
	(match falseBlk.con with (* We make two incoming edges *)
	  None -> typeBlock locEnv falseBlk
	| _    -> ());
	compileTest(and1, locEnv, sndBlk,  falseBlk, false);
	replaceCurrBlock sndBlk;
	compileTest(and2, locEnv, trueBlk, falseBlk, falseSeq);
    | Conditional(or1,  {raw_exp = Const(Bool true)}, or2)  ->
	let sndBlk = createSeqBlock "orTest" in
	(match trueBlk.con with (* We make two incoming edges *)
	  None -> typeBlock locEnv trueBlk
	| _    -> ());
	compileTest(or1, locEnv, trueBlk, sndBlk, true);
	replaceCurrBlock sndBlk;
	compileTest(or2, locEnv, trueBlk, falseBlk, falseSeq);
(*    | Conditional(tst, iftrue, iffalse) -> *)
    | _ -> 
	compileExpression(exp, r1, locEnv, false);
	if falseSeq
	then (btagi (dereg r1) i32_1 Eq trueBlk;  seqEdge falseBlk)
	else (btagi (dereg r1) i32_0 Eq falseBlk; seqEdge trueBlk)
  in
  (*** compileStatement ***) 
  let rec compileStatement (stmt, locEnv, tailpos) =
    
    (*** Helpers for compileStatement ***)
    let doBasicSubstmt s = compileStatement(s, locEnv, false) in
    let doExpression e r = compileExpression(e,r,locEnv,tailpos); r in 
 
    (*** Main match for compileStatement ***)
    match (fst stmt) with
      Skip  -> synth_none
    | Exp e ->  
	let tail_call = compileExpression(e, newReg0(), locEnv, tailpos) in
	if tail_call & tailpos
	then synth_returns
	else synth_none
    | Seq (s1, s2) ->
	let synth1 = 
	  match fst s2 with  (* tail call elim, assuming sane parser *)
	    Popsyntax.Return(None) -> compileStatement(s1, locEnv, true)
	  | _                      -> doBasicSubstmt s1 in
	if synth1.must_exit (* then s2 is dead code *)
	then synth1 
	else (let synth2 = doBasicSubstmt s2 in
	{ must_exit    = synth2.must_exit;
	  may_break    = synth1.may_break    or synth2.may_break;
	  may_continue = synth1.may_continue or synth2.may_continue
	} )

    | Popsyntax.Return (Some e) -> 
	let r = newReg1() in 
	let tail_call = compileExpression(e, r, locEnv, true) in
	if not tail_call
	then (emit (move (Reg (funRetReg funId)) r);
	      emit (Retn None);
	      addReturner !currentBlock)
	else killReg r; (* FMS : experiment. *)
	synth_returns
    | Popsyntax.Return (None) -> 
	emit (Retn None);
	addReturner !currentBlock;
	synth_returns
    | IfThenElse(e, st, sf) -> 
	let trueStartBlock  = createSeqBlock     "ifTrue"  in
	let falseStartBlock = createBlock locEnv "ifFalse" in
	let mergeBlock      = createSeqBlock     "ifMerge" in

	compileTest(e, locEnv, trueStartBlock, falseStartBlock, false);

	replaceCurrBlock falseStartBlock;
	let sndretn = compileStatement (sf, locEnv, tailpos) in
	if not sndretn.must_exit
	then fallthru mergeBlock;
	let falseEndBlock = !currentBlock in

	replaceCurrBlock trueStartBlock;
	let fstretn = compileStatement (st, locEnv, tailpos) in
	if fstretn.must_exit 
	then 
	  (if not sndretn.must_exit 
	  then
	    (let arr = falseEndBlock.code in (* Nuke fallthru -- an UGLY hack *)
	    Array.set arr ((Array.length arr) - 1) Nop))
	else
	  (if sndretn.must_exit
	  then sequence mergeBlock
	  else (knownjump mergeBlock;
	   	typeBlock locEnv mergeBlock));
	
	replaceCurrBlock mergeBlock;	    
	synth_merge fstretn sndretn

    | While (e, s) ->
	let testStartBlock   = createBlock locEnv "whileTest"  in
	let bodyStartBlock   = createBlock locEnv "whileBody"  in
	let afterBlock       = createSeqBlock     "whileAfter" in

	knownjump testStartBlock;

	replaceCurrBlock bodyStartBlock;
	let bodyretn =
	  compileStatement(s, newLoopEnv locEnv afterBlock testStartBlock, 
			   false) in
	if not bodyretn.must_exit then fallthru testStartBlock;
	if bodyretn.may_break     then typeBlock locEnv afterBlock;

	replaceCurrBlock testStartBlock;
	compileTest(e, locEnv, bodyStartBlock, afterBlock, true);

	replaceCurrBlock afterBlock;
	synth_none 

    | Break    -> knownjump (getBreakBlock    locEnv); synth_breaks
    | Continue -> knownjump (getContinueBlock locEnv); synth_continues
    | For (e1, e2, e3, s) ->
	doExpression e1 (newReg0 ());
	let testStartBlock = createBlock locEnv "forTest" in
	let bodyStartBlock = createBlock locEnv "forBody" in
	let nextStartBlock = createSeqBlock     "forNext" in
	let afterBlock     = createSeqBlock     "forAfter" in
	
	knownjump testStartBlock;

	replaceCurrBlock bodyStartBlock;
	let bodyretn = 
	  compileStatement(s, newLoopEnv locEnv afterBlock nextStartBlock,
			   false) in
	if bodyretn.may_continue
	then 
	  (typeBlock locEnv nextStartBlock;
	   fallthru nextStartBlock;
	   replaceCurrBlock nextStartBlock)
	else
	  del_block cfg nextStartBlock.lab;
	doExpression e3 (newReg0 ());
	fallthru testStartBlock;

	if bodyretn.may_break then typeBlock locEnv afterBlock;

	replaceCurrBlock testStartBlock;
	compileTest(e2, locEnv, bodyStartBlock, afterBlock, true);
	
	replaceCurrBlock afterBlock;
	synth_none 

    | IntSwitch(e, intStmtList, defaultstmt) -> (* cascading ifs for now *)
	let reg = newRegInf () in
       	let r = dereg (doExpression e reg) in
	let afterBlock = createBlock locEnv "afterSwitch" in

	let allretn = 
	  List.fold_left
	    (fun allretn (i,s) ->
	      let caseBlock      = createSeqBlock     "case" in
	      let bodyStartBlock = createBlock locEnv "body" in
	      
	      emit (Cmp (Reg r, Immed i));
	      emit (Jcc (Eq, (bodyStartBlock.lab, jumpCoercion)));
	      add_edge_bb cfg !currentBlock Branch bodyStartBlock;
	      sequence caseBlock;

	      replaceCurrBlock bodyStartBlock;
	      killReg(reg); (* FMS: I think it should go here? *)
	      let bodyretn = compileStatement(s, locEnv, tailpos) in 
	      if not bodyretn.must_exit
	      then knownjump afterBlock;

	      replaceCurrBlock caseBlock;
	      synth_merge allretn bodyretn)
	    synth_returns
	    intStmtList in
	
	let defaultretn = compileStatement(defaultstmt, locEnv, tailpos) in 
	if not defaultretn.must_exit
	then fallthru afterBlock;

	replaceCurrBlock afterBlock;
	synth_merge allretn defaultretn
    | CharSwitch (e, cslist, s) -> (*Done as ints, Const Char case changed too*)
	doBasicSubstmt
	  (IntSwitch(e, List.map(fun(c,s) -> (int_to_int32 (Char.code c),s)) 
		       cslist, s),
	   snd stmt)
    | UnionSwitch (e, switchList, stmtopt) -> 
       	let r    = dereg (doExpression e (newReg1 ())) in
	let topt = e.exp_typ in
	let un   = findUnion env (fst (getNamedType (deopt topt))) in
	let (void_cases, value_cases) =
	  List.fold_right
	    (fun (fn, varopt, s) (voids, values) ->
	      if (Dict.member un.void_fields fn)
	      then ((Dict.lookup un.void_fields fn, varopt, s)::voids, values)
	      else (voids, (Dict.lookup un.value_fields fn, varopt, s)::values))
	    switchList ([],[]) in
	let void_cases = 
	  Sort.list (fun (tag1,_,_) (tag2,_,_)->(tag1 >$ tag2)) 
	    void_cases in
	let value_cases =
	  Sort.list (fun ((tag1,_,_,_),_,_)((tag2,_,_,_),_,_)->(tag1 >$ tag2))
	    value_cases in
	let voids_exhaust  = List.length void_cases  = un.num_void_fields  in 
	let values_exhaust = List.length value_cases = un.num_value_fields in 

	let afterBlock   = createBlock locEnv "afterSwitch"  in
	let defaultBlock = 
	  if voids_exhaust 
	  then createSeqBlock     "defaultSwitch"
	  else createBlock locEnv "defaultSwitch"            in

	let run  = newRegInf() in 
	let runr = dereg run in 
	emit(moveCoerce run (Reg r) [Unroll]);

	let voidsretn =
	  if List.length void_cases = 0
	  then synth_returns
	  else
	    let doOneVoid (tag, _, s) brancher =
	      let caseBlock      = createSeqBlock     "case" in
	      let bodyStartBlock = createBlock locEnv "body" in
	      
	      brancher tag bodyStartBlock;
	      sequence caseBlock;

	      replaceCurrBlock bodyStartBlock;
	      killReg(run); (* FMS: Added for experiment. ??? *)
	      let bodyretn = compileStatement(s, locEnv, tailpos) in 
	      if not bodyretn.must_exit
	      then knownjump afterBlock;
	      
	      replaceCurrBlock caseBlock;
	      bodyretn in
	    let voidsretn = 
	      List.fold_left
	      	(fun voidsretn case ->
		  synth_merge voidsretn 
		    (doOneVoid case (fun tag dest -> btagi runr tag Eq dest)))
	      	synth_returns 
	      	(if voids_exhaust then (List.tl void_cases) else void_cases) in
	    if voids_exhaust 
	    then synth_merge voidsretn 
	      	(doOneVoid (List.hd void_cases) 
		 (if (List.length value_cases = 0)
		 then
		   (fun tag dest -> knownjump dest)
		 else
		   (fun tag dest -> btagi runr tag Eq dest)))
	    else voidsretn in

	if not voids_exhaust
	then 
	  (let caseBlock = createSeqBlock "case" in
	  btagi runr (int_to_int32 un.num_void_fields) Below defaultBlock;
	  sequence caseBlock;
	  replaceCurrBlock caseBlock);

     	let valuesretn =
	  if List.length value_cases = 0
	  then synth_returns
	  else
	    (let btagvar tag dest =
	      emit (Btagvar(runr, i32_0, tag, (dest.lab, jumpCoercion), Eq));
	      add_edge Branch dest                in
	    let jumpvar tag dest = knownjump dest in
	    let doOneValue((tag, lsumcon, lcon, _), varopt, s) brancher =
	      let bodyEnv = 
	      	match varopt with
		  None   -> locEnv
	      	| Some _ -> addTempToMap locEnv runr lsumcon  in
	      
	      let caseBlock      = createSeqBlock      "case" in
	      let bodyStartBlock = createBlock bodyEnv "body" in

	      brancher tag bodyStartBlock;
	      sequence caseBlock;
	    
	      let valReg = newRegInf() in
	      replaceCurrBlock bodyStartBlock;
	      emit(move valReg (prjrCoerce runr i32_4 [Fromsum]));
	      killReg(run); (* FMS: Experiment ??? *)
	      let bodyretn = 
	      	compileStatement
		  (s, addToMap locEnv (deopt varopt) (dereg valReg) lcon, 
		   tailpos) in
	      killReg(valReg); (* FMS: Experiment ??? *)
	      if not bodyretn.must_exit
	      then knownjump afterBlock;

	      replaceCurrBlock caseBlock;
	      bodyretn in
	    let valuesretn = List.fold_left
	      	(fun valuesretn case ->
	      	  synth_merge valuesretn (doOneValue case btagvar))
	      	synth_returns
	      	(if values_exhaust 
		then (List.tl value_cases) 
		else value_cases) in
	    if values_exhaust
	    then synth_merge valuesretn 
		(doOneValue (List.hd value_cases) jumpvar)
	    else valuesretn) in

	let defaultretn =
	  (match stmtopt with
	    None   -> synth_returns
	  | Some ds -> 
	      ((if not values_exhaust
	      then 
		(if voids_exhaust
		then sequence defaultBlock
		else fallthru defaultBlock));
	       replaceCurrBlock defaultBlock;
	       killReg(run); (* FMS: experiment ??? *)
	       let retn = compileStatement(ds, locEnv, tailpos) in
	       if not retn.must_exit
	       then fallthru afterBlock;
	       retn)) in
	
	replaceCurrBlock afterBlock;
	synth_merge voidsretn (synth_merge valuesretn defaultretn)

    | Decl (v, t, eoptionRef , s) -> 
	let reg = newRegInf () in
	let r = dereg (doExpression (deopt !eoptionRef) reg) in
	let temp = compileStatement(s, 
				    addToMap locEnv v r (lazy (typeCon t)),
				    tailpos) in
	killReg(reg); 
	temp
(* Cyclone *)
    | Cut s -> failwith "unfinished code gen"
    | Splice s -> failwith "unfinished code gen"
(* Cyclone *)
    | Do (s, e) -> 
	let bodyStartBlock = createBlock locEnv "doBody"  in
	let testStartBlock = createSeqBlock     "doTest"  in
	let afterBlock     = createSeqBlock     "doAfter" in

	fallthru bodyStartBlock;
	replaceCurrBlock bodyStartBlock;
	let bodyretn = 
	  compileStatement(s, 
			   newLoopEnv locEnv afterBlock testStartBlock,
			   false) in
	if bodyretn.may_continue 
	then (typeBlock locEnv testStartBlock; 
	      fallthru testStartBlock; 
	      replaceCurrBlock testStartBlock)
	else del_block cfg testStartBlock.lab;
	
	if bodyretn.may_break
	then typeBlock locEnv afterBlock;

	compileTest(e, locEnv, bodyStartBlock, afterBlock, true);

	replaceCurrBlock afterBlock;
	synth_none (* Conservative eg. do return; while x *)
    | Try _ -> failwith "unfinished code gen"
  in
  (*** initialization ***)
  let escapes = funEscapes funId in
  let retaddReg = newReg() in
  let declList' = List.map (fun (var,tau) -> (newRegInf(),var,tau)) declList in
  let locEnv    = snd (List.fold_left 
			 (fun (n, partialLocEnv) (r,var, tau) -> 
			   (if escapes
			   then emit (move r (prjr Esp (int_to_int32 (n*4))))
			   else emit (move r (Reg (paramReg1 funId n))));
			   (n+1,  
			    addToMap partialLocEnv var (dereg r)
			      (lazy (typeCon tau))))
			 (1, emptyLocalEnv)
			 declList') in 
  let bodysynth = compileStatement(ts, locEnv, false) in
  List.iter (fun (r,_,_) -> killReg(r)) declList'; (* FMS: Added declList' *)
  if not bodysynth.must_exit
  then emit (Retn None)
  else ();
  replaceCurrBlock dummyBlock;
  (!returnees, !returners, !tailCallees)

(*** Preprocess, postprocess, and entry point ***)
let initProcBlock cfg decl = 
  let funId    = decl.fn_name     in
  let funLabel = varToLab funId   in
  let typeVars = decl.fn_tyvars   in
  let retTau   = decl.fn_ret_type in
  let args     = decl.fn_args     in
  let escapes  = funEscapes funId in

  let inputArgs = 
    if escapes
    then rs_empty 
    else 
      fst (List.fold_left
	     (fun (regState, n) (id, tau) -> 
	       (rs_set_reg regState 
		  (paramReg1 funId n) (typeCon tau),
	    	n+1))
	     (rs_empty, 1)
	     args) in
  let stackVals =
    if escapes
    then List.map (fun arg -> typeCon (snd arg)) args
    else [] in

  let ls = 
    labelState typeVars (funRetReg funId) retTau inputArgs stackVals in
  add_block cfg (make_block funLabel (Some ls) funLabel (Array.create 1 Nop));
  add_proc cfg funLabel;
  (if escapes 
  then add_root cfg funLabel
  else 
    let rec addArgs n = 
      if (n > List.length args) then ()
      else (add_arg cfg funLabel (paramReg1 funId n); 
            (addArgs (n+1)))
    in 
    addArgs 1);
  match retTau with
    VoidType -> ()
  | _        -> add_ret cfg funLabel (funRetReg funId)
    
let compileToCode env topFuns =
  let cfg = empty_cfg () in
  (* Add all procs to the cfg *)
  List.iter (fun f -> initProcBlock cfg f) topFuns;  
  (* Do code generation and build return lists *)
  if !debug then print_string "started compileFun\n";
  let retlists =
    Dict.inserts (Dict.empty compare)
    (List.map (fun f -> (f.fn_name, compileFun (cfg, env, f))) topFuns) in
  if !debug then print_string "finished compileFun\n";
  (* Add return edges *) 
  (* Complicated severely by tail calls -- CLEAN THIS UP! *)
  let (allReturnees, returnerDict) =
    Dict.fold_dict
      (fun f (retees, reters, tailCallees) (allReturnees, returnerDict) ->
	let includeTailCalls = 
	  let rec aux moreRetees funsLeft funsUsed =
	    match funsLeft with
	      []     -> moreRetees
	    | h::t -> 
	      	if not (Dict.member funsUsed h)
	      	then 
		  let (_, newReters, newTailCallees) = Dict.lookup retlists h in
	      	  aux (newReters@moreRetees) 
		    (newTailCallees@t)
		    (Dict.insert funsUsed h ())
	      	else
		  aux moreRetees t funsUsed in
	  aux [] tailCallees (Dict.insert (Dict.empty compare) f ()) in
	(retees @ allReturnees, 
	 Dict.insert returnerDict f (reters@includeTailCalls)))
      retlists 
      ([], Dict.empty compare) in
  List.iter     
    (fun (blk, id) ->
      List.iter 
	(fun retblk -> 
(*	  if !debug then print_string ((id_to_string retblk.lab) ^ "-->" ^ 
				      (id_to_string blk.lab) ^ "\n"); *)
	  add_edge_bb cfg retblk Cfg.Return blk)
        (if (Dict.member returnerDict id) (* imports won't be in there *)
      	then Dict.lookup returnerDict id
	else []))
    allReturnees;
  if !debug then print_string "finished ret edges\n";
  cfg                
       
let compileType env topType = 
  let computeKind typeVars =
    List.fold_right (fun t k -> Karrow(k4byte,k)) typeVars k4byte in
  let abstractCon typeVars baseCon =
    List.fold_right (fun v -> clam (typeVarToLab v) k4byte) typeVars baseCon in
  match topType with
    StructDecl sd ->
      let cg_sd = findStruct env sd.st_name in
      let typeVars = sd.st_tyvars in
      let baseCon = 
	if cg_sd.s_possibly_null then (chptr [i32_0] (Some cg_sd.fieldcons))
      	else (cptr  cg_sd.fieldcons) in
      (sd.st_scope, (cg_sd.s_name, computeKind typeVars, 
		     Some (abstractCon typeVars baseCon)))
  | UnionDecl u -> 
      let cg_un = findUnion env u.un_name in
      let typeVars = u.un_tyvars in      
      (u.un_scope, (cg_un.u_name, computeKind typeVars, 
		    Some (abstractCon typeVars cg_un.talcon)))
  | ExternType(tn, typeVars, false) ->
      (Extern, (typeToLab tn, computeKind typeVars, None))
  | _ -> print_string "nullable, abstract type"; failwith "unfinished code gen"

let compileGlobalVars env globalList =
  let compileGlobal dataBlocks (scope, name, typ, eoptref) =
    
    let return con data blocks = (* For now, not using inference *)
      let lab = id_new name in
      (((lab, Some con, data)::blocks), con, Dlabel(lab,[])) in
      
    let rec compileData e =
      match e.raw_exp with
	Const(Popsyntax.Int  i) ->
	  ([], intCon,  D4bytes(i,[Subsume cbyte4]))
      | Const(Char c)->
	  ([], charCon, D4bytes (int_to_int32 (Char.code c),[Subsume cbyte4]))
      | Const(Bool b)->
	  ([], boolCon, D4bytes((if b then i32_1 else i32_0),[Tosum boolCon]))
      | Const(Null)  ->
	  let typ = deopt e.exp_typ in
	  let con = typeCon typ in ([], con, D4bytes(i32_0, [RollTosum con]))
      | Const(String s) -> ([], stringCon, Dlabel (add_string s,[])) 
      |	ConstArray(el,topt) ->
	  let t = typeCon 
	      (match topt with
	      	Some t -> t
	      | None   -> deopt ((List.hd el).exp_typ)) in
	  let len31 = List.length el in
	  let len = int_to_int32 len31 in
	  let (blocks, _, datas) = compileDataList el in
	  let thisData = (((D4bytes (len,[]))::(Dup)::datas),
 			  [(Pack (pcint len,arrayCon t));
			    (Toarray(i32_4,0,cfield t ReadWrite))]) in 
	  return (arrayCon t) thisData blocks
      |	NewStruct(tn, ts, el) ->
	  let st = findStruct env tn in
	  let (blocks, _, datas) = compileDataList el in
	  let con = typeCon (deopt e.exp_typ) (* nameCon st.s_name *) in
	  let coerce = if st.s_possibly_null then RollTosum con else Roll con in
	  return con (datas, [coerce]) blocks 
      |	NewUnion(tn,ts,fn,eopt) ->
	  let un = findUnion env tn   in
	  let con = typeCon (deopt e.exp_typ) (*nameCon un.u_name*) in
	  let coerce = RollTosum con in
	  (match eopt with
	    None   -> ([],con, D4bytes ((Dict.lookup un.void_fields fn), [coerce]))
	  | Some e ->
	      let (blocks, _, data) = compileData e in
	      let (tag,_,_,_) = Dict.lookup un.value_fields fn in
	      return con ([(D4bytes (tag,[])); data], [coerce]) blocks)
      |	NewTuple el ->
	  let (blocks, cons, datas) = compileDataList el in
	  let con = cprod_b (List.map (fun c -> (cfield c Read)) cons) in
	  return con (datas,[]) blocks 
      |	_ -> impossible()
    and compileDataList el =
      List.fold_right
	(fun elt (blocks, cons, datas) ->
	  let (subBlocks, con, data) = compileData elt in
	  ((subBlocks@blocks), (con::cons), (data::datas)))
 	el ([], [], []) in
    let (blocks, con, data) = compileData (deopt !eoptref) in
    (varToLab name, Some (cprod_b [cfield con ReadWrite]), ([data],[]))
    ::(blocks@dataBlocks)
  in  
  List.fold_left compileGlobal [] globalList
    
(* Convert environment *)
let popToCgUnion u = (* Does not special-case single value *)
  let (voids, values) =
    List.fold_right
      (fun (fn, t) (voids, values) ->
	match t with
	  VoidType -> (fn::voids, values)
	| _        -> (voids, (fn,typeCon t)::values))
      u.un_fields ([],[]) in
  let voids = if u.un_possibly_null then "$null"::voids else voids in
  let (void_fields, tags, num_tags) = 
    (List.fold_left
       (fun (dict, tags, i) fn -> (Dict.insert dict fn (int_to_int32 i), 
				   (int_to_int32 i)::tags, i+1))
       (Dict.empty compare, [], 0) voids) in
  let (value_fields, variants, num_variants) =
    List.fold_left
      (fun (dict,variants, i31) (fn, t) -> 
	let i = int_to_int32 i31 in
	let valType   = cprod [cfield (csing (pcint i)) Read; cfield t Read] in
	let valSumType= lazy (cptr (csum [valType]))                         in
	let mallocarg = malloc_prod [csing (pcint i); t]                     in
	(Dict.insert dict fn (i,valSumType,lazy t,mallocarg),
	 valType::variants, 
	 i31 + 1))
      (Dict.empty compare, [], 0) values in
  let sum = 
    match variants with
      [] -> chptr tags None
    | _  -> chptr tags (Some(csum variants)) in
  { u_name           = typeToLab u.un_name;
    u_possibly_null  = u.un_possibly_null;
    void_fields      = void_fields;
    value_fields     = value_fields;
    num_void_fields  = num_tags;
    num_value_fields = num_variants;
    talcon           = sum
  } 

let popToCgStruct sdecl = 
  let popcapToTalCap c =
    match c with 
      Popsyntax.ReadOnly  -> Tal.Read
    | Popsyntax.ReadWrite -> Tal.ReadWrite in

  let (prodlist, fieldcons, fieldnames) = 
    List.fold_right
      (fun (id,c,tau) (prodlist, fieldcons, fieldnames) ->
	let t = typeCon tau in
	(t::prodlist, (cfield t (popcapToTalCap c))::fieldcons, id::fieldnames))
      sdecl.st_fields 
      ([], [], []) in
  let uninits = List.map (fun t -> cfield t Uninit) prodlist in
  let fieldoffsets =
    snd (List.fold_left
	   (fun (i, dict) fieldname -> (i +$ i32_1, 
				  Dict.insert dict fieldname (i32_4 *$ i)))
	   (i32_0, Dict.empty compare)
	   fieldnames)  in
  let mallocarg = malloc_prod prodlist in
      
  let makeLazyType i =
    (lazy
       (cprod(fst (List.fold_right2
		     (fun init uninit (l, j) -> 
		       (if (j < i) then init else uninit)::l, j + 1)
		     fieldcons uninits
		     ([], 0))))) in
  let initTypes = Utilities.flist makeLazyType (List.length fieldcons) in
    { s_name          = typeToLab sdecl.st_name;
      s_possibly_null = sdecl.st_possibly_null;
      fieldoffsets    = fieldoffsets;
      fieldcons       = cprod fieldcons;
      mallocarg       = mallocarg;
      initTypes       = initTypes
    } 

(* entry point *)
let code_gen moduleName importName exportName (decls, popenv) =
  try 
  let env = { cg_structs   = Dict.map_dict popToCgStruct popenv.structs;
	      cg_unions    = Dict.map_dict popToCgUnion  popenv.unions;
	      cg_abstracts = popenv.abstracts;
	      cg_globals   = popenv.globals
	    } in
  string_list := [];
  let (topfuns, topTypes, topExterns, globals) =
    List.fold_right 
      (fun (d,_) (fs, ts, xs, gs) -> match d with
	FunDecl    f           -> (f::fs, ts, xs, gs)
      |	StructDecl s           -> (fs, d::ts, xs, gs)
      |	UnionDecl  u           -> (fs, d::ts, xs, gs)
      |	ExternVal(v, t)        -> (fs, ts, (v,t)::xs, gs)
      |	GlobalDecl(s,v,t,eor)  -> (fs, ts, xs, (s,v,t,eor)::gs)
      |	ExternType _           -> (fs, d::ts, xs, gs)
      | ExceptionDecl _        -> failwith "unfinished code gen")
      decls ([], [], [], []) in

  let cfg                     = compileToCode env topfuns           in
  let globalBlocks            = compileGlobalVars env globals       in
  let strings                 = stringsToData()                     in
  let typeBlocks              = List.map (compileType env) topTypes in
  let (typIn, typCon, typOut) = 
    List.fold_right 
      (fun (scope, (id, kind, con)) (ti, tc, te) ->
	let intCon = 
	  match con with
	    None   -> AbsCon
	  | Some _ -> ConcCon (deopt con) in
	match scope with
	  Static   -> (ti, (id,kind,deopt con)::tc, te)
	| Public   -> (ti, (id,kind,deopt con)::tc, 
		       (id,kind,intCon)::te)
	| Extern   -> ((id,kind,intCon)::ti, tc, te)
  	| Abstract -> (ti, (id,kind,deopt con)::tc, (id,kind,AbsCon)::te))
      typeBlocks
      ([], [], []) in
  let valsIn  = 
    List.map 
      (fun (n,t) ->
 	let basecon = typeCon t in
	let con = 
	  match t with
	    FnType _ -> basecon
	  | _ -> cprod_b [cfield basecon ReadWrite] in	         
	(varToLab n, con))
      topExterns in
  let funOut = 
    List.map
      (fun f -> (varToLab f.fn_name,
		 typeCon 
		   (FnType(f.fn_tyvars, f.fn_ret_type,List.map snd f.fn_args))))
      (Utilities.filter (fun f -> f.fn_static) topfuns) in
  let globalsOut =
    List.map
      (fun (s,v,t,eor) -> 
	let con = typeCon t in
	(varToLab v, cprod_b [cfield con ReadWrite]))
      (Utilities.filter 
	 (fun (s,v,t,eor) -> match s with Public -> true | _ -> false)
	 globals) in
      
(*  CfgOptimize.jumpthread cfg; *)
(*  Cfg.app 
    (fun block -> 
      print_string ((id_to_string block.lab)^"\t");
      Set.app 
      	(fun (_,_,l) -> print_string (id_to_string l)) block.succ;
      print_string "\t";
      Set.app 
      	(fun (l,_,_) -> print_string (id_to_string l)) block.pred;
      print_newline ())
    cfg;*)
  let context = startctxt in
  let context =
    List.fold_left
      (fun ctxt (n,k,cc) -> Talctxt.add_con ctxt n k)
      context typIn in
  let context =
    List.fold_left
      (fun ctxt (n,k,c) -> Talctxt.add_con ctxt n k)
      context typCon in
  let context = 
    List.fold_left
      (fun ctxt (n,k,cc) ->
	let cc = 
	  match cc with
	    AbsCon    -> AbsCon
	  | ConcCon c -> ConcCon (snd (Talcon.check ctxt c)) 
	  | _         -> impossible() in
	Talctxt.add_con_def ctxt n cc)
      context typIn in
  let context =
    List.fold_left 
      (fun ctxt (n,k,c) -> 
	Talctxt.add_con_def ctxt n (ConcCon (snd (Talcon.check ctxt c))))
      context typCon in
  let context =
    List.fold_left
      (fun ctxt (f, c) -> 
	Talctxt.add_val ctxt f (Some(snd (Talcon.check ctxt c))))
      context ((new_array_label, new_array_con)::valsIn)  in
  let context = 
    let checkedStringCon = snd (Talcon.check context stringCon) in
    List.fold_left
      (fun ctxt (n, copt, _) -> Talctxt.add_val ctxt n (Some checkedStringCon))
      context strings in
  let context =
     List.fold_left
      (fun ctxt (n, copt, _) ->
	Talctxt.add_val ctxt n (Some(snd (Talcon.check ctxt (deopt copt)))))
      context globalBlocks in
  Cfgopt.remove_dead_blocks cfg;
  
  if !allocateregs
  then (* Move this context stuff to cfg at some point *)
    (set_context cfg context;
     regalloc cfg numRegisters;
     if !optimize then Cfgopt.peephole cfg)
  else
    (if !optimize then Cfgopt.peephole cfg
    else Cfgopt.remove_dead_types cfg);
(* Make this go away when interfaces can have abbrevs *)
(*  let typOut = 
    List.map
      (fun ((id,kind,intcon) as t) ->
	match intcon with
	  AbsCon    -> t
	| ConcCon c -> (* get checked version *) 
	    (id,kind, ConcCon (snd (Talcon.check context c)))
	| _ -> failwith "unfinished code gen")
      typOut in
  let typIn =
    List.map
      (fun ((id,kind,intcon) as t) ->
	match intcon with
	  AbsCon    -> t
	| ConcCon c -> (* get checked version *) 
	    (id,kind, ConcCon (snd (Talcon.check context c)))
	| _ -> failwith "unfinished code gen")
      typIn in
*)
(* End of hack b/c of no interface abbrevs *)

  let has_main  = hasFunction env "main" in
  (* Add tal_main if necessary *)
  if has_main  then 
    (add_block cfg (make_block tal_main_label (Some tal_main_con) tal_main_label
		      tal_main_code);
     add_proc cfg tal_main_label;
     add_root cfg tal_main_label);
  let abbrevs =  [|(arrayAbbrevVar,  arrayAbbrev); 
		   (stringAbbrevVar, stringAbbrev)|] in

  ({ imports      = [|"tal.tali"; "pop_runtime.tali";
		      importName |];
     exports      = if has_main 
                    then [|exportName; "tal_prog.tali"|] 
                    else [|exportName|];
     imp_abbrevs  = [||]; 
     con_blocks   = Array.of_list typCon;
     code_blocks  = cfg_to_code_blocks cfg;
     data_blocks  = Array.of_list (strings@globalBlocks)
(* Cyclone *)
       ;
     templates=[||]
(* End Cyclone *)
   },
   { int_abbrevs  = abbrevs;
     int_cons     = Array.of_list typIn;
     int_vals     = Array.of_list valsIn
   },
   { int_abbrevs  = abbrevs;
     int_cons     = Array.of_list typOut;
     int_vals     = Array.of_list (funOut @ globalsOut);
   })
  with
    Talctxt.Talverify (c,ve) -> 
      Talpp.print_Talverify Format.std_formatter Talpp.std_options (c,ve);
      failwith "regalloc failed"

(* EOF: popcompile.ml *)
