(* Status:
   I have just added global variable declarations of the form
   public int x;
   private int y[];

   Testing is not by any means extensive.  More testing is needed to make
   sure all the cases work on the LHS of assignment as well.

   NOTE: Null labels only work if the type is concrete.  If the type is 
   abstract the code will die although the popcorn type checker will not 
   complain.

   I nuked the special single value case for unions because of complications
   involving the value case being an option struct.  For example:
   ?struct bar { int x; }

   union foo {
   void x,y,z;
   bar w;
   }

   What is the type of foo?  Can we really flatten the tuple?  If we do is
   foo effectively an option foo?  I couldn't figure out the answers to all
   these questions to my satisfaction so we never generate special code for
   the single value case.  Union switches were broken in this case anyways.

   Why aren't pointers to labels Read only???  
   Or how do I make them read-only?
*)

module T = Tal ;;
module P = Popsyntax ;;
module PT = Poptype ;;
module Id = Identifier ;;

exception Unimplemented of string ;;
exception Impossible of string ;;

let unimpl s = Unimplemented s;;
let impos s = Impossible s;;

(* Abbreviations *)
let dc = T.defcon ;;

(* The global_env tracks definitions of types and types of global variables.
 * The local_env tracks the types and stack positions (in bytes relative to
 * the current stack pointer) of local variables.  The stack_type tracks
 * the current type of the stack.
 * 
 * The break label, when Some(lab,n), is the label that a break should
 * jump to.  However, before jumping, the break should pop s - n local 
 * variables from the stack, where s is the current size of the stack.
 * Similarly, the continue label, when Some(lab,n) is the label that a 
 * continue should jump to.  
 *)

type id = Id.identifier ;;

type stack_or_reg = TopStack | Stack of int | Register of T.reg ;;

type union_info = 
    { void_infos: (P.field_name * int) list;
      value_infos: (P.field_name * (int * T.con)) list;
      single_value_case: bool ;
      union_con: T.con;
      union_real_con: T.con;
      union_null: bool
    } 

type sfield_info = (T.con * T.variance);;

type struct_info =
    { sfield_infos: (P.field_name * int * sfield_info) list;
      struct_null: bool;
      struct_con: T.con;
      struct_real_con: T.con
    } 

type type_info =
    { unions: (P.type_name, union_info) Dict.dict;
      structs: (P.type_name, struct_info) Dict.dict
    } 
	
type env = 
    { global_env: PT.global_env;
      local_env: (P.var * (T.con * int)) list;
      args_on_stack: int;
      stack_type: T.con;
      break_label: (id*int) option;
      continue_label: (id*int) option;
      type_info: type_info;
      mutable regs: T.register_state
    } 

(********************************************************************)
(* code generation utilities                                        *)
(********************************************************************)

(* pid2tid : P.var -> T.var 
   Takes a non-type popcorn variable and returns a TAL id. *)
let pid2tid p = Id.id_of_string ("_" ^ p) ;;

let null_name s = Id.id_of_string ("null_" ^ s ^ "$");;
(* Takes a type name in popcorn and returns a TAL id. *)
let name s = Id.id_of_string (s ^ "$") ;;

(* Converts a list of registers and constructors into a constructor for a code label. *)
let list_to_ctxt (regs : (T.reg*T.con) list) = T.ccode_l regs;;

let add_to_state = T.rs_set_reg;;

let state_to_ctxt state = T.ccode state;;

let stack_v = Id.id_of_string "s";; (* Register we use to represent the stack. *)
let stack_c = T.cvar stack_v;;

let int_con = T.cbyte4;;
let bool_con = T.chptr [0;1] None;;
let char_con = int_con;;
let array_size_var = Id.id_new "size";;
let array_real_con c = T.carray_s array_size_var (T.cfield c T.ReadWrite);;
let array_arg_var = Id.id_new "c";;
let array_abbrev_var = Id.id_new "arr";;
let array_abbrev =
  (array_abbrev_var,
   T.clam array_arg_var T.k4byte (array_real_con (T.cvar array_arg_var)))
;;
let array_con c = T.capp (T.cvar array_abbrev_var) c;;
let string_var = Id.id_new "string";;
let string_real_con = array_real_con (T.pcbytes T.Byte1);;
let string_abbrev = (string_var, string_real_con);;
let string_con = T.cvar string_var;;
let name_con n = T.clab (name n);;
let opt_con c = T.chptr [0] (Some (T.cfield c T.Read));;

let default_con_blocks = [];;

let main_id = "main";;
let main_label = Id.id_of_string "__main$";;
let pop_exit_label = Id.id_of_string "_tal_exit";;

let never_null_label = Id.id_of_string "_pop_never_null";;
let never_null_con = list_to_ctxt [];;


let tal_main = Id.id_of_string "_tal_main";;
let sptr c = T.csptr c;;

let new_array_label = Id.id_of_string "_new_array";;
let new_array_con = 
  begin
    let arr_typ = Id.id_new "a" in
    let arr_typ_con = T.cvar arr_typ in
    let stack = T.ccons int_con (T.ccons arr_typ_con stack_c) in
    let ret_state =
      list_to_ctxt [(T.Eax,array_real_con arr_typ_con); (T.Esp,sptr stack)] in
    let initial_state =
      list_to_ctxt [T.Esp, sptr (T.ccons ret_state stack)] in
    let con' = T.cforall arr_typ T.k4byte initial_state in
    let con = T.cforall stack_v T.Kstack con' in
    con
  end ;;

let (tal_main_code_block,tal_main_con) = 
  begin
(* let tal_main_con = list_to_ctxt [(T.Esp,sptr (dc T.Cempty))];;*)
    let tal_main_state = (dc T.Cempty) in
    let tal_main_con = list_to_ctxt [(T.Esp,sptr tal_main_state)] in
    let tal_main_code = [|T.Call (T.Addr main_label,[T.Tapp tal_main_state]);
			  T.Push (T.Immed 0,[]);
			  T.Jmp (T.Addr pop_exit_label,[T.Tapp T.cempty])
			|] in
    ((tal_main,tal_main_con,tal_main_code),tal_main_con)
  end ;;


let default_import_vals = [] (*[ (new_array_label,new_array_con) ]*);;

let nonsense_id = Id.id_new "nonsense";;
let nonsense_con = T.cempty;;

let export_cons : T.int_con list ref = ref [] ;;
let export_vals :(id * T.con) list ref = ref [] ;;
let import_cons : T.int_con list ref = ref [] ;; 
let import_vals : (id * T.con) list ref = ref [];; 

(* list of code blocks (in reverse order) *)
let code_blocks : T.code_block list ref = ref [];;
let data_blocks : T.data_block list ref = ref [];;
(* current label whose instructions are in current_instrs *)
let current_label : (id * T.con) ref = ref (nonsense_id,nonsense_con);;
(* instructions kept in reverse order *)
let current_instrs : T.instruction list ref = ref [];;

let reset_generator () =
  export_cons := [];
  export_vals := [];
  import_cons := [];
  import_vals := [];

  code_blocks := [];
  data_blocks := [];
  current_label := (nonsense_id,nonsense_con); (* Should not be used. *)
  current_instrs := [];
  ()
;;
(* emit one instruction *)
let emit i = current_instrs := i::(!current_instrs);;

let bool_false = (T.Tag 0,[T.Tosum bool_con]);;
let bool_true =  (T.Tag 1,[T.Tosum bool_con]);;

let data_bool_false = T.Dtag (0,[T.Tosum bool_con]);;
let data_bool_true = T.Dtag (1,[T.Tosum bool_con]);;

let branch_coercion = [T.Tapp stack_c] ;;

let add_string s = 
  begin
    let lab = Id.id_new "string" in
    let len = String.length s in
    data_blocks := (lab,
		    None,
		    ([T.Dtag (len,[]); T.Dup; T.Dbytes s],
		     [T.Pack (T.pcint len,string_con); T.Toarray (4,0)])) 
       :: !data_blocks;
    lab
  end

(* for emitting comments *)
let print_comments = ref true;;
let comment s = if (!print_comments) then emit(T.Comment("\t"^s)) else ();;

(* emit a label -- this packages up the current label and list of
 * instructions as a code block, pushes that code block on the
 * list of code blocks, and starts a new instruction list. *)
let flush_code() =
  let instrs = Array.of_list (List.rev (!current_instrs)) in
  let (cl,clc) = !current_label in
  begin
    code_blocks := (cl,clc,instrs)::(!code_blocks);
    current_instrs := []
  end
let emit_lab env l = 
  begin
    let stack_state = add_to_state env.regs T.Esp (sptr env.stack_type) in
    let l_con = T.cforall stack_v T.Kstack (state_to_ctxt stack_state) in
    flush_code();
    current_label := (l,l_con)
  end

let empty_regs = T.rs_empty ;;

let con2field c = T.cfield c T.Read ;;

exception Void_Type;; (* Void_Types have no TAL constructor. *)

