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

(* Does not support global variables. *)

(* Does not do abstract types at all.  Doing nullable ones in the old TAL
   is a pain, but doing non-nullable ones should be easy *)

(* 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
 *)

(* Remove this by doing it in optimizer:
   Nasty hack: Must not replace a block before it has an incoming edge 
   else it will be dead code and eliminated 
 *)

(* switch just does cascading ifs for now *)

(* 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. compileStatement
 *    d. initialization
 * 9. Preprocess, postprocess, and entry point
 ***)

let allocateregs = ref true
let optimize     = ref true

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

let debug = !debugr

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  ^ "$")

(*** Global environment access ***)
type cg_struct = { s_name:          identifier;
		   s_possibly_null: bool;
		   fieldoffsets:    (field_name, int) 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, int)          Dict.dict;
		   value_fields:     (field_name, 
				      int               (* 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, 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 findFunction env id = findInGlobalEnv env.cg_globals   id 
let hasFunction  env id = Dict.member     env.cg_globals   id

    (* hack for the moment to use print int *)
let funEscapes v = (not !noFunsEscape) &
                   (!allFunsEscape or (v = "new_array") or (v = "main"))
(* Level 0 coarseness -- every function uses stack
		     calling convention -- change to false for Steve debug *)
let funExpEscapes exp = (* Level 1 coarseness -- no flow analysiss *)
  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 *)
    }
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)
    }
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
   }
let addTempToMap locEnv r lt =
   {
     var_to_reg       = locEnv.var_to_reg;
     reg_to_type      = addRegType locEnv r lt;
     loopEnv          = locEnv.loopEnv
   }
let newLoopEnv locEnv brkBlock cntBlock =
  {
     var_to_reg       = locEnv.var_to_reg;
     reg_to_type      = locEnv.reg_to_type;
     loopEnv          = (brkBlock, cntBlock)
  }                               
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