(* typ2con : env -> P.typ -> T.con *)
(* Given a popcorn type, it produces the equivalent Tal type (constructor) 
   We assume that all type names have been lettyped already.
*) 
let rec typ2con env t =
  begin
    match t with 
      P.VoidType -> (raise Void_Type)
    | P.IntType -> int_con
    | P.BooleanType -> bool_con
    | P.StringType -> string_con
    | P.CharType -> char_con
    | P.ArrayType t' -> (array_con (typ2con env t'))
    | P.FnType  (t',tl) -> fst (fun_con env t' tl)
    | P.NamedType n -> (name_con n)
    | P.TupleType ts ->
	let aux t = T.cfield (typ2con env t) T.Read in
	T.cprod_b (List.map aux ts)
  end
and fun_con env ret_typ params =
  begin
    (* Our calling convention pushes all arguments from right to left onto 
       the stack, with the return value in EAX *)
    let rec map params a =
      begin
	match params with
	  [] -> a 
	| hd :: tl ->
	    try
	      (map tl ((typ2con env hd) :: a))
	    with Void_Type -> (map tl a)
      end in
    let p_cons = List.rev (map params []) in
    let stack_p = (List.fold_right T.ccons p_cons stack_c)  in
    let ret_state = 
      begin
	try
	  list_to_ctxt [(T.Eax,typ2con env ret_typ);(T.Esp,sptr stack_p)]
      	with Void_Type -> list_to_ctxt [T.Esp,sptr stack_p] 
      end in
    let stack_on_entry = T.ccons ret_state stack_p in
    let fun_state = list_to_ctxt [T.Esp,sptr stack_on_entry] in
    let lab_con = T.cforall stack_v T.Kstack fun_state in
    (lab_con,stack_on_entry)
  end

(* Given a popcorn type, it produces the equivalent Tal type (constructor)
 * but doesn't use abbrevs so it can go in an interface file.
 *) 
let rec typ2con_r env t =
  begin
    match t with 
      P.VoidType -> (raise Void_Type)
    | P.IntType -> int_con
    | P.BooleanType -> bool_con
    | P.StringType -> string_real_con
    | P.CharType -> char_con
    | P.ArrayType t' -> (array_real_con (typ2con_r env t'))
    | P.FnType  (t',tl) -> fst (fun_con_r env t' tl)
    | P.NamedType n -> (name_con n)
    | P.TupleType ts ->
	let aux t = T.cfield (typ2con_r env t) T.Read in
	T.cprod_b (List.map aux ts)
  end
and fun_con_r env ret_typ params =
  begin
    (* Our calling convention pushes all arguments from right to left onto 
       the stack, with the return value in EAX *)
    let rec map params a =
      begin
	match params with
	  [] -> a 
	| hd :: tl ->
	    try
	      (map tl ((typ2con_r env hd) :: a))
	    with Void_Type -> (map tl a)
      end in
    let p_cons = List.rev (map params []) in
    let stack_p = (List.fold_right T.ccons p_cons stack_c)  in
    let ret_state = 
      begin
	try
	  list_to_ctxt [(T.Eax,typ2con_r env ret_typ);(T.Esp,sptr stack_p)]
      	with Void_Type -> list_to_ctxt [T.Esp,sptr stack_p] 
      end in
    let stack_on_entry = T.ccons ret_state stack_p in
    let fun_state = list_to_ctxt [T.Esp,sptr stack_on_entry] in
    let lab_con = T.cforall stack_v T.Kstack fun_state in
    (lab_con,stack_on_entry)
  end

(* needs_indirect : P.typ -> bool *)
(* When put into the static area certain type require an extra pointer and
   others do not.  For example int becomer pointer to an int, as does 
   bool.  But string, structs, unions, and arrays are as usual. *)
let needs_indirect t =
  begin
    match t with
      P.FnType _ -> false
    | _ -> true
  end

let exp2typ e =
  begin
    match e.P.exp_typ with
      None -> (raise (impos "Expression without type!!"))
    | Some t -> t
  end;;

let exp2con env e = (typ2con env (exp2typ e));;

let fallthru() = emit(T.Fallthru[stack_c])

let add_reg env reg con = env.regs <- (T.rs_set_reg env.regs reg con) ;;
let lookup_reg env reg = T.rs_get_reg env.regs reg ;;
let rm_reg env reg = env.regs <- (T.rs_del_reg env.regs reg) ;;

let copy_env env = 
  { global_env = env.global_env;
    local_env = env.local_env;
    args_on_stack = env.args_on_stack;
    stack_type = env.stack_type;
    break_label = env.break_label;
    continue_label = env.continue_label;
    type_info = env.type_info;
    regs = env.regs
  } 
;;

(* push : env -> reg -> env, pushes reg onto the stack.
   If the current register state (env.regs) does not contain the register
   does nothing. Otherwise updates the stack con, and removes reg from env.regs *)  
let push env reg =
  begin
    try
      let reg_con = T.rs_get_reg env.regs reg in
      let new_local_env = 
      	(List.map (fun (v,(c,i)) -> (v,(c,i+1))) env.local_env) in
      let new_stack_type = T.ccons reg_con env.stack_type in
      emit (T.Push (T.Reg reg, []));
    { global_env = env.global_env;
      local_env = new_local_env;
      args_on_stack = env.args_on_stack;
      stack_type = new_stack_type;
      break_label = env.break_label;
      continue_label = env.continue_label;
      type_info = env.type_info;
      regs = T.rs_del_reg env.regs reg 
    } 
    with Dict.Absent -> env
  end

(* push_keep : env -> reg -> env, pushes reg onto the stack.
   If the current register state (env.regs) does not contain the register
   does nothing. Otherwise updates the stack con. *)  
let push_keep env reg =
  begin
    try
      let reg_con = T.rs_get_reg env.regs reg in
      let new_local_env = 
      	(List.map (fun (v,(c,i)) -> (v,(c,i+1))) env.local_env) in
      let new_stack_type = T.ccons reg_con env.stack_type in
      emit (T.Push (T.Reg reg, []));
    { global_env = env.global_env;
      local_env = new_local_env;
      args_on_stack = env.args_on_stack;
      stack_type = new_stack_type;
      break_label = env.break_label;
      continue_label = env.continue_label;
      type_info = env.type_info;
      regs = env.regs
    } 
    with Dict.Absent -> env
  end

(* pop : T.register -> () *)
(* emits the code to pop one word off the stack into the register. 
   Does not return an env since presumably we are restoring the env. *)
let pop reg = emit(T.Pop (T.Reg reg)) ;;

(* pop freeing i stack slots. *)
let pop_free i = 
  if i>0
  then emit(T.ArithBin(T.Add,T.Reg T.Esp,T.Immed (4*i)))
  else ();;

(* peek - load the ith word from the top of the stack without popping. *)
let peek reg i = emit (T.Mov (T.Reg reg,(T.Prjr ((T.Esp,[]),4*i),[]))) ;;

(* add_local_var: var -> T.con -> env -> env *)
(* Adds the local variable var to the current environment.  
   Variable is already on the stack but stack-con has not been 
   updated, nor has local_env. 
*)
let add_local_var x con env =
  begin
    let new_local_env = (x,(con,0)) :: 
      (List.map (fun (x,(c,i)) -> (x,(c,i+1))) env.local_env) in
    let new_stack_type = T.ccons con env.stack_type in      
    { global_env = env.global_env;
      local_env = new_local_env;
      args_on_stack = env.args_on_stack;
      stack_type = new_stack_type;
      break_label = env.break_label;
      continue_label = env.continue_label;
      type_info = env.type_info;
      regs = env.regs
    } 
  end

let set_loop_labels env loopend looptest = 
  begin
  let stack_depth = List.length env.local_env in
    { global_env = env.global_env;
      local_env = env.local_env;
      args_on_stack = env.args_on_stack;
      stack_type = env.stack_type;
      break_label = Some (loopend,stack_depth);
      continue_label = Some (looptest,stack_depth);
      type_info = env.type_info;
      regs = env.regs
    } 
  end

let typ2struct_info env nt = 
  begin
    let n = match nt with
      P.NamedType n -> n
    | _ -> (raise (impos "typ2struct_info: struct without name."))
    in
    try
      Dict.lookup env.type_info.structs n
    with Dict.Absent -> (raise (impos "typ2struct_info: struct without info."))
  end;;

let typ2union_info env nt = 
  begin
    let n = match nt with
      P.NamedType n -> n
    | _ -> (raise (impos "typ2union_info: union without name."))
    in
    try
      Dict.lookup env.type_info.unions n
    with Dict.Absent -> (raise (impos "typ2union_info: union without info."))
  end;;

let struct_field_offset s_info f =
  begin
    let rec aux fields =
      match fields with
	[] -> (raise (impos "struct_field_offset: No such field"))
      |	((n,o,_)::tl) -> if n=f then o else (aux tl)
    in
    aux (s_info.sfield_infos)
  end;;

let mallocarg2con m =
  let rec aux m =
    match m with
      T.Mprod mas -> T.cprod (List.map aux mas)
    | T.Mfield c -> T.cfield c T.Uninit
    | T.Mbytearray (scale,size) ->
 	T.carray (T.pcint size) (T.cfield (T.pcbytes scale) T.ReadWrite)
    | T.Mexnname c -> raise (impos "mallocarg2con: nested enname") in
  aux m
;;

(* Check that r != null, raise null exception if r == null. *)
let check_not_null r =
   begin
     emit(T.Btagi(r,0,(never_null_label,[]),T.Eq));
     emit(T.Coerce(r,[T.Fromsum]))
   end;;

(* io_namedtype : P.var -> P.Scope -> bool -> T.con -> T.con_block *)
(* Imports and Exports whatever is necessary based on the scope and whether
   this con can be null or not. *)
let io_namedtype id scope null con con_r =
  begin
    let label = name id in
    let null_label = null_name id in
    let null_val = T.Dtag(0,[T.RollTosum (name_con id)]) in
    let null_label_con =
      T.cprod_b [T.cfield (name_con id) T.ReadWrite] in
    let null_data = (null_label,Some(null_label_con),([null_val],[])) in
    let int_con = (label,T.k4byte,T.ConcCon con_r) in
    begin
      match scope with
      	P.Public -> 
	  begin
	    export_cons := (int_con :: !export_cons);
	    if null 
	    then (data_blocks := (null_data :: !data_blocks);
		  export_vals := (null_label,null_label_con) :: !export_vals);
	    [(label,T.k4byte,con)]
	  end
      |	P.Extern ->
	  begin
	    import_cons := (int_con :: !import_cons);
	    if null 
	    then import_vals := (null_label,null_label_con) :: !import_vals;
	    []
	  end
      |	P.Static ->
	  begin
	    if null then data_blocks := null_data :: (!data_blocks);
	    [(label,T.k4byte,con)]
	  end
      | P.Abstract ->
          begin
            let abs_con = (label, T.k4byte, T.AbsCon) in
            export_cons := (abs_con :: !export_cons);
            if null 
            then (data_blocks := (null_data :: !data_blocks);
                  export_vals := (null_label,null_label_con) :: !export_vals);
            [(label,T.k4byte,con)]
          end
    end
  end