(* 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 booleanCon  = chptr [0;1] None
let charCon     = intCon
let arrayCon c  = capp (cvar arrayAbbrevVar) c
let stringCon   = (*stringRealCon*)cvar stringAbbrevVar
let nameCon     = clab
let optCon c    = chptr [0] (Some (cfield c Read))

(*** 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 (*cprod_b [cfield stringCon ReadWrite]*) in
  List.map 
    (fun (l,s) -> 
      let len = String.length s in
      (l, Some con (*None*), 
       ([Dtag (len,[]); Dup; Dbytes s],
	[Pack (pcint len, stringCon); Toarray (4,0)])))
    !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)
let funRetReg s    = if funEscapes s then Eax else paramReg(s,0)

let move (dest, src)          = Mov(dest, (src, []))
let moveCoerce(dest, src, cl) = Mov(dest, (src, cl))

let rec realTypeCon useAbbrevs tau =
  let useAbbrevs = false in 
  match tau with
     IntType        -> intCon
   | BooleanType    -> booleanCon
   | VoidType       -> failwith "code_gen: VoidType encountered in typeCon"
   | StringType     -> if useAbbrevs then stringCon else stringRealCon
   | ArrayType c    -> if useAbbrevs then arrayCon (realTypeCon useAbbrevs c)
	               else arrayRealCon (realTypeCon useAbbrevs c)
   | FnType (t, tl) ->  (* assumes escaping -- else this wouldn't be called!! *)
       labelState Eax t rs_empty (List.map (realTypeCon useAbbrevs) tl)
   | NamedType s    -> clab (typeToLab s) 
   | CharType       -> charCon
   | TupleType ts   -> cprod_b 
	 (List.map (fun t -> cfield (realTypeCon useAbbrevs t) Read) ts)

(* Fix this to avoid calling stackValsCons twice *)
and stackValsCons stackVals = 
  List.fold_right
    (fun tau typeSoFar -> ccons tau typeSoFar)
    stackVals
    callerStackCvar
and retAddrType retReg retType stackVals =
  let returnRegisters = 
    match retType with
      VoidType -> rs_empty
    | _        -> rs_set_reg rs_empty retReg (realTypeCon true retType) in
  ccode (rs_set_reg returnRegisters Esp (csptr (stackValsCons stackVals)))
and onStack retReg retType stackVals =
  ccons (retAddrType retReg retType stackVals) (stackValsCons stackVals)
and labelState retReg retType currentRegs stackVals =
  cforall callerStackVar Kstack
    (ccode (rs_set_reg currentRegs 
	      Esp (csptr (onStack retReg retType stackVals))))

let typeCon = realTypeCon true

(*** 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 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 
	  (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 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
  
  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 knownjump toBlock =
    (emit (Jmp (Addr toBlock.lab, jumpCoercion));
     add_edge Jump toBlock)                        in
  
  let makeBlockType locEnv = 
    labelState (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 currBlockUnreachable () = 
    Set.is_empty (!currentBlock).pred 
      & not ((id_compare (!currentBlock).fun_lab (!currentBlock).lab) = 0)    in

  let replaceCurrBlock nextBlock =
    if currBlockUnreachable ()
    then del_block cfg !currentBlock.lab
    else (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 = newReg() in
      let lr = dereg leftReg  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 = 
	match deopt stExp.exp_typ with NamedType t -> t | _ -> impossible() 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, 0, (null_exn_label,  []), Eq));
	(offset, Fromsum))
      else
      	(offset, Unroll) in
    
    let subexp1    = newReg() in let subexp1r = dereg subexp1 in
    let subexp2    = newReg() in let subexp2r = dereg subexp2 in
    let subexp3    = newReg() in let subexp3r = dereg subexp3 in
    let resultRegr = dereg resultReg in

    (*** Main match for compileExpression ***)
    match exp with
      Const(Popsyntax.Int i) ->
	emit (move (resultReg, Immed i))
    | Const(Popsyntax.Char c) -> (* compile chars as ints *)
	emit (move (resultReg, Immed (Char.code c)))
    | Const(Bool b) ->
	emit (moveCoerce
		(resultReg, Tag(if b then 1 else 0), [Tosum booleanCon]))
    | Const(String s) -> 
	emit (move (resultReg, Addr (add_string s)))
    | Const(Null tn) -> 
	let c = clab (typeToLab tn) in
	emit (moveCoerce (resultReg, Tag 0, [RollTosum c]))
    | 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 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 makeLazyType i = 
	  (lazy
	     (cprod_b
	     	[ cfield size_con ReadWrite;
		  cprod 
		    ((Utilities.replicate initIndType (i-1)) @
		     (Utilities.replicate uninitIndType (len-i+1))) ])) in

	emit (Malloc (4*(len+1), mallocarg));           (* get memory *)
	emit (move (subexp1, Reg Eax));
	emit (move (Prjr ((subexp1r,[]),0), Tag len));  (* store length *)

	List.fold_left (* compute/store values *)
	  (fun i te ->
	    let nr = newReg() in
	    compileExpression(te, nr, 	                 (* compute one value *)
			      addTempToMap locEnv subexp1r (makeLazyType i),
			      false);
	    emit (move (Prjr ((subexp1r,[]), 4*i), nr)); (* store one value   *)
	    i+1)
	  1 el;

	emit (moveCoerce (resultReg, subexp1, [ Pack (pcint len, arrayCon t);
						Toarray(4,0)]))

    | Var v -> (* Does local vars and top-level functions only for now *)
	(try 
	  emit (move (resultReg, Reg (varToReg locEnv v)))
	with
	  Dict.Absent -> 
	    emit (move (resultReg, Addr (varToLab v))))
    | 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, Tag 0, [Tosum booleanCon]));
		emit (Cmp (subexp1, resultReg));
      		emit (Setcc(Eq, resultReg))
	    | Bitnot -> 
		emit (ArithUn (Tal.Not, subexp1));
	    	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,[]),0)));
		emit (Coerce (resultRegr, [Subsume cbyte4]))
	    |  _ -> impossible())
	| (Popsyntax.Eq | Neq | Gt | Lt | Gte | Lte) ->
	  let ic = match p with Popsyntax.Eq -> Eq
      	                               | Neq -> NotEq
				       | Gt  -> Greater
				       | Lt  -> Less
				       | Gte -> GreaterEq
				       | Lte -> LessEq 
				       | _   -> impossible() in
	  doBasicSubexp(List.hd el,           subexp1);
	  doBasicSubexp(List.hd (List.tl el), subexp2);
	  emit (Cmp (subexp1, subexp2));
	  emit (moveCoerce (resultReg, Tag 0, [Tosum booleanCon]));
	  emit (Setcc(ic, resultReg))
    	| (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));
	    emit (move (resultReg, subexp1))
	| (Ord | Chr) -> 
	    compileExpression(List.hd el, resultReg, locEnv, tailpos))

    | Conditional (e1, e2, e3) ->
	doBasicSubexp (e1, subexp1);
	let trueStartBlock  = createSeqBlock     "ifTrue"  in
	let falseStartBlock = createBlock locEnv "ifFalse" in
	let mergeBlock      = createBlock 
	    (addTempToMap locEnv resultRegr (lazy (typeCon typ))) 
	    "ifMerge"                                      in
	btagi subexp1r 0 Eq falseStartBlock;
	sequence trueStartBlock;

	replaceCurrBlock trueStartBlock;
	compileExpression(e2, resultReg, locEnv, tailpos);
	knownjump mergeBlock;

	replaceCurrBlock falseStartBlock;
	compileExpression(e3, resultReg, locEnv, tailpos);
	fallthru mergeBlock;

	replaceCurrBlock mergeBlock
    
    | Assign (e1, e2) -> 
        (* Only handles cases allowed by poptype.check_valid_lhs *)
	(match e1.raw_exp with
    	| Var v -> 
	    doBasicSubexp(e2, resultReg);
	    emit (move (Reg (varToReg locEnv v), resultReg));
	| StructMember (stExp, fn) ->
	    let (offset, co) = structMemberLhs(stExp, fn, subexp1) in
	    doBasicSubexp(e2, resultReg);
	    emit (move (Prjr ((subexp1r, [co]), offset), resultReg))
	| Subscript (arrExp, indExp) ->
	    let scale = 
	      match deopt arrExp.exp_typ with
		StringType -> 1
	      |	_          -> 4 in
	    doBasicSubexp(arrExp, subexp1);
	    doBasicSubexp(indExp, subexp3);
	    doBasicSubexp(e2,     resultReg);
	    emit (Unpack (arraySizeVar, subexp1r, (subexp1,[])));
	    emit (Aupd (Prjr((subexp1r,[]),4), scale, subexp3r, resultRegr,
			Prjr((subexp1r,[]),0)))
    	| _ -> impossible())
    | AssignOp(e1, p, e2) ->
	(* Only handles cases allowed by poptype.check_valid_lhs *)
	(match e1.raw_exp with
    	| Var v -> 
	    let r = Reg (varToReg locEnv v) in
	    doBinOp (p, r, e2);
	    emit (move (resultReg, r))
    	| StructMember (stExp, fn) ->
	    let (offset, co) = structMemberLhs(stExp, fn, subexp1) in
	    emit (move (subexp2, Prjr((subexp1r, [co]), offset)));
	    doBinOp (p, subexp2, e2);
	    emit (move (Prjr ((subexp1r, [co]), offset), subexp2));
	    emit (move (resultReg, subexp2))
    	| Subscript (arrExp, indExp) -> 
	    let scale = 
	      match deopt arrExp.exp_typ with
		StringType -> 1
	      |	_          -> 4 in
	    doBasicSubexp(arrExp, subexp1);
	    doBasicSubexp(indExp, subexp2);
	    emit (Unpack (arraySizeVar, subexp1r, (subexp1,[])));
	    emit (Asub (resultRegr, Prjr((subexp1r,[]),4), scale, subexp2r,
			Prjr((subexp1r,[]),0)));
	    doBinOp(p, resultReg, e2);
	    emit (Aupd (Prjr((subexp1r,[]),4), scale, subexp3r, resultRegr,
			Prjr((subexp1r,[]),0)))
	| _ -> impossible())

    | FunCall(fexp, arglist) -> (* Messy b/c of escaping and tail-call elim *)
      (* Assumes non-var must be escaping! *)
	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 (paramReg(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

	(* reg alloc must have stack back how I assume here or adjust the Prjr*)
        (* For register allocator *)
	let callstartInst  = Xarray.length !currentIvec in
	emit(Comment "callstart"); 
	let callstartBlock = !currentBlock in
	
	if escapes 
	then 
	  (let passArg = 
	    (if isTailCall (* bang stack frame -- messes up Steve? *)
	                    (* okay to bang because already in regs *)
	    then fun i -> move (Prjr((Esp,[]), 4*i), Reg (paramReg(f,i)))
	    else fun i -> Push (Reg (paramReg(f,i)), [])) in
	  (List.fold_right
	    (fun e i -> emit (passArg i); i-1) arglist (List.length arglist));
	  ());
	  
	emit (callInst (callLoc, [Tapp callCoercion]));
	        
	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 (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));

    | NewStruct (tn, el) -> 
	let st = findStruct env tn in
	emit (Malloc (4*(List.length el), st.mallocarg));
	emit (move (subexp1, Reg Eax));
	List.fold_left2
	  (fun i e lt ->
	    let r = newReg() in
	    compileExpression
	      (e, r, addTempToMap locEnv subexp1r lt, false);
	    emit (move (Prjr ((subexp1r,[]), 4*i), r));
	    i+1)
	  0 el st.initTypes;
  	emit (moveCoerce 
		(resultReg, subexp1,
		 let s = clab st.s_name in
		 [(if st.s_possibly_null then RollTosum s else Roll s)]))
			     
    | StructMember(e, fn) ->
	let (offset, co) = structMemberLhs(e, fn, subexp1) in
	emit (move (resultReg, Prjr ((subexp1r, [co]), offset)))
    | NewUnion(tn, fn, eopt) -> (* Doesn't special-case single value *)
	let un = findUnion env tn in
	(match eopt with
	  None   ->
	    let tag = Dict.lookup un.void_fields fn in
	    emit(moveCoerce(resultReg, Tag tag, [RollTosum (clab un.u_name)]))
	| Some e ->
	    let (tag,_,_,mallocarg) = Dict.lookup un.value_fields fn in
	      
	    doBasicSubexp(e, subexp1);
	    emit(Malloc(8, mallocarg));
	    emit(move (subexp2, Reg Eax));
	    emit(move (Prjr ((subexp2r,[]), 4), subexp1));
	    emit(move (Prjr ((subexp2r,[]), 0), Tag tag));
	    emit(moveCoerce(resultReg, subexp2, [RollTosum (clab un.u_name)])))
    | NewTuple el -> (* similar to ConstArray *)
	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
	emit (Malloc (4*len, mallocarg));
	emit (move (subexp1, Reg Eax));
	List.fold_left
	  (fun i te ->
	    let nr = newReg() 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,[]), 4*i), nr));
	    i+1)
	  0 el;
	emit (move (resultReg, subexp1))
    | TupleMember(e, i) -> 
	doBasicSubexp(e, subexp1);
	emit (move (resultReg, Prjr((subexp1r,[]),4*(i-1))))
    | Subscript(arrExp, indExp) -> 
	let scale = 
	  match deopt arrExp.exp_typ with
	    StringType -> 1
	  | _          -> 4 in
 	doBasicSubexp(arrExp, subexp1);
	doBasicSubexp(indExp, subexp2);
	emit (Unpack (arraySizeVar, subexp1r, (subexp1,[])));
	emit (Asub (resultRegr, Prjr((subexp1r,[]),4), scale, subexp2r,
			Prjr((subexp1r,[]),0)));
    | 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 8));
	emit (Comment "callend");
	emit (move (resultReg, Reg Eax));

    | Compile f -> failwith "unfinished code gen"
    | Hole    e -> failwith "unfinished code gen"
  in
  (*** compileStatement ***) 
  let rec compileStatement (stmt, locEnv, tailpos) =
    
    (*** Helpers for compileStatement ***)
    let doBasicSubstmt s = compileStatement(s, locEnv, false) in
    let doExpression e = 
      let r = newReg() in compileExpression(e, r, locEnv, false); r in

    let loopExit toBlock = (* used by Break and Continue *)
      knownjump toBlock;
              (* this block should be dead !*)
      replaceCurrBlock (createBlock locEnv "afterBreak") in 

    (*** Main match for compileStatement ***)
    match (fst stmt) with
      Skip  ->  synth_none
    | Exp e ->  
	doExpression e;
	if currBlockUnreachable() (* then it must be a tail call *)
	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 = newReg() in compileExpression(e, r, locEnv, true);
	if not (currBlockUnreachable ()) (* else it must tail call *)
	then (emit (move (Reg (funRetReg funId), r));
	      emit (Retn None);
	      addReturner !currentBlock);
	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

	btagi    (dereg (doExpression e)) 0 Eq falseStartBlock;
	sequence trueStartBlock;

	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   = createSeqBlock     "whileBody"  in
	let afterBlock       = createBlock locEnv "whileAfter" in

	fallthru testStartBlock;
	replaceCurrBlock testStartBlock;
	btagi    (dereg (doExpression e)) 0 Eq afterBlock;
	sequence bodyStartBlock;

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

    | Break    -> loopExit (getBreakBlock    locEnv); synth_breaks
    | Continue -> loopExit (getContinueBlock locEnv); synth_continues
    | For (e1, e2, e3, s) ->
	doExpression e1;
	let testStartBlock = createBlock locEnv "forTest" in
	let bodyStartBlock = createSeqBlock     "forBody" in
	let nextStartBlock = createSeqBlock     "forNext" in
	let afterBlock     = createBlock locEnv "forAfter" in
	
	fallthru testStartBlock;
	replaceCurrBlock testStartBlock;
        btagi    (dereg (doExpression e2)) 0 Eq afterBlock;
	sequence bodyStartBlock;

	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;
	 knownjump testStartBlock);

	replaceCurrBlock afterBlock;
	synth_none 

    | IntSwitch(e, intStmtList, defaultstmt) -> (* cascading ifs for now *)
       	let r = dereg (doExpression e) 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;
	      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) -> (Char.code c,s)) cslist, s),
	   snd stmt)
    | UnionSwitch (e, switchList, stmtopt) -> 
       	let r    = dereg (doExpression e) in
	let topt = e.exp_typ in
	let un   = 
	  match deopt topt with
	    NamedType n -> findUnion env n
	  | _ -> impossible() 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

	emit(Coerce(r, [Unroll]));

	let voidsretn =
	  List.fold_left
	    (fun voidsreturn (tag, _, s) -> 
	      let caseBlock      = createSeqBlock     "case" in
	      let bodyStartBlock = createBlock locEnv "body" in
	      
	      btagi    r tag Eq bodyStartBlock;
	      sequence caseBlock;

	      replaceCurrBlock bodyStartBlock;
	      let bodyretn = compileStatement(s, locEnv, tailpos) in 
	      if not bodyretn.must_exit
	      then knownjump afterBlock;

	      replaceCurrBlock caseBlock;
	      synth_merge voidsreturn bodyretn)
	    synth_returns void_cases in

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

	
     	let valuesretn =
	  let btagvar tag dest =
	    emit (Btagvar(r, 0, tag, (dest.lab, jumpCoercion), Eq));
	    add_edge Branch dest in
	  let jumpvar tag dest =
	    emit (Jmp (Addr dest.lab, jumpCoercion));
	    add_edge Jump  dest in
	  let doOneValue((tag, lsumcon, lcon, _), varopt, s) brancher =
	    let bodyEnv = 
	      match varopt with
		None   -> locEnv
	      | Some _ -> addTempToMap locEnv r lsumcon in
		      
	    let caseBlock      = createSeqBlock      "case" in
	    let bodyStartBlock = createBlock bodyEnv "body" in

	    brancher tag bodyStartBlock;
	    sequence caseBlock;
	    
	    let valReg = newReg() in
	    replaceCurrBlock bodyStartBlock;
	    emit(move(valReg,(Prjr((r,[Fromsum]),4))));
	    let bodyretn = 
	      compileStatement
		(s, addToMap locEnv (deopt varopt) (dereg valReg) lcon, 
		 tailpos) in
	    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;
	       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 r = dereg (doExpression (deopt !eoptionRef)) in
	compileStatement(s, 
			 addToMap locEnv v r (lazy (typeCon t)),
			 tailpos)
    | Suspend s -> failwith "unfinished code gen"
    | Resume  s -> failwith "unfinished code gen"
    | 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
	(* Doesn't optimize bodies that always return -- they're stupid *)
	if bodyretn.may_continue 
	then (typeBlock locEnv testStartBlock; 
	      fallthru testStartBlock; 
	      replaceCurrBlock testStartBlock)
	else del_block cfg testStartBlock.lab;

	btagi (dereg (doExpression e)) 1 Eq bodyStartBlock;

	if bodyretn.may_break 
	then typeBlock locEnv afterBlock;

	fallthru afterBlock;
	replaceCurrBlock afterBlock;
	
	synth_none (* Conservative eg. do return; while x *)
  in
  (*** initialization ***)
  let escapes = funEscapes funId in
  let retaddReg = newReg() in
  let locEnv    = snd (List.fold_left 
			 (fun (n, partialLocEnv) (var, tau) -> 
			   let r  = newReg() in 
			   (if escapes
			   then emit (move (r, Prjr ((Esp, []),n*4)))
			   else emit (move (r, Reg (Virt (id_make funId n)))));
			   (n+1, 
			    addToMap partialLocEnv var (dereg r)
			      (lazy (typeCon tau))))
			 (1, emptyLocalEnv)
			 declList) in 
  
  let bodysynth = compileStatement(ts, locEnv, false) in
  
  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 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 
		  (Virt(id_make 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 (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 (Virt (id_make 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) (* Quick hack to use std lib *)
      	then Dict.lookup returnerDict id
	else []))
    allReturnees;
  if debug then print_string "finished ret edges\n";
  cfg                
       
let compileType env topType = 
  match topType with
    StructDecl sd ->
      let cg_sd = findStruct env sd.st_name in
      (sd.st_scope, 
       (cg_sd.s_name, k4byte,
	if cg_sd.s_possibly_null
        then chptr [0] (Some cg_sd.fieldcons)
        else cptr cg_sd.fieldcons))
  | UnionDecl u -> 
      let cg_un = findUnion env u.un_name in
      (u.un_scope, (cg_un.u_name, k4byte, cg_un.talcon))
  | _ -> failwith "unfinished code gen"

(* 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 i, i::tags, i+1))
       (Dict.empty compare, [], 0) voids) in
  let (value_fields, variants, num_variants) =
    List.fold_left
      (fun (dict,variants, i) (fn, t) -> 
	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, 
	 i+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+1, Dict.insert dict fieldname (4*i)))
	   (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) =
  (* Build the environment we need for code gen *)
  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
  
  let (topfuns, topTypes, topExterns) =
    List.fold_right 
      (fun (d,_) (fs, ts, xs) -> match d with
	FunDecl    f       -> (f::fs, ts,    xs)
      |	StructDecl s       -> (fs,    d::ts, xs)
      |	UnionDecl  u       -> (fs,    d::ts, xs)
      |	ExternVal(v, FnType(t, tl)) -> (fs, ts, (t,v,tl)::xs)
      |	ExternFun (t,v,tl) -> (fs,    ts,    (t,v,tl)::xs)
      |  _ -> failwith "unfinished code gen")
      decls
      ([], [], []) in

  let cfg                     = compileToCode env topfuns                     in
  let strings                 = stringsToData()                               in
  let typeBlocks              = List.map (fun x-> compileType env x) topTypes in
  let (typIn, typCon, typOut) = 
    List.fold_right 
      (fun (scope, (id, kind, con)) (ti, tc, te) ->
	match scope with
	  Static   -> (ti, (id,kind,con)::tc, te)
	| Public   -> (ti, (id,kind,con)::tc, (id,kind,ConcCon con)::te)
	| Extern   -> ((id,kind,ConcCon con)::ti, tc, te)
  	| Abstract -> (ti, (id,kind,con)::tc, (id,kind,AbsCon)::te))
      typeBlocks
      ([], [], []) in
  let funIn  = 
    List.map 
      (fun (t,n,tl) -> (varToLab n,realTypeCon false (FnType(t,tl))))
      topExterns in
  let funOut = 
    List.map
      (fun f -> (varToLab f.fn_name,
		 realTypeCon false 
		   (FnType(f.fn_ret_type,List.map snd f.fn_args))))
      (Utilities.filter (fun f -> f.fn_static) topfuns) 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;*)
  if !allocateregs
  then 
    (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,cc) ->
	  let cc = 
	    match cc with
	      AbsCon -> AbsCon
	    | ConcCon c -> ConcCon (snd (Talcon.check context c)) in
	  Talctxt.add_con_def context n cc)
	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,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 
	    (snd (Talcon.check ctxt c)))
        context
        ((new_array_label, new_array_con)::funIn)  in
    let context = 
      List.fold_left
	(fun ctxt  (n, copt, _) -> Talctxt.add_val ctxt n 
	    (snd (Talcon.check ctxt (deopt copt))))
	context 
	strings in
    (* ADD ABSTRACT TYPES HERE! *)
      
    set_context cfg context;

    (try regalloc cfg numRegisters with
      Talctxt.Talverify (c,ve) -> begin
        Talpp.print_Talverify Format.std_formatter Talpp.std_options (c,ve);
        failwith "regalloc failed";
      end);
    if !optimize then Cfgopt.peephole cfg)
  else
    (if !optimize then Cfgopt.peephole cfg
    else Cfgopt.remove_dead_types cfg);
    
  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);

  ({ imports      = [|"tal.tali"; "pop_runtime.tali";
		      importName |];
     exports      = if has_main 
                    then [|exportName; "tal_prog.tali"|] 
                    else [|exportName|];
     imp_abbrevs  = [|(arrayAbbrevVar,  arrayAbbrev); 
		      (stringAbbrevVar, stringAbbrev)|]; 
     con_blocks   = Array.of_list typCon;
     code_blocks  = cfg_to_code_blocks cfg;
     data_blocks  = Array.of_list strings
   },
   { int_includes = [||];
     int_cons     = Array.of_list typIn;
     int_vals     = Array.of_list funIn
   },
   { int_includes = [||];
     int_cons     = Array.of_list typOut;
     int_vals     = Array.of_list funOut;
   })
    
(* EOF: popcompile.ml *)