(**************************Code Generation *******************************)
(* cg_bop : env -> P.Primop -> stack_or_reg -> con option *)
(* One value is assumed to be in Eax.  The other is either on the stack or
   in a register. 
   If the other value is on the top of the stack it is popped off the stack.
   Generate the code for the operation leaving the result in Eax. 
   Only for binary operators.
   Returns the constructor for the result if different from EAX. 
*)
let cg_bop env p sor =
  begin
    let get_val =
      match sor with
	TopStack -> (fun r -> pop r;r)
      |	Stack i -> (fun r -> peek r i;r)
      |	Register r -> (fun r' -> r)
    in
    match p with
      (P.Plus | P.Times | P.Minus | P.Bitand | P.Bitor | P.Bitxor) ->
	begin
	  let op = 
	    (match p with
	      P.Plus -> T.Add
	    | P.Times -> T.Imul2
	    | P.Minus -> T.Sub
	    | P.Bitand -> T.And
	    | P.Bitor -> T.Or
	    | P.Bitxor -> T.Xor
	    | _ -> (raise (impos "This is exhaustive!!"))) in 
	  let reg2 = get_val T.Ebx in
	  emit(T.ArithBin (op,T.Reg T.Eax,T.Reg reg2));
	  None
	end
    | (P.Bitlshift | P.Bitlrshift | P.Bitarshift) ->
	begin
	  let op = 
	    (match p with
	      P.Bitlshift -> T.Shl
	    | P.Bitlrshift -> T.Shr
	    | P.Bitarshift -> T.Sar
	    | _ -> (raise (impos "This is exhaustive"))) in
	  let reg2 = get_val T.Ecx in
	  (if not (reg2 = T.Ecx) then emit(T.Mov (T.Reg T.Ecx,(T.Reg reg2,[]))));
	  emit (T.ArithSR (op,T.Reg T.Eax, None));
	  None
	end
    | (P.Div | P.Mod ) -> 
	begin
	  let op = T.Idiv in
	  let reg2 = get_val T.Edx in
	  emit(T.ArithMD (op,T.Reg reg2));
	  begin
	    match p with 
	      P.Mod -> emit(T.Mov (T.Reg T.Eax, (T.Reg T.Edx,[])))
	    | P.Div -> ()
	    | _ -> (raise (impos "This is exhaustive!"))
	  end;
	  None
	end		
    | (P.Gt | P.Lt | P.Gte | P.Lte | P.Eq | P.Neq) ->
	begin
	  let op =
	    (match p with
	      P.Gt -> T.Greater
	    | P.Lt -> T.Less
	    | P.Gte -> T.GreaterEq
	    | P.Lte -> T.LessEq
	    | P.Eq -> T.Eq
	    | P.Neq -> T.NotEq
	    | _ -> (raise (impos "This is exhaustive!!")))in
	  let reg2 = get_val T.Ecx in
	  let aux_reg = if reg2 = T.Ebx then T.Ecx else T.Ebx in
	  emit (T.Mov (T.Reg aux_reg,(T.Reg T.Eax,[])));
          emit (T.Mov (T.Reg T.Eax,bool_false));
	  emit (T.Cmp (T.Reg aux_reg,T.Reg reg2));
	  emit (T.Setcc (op,T.Reg T.Eax));
	  Some(bool_con)
	end
    | _ -> (raise (impos "cg_exp: Binary Primop"))  
  end
(* For now all results are put in EAX and EAX is saved by 
   "caller" when needed. *)
let rec cg_exp env e = 
  begin
    match e.P.raw_exp with
      P.Const c ->
	begin
	  let (cgop,const_con) = 
	    (match c with
	      P.Int i -> ((T.Immed i,[]),int_con)
	    | P.Bool b -> ((if b then bool_true else bool_false),bool_con)
	    | P.String s -> 
		let lab = add_string s in 
		((T.Addr lab,[]),string_con)
	    | P.Char c -> ((T.Immed (Char.code c),[]),char_con)
	    | P.Null n -> 	
		let t_n = null_name n in
		((T.Prjl ((t_n,[]),0),[]),name_con n))
	  in 
	  emit(T.Mov(T.Reg T.Eax,cgop));
	  (add_reg env T.Eax const_con)
	end  
    | P.ConstArray (es,ot) -> 
	begin
	  let size = List.length es in
	  let scale = 4 in
	  let real_size = (size * scale) + 4 in (* 4 for tag. *)
	  let con = 
	    match (ot,es) with
	      (None,hd::tl) -> (exp2con env hd)
	    | (Some t,_) -> (typ2con env t)
	    | _ -> (raise (impos "cg_exp: ConstArray: Without type."))
	  in
	  let rec aux es a =
	    match es with [] -> a | (hd::tl) -> (aux tl (con::a)) in
	  let mfs = aux es [] in
	  let size_con = T.csing (T.pcint size) in
	  let mallocarg = T.Mprod [T.Mfield size_con; T.malloc_prod mfs] in
	  emit (T.Malloc (real_size,mallocarg));
	  emit (T.Mov (T.Reg T.Ebx,(T.Reg T.Eax,[])));
	  let mfs2con mfs i =
	    let mf2fi con = T.cfield con T.ReadWrite in
	    let mf2fu con = T.cfield con T.Uninit in
	    let rec aux mfs i = 
	      (match mfs with
		[] -> []
	      | (hd::tl) -> 
		  (if i=0 
		  then (mf2fi hd) :: (aux tl i)
		  else (mf2fu hd) :: (aux tl (i-1)))) in
	    let size_con =
	      T.cfield size_con (if i=0 then T.ReadWrite else T.Uninit) in
	    T.cprod_b [size_con; T.cprod (aux mfs (i-1))] in
	  add_reg env T.Ebx (mfs2con mfs (size+1));
	  let env' = push env T.Ebx in
	  let rec cg_fields env' elt es =
	    begin
	      match es with
		[] -> env'
	      |	(hd::tl) -> 
		  begin
		    let offset = (elt*scale) in
		    cg_exp env' hd;
		    pop T.Ebx;	    
		    emit(T.Mov (T.Prjr ((T.Ebx,[]),offset),(T.Reg T.Eax,[])));
		    add_reg env T.Ebx (mfs2con mfs elt);
		    let env'' = push env T.Ebx in
		    (cg_fields env'' (elt-1) tl)
		  end
	    end in
	  let env'' = (cg_fields env' size (List.rev es)) in
	  pop T.Eax;
	  emit(T.Mov (T.Prjr ((T.Eax,[]),0),(T.Tag (size),[])));
	  emit(T.Coerce(T.Eax,[ T.Pack (T.pcint size,array_con con);
				T.Toarray (4,0) ]));
	  add_reg env T.Eax (array_con con)
	end
    | P.Var x ->
	begin
	  try 
           let (c,offset) = List.assoc x env.local_env in
	   emit (T.Mov(T.Reg T.Eax,(T.Prjr((T.Esp,[]),4*offset),[])));
	   (add_reg env T.Eax c)
	  with Not_found -> 
	    begin
	      try 
	      	let t = Dict.lookup env.global_env.PT.globals x in
              	let n = pid2tid x in
              	let src = if needs_indirect t  then T.Prjl ((n,[]),0) 
              	else  T.Addr n in
              	emit(T.Mov(T.Reg T.Eax,(src,[])));
	      	(add_reg env T.Eax (typ2con env t))
	      with Dict.Absent -> (raise (impos "cg_exp: Var without type."))
	    end
	end
    | P.Primop(p,[e]) ->
	begin
	  cg_exp env e;
	  let r = T.Eax in 
	  match p with
	    P.Not ->
	      begin
		emit(T.Mov (T.Reg T.Ebx, bool_false));
		emit(T.Cmp (T.Reg T.Eax, T.Reg T.Ebx));
		emit(T.Setcc(T.Eq,T.Reg T.Eax))
	      end
	  | P.Bitnot -> (emit(T.ArithUn (T.Not,T.Reg T.Eax)); 
			 add_reg env T.Eax int_con)
	  | P.Size -> 
	      emit (T.Unpack (array_size_var,T.Eax,(T.Reg T.Eax,[])));
	      emit (T.Mov (T.Reg T.Eax,(T.Prjr ((T.Eax,[]),0),[])));
	      emit (T.Coerce (T.Eax,[T.Subsume T.cbyte4]));
	      add_reg env T.Eax int_con
	  | P.Ord -> (add_reg env T.Eax int_con)
	  | P.Chr -> (add_reg env T.Eax char_con)
	  | _ -> (raise (impos "cg_exp: Unary op expected."))
	end
    | P.Primop(p,[e1;e2]) ->
	begin
	  cg_exp env e2;
	  let env' = push env T.Eax in
	  cg_exp env' e1;
	  match (cg_bop env' p TopStack) with
	    None -> ()
	  | Some con -> (add_reg env T.Eax con)
	  
	end
    | P.Primop _ -> (raise (impos "cg_exp: ?? Primop"))
    | P.Conditional (e1,e2,e3) ->
	begin
	  let false_lab = Id.id_new "condfalse" in
      	  let end_lab = Id.id_new "condend" in
	  cg_exp env e1;
	  env.regs <- empty_regs;
	  emit (T.Btagi(T.Eax,0,(false_lab,branch_coercion),T.Eq));
	  cg_exp env e2;
	  emit (T.Jmp(T.Addr end_lab,branch_coercion));
	  env.regs <- empty_regs;
	  emit_lab env false_lab;
	  cg_exp env e3;
	  fallthru();
          let t= exp2typ e2 in
          if t = P.VoidType then env.regs <- empty_regs;
	  emit_lab env end_lab
	end
    | P.Assign (e1,e2) -> 
	begin
	  cg_exp env e2;
	  cg_lhs_exp env e1 None;
	end
    | P.AssignOp (e1,p,e2) ->
	begin	
	  cg_exp env e2;
	  cg_lhs_exp env e1 (Some p);
  	end
    | P.FunCall (e,es) ->
	begin
	  let cg_arg env e = (cg_exp env e; push env T.Eax) in
	  let env' = List.fold_left cg_arg env (List.rev es) in
	  cg_exp env' e;
	  emit(T.Call (T.Reg T.Eax,[T.Tapp env.stack_type]));
	  let n = List.length es in
	  (pop_free n);
	  
	end
    | P.NewStruct(n,es) -> 
	begin
	  let s_info = try Dict.lookup env.type_info.structs n 
	  with Dict.Absent -> (raise (impos "cg_exp: unbound struct."))
	  in
	  let num_fields = (List.length es) in
	  let mallocarg = T.malloc_prod (List.map (fun (_,_,(c,v)) -> c) 
				     s_info.sfield_infos) in
	  let malloccon = ref (mallocarg2con mallocarg) in

	  let cg_field env e = (cg_exp env e; push env T.Eax ) in
	  let env' = (List.fold_left cg_field env (List.rev es)) in
	  (* Do the malloc *)
	  emit (T.Malloc (4*num_fields,mallocarg));
	  emit (T.Mov (T.Reg T.Ebx,(T.Reg T.Eax,[])));
	  
	  let offset = ref 0 in
	  let store_field ()= 
	    pop T.Eax; 
	    emit(T.Mov (T.Prjr ((T.Ebx,[]),4 * !offset),(T.Reg T.Eax,[])));
	    incr offset
	  in 
	  while(!offset<num_fields) do store_field () done;
	  (if (s_info.struct_null)
	  then emit(T.Mov(T.Reg T.Eax,(T.Reg T.Ebx,[T.RollTosum(name_con n)])))
	  else emit(T.Mov(T.Reg T.Eax,(T.Reg T.Ebx,[T.Roll(name_con n)]))));
	  add_reg env T.Eax (name_con n)
	end
    | P.StructMember (e',n) ->
	begin
	  cg_exp env e';
	  let t = exp2typ e' in
	  let s_info = typ2struct_info env t in
	  let offset = struct_field_offset s_info n in
	  emit(T.Coerce(T.Eax,[T.Unroll]));
	  (if s_info.struct_null then check_not_null T.Eax);
	  emit(T.Mov (T.Reg T.Eax,(T.Prjr ((T.Eax,[]),4*offset),[])));
	  add_reg env T.Eax (exp2con env e)
	end
    | P.NewUnion (nt,f,eo) ->
	begin
	  let u_info = typ2union_info env (P.NamedType nt) in
	  try (match eo with
	    None -> (* void_case *)
	      begin
		let tag = List.assoc f u_info.void_infos in
		emit(T.Mov (T.Reg T.Eax, 
			    (T.Tag tag,[T.RollTosum (name_con nt)])));
	        (add_reg env T.Eax (name_con nt))
	      end
	  | Some(e') -> (* value_case *)
	      begin
		let (tag,con) = List.assoc f u_info.value_infos in
		let single_value_case = u_info.single_value_case in
		cg_exp env e';
(* For now we are killing this special case.
		if single_value_case 
		then 
		  let mallocarg =  T.malloc_prod [con] in
		  (emit (T.Push (T.Reg T.Eax,[]));
		   emit (T.Malloc(4,mallocarg));
		   emit (T.Pop (T.Reg T.Ebx));
		   emit (T.Mov (T.Prjr ((T.Eax,[]),0),(T.Reg T.Ebx,[]))))
		else 
*)
		  begin
		   let tag_con = T.csing (T.pcint tag) in
		   let mallocarg = T.malloc_prod [tag_con;con] in 
		   (emit (T.Push (T.Reg T.Eax,[]));
		    emit (T.Malloc(8,mallocarg));
		    emit (T.Pop (T.Reg T.Ebx));
		    emit(T.Mov(T.Prjr ((T.Eax,[]),4),(T.Reg T.Ebx,[])));
		    emit(T.Mov(T.Prjr ((T.Eax,[]),0),(T.Tag tag,[])));
		    emit (T.Coerce (T.Eax,[T.RollTosum (name_con nt)])))
		  end;
		add_reg env T.Eax (name_con nt)
	      end) 
	  with Not_found->(raise (impos "cg_exp: NewUnion: No such tag."))
	end
    | P.NewTuple es ->
	let num_fields = (List.length es) in
	let margs = List.map (exp2con env) es in
	let mallocarg = T.malloc_prod margs in
	let c = 
	  T.cprod_b (List.map (fun c -> T.cfield c T.Read) margs) in
	let env' = List.fold_left (fun env e -> cg_exp env e; push env T.Eax)
	    env (List.rev es) in
	emit (T.Malloc (4*num_fields,mallocarg));
	for offset = 0 to num_fields - 1 do
	  pop T.Ebx;
	  emit(T.Mov (T.Prjr ((T.Eax,[]),4 * offset),(T.Reg T.Ebx,[])));
	done;
	add_reg env T.Eax c
    | P.TupleMember(e,i) ->
	(match exp2typ e with
	  P.TupleType ts ->
	    let result_t = typ2con env (List.nth ts (i - 1)) in
	    cg_exp env e;
	    emit(T.Mov (T.Reg T.Eax, (T.Prjr((T.Eax,[]),4*(i-1)),[])));
	    add_reg env T.Eax result_t
	| _ -> raise (impos "cg_exp: TupleMember: not tuple"))
    | P.Subscript (e1,e2) ->
	begin
	  cg_exp env e2;
	  let env' = push env T.Eax in
	  cg_exp env' e1;
	  pop T.Ebx;
	  let scale = match exp2typ e1 with P.StringType -> 1 | _ -> 4 in
	  emit (T.Unpack (array_size_var,T.Eax,(T.Reg T.Eax,[])));
	  emit (T.Asub (T.Eax, T.Prjr ((T.Eax,[]),4), scale, T.Ebx,
			T.Prjr ((T.Eax,[]),0)));
	  let eax_con = exp2con env e in
	  (add_reg env T.Eax (eax_con))
	end
    | P.NewArray(e1,e2) -> (* e1 is the size, e2 is the initializer. *)
	begin
	  cg_exp env e2;
	  let e2_con = 
	    try
	      (lookup_reg env T.Eax)
	    with Dict.Absent -> (raise (impos "cg_exp: NewArray"))
	  in
	  let env' = push env T.Eax in
	  cg_exp env' e1;
	  let env'' = push env' T.Eax in
	  emit(T.Call (T.Addr new_array_label,
		       [T.Tapp e2_con; T.Tapp env.stack_type]));
	  pop_free 2;
	  add_reg env T.Eax (array_con e2_con)
	end
    | P.Compile _ -> raise(unimpl "compile")
    | P.Hole _ -> raise(unimpl "hole")
  end
(* cg_lhs_exp: env -> exp -> P.op option -> unit.
   Compute the address of exp (if needed push Eax onto the stack)
   if Some op then push stuff for address onto stack if dynamic.
                   load the value
                   compute op
   Store EAX into address.
*)

and cg_lhs_exp env e op_opt=
  begin
    match e.P.raw_exp with
      P.Var x -> 
	begin
	  let gop = 
	    try 
              let (con,offset) = List.assoc x env.local_env in
	      (T.Prjr ((T.Esp,[]),4*offset))
	    with Not_found -> 
	      begin
	      	try 
                  let t = Dict.lookup env.global_env.PT.globals x in
                  let n = pid2tid x in
                  if needs_indirect t 
                  then T.Prjl ((n,[]),0)
                  else T.Addr n
	      	with Dict.Absent -> (raise (impos "cg_exp: Var without type."))
	      end in
	  (match op_opt with
	    None -> ()
	  | Some op ->
	      let env' = push env T.Eax in
	      cg_exp env' e;
	      let _ = cg_bop env' op TopStack in
	      ()
	   );   
	  emit(T.Mov (gop,(T.Reg T.Eax,[])));
	end
    | P.StructMember (e,f) ->
	begin
	  let env' = push env T.Eax in
	  cg_exp env' e;
	  let struct_info = typ2struct_info env (exp2typ e) in
	  let gop r =
	    let offset = struct_field_offset struct_info f in
	    (T.Prjr ((r,[]),4*offset))
	  in
	  (match op_opt with
	    None -> (pop T.Ebx;
		     emit(T.Coerce(T.Eax,[T.Unroll]));
		     (if(struct_info.struct_null) then check_not_null T.Eax);
		     emit(T.Mov (gop T.Eax,(T.Reg T.Ebx,[]))))
	  | Some op ->
	      begin
		let env'' = push env' T.Eax in (* Eax has address of struct.*)
		emit (T.Coerce (T.Eax,[T.Unroll]));
		(if struct_info.struct_null then check_not_null T.Eax);
		emit (T.Mov (T.Reg T.Eax, (gop T.Eax,[])));
		cg_bop env'' op (Stack 1);
		pop T.Ebx; (* EBX = address of struct. EAX = value *)
		(* XXX - I don't think the following check is necessary,
		   but for now... *)
		(if struct_info.struct_null then check_not_null T.Ebx);
		emit (T.Coerce (T.Ebx,[T.Unroll]));
		emit (T.Mov (gop T.Ebx,(T.Reg T.Eax,[])));
		pop_free 1 (* Free value we pushed originally. *)
	      end)
	end
    | P.Subscript (e1,e2) ->
	begin
	  let env' = push env T.Eax in 
	  cg_exp env' e2;
	  let env'' = push env' T.Eax in
	  cg_exp env'' e1;
	  (* Eax = address of array; Stack = offset,value *)
	  match op_opt with
	    None ->
	      begin
		emit (T.Unpack (array_size_var, T.Ecx, (T.Reg T.Eax,[])));
		pop T.Ebx;
		pop T.Eax;
		emit (T.Aupd (T.Prjr ((T.Ecx,[]),4), 4, T.Ebx, T.Eax,
			      T.Prjr ((T.Ecx,[]),0)))
	      end
	  | Some op ->
	      begin
		emit (T.Unpack (array_size_var, T.Ecx, (T.Reg T.Eax,[])));
		pop T.Ebx; (* subscript *)
		emit (T.Asub (T.Eax, T.Prjr ((T.Ecx,[]),4), 4, T.Ebx,
			      T.Prjr ((T.Ecx,[]),0)));
		cg_bop env op (Stack 0);
          	emit (T.Aupd (T.Prjr ((T.Ecx,[]),4), 4, T.Ebx, T.Eax,
			      T.Prjr ((T.Ecx,[]),0)));
		pop_free 1
	      end
	end
    | _ -> (raise (impos "cg_lhs_exp: Not allowed by type-checker."))
  end

(* cg_stmt env -> P.stmt -> bool *)
(* bool = true if stmt returns, false otherwise. *)
let rec cg_stmt env (s,loc) = 
  begin
    match s with
      P.Skip -> false
    | P.Exp e -> cg_exp env e; false
    | P.Seq (s1,s2) -> (cg_stmt env s1 or cg_stmt env s2)
    | P.Return eopt ->
      	begin
	  (match eopt with
	    None -> ()
	  | Some e -> cg_exp env e; ());
	(* pop local variables from stack*)
	  let n = (List.length env.local_env) - env.args_on_stack in
	  pop_free n;
	  emit(T.Retn None); 
	  true
      	end
    | P.IfThenElse(e,s1,s2) ->
      	begin
      	  let false_lab = Id.id_new "iffalse" in
      	  let end_lab = Id.id_new "ifend" in
	  cg_exp env e;
	  emit (T.Btagi(T.Eax,0,(false_lab,branch_coercion),T.Eq));
	  let s1_returns = cg_stmt env s1 in
	  (if not s1_returns
	  then emit (T.Jmp(T.Addr end_lab,branch_coercion)));
	  env.regs <- empty_regs;
	  emit_lab env false_lab;
	  let s2_returns = cg_stmt env s2 in
	  if not s2_returns
	  then fallthru();
	  env.regs <- empty_regs;
	  if not (s1_returns & s2_returns)
	  then (emit_lab env end_lab; false)
	  else true
      	end
    | P.While(e,s) ->
      	begin
	  let loopbody = Id.id_new "whilebody" in
          let looptest = Id.id_new "whiletest" in
	  let loopend = Id.id_new "whileend" in
	  let env' = set_loop_labels env loopend looptest in
	  emit(T.Jmp(T.Addr looptest,branch_coercion));
	  env'.regs <- empty_regs;
	  emit_lab env' loopbody;
	  (if(not (cg_stmt env' s)) then fallthru());
	  env'.regs <- empty_regs;
	  emit_lab env' looptest;
	  cg_exp env' e;
	  emit (T.Btagi(T.Eax,1,(loopbody,branch_coercion),T.Eq));
	  fallthru();
	  env'.regs <- empty_regs;
	  emit_lab env' loopend;
	  false
      	end
    | P.Break -> 
      	(match env.break_label with
	  None -> (raise (impos "cg_stmt: missing break label"))
      	| Some (l,n) -> 
	    begin
	      let d = (List.length env.local_env) - n in
	      pop_free d;
	      emit(T.Jmp(T.Addr l,branch_coercion));
	      false
	    end)
    | P.Continue ->
      	begin
	  match env.continue_label with
	    None -> (raise (impos "cg_stmt: missing continue label"))
      	  | Some (l,n) -> 
	      begin
	      	let d = (List.length env.local_env) - n in
	      	pop_free d;
	      	emit(T.Jmp(T.Addr l,branch_coercion));
		true
	      end
	end
    | P.For(e1,e2,e3,s) ->
      	begin
	  let looptest = Id.id_new "fortest" in
	  let loopbody = Id.id_new "forbody" in
	  let loopcount = Id.id_new "forcount" in
	  let loopend = Id.id_new "forend" in
	  let env' = set_loop_labels env loopend loopcount in
	  cg_exp env e1;
	  emit(T.Jmp(T.Addr looptest,branch_coercion));
	  env'.regs <- empty_regs;
	  emit_lab env' loopbody;
	  let s_returns = (cg_stmt env' s) in
	  (if (not s_returns) then fallthru());
	  env'.regs <- empty_regs;
	  emit_lab env' loopcount;
	  cg_exp env' e3;
	  fallthru();
	  env'.regs <- empty_regs;
	  emit_lab env' looptest;
	  cg_exp env' e2;  
	  emit (T.Btagi(T.Eax,1,(loopbody,branch_coercion),T.Eq));
	  fallthru();
	  env'.regs <- empty_regs;
	  emit_lab env' loopend;
	  false
     	end
    | P.CharSwitch(e,ss,s) -> 
      (* compiler character switches as integer switches *)
	let raw_e' = (P.Primop(P.Ord,[e])) in
	let e' = { P.exp_typ = Some P.IntType; 
		   P.raw_exp = raw_e'; 
		   P.exp_loc = e.P.exp_loc
		 } in
	let (ss',s') = List.map (fun (c,s) -> (Char.code c,s)) ss,s in
      	cg_stmt env (P.IntSwitch(e', ss', s'),loc)
    | P.IntSwitch(e,ss,s) ->
      (* just do iterated ifs -- later we can do something smart. *)
      	begin
      	  cg_exp env e;
	  let env_empty = copy_env env in
	  let env2 = copy_env env in
	  env_empty.regs <- empty_regs;
      	  let end_label = Id.id_new "endswitch" in
      	  let rec aux r l arms returns = 
	    (match arms with
	      [] -> 
	      	begin
	      	  let s_returns = cg_stmt env s in
	      	  fallthru();
	      	  (if not (s_returns & returns)  
                  then (emit_lab env_empty end_label;false)
		  else true)
	      	end
	    | (i,s)::rest -> 
	      	begin
	      	  let l' = Id.id_new ("l" ^ (string_of_int i)) in
	      	  emit(T.Cmp(T.Reg r,T.Immed i));
	      	  emit(T.Jcc(T.NotEq,(l',branch_coercion)));
	      	  let s_returns = cg_stmt env_empty s in
	      	  (if not s_returns
                   then emit(T.Jmp(T.Addr end_label,branch_coercion)));
	      	  emit_lab env2 l';
	      	  aux r l' rest (s_returns & returns)
	      	end) in
	  (aux T.Eax (Id.id_new "never_used") ss true)
      	end
    | P.UnionSwitch(e,ss,d) ->
	begin
	  cg_exp env e;
	  let r = T.Eax in
      	  let u_info = typ2union_info env (exp2typ e) in
     	  let void_infos = u_info.void_infos in
(*	  let single_value_case = u_info.single_value_case in *)
	  let value_infos = u_info.value_infos in
	  let end_label = Id.id_new "endswitch" in
      	  let default_label = Id.id_new "default" in
      	  let cg_default d = 
	    (match d with
	      None -> true
	    | Some s -> 
	      	begin
		  env.regs <- empty_regs;
	      	  emit_lab env default_label; 
	      	  (if not (cg_stmt env s)
	      	  then (fallthru(); false)
		  else true)
	      	end) in
      	  let cg_void_case (tag,lab,s) = 
	    begin
	      env.regs <- empty_regs;
	      emit_lab env lab; 
	      (if not (cg_stmt env s)
	      then (emit(T.Jmp(T.Addr end_label,branch_coercion)); false)
	      else true)
	    end in
	  let cg_void_branch (tag,lab,s) =
	    begin
	      emit(T.Btagi(r,tag,(lab,branch_coercion),T.Eq));
	    end in
      	  let cg_value_case (tag,con,lab,x,s) = 
	    let rc =
	      T.cprod [ T.cfield (T.csing (T.pcint tag)) T.Read;
			T.cfield con T.Read ] in
	    let rc = T.cptr (T.csum [rc]) in
	    begin
	      add_reg env r rc;
	      emit_lab env lab;
	      emit(T.Mov(T.Reg T.Eax,(T.Prjr((r,[T.Fromsum]),4),[])));
	      emit(T.Push(T.Reg T.Eax,[]));
	      let s_returns = cg_stmt (add_local_var x con env) s in
	      if not s_returns 
	      then (pop_free 1;
		    emit(T.Jmp (T.Addr end_label,branch_coercion)); 
		    false)
	      else true
	    end in
	  let cg_value_branch (tag,con,lab,x,s) =
	    begin
	      emit(T.Btagvar(r,0,tag,(lab,branch_coercion),T.Eq))
	    end in
    	  let rec split cs value_cs void_cs= 
	    (match cs with
	      [] -> (List.rev value_cs, List.rev void_cs)
	    | ((f,Some(x),s) :: tl) -> 
		begin
		  let lab = Id.id_new (f ^ "_value") in
		  let (tag,con) = 
		    try List.assoc f value_infos
		    with Not_found -> (raise (impos ("cg_exp: Unionswitch: Value case without tag."))) 
		  in
		  split tl ((tag,con,lab,x,s)::value_cs) void_cs
		end
	    | ((f,None,s) :: tl) ->
		begin
		  let lab = Id.id_new (f ^ "_void") in
		  let tag = 
		    try List.assoc f void_infos 
		    with Not_found -> (raise (impos ("cg_exp: UnionSwitch: Void case without tag.")))
		  in
		  split tl value_cs ((tag,lab,s) :: void_cs)
		end)
	  in
	  let (value_cases,void_cases) = split ss [] [] in
	  let value_cases = (Sort.list 
			     (fun (tag1,_,_,_,_) (tag2,_,_,_,_)->(tag1>tag2))
			     value_cases)
	  in
	  let void_cases = (Sort.list (fun (tag1,_,_) (tag2,_,_)->(tag1>tag2))
			      void_cases)
	  in
	  let cg_default_void_case tag = 
	    emit (T.Btagi(T.Eax,tag,(default_label,branch_coercion),T.Below))
	  in
	  let voids_exhaustive = (List.length void_cases =
				  List.length void_infos) in
	  let values_exhaustive = (List.length value_cases = 
				   List.length value_infos) in
	  let cg_value_branches vc = 
	    begin
	      match (voids_exhaustive,List.rev vc) with
		(false,hd::tl) -> 
		  begin
		    let (tag,_,_,_,_) = hd in
		    cg_default_void_case tag;
		    List.iter cg_value_branch vc;
		  end
	      |	_ -> (List.iter cg_value_branch vc)
	    end in
	  emit(T.Coerce(r,[T.Unroll]));
      	  (match d with
	    Some s ->
	      begin
	  	List.iter cg_void_branch void_cases;
		cg_value_branches value_cases ;
		emit (T.Jmp (T.Addr default_label,branch_coercion))
	      end
	  | None -> 
	      begin
		match value_cases with
		  [] ->
		    begin
		      match void_cases with
			[] -> (raise (impos "...."))
		      |	(hd::tl) ->
			  begin
			    List.iter cg_void_branch tl;
			    fallthru();
			  end

		    end
		| hd::tl ->
		    begin
		      List.iter cg_void_branch void_cases;
		      List.iter cg_value_branch tl;
		      fallthru();
		    end
	      end
		);
	  let values_return = (List.for_all (fun x -> x)
	      (List.map cg_value_case value_cases)) in
	  let voids_return = (List.for_all (fun x -> x) 
	      (List.map cg_void_case void_cases)) in
	  let default_returns = (cg_default d) in
	  if not (voids_return & (values_return & default_returns)) 
	  then
	    (env.regs <- empty_regs;
	    emit_lab env end_label;
	    false)
	  else true  
	end
    | P.Decl(x,t,roe,s) ->
      	begin
	  let e = 
	    (match !roe with
	      None -> (raise (impos "cg_stmt : decl - None"))
	    | Some e -> e)
	  in
	  cg_exp env e;
	  emit(T.Push (T.Reg T.Eax,[]));
	  if not (cg_stmt (add_local_var x (typ2con env t) env) s)
	  then (pop_free 1; false)
	  else true
      	end
    | P.Do(s,e) ->
        begin
          let loopstart = Id.id_new "loopstart" in
          let looptest = Id.id_new "looptest" in
          let loopend = Id.id_new "loopend" in
          fallthru();
          let env' = set_loop_labels env loopend loopstart in
	  env'.regs <- empty_regs;
          emit_lab env' loopstart;
	  let s_returns = (cg_stmt env' s) in
	  (if (not s_returns) then fallthru());
	  env'.regs <- empty_regs;
          emit_lab env' looptest;
          cg_exp env' e;
	  emit (T.Btagi(T.Eax,1,(loopstart,branch_coercion),T.Eq));
	  fallthru();
	  env'.regs <- empty_regs;
          emit_lab env' loopend;
          false
        end
    | P.Suspend _ -> raise(unimpl "suspend")
    | P.Resume _ -> raise(unimpl "resume")
  end (* cg_stmt *)
 
(* info_structdecl: env -> P.structdecl -> struct_info *)
let info_structdecl env st =
  begin
    let scope = st.P.st_scope in
    let name = st.P.st_name in
    let null = st.P.st_possibly_null in
    let fields = st.P.st_fields in
    let offset = ref 0 in
    let post_incr  i = (let j = !i in i:=j+1;j) in
    let info_field r sf =
      begin
	let (n,cap,t) = sf in
	(n,post_incr offset, 
	 ((if r then typ2con_r env t else typ2con env t),
	  (match cap with
	     P.ReadOnly ->  T.Read
	   | P.ReadWrite -> T.ReadWrite)
	 ))
      end in
    let field_infos = List.map (info_field false) fields in
    let field_infos_r = List.map (info_field true) fields in
    let struct_con' =
      let aux (_,_,(con,cap)) = T.cfield con cap in
      T.cprod (List.map aux field_infos) in
    let struct_con_r' =
      let aux (_,_,(con,cap)) = T.cfield con cap in
      T.cprod (List.map aux field_infos_r) in
    let struct_con =
      T.chptr (if null then [0] else []) (Some struct_con') in
    let struct_con_r =
      T.chptr (if null then [0] else []) (Some struct_con_r') in
    { sfield_infos = field_infos;
      struct_null = null;
      struct_con = struct_con;
      struct_real_con = struct_con_r
    }
  end;;
(* info_uniondecl: env -> P.uniondecl -> union_info *)  
let info_uniondecl env ud =
  begin
    let scope = ud.P.un_scope in
    let union_fields = ud.P.un_fields in
    let void_fields = ref [] in
    let value_fields = ref [] in
    let rec sort_fields fields =
      (match fields with
	[] -> ()
      |	((f,t) :: tl) -> 
	  begin
	    (match t with 
	      P.VoidType -> (void_fields := (f,t) :: !void_fields )
	    | _ -> (value_fields := (f,t) :: !value_fields));
	    sort_fields tl
	  end); in
    sort_fields union_fields;
    let (void_fields,value_fields) =  (List.rev !void_fields,
				       List.rev !value_fields) in
    let i = ref 1 in
    let post_incr i = (let j = !i in  i:=j+1;j) in
    let void_info (n,t) = (n,post_incr i) in
    let value_info r (n,t) =
      (n,(post_incr i,
	  if r then typ2con_r env t else typ2con env t)) in
    let void_infos = List.map void_info void_fields in
    let ri = !i in
    let value_infos = 
      (try
	List.map (value_info false) value_fields
      with Void_Type -> (raise (impos "info_uniondecl: void_type"))) in
    i := ri;
    let value_infos_r = 
      (try
	List.map (value_info true) value_fields
      with Void_Type -> (raise (impos "info_uniondecl: void_type"))) in
    let void_infos' =
      if ud.P.un_possibly_null
      then 
	("$null", 0) :: void_infos
      else
	void_infos
    in
    let tags = List.map (fun (n,i) -> i) void_infos' in
    let sum = 
      match value_infos with
	[] -> None
(* single_value_case:
      | [(n,(tag,con))] -> Some (con2field con)
*)
      | _ ->
	  begin
	    let aux (n,(tag,con)) =
	      T.cprod [ T.cfield (T.csing (T.pcint tag)) T.Read;
			con2field con ] in
	    let vars = List.map aux value_infos in
	    Some (T.csum vars)
	  end in
    let sum_r = 
      match value_infos with
	[] -> None
(* single_value_case:
      | [(n,(tag,con))] -> Some (con2field con)
*)
      | _ ->
	  begin
	    let aux (n,(tag,con)) =
	      T.cprod [ T.cfield (T.csing (T.pcint tag)) T.Read;
			con2field con ] in
	    let vars = List.map aux value_infos_r in
	    Some (T.csum vars)
	  end in
    { void_infos = void_infos';
      value_infos = value_infos;
      single_value_case = (List.length value_infos) = 1;
      union_con = T.chptr tags sum;
      union_real_con = T.chptr tags sum_r;
      union_null= ud.P.un_possibly_null
    } 	
  end
    
(* cg_typedecl : env -> P.topdecl -> (env * (T.con_block list)) *)
let cg_typedecl (env : env) (td : P.top_decl) = 
  begin
    let (raw_td,loc) = td in
    let unions = ref env.type_info.unions in
    let structs = ref env.type_info.structs in
    let con_block : T.con_block list = 
      begin
      	match raw_td with
          P.StructDecl sd ->
	    begin
	      let null = sd.P.st_possibly_null in
	      let scope = sd.P.st_scope in
	      let name = sd.P.st_name in
	      let  s_info = info_structdecl env sd in
	      structs:= Dict.insert !structs name s_info;
	      let con = s_info.struct_con in
	      io_namedtype name scope null con s_info.struct_real_con
	    end
      	| P.UnionDecl ud ->  (* This is busted!!! *)
	    begin
	      let name = ud.P.un_name in
	      let scope = ud.P.un_scope in
	      let null = ud.P.un_possibly_null in
	      let u_info = info_uniondecl env ud in
	      let con = u_info.union_con in
	      unions := Dict.insert !unions name u_info;
	      io_namedtype name scope null con u_info.union_real_con
	    end
      	| P.ExternType (tn,b) -> (* ?? *)
	    begin
	      let tn_label = name tn in
	      import_cons := (tn_label,T.k4byte,T.AbsCon) :: !import_cons;
	      begin
		(if b then
		  import_vals := (((null_name tn), name_con tn) 
				  :: !import_vals))
	      end;
	      []
	    end
	| P.ExternFun (ret_typ,n,params) ->
	    begin
	      let (con,_) = fun_con_r env ret_typ params in
	      import_vals := (pid2tid n,con) :: !import_vals;
	      []
	    end
      	| P.ExternVal (v,t) ->
            begin
              let ptr_to con = T.cptr (T.cfield con T.ReadWrite) in
              let con' = typ2con_r env t in
              let con = 
              	if needs_indirect t
              	then ptr_to con'
              	else con' in
              import_vals := (pid2tid v,con) :: !import_vals;
              []
            end
      	| _ -> (raise (impos "cg_typedecl:!!!"))
      end in
    ({ global_env = env.global_env; 
       local_env = env.local_env; 
       args_on_stack = env.args_on_stack;
       stack_type = env.stack_type;
       break_label = env.break_label;
       continue_label = env.continue_label;
       type_info = { unions = !unions; structs = !structs};
       regs = env.regs
     },
     con_block)
  end

let cg_fundecl env fd =
  begin
    let name = fd.P.fn_name in
    let ret_typ = fd.P.fn_ret_type in
    let args = fd.P.fn_args in
    let body = fd.P.fn_body in
    let params = List.map (fun (x,t) -> t) args in
    let (con,stack_type) = fun_con env ret_typ params in
    let lab = if name = main_id then main_label else (pid2tid name) in
    if fd.P.fn_static then begin
      let (con_r,_) = fun_con_r env ret_typ params in
      export_vals := ((lab,con_r) :: !export_vals)
    end;
    current_label := (lab,con);
    let depth = ref 0 in
    let aux (x,t) = (x,(typ2con env t, (incr depth; !depth))) in
    let local_env = List.map aux args in
    let env' = 
      { global_env = env.global_env;
	local_env = List.rev local_env;
	args_on_stack = List.length local_env;
	stack_type = stack_type;
	break_label = None;
	continue_label = None;
	type_info = env.type_info;
	regs = empty_regs
      } in
    (if (not (cg_stmt env' body)) then emit(T.Retn None));
    flush_code();
    if (name = main_id) then true else false 
  end

(* cg_global_decl : env -> (scope*var*typ * (exp option) ref) -> () *)
(* This is really tricky because I am allowing nested structs and unions at 
   the top-level. We need to generate both data_blocks and data_items.
*)
let cg_globaldecl env (s,x,t,eopt) =
  begin
    let extend_dbs db = (data_blocks := db :: !data_blocks) in  
    let ptr_to con = T.cprod_b [T.cfield con T.ReadWrite] in
    let constarray_con env (el,ot) =
      begin 
      	let con = match (el,ot) with
          (hd::tl,None) -> (exp2con env hd)
              |       (_,Some t) -> (typ2con env t)
              |       _ -> raise (impos "cg_globaldecl: constarray without type")
      in
      array_con con
      end in
    let rec gen_indirect_data_block n e =
      begin
      let dlabel name = ([T.Dlabel (name,[])],[]) in
      let d_name = Id.id_unique n in
      match e.P.raw_exp with
        P.Const c ->
          begin match c with
            P.Int i -> 
              let con = ptr_to int_con in
              extend_dbs (n,Some con,([T.D4bytes i],[]));
              con
          | P.Char c -> 
              let con = ptr_to char_con in
              extend_dbs (n,Some con,([T.D4bytes (Char.code c)],[]));
              con
          | P.Bool b -> 
              let con = ptr_to bool_con in
              let di = if b then data_bool_true else data_bool_false in
              extend_dbs (n,Some con,([di],[]));
              con
          |  P.String s ->
              let di = T.Dbytes s in
              let con = string_con in
              let db = (n,Some(ptr_to con),dlabel d_name) in
              extend_dbs db;
              (gen_data_block d_name e);
              con
          | P.Null tn ->
              let con = name_con tn in
              let db = (n,Some (ptr_to con), 
                        ([T.Dtag (0,[T.RollTosum con])],[])) in
              extend_dbs db;
              con
          end
      | P.ConstArray (el,ot) ->
          let con = constarray_con env (el,ot) in
          let db = (n, Some(ptr_to con), dlabel d_name) in
          extend_dbs db;
          (gen_data_block d_name e);
          con
      | P.NewStruct (tn,el) ->
          let con = name_con tn in
          let db = (n,Some (ptr_to con),dlabel d_name) in
          extend_dbs db;
          (gen_data_block d_name e);
          con
      | P.NewUnion (tn,f,eo) ->
          begin
            let con = name_con tn in
            match eo with
              None -> (* This is a void case.  Just like null. *)
                begin
                  let tag = 
                    try
                      let union_info = typ2union_info env (P.NamedType tn) in
                      List.assoc f union_info.void_infos
                    with Not_found -> raise (impos "gen_indirect_data_block: Non-existent field of union.")
                  in
                  let db = (n,Some (ptr_to con),
                            ([T.Dtag (tag,[T.RollTosum  con])],[])) in
                  (extend_dbs db);
                  con
                end
            | Some _ -> 
                begin
                  let db = (n,Some(ptr_to con),
                            ([T.Dlabel (d_name,[])],[])) in
                  extend_dbs db;
                  (gen_data_block d_name e);
                  con
                end
          end
      | P.NewTuple el ->
	  let cs = List.map (fun e -> T.cfield (exp2con env e) T.Read) el in
          let con = T.cprod_b cs in
          let db = (n,Some(ptr_to con),dlabel d_name) in
          extend_dbs db;
          (gen_data_block d_name e);
          con
      | _ -> raise (impos "Non-constant initializer for global.")
      end
    and gen_data_block n e =
      begin
      match e.P.raw_exp with
        P.Const c ->
          begin match c with
          | P.String s -> 
              let di = T.Dbytes s in
              let len = String.length s in
              let db =
		(n, None, 
                 ([T.Dtag (len,[]); T.Dup; T.Dbytes s],
		  [T.Pack (T.pcint len,string_con); T.Toarray (4,0)])) in
              extend_dbs db
          | _ -> raise (impos "No direct data_blocks of this type")
          end
      | P.ConstArray (el,ot) ->
          let len = List.length el in
          let elements = List.map gen_data_item el in
          let con = constarray_con env (el,ot) in
          extend_dbs (n,
		      None,
		      ((T.Dtag (len,[]))::(T.Dup)::elements,
		       [T.Pack (T.pcint len,con);T.Toarray (4,0)]))
      | P.NewStruct (tn,el) -> 
          let elements = List.map gen_data_item el in
          let con = name_con tn in
          let null = 
            begin
              let struct_info = typ2struct_info env (P.NamedType tn) in
              struct_info.struct_null
            end in
          let db coerce = (n,Some con, (elements, [coerce])) in
          if null 
          then extend_dbs (db (T.RollTosum con)) 
          else extend_dbs (db (T.Roll con))
      | P.NewUnion (tn,f,eo) ->
          begin
            let con = name_con tn in
            match eo with
              None -> raise (impos "gen_data_block: Direct tagged case.")
            | Some e ->
                try 
                  let union_info = typ2union_info env (P.NamedType tn) in
(*        let svc = union_info.single_value_case in *)
                  let tag = fst (List.assoc f union_info.value_infos) in
(*                if svc
                  then (gen_data_block n e)
                  else
*)
                    let elements = (T.Dtag(tag,[])) :: [gen_data_item e] in
                    let db = (n,Some con, (elements, [T.RollTosum con])) in
                    extend_dbs db
                with Not_found -> 
                  raise (impos "gen_data_block:Non-existent field of union.")
          end
      | P.NewTuple (el) ->
	  let cs = List.map (fun e -> T.cfield (exp2con env e) T.Read) el in
          let con = T.cprod_b cs in
          let elements = List.map gen_data_item el in
          extend_dbs (n,Some con,(elements,[]))
      | _ -> raise (impos "Non-constant initializer for global var.")
      end
    and gen_data_item e =
      begin match e.P.raw_exp with
      P.Const c ->
        begin match c with
          P.Int i -> T.D4bytes i
        | P.Bool b -> 
              if b then data_bool_true else data_bool_false
        | P.String s -> 
            let sname = Id.id_new "string" in
            gen_data_block sname e;
            T.Dlabel (sname,[])
        | P.Char c -> (T.D4bytes (Char.code c))
        | P.Null tn -> T.Dlabel(null_name tn,[])
        end
      | P.ConstArray (el,t) ->
        begin
          let arr_name = Id.id_new "array" in
          gen_data_block arr_name e;
          T.Dlabel(arr_name,[])
        end
      | P.NewStruct (tn,el) -> 
        begin
          let st_name = Id.id_new "struct" in
          gen_data_block st_name e;
          T.Dlabel(st_name,[])
        end
      | P.NewUnion (tn,f,eo) -> (* XXX *)
        begin
          match eo with
            None ->
              let con = name_con tn in
              let tag = 
                try
                  let union_info = typ2union_info env (P.NamedType tn) in
                  List.assoc f union_info.void_infos 
                with Not_found -> raise(impos "gen_data_item: No such case.")
              in
              T.Dtag(tag,[T.RollTosum con])
          | Some _ ->
              let un_name = Id.id_new "union" in
              gen_data_block un_name e;
              T.Dlabel(un_name,[])
        end
      | P.NewTuple (el) ->
        begin
          let tu_name = Id.id_new "tuple" in
          gen_data_block tu_name e;
          T.Dlabel(tu_name,[])
        end
      |       _ -> raise (impos "Non-constant initializer for global var.")
      end in
    let n = pid2tid x in
    match !eopt with
      None -> raise (impos "cg_globaldecl: Uninitialized global variable.")
    | Some e -> 
      begin
        let con = gen_indirect_data_block n e in
        match s with
          P.Static -> ()
        | P.Public -> (export_vals := (n,con) :: !export_vals)
        | (P.Extern | P.Abstract) -> raise (impos "global_decl: extern/abstract global")
      end
  end
(* cg_all : env -> P.top_decl list -> T.tal_imp *)
(* Sort the top decls, Generate the type decls, Generate the functions,
   build the tal_imp structure. *)
let cg_all env topdecls = 
  begin
    let type_decls = ref []  in
    let fun_decls = ref [] in
    let global_decls = ref [] in
    let rec sort_decls ds = 
      begin
	match ds with
	  [] -> ()
	| ((P.FunDecl fd,_) :: tl) -> (fun_decls := fd :: !fun_decls; 
				       sort_decls tl)
      	| ((P.GlobalDecl g,_) :: tl) -> (global_decls := g :: !global_decls; 
					 sort_decls tl)
	| ( hd :: tl) -> (type_decls := hd :: !type_decls; 
			  sort_decls tl)
      end in
    sort_decls topdecls;
    let type_decls = !type_decls in
    let fun_decls = !fun_decls in
    let global_decls = !global_decls in
    reset_generator ();
    let aux td (env,cbl) =
      begin
      	let (env',cbl') = cg_typedecl env td in
        (env',cbl'@ cbl)
      end in
    let (env',con_blocks) = List.fold_right aux type_decls (env,[]) in
    let _ = List.map (cg_globaldecl env') global_decls
    in
    let has_main = (List.map (cg_fundecl env') fun_decls) in
    let has_main = List.exists (fun x -> x) has_main in
    (if has_main then
      code_blocks := tal_main_code_block :: !code_blocks);
    (con_blocks,has_main)
  end

let code_gen mod_name import_file export_file (td,global_env) =
  begin
    let env = { global_env = global_env;
		local_env = [];
		args_on_stack = 0;
		stack_type = tal_main_con;
		break_label = None;
		continue_label = None;
		type_info = { unions=Dict.empty compare; 
			      structs=Dict.empty compare 
			    };
		regs = empty_regs
	      }	in
    let (con_blocks,has_main) = cg_all env td in
    let implementation =     
      { T.imports = [| "tal.tali"; "pop_runtime.tali"; import_file |];
      	T.exports = if has_main then [|"tal_prog.tali"; export_file|]
	else [|export_file|];
	T.imp_abbrevs = [|array_abbrev;string_abbrev|];
      	T.con_blocks = Array.of_list (default_con_blocks @ con_blocks);
      	T.code_blocks = Array.of_list (List.rev !code_blocks);
      	T.data_blocks = Array.of_list !data_blocks
    } in
    let export_interface = 
      { T.int_includes = [||];
	T.int_cons = (Array.of_list !export_cons);
	T.int_vals = (Array.of_list !export_vals)
      }	in
    let import_interface = 
      { T.int_includes = [||];
	T.int_cons = (Array.of_list !import_cons);
	T.int_vals = (Array.of_list (default_import_vals @ !import_vals))
      }	in
    (implementation,import_interface,export_interface)
  end
