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

(* Status:
 * Option unions are NOT supported.
 *   
 * No 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? 
 *)

(* Table of contents:
 * 1. (Modules/Exceptions)
 * 2. (Types) for the Global environment, and miscellaneous data types.
 * 3. (Utilities)
 *   a. (General) generally useful
 *   b. (Emit) Code emission interface (could be a module)
 *   c. (Types) Type compilation (may go into its own module soon)
 *   d. (Exp) Expression manipulation
 *   e. (Env) Environment manipulation
 * 4. (Code Generation)
 *   a. (Support) 
 *   b. (Main)
 * 5. (Entry Point)
 *)

(*********************************Modules/Exception****************************)
open Numtypes;;
module T = Tal
module P = Popsyntax 
module PT = Poptype 
module Id = Identifier
module Peephole = Poppeep
module X = Poperr

exception Unimplemented of string
exception Impossible of string
exception Void_Type (* Void_Types have no TAL constructor. *)

(***************************************Types**********************************)
type id = Id.identifier
type stack_or_reg = TopStack | Stack of int | Register of T.reg

type union_info = 
    { union_tyvars: id list;  (* Dan fix for UnionSwitch *)
      void_infos: (P.field_name * int32) list;
      value_infos: (P.field_name * (int32 * T.con)) list;
      single_value_case: bool ;
      union_con: T.con;
      union_kind: T.kind;
      union_null: bool
    } 

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

type struct_info =
    { struct_arity: int; (* # of type arguments *)
      sfield_infos: (P.field_name * int * sfield_info) list;
      struct_null: bool;
      struct_con: T.con;
      struct_mem_con: T.con;
      struct_mem_kind: T.kind;
      struct_kind: T.kind
    } 

type type_info =
    { unions: (P.type_name, union_info) Dict.dict;
      structs: (P.type_name, struct_info) Dict.dict
    } 
	
(* Cyclone *)
(* Environment local to a function *)
type fenv =
    { f_tyvars: P.var list;
      f_local_env: (P.var * (T.con * int)) list;
      f_args_on_stack: int;
      f_stack1_type: T.con;
      f_stack2_type: T.con; (* Stack after exception handler. *)
      f_break_label: (id*int) option;
      f_continue_label: (id*int) option;
      f_regs: T.register_state
    } 
type cenv =
    Hidden of fenv
  | Frame of fenv
  | Outermost of fenv
(* End Cyclone *)

type code_mark =
    M_Label of id * T.con option
  | M_ISeq of T.instruction array
(* Cyclone *)
  | M_TypeAbbrev of id * T.con
      (* Delimiters for templates *)
  | M_TemplateBeg of id * id * T.con * fenv
  | M_TemplateEnd of T.con
      (* Expression to fill a hole *)
  | M_Fill of id * P.exp
      (* Jumps from inside templates might need to be patched.
      ** First id is the target, second id is id of the template
      ** containing the jump, if the jump is an inter-template jump. *)
  | M_Jmp of id * (id * id) option ref * T.con * T.coercion list
  | M_Jcc of T.condition * id * (id * id) option ref * T.con * T.coercion list
  | M_Btagi of T.reg * Numtypes.int32 * id T.coerce * T.condition
        * (id * id) option ref * T.con
  | M_Btagvar of T.reg * Numtypes.int32 * Numtypes.int32 * id T.coerce
        * T.condition * (id * id) option ref * T.con
(* End Cyclone *)

(* 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.  
 *
 * sptr_offsets tracks the location of the stack pointers pushed in
 * a try.  A continue or break must restore the appropriate one into EBP.
 * Similarly a return must restore the outermost one. (last one)
 *)
type env = 
    { global_env: PT.global_env;
      tyvars: P.var list;
      local_env: (P.var * (T.con * int)) list;
      args_on_stack: int;
      stack1_type: T.con;
      stack2_type: T.con; (* Stack after exception handler. *)
      break_label: (id*int) option;
      continue_label: (id*int) option;
      sptr_offsets: int list;
      type_info: type_info;
      regs: T.register_state
(* Cyclone *)
        ;
      cenvs: cenv list
(* End Cyclone *)
    } 

(************************************Utilities*********************************)
(********************************Utilities::General****************************)

let unimpl s = raise (Unimplemented ("popcompile:"^s));;
let impos s = raise (Impossible ("popcompile:"^s));;
let deSome x = (match x with Some(v) -> v | None -> impos "deSome")

(* Translate popcorn ids of values, types, mems(non option component),
 * tyvars to tal ids 
 *)
let tid_val p = Id.id_of_string ("_" ^ p)
let tid_mem p = Id.id_of_string(p ^ "?mem")
let tid_type p = Id.id_of_string (p ^ "?")
let tid_tyv p = Id.id_of_string ("v" ^ p)
let tid_exn p = Id.id_of_string (p ^ "?exn")

let lookup_struct env n = Dict.lookup env.type_info.structs n
let lookup_union env n = Dict.lookup env.type_info.unions n
let lookup_global env x = Dict.lookup env.global_env.PT.globals x
let lookup_exn env x = Dict.lookup env.global_env.PT.exceptions x

let to_i32 = int_to_int32 

(*********************************Utilities::Emit******************************)
let nonsense_id = Id.id_new "nonsense"
type gen_state = 
    { mutable export_cons : T.int_con list;
      mutable export_vals : (id * T.con) list;
      mutable import_cons : T.int_con list;
      mutable import_vals : (id * T.con) list;
      mutable code_marks : code_mark list;
      mutable data_blocks : T.data_block list;
      mutable label : (id * T.con option);(*Label for current block.*)
      mutable instrs : T.instruction list (*Instr in current block *)
    } 

(* Encapsulates the state of the code generator. *)
let gen_state = { export_cons = []; export_vals = [];
		  import_cons = []; import_vals = [];
		  code_marks = []; data_blocks = [];
		  label = (nonsense_id, None); instrs = []
		} 

(* Cyclone *)
(* Eventually, put this in gen_state *)
(* mapping from labels to inter-template-jump information *)
let forward_itjs = Hashtbl.create 11
(*
    (id *
       (id * id * ((T.reg * id * id * T.reg * id * id) -> T.instruction)))
    Hashtbl.t
*)
(* mapping from labels to the templates they occur in *)
let tmpl_of_label = Hashtbl.create 11
(* End Cyclone *)

let reset_generator () = 
  begin
    let gs = gen_state in
    gs.export_cons<-[]; gs.export_vals<-[]; gs.import_cons<-[]; 
    gs.import_vals<-[]; gs.code_marks<-[]; gs.data_blocks<-[];
    gs.label<-(nonsense_id, None); gs.instrs <- []
(* Cyclone *)
         ;
    Hashtbl.clear forward_itjs;
    Hashtbl.clear tmpl_of_label;
    ()
(* End Cyclone *)
  end

let gen_export_con c = (gen_state.export_cons <- (c :: gen_state.export_cons))
let gen_export_val v = (gen_state.export_vals <- (v :: gen_state.export_vals))
let gen_import_con c = (gen_state.import_cons <- (c :: gen_state.import_cons))
let gen_import_val v = (gen_state.import_vals <- (v :: gen_state.import_vals))
let gen_data_block d = (gen_state.data_blocks <- (d :: gen_state.data_blocks))

(* flush_code : T.instruction list -> T.instruction list -> unit
 * Pushes the block on the current list of code blocks and
 * starts a new block.  Does some simple peephole optimization.
 *)
let flush_code () =
  match gen_state.instrs with
    [] -> ()
  | ilist ->
      begin
        let iv = Array.of_list(Peephole.optimize(List.rev ilist)) in
        gen_state.code_marks <- ((M_ISeq iv) :: gen_state.code_marks);
        gen_state.instrs<-[]
      end
let gen_code_mark m =
  begin
    flush_code();
    gen_state.code_marks <- (m :: gen_state.code_marks)
  end      
let gen_set_label (l,c) = gen_code_mark(M_Label(l,c))
let gen_code_block (l,c,iv) =
  begin
    gen_set_label (l,c);
    gen_code_mark(M_ISeq iv)
  end


let emit i = gen_state.instrs <- (i :: gen_state.instrs)	  
let print_comments = ref true;;
let emit_comment s = if (!print_comments) then emit(T.Comment("\t"^s)) else ();;
let emit_label l con_opt = (flush_code (); gen_set_label(l,con_opt))

(* Cyclone *)
let get_cyclone_con env = fst(deSome(T.get_cyclone_field env.regs))
let set_cyclone_con rs con = T.set_cyclone_field rs con T.ReadWrite
let get_vis_fenv env =
  { f_tyvars = env.tyvars;
    f_local_env = env.local_env;
    f_args_on_stack = env.args_on_stack;
    f_stack1_type = env.stack1_type;
    f_stack2_type = env.stack2_type;
    f_break_label = env.break_label;
    f_continue_label = env.continue_label;
    f_regs = env.regs
  } 
let put_vis_fenv fenv env =
  let new_cenvs =
    let rec aux cs =
      match cs with
        [] -> []
      | (Hidden fenv2)::tl -> (Hidden fenv2)::(aux tl)
      | (Frame _)::tl -> (Frame fenv)::tl
      | (Outermost _)::tl -> (Outermost fenv)::tl in
    aux env.cenvs in
  { env with
    tyvars = fenv.f_tyvars;
    local_env = fenv.f_local_env;
    args_on_stack = fenv.f_args_on_stack;
    stack1_type = fenv.f_stack1_type;
    stack2_type = fenv.f_stack2_type;
    break_label = fenv.f_break_label;
    continue_label = fenv.f_continue_label;
    regs = fenv.f_regs;
    cenvs = new_cenvs
    } 
let flush_vis_fenv env =
  let new_cenvs =
    let rec aux cs =
      match cs with
        [] -> []
      | (Frame _)::tl ->
          let fenv = get_vis_fenv env in
          (Frame fenv)::tl
      | (Outermost _)::tl ->
          let fenv = get_vis_fenv env in
          (Outermost fenv)::tl
      | (Hidden fenv2)::tl -> (Hidden fenv2)::(aux tl) in
    aux env.cenvs in
  { env with cenvs = new_cenvs} 

let stack_height env =
  let rec aux con =
    match con.T.rcon with
      T.Ccons(_,con) -> 1 + aux con
    | _ -> 0 in
  aux(env.stack1_type)

let put_vis_cg_type env cg_type =
  { env with regs = set_cyclone_con env.regs cg_type }
let dc = T.defcon
let cg_push env ti ls hs post_con_opt =
  let cg_type =
    match (get_cyclone_con env).T.rcon with
      T.Ctcons({T.rcon=T.Ctrgn(pre,post,t)},tl) ->
        dc(T.Ctcons(dc(T.Ctrgn(pre,post_con_opt,(ti,ls,hs)::t)),
                    tl))
    | _ -> impos "cg_push: bad type for ECG"
  in put_vis_cg_type env cg_type

let cg_pop_hole env h =
  let cg_type =
    match (get_cyclone_con env).T.rcon with
      T.Ctcons({T.rcon=T.Ctrgn(pre,post,(ti,ls,hs)::t)},tl) ->
        let hs' =
          List.concat
            (List.map
               (fun (l,c) -> if l=h then [] else [(l,c)])
               hs) in
        dc(T.Ctcons(dc(T.Ctrgn(pre,post,(ti,ls,hs')::t)),
                    tl))
    | _ -> impos "cg_pop_hole: bad type for ECG"
  in put_vis_cg_type env cg_type

let cg_pop_free env n =
  let dumped_tmpls =
    match (get_cyclone_con env).T.rcon with
      T.Ctcons({T.rcon=T.Ctrgn(pre,post,t)},tl) -> t
    | _ -> impos "cg_pop_free: bad type for ECG" in
  let rec aux n l =
    if n<=0 then () else begin
      match l with
        (ti,_,_)::tl -> emit(T.CgForget ti); aux (n-1) tl
      | _ -> impos "Popcompile.cg_pop_free: bad type for ECG 2"
    end in
  aux n dumped_tmpls

let abbrev_con con =
  match con.T.rcon with
    T.Cvar _ -> con  (* Don't bother to abbreviate a variable *)
  | T.Cprim _ -> con (* or a primitive type *)
  | _ ->
      let abbrev_var = Id.id_new "t" in 
      let abbrev_con = dc(T.Cvar abbrev_var) in
      gen_code_mark(M_TypeAbbrev(abbrev_var,con));
      abbrev_con

(* Type variable ranging over cg region stacks *)
let cg_v = Id.id_of_string "cg"
let cg_c = T.cvar cg_v

(* End Cyclone *)

(*********************************Utilities::Types*****************************)
let stack1_v = Id.id_of_string "s1"
let stack1_c = T.cvar stack1_v
let stack2_v = Id.id_of_string "s2"
let stack2_c = T.cvar stack2_v

let exn_con = T.pcexn
let int_con = T.cbyte4
let bool_con = T.chptr [i32_0;i32_1] None
let char_con = int_con
let array_size_var = Id.id_of_string "?sz"
let array_real_con c = T.carray_s array_size_var (T.cfield c T.ReadWrite)
let array_abbrev_var = Id.id_of_string "?arr"
let array_abbrev =
  let c = Id.id_of_string "c" in
  (array_abbrev_var, T.clam c T.k4byte (array_real_con (T.cvar c)))
let array_con c = T.capp (T.cvar array_abbrev_var) c

let string_abbrev_var = Id.id_of_string "?str"
let string_real_con = array_real_con (T.pcbytes T.Byte1)
let string_abbrev = (string_abbrev_var, string_real_con)
let string_con = T.cvar string_abbrev_var

(* Type of the handler as seen in function types. *)
let handle_abbrev_var = Id.id_of_string "?H"
let handle_abbrev = 
  begin
    let sv = Id.id_of_string "s" in
    let svc = T.cvar sv in
    (handle_abbrev_var,
     T.clam sv T.Kstack (T.ccode_l [(T.Eax,exn_con);(T.Esp, T.csptr svc)]))
  end
let handle_con s = T.capp (T.cvar handle_abbrev_var) s

(* Abbreviation for shape of stack pointer in EBP *)
let exn_stack_abbrev_var = Id.id_of_string "?E"
let exn_stack_abbrev = 
  begin
    let sv = Id.id_of_string "s" in
    let svc = T.cvar sv in
    (exn_stack_abbrev_var,
     T.clam sv T.Kstack (T.ccons (handle_con svc) svc))
  end
let exn_stack_con s = T.capp (T.cvar exn_stack_abbrev_var) s

(* Abbreviate the stack shape common to all labels.
   We need two variables because void functions return nothing in EAX. *)
let stack_abbrev_var = Id.id_of_string "?S"
let stack_abbrev_var_void = Id.id_of_string "?Sv"

let (stack_abbrev, stack_abbrev_void) =
  begin
    let (rv,s1v,s2v) = (Id.id_of_string "?ret",Id.id_of_string "?s1", Id.id_of_string "?s2") in
    let (s1vc,s2vc,rvc) = (T.cvar s1v,T.cvar s2v, T.cvar rv) in
(* Cyclone *)
    let cg_v = Id.id_new "cg" in
    let cg_c = T.cvar cg_v in
(* End Cyclone *)
    let (abbrev,abbrev_void) = 
      let (ret_state,ret_state_void) =
	let ret_ctxt = 
	  let ebp_stk = exn_stack_con s2vc in
	  [ (T.Esp, T.csptr (T.cappend s1vc ebp_stk));
	    (T.Ebp, T.csptr ebp_stk)]
	in
	(T.ccode_l_tla ((T.Eax, rvc):: ret_ctxt)
(* Cyclone *)
           (T.cprod_b [T.cfield cg_c T.ReadWrite])
(* End Cyclone *)
           ,
         T.ccode_l_tla ret_ctxt
(* Cyclone *)
           (T.cprod_b [T.cfield cg_c T.ReadWrite])
(* End Cyclone *)
           )
      in
      let aux r =
        T.clam s1v T.Kstack
          (T.clam s2v T.Kstack
(* Cyclone *)
             (T.clam cg_v T.Ktstack
(* End Cyclone *)
                (T.ccons r s1vc)))
      in
      (T.clam rv T.k4byte (aux ret_state), aux ret_state_void)
    in
    ((stack_abbrev_var,abbrev), (stack_abbrev_var_void, abbrev_void))
  end

(* stack has s1 @ h(s2) @ s2 *)
let stack_con ret_con_opt s1 s2
(* Cyclone *)
    cg
(* End Cyclone *)
    =
  begin match ret_con_opt with
    Some ret_con -> 
(* Cyclone *)
      (T.capp
(* End Cyclone *)
         (T.capp (T.capp (T.capp (T.cvar stack_abbrev_var) ret_con) s1) s2)
(* Cyclone *)
         cg)
(* End Cyclone *)
  | None -> 
(* Cyclone *)
      (T.capp
(* End Cyclone *)
         (T.capp (T.capp (T.cvar stack_abbrev_var_void) s1) s2)
(* Cyclone *)
         cg)
(* End Cyclone *)
  end

let handler_abbrev_var = Id.id_of_string "?Ha"
let handler_abbrev =
  begin
    let (s1v,s2v) = (Id.id_of_string "?s1", Id.id_of_string "?s2") in
    let (s1vc,s2vc) = (T.cvar s1v, T.cvar s2v) in
    let esp_stk = T.ccons (T.csptr (exn_stack_con s2vc))
	(T.cappend s1vc (exn_stack_con s2vc))
    in
    (handler_abbrev_var, T.clam s1v T.Kstack (T.clam s2v T.Kstack esp_stk))
  end

(* Type for an exception handler with local stack s.
   s corresponds to env.stack1_type. *)
let handler_con s1 s2 = (T.capp (T.capp (T.cvar handler_abbrev_var) s1) s2)

let opt_con c = T.chptr [i32_0] (Some c)

let tyvars_to_cons tyvars = (List.map (fun v -> T.cvar (tid_tyv v)) tyvars)
let tyvars_to_lam tyvars con =  
  (List.fold_right (fun v -> T.clam (tid_tyv v) T.k4byte) tyvars con)
let rec tyvars_to_kind ts k=
  begin
    match ts with
      [] -> k
    | (hd::tl) -> tyvars_to_kind tl (T.Karrow(T.k4byte,k))  
  end

(* app_cons : con -> con list -> con. Applies cs to c *)
let app_cons c cs = (List.fold_left (fun c1 c2 -> T.capp c1 c2) c cs)

let rec compress t =
  begin
    let aux r = 
      match !r with 
	None -> t
      |	Some t' -> (let t' = compress t' in r := Some t'; t') 
    in
    match t with
      P.Evar r -> aux r | P.OptionEvar r -> aux r
    | _ -> t
  end


(* raw_name_con : id -> con list -> con *)
let raw_name_con n cs = app_cons (T.clab n) cs
let name_con n cs = raw_name_con (tid_type n) cs
let mem_name_con n cs = raw_name_con (tid_mem n) cs

(* Used to instantiate uninstantiated option evar's *)
let bogus_option_var = Id.id_new "bogus_option"
let bogus_option_con = T.chptr [i32_0] None
let bogus_option_con_block = (bogus_option_var,T.k4byte,bogus_option_con)

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

let fun_coercion stack1 stack2 cg cons =
  cg::(T.Tapp stack2)::(T.Tapp stack1)::
  (List.rev (List.map (fun c -> T.Tapp c) cons))

let branch_coercion env = 
(* Cyclone *)
  (T.Tapp cg_c)::
(* End Cyclone *)
  (T.Tapp stack2_c)::(T.Tapp stack1_c)::
  (List.rev (List.map (fun v -> T.Tapp(T.cvar(tid_tyv v))) env.tyvars))

let fallthru env = 
  let tcons = List.map (fun v -> T.cvar(tid_tyv v)) env.tyvars in
  emit(T.Fallthru (tcons @ [stack1_c;stack2_c
(* Cyclone *)
                               ;cg_c
(* End Cyclone *)
                           ]))

(* Given a code type just attaches forall tyvars,s1,s2. code *)
let close_code tyvars code =
  begin
    List.fold_right (fun v c -> T.cforall (tid_tyv v) T.k4byte c) tyvars
	(T.cforall stack1_v T.Kstack
           (T.cforall stack2_v T.Kstack
(* Cyclone *)
              (T.cforall cg_v T.Ktstack
(* End Cyclone *)
                 code)))
  end

let outermost env = true

(* Cyclone *)
let outermost env =
  let rec aux cs =
    match cs with
      [] -> true
    | (Outermost _)::_ -> true
    | (Hidden _)::cs -> aux cs
    | (Frame _)::_ -> false in
  aux env.cenvs
(* End Cyclone *)

(* Type of a label at an environment.  Copied from emit_lab; we should
   consolidate this. *)
let mk_label_con env =
  begin
    let stack_state = 
      let esp_set = T.rs_set_reg env.regs T.Esp 
	  (T.csptr(T.cappend env.stack1_type (exn_stack_con env.stack2_type))) 
      in
      T.rs_set_reg esp_set T.Ebp (T.csptr (exn_stack_con env.stack2_type))
    in
    let l_con = close_code env.tyvars (T.ccode stack_state) in
    l_con
  end

(* In Cyclone jumps between templates have to be patched.
   Therefore we added emit_jmp, emit_jcc, emit_btagi,
   and emit_btagvar. *)
let emit_jmp env label coercion =
(* Cyclone *)
  if not(outermost env)
  then
    (* Make sure we have a coercion (not just an empty coercion)
       in case the jump is an inter-template jump. *)
    let coercion = branch_coercion env in
    let target_con = mk_label_con env in
    gen_code_mark(M_Jmp(label,ref None,target_con,coercion))
  else
(* End Cyclone *)
    emit (T.Jmp(T.Addr label,coercion))

let emit_jcc env cc label coercion =
(* Cyclone *)
  if not(outermost env)
  then
    let coercion = branch_coercion env in
    let target_con = mk_label_con env in
    gen_code_mark(M_Jcc(cc,label,ref None,target_con,coercion))
  else
(* End Cyclone *)
    emit (T.Jcc(cc,(label,coercion)))

let emit_btagi (reg,i,(label,coercion),condition) env =
(* Cyclone *)
  if not(outermost env)
  then
    let coercion = branch_coercion env in
    let target_con = mk_label_con env in
    gen_code_mark(M_Btagi(reg,i,(label,coercion),condition,ref None,target_con))
  else
(* End Cyclone *)
    emit (T.Btagi(reg,i,(label,coercion),condition))

let emit_btagvar (reg,i1,i2,(label,coercion),condition) env =
(* Cyclone *)
  if not(outermost env)
  then
    let coercion = branch_coercion env in
    let target_con = mk_label_con env in
    gen_code_mark(M_Btagvar(reg,i1,i2,(label,coercion),condition,ref None,target_con))
  else
(* End Cyclone *)
    emit (T.Btagvar(reg,i1,i2,(label,coercion),condition))


(* typ2con : P.typ -> T.con *)
(* Given a popcorn type, it produces the equivalent Tal type (constructor). *)
let rec typ2con t =
  begin
    match t with 
      P.VoidType -> (raise Void_Type)
    | P.Evar r ->
	(* if we have an unconstrained evar then we can instantiate it with 
           * any (4-byte) type so we choose int to make our lives simple. *)
	(match !r with
	  Some t -> typ2con t
	| None -> (r := Some(P.IntType); int_con))
    | P.OptionEvar r ->
	(* here, we must instantiate the evar with a valid "option" type.
	 * bogus_option_... is defined above for this express purpose. *)
	(match !r with
	  Some t -> typ2con t
	| None -> T.clab bogus_option_var)
    | P.VarType v -> T.cvar (tid_tyv v)
    | P.IntType -> int_con
    | P.BooleanType -> bool_con
    | P.StringType -> string_con
    | P.CharType -> char_con
    | P.ArrayType t' -> (array_con (typ2con t'))
    | P.FnType  (vs,t',tl) -> 
	let (res,_,_) = (fun_con vs t' tl) in
	res
    | P.NamedType (n,ts) -> (name_con !n (types2cons ts))
    | P.TupleType ts ->
	let aux t = T.cfield (typ2con t) T.Read in
	T.cprod_b (List.map aux ts)
    | P.ExnType -> exn_con
  end
(* fun_con vs ret_typ params
   vs = type arguments. *)
and fun_con vs 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 =
      match params with
	[] -> a 
      | (hd::tl) ->(try map tl ((typ2con hd) :: a) with Void_Type -> (map tl a))
    in
    let p_cons = List.rev (map params []) in
    let stack_p = (List.fold_right T.ccons p_cons stack1_c)  in
    let ret_con_opt = try Some (typ2con ret_typ) with Void_Type -> None in
    let stack = (stack_con ret_con_opt stack_p stack2_c
(* Cyclone *)
                   cg_c
(* End Cyclone *)
                   ) in
    let exn_stack = exn_stack_con stack2_c in
    let fun_state =
      T.ccode_l_tla [ (T.Esp,T.csptr (T.cappend stack exn_stack));
		      (T.Ebp,T.csptr exn_stack)]
(* Cyclone *)
        (T.cprod_b [T.cfield cg_c T.ReadWrite])
(* End Cyclone *)
    in
    let lab_con = close_code vs fun_state in
    (lab_con,stack,stack2_c)
  end
and types2cons ts = List.map typ2con ts

(* needs_indirect : P.typ -> bool
 * Functions are already pointers so we don't need to indirect to get the 
 * actual value.  In all other cases we do. 
 *)
let needs_indirect t = (match t with P.FnType _ -> false | _ -> true)

(* get the name of a named type *)
let rec get_name t =
  begin
    let aux r = 
      match r with
	None -> impos "get_name: uninstantiated evar"
      | Some t -> get_name t
    in
    match t with
      P.NamedType(n,ts) -> !n
    | P.Evar r -> aux !r | P.OptionEvar r -> aux !r
    | _ -> impos "get_name: unnamed type"
  end

let typ2struct_info env nt = lookup_struct env (get_name nt)
let typ2union_info env nt = lookup_union env (get_name nt)

let struct_field_offset s_info f =
  begin
    let rec aux fields =
      match fields with
	[] -> 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 -> impos "mallocarg2con: nested enname" in
  aux m
;;
 
(* info_structdecl: env -> P.structdecl -> struct_info *)
let info_structdecl env st =
  begin
    let (scope,name,tyvars,null,fields) =
      (st.P.st_scope,st.P.st_name,st.P.st_tyvars,st.P.st_possibly_null,
       st.P.st_fields) 
    in
    
    let tycons = tyvars_to_cons tyvars in
    let tylam = tyvars_to_lam tyvars in    
    let kind = tyvars_to_kind tyvars T.k4byte in

    let mem_kind = 
      let base_kind = T.Kmemi (to_i32 (4 * (List.length fields))) in
      tyvars_to_kind tyvars base_kind
    in
    let offset = ref 0 in
    let post_incr  i = (let j = !i in i:=j+1;j) in
    let info_field typ2con sf =
      begin
	let (n,cap,t) = sf in
	let con = typ2con t in
	let t_cap = 
	  match cap with
	    P.ReadOnly -> T.Read
	  | P.ReadWrite -> T.ReadWrite
	in
	(n,post_incr offset,(con,t_cap))
      end 
    in
    let field_infos = List.map (info_field typ2con) fields in

    let aux (_,_,(con,cap)) = T.cfield con cap in
    let struct_mem_con' = T.cprod (List.map aux field_infos) in

    let struct_con = tylam (T.chptr 
			      (if null then [i32_0] else []) 
			      (Some (mem_name_con name tycons)))
    in
    let struct_mem_con = tylam struct_mem_con' in

    { struct_arity = List.length tyvars;
      sfield_infos = field_infos;
      struct_null = null;
      struct_con = struct_con;
      struct_mem_con = struct_mem_con;
      struct_kind = kind;
      struct_mem_kind = mem_kind
    }
  end

(* info_uniondecl: env -> P.uniondecl -> union_info *)  
let info_uniondecl env ud =
  begin
    if ud.P.un_possibly_null
    then unimpl "info_uniondecl : option unions.";
    let (scope,name,tyvars,union_fields) = 
      (ud.P.un_scope, ud.P.un_name, ud.P.un_tyvars, ud.P.un_fields) 
    in

    let tylam = tyvars_to_lam tyvars in
    let kind = tyvars_to_kind tyvars T.k4byte in

    let rec sort_fields fields void_fields value_fields =
      begin match fields with
	[] -> (List.rev void_fields, List.rev value_fields)
      |	((f,P.VoidType) :: tl) -> sort_fields tl (f::void_fields) value_fields
      |	((f,t)::tl) -> sort_fields tl void_fields ((f,t)::value_fields)
      end 
    in
    let (void_fields, value_fields) = sort_fields union_fields [] [] in
    let value_field_con (f,t) = (f,typ2con t) in
    let value_field_cons = List.map value_field_con value_fields in

    let i = ref 1 in
    let post_incr i = (let j = !i in  i:=j+1;to_i32 j) in
    let void_infos = List.map (fun f -> (f,post_incr i)) void_fields in
    
    let value_info (f,con) =
      let j = post_incr i in
      (f,(j,con))
    in
    let value_infos =
      try
	List.map value_info value_field_cons
      with Void_Type -> impos "info_uniondecl: void_type"
    in
    let tags = List.map (fun (n,i) -> i) void_infos in
    let sum = 
      match value_infos with
	[] -> None
      | _ ->
	  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
    { union_tyvars = List.map tid_tyv tyvars; (* Dan fix for UnionSwitch *)
      void_infos = void_infos;
      value_infos = value_infos;
      single_value_case = (List.length value_infos) = 1;
      union_con = tylam (T.chptr tags sum);
      union_kind = kind;
      union_null= ud.P.un_possibly_null
    } 	
  end

let mk_fenv fd =
  begin
    let tyargs = fd.P.fn_tyvars in
    let ret_typ = fd.P.fn_ret_type in
    let args = fd.P.fn_args in
    let params = List.map (fun (x,t) -> t) args in
    let (_,stack1_type,stack2_type) = fun_con tyargs ret_typ params in
    let depth = ref 0 in
    let aux (x,t) = (x,(typ2con t, (incr depth; !depth))) in
    let local_env = List.map aux args in
    { f_tyvars = tyargs;
      f_local_env = List.rev local_env;
      f_args_on_stack = List.length local_env;
      f_stack1_type = stack1_type;
      f_stack2_type = stack2_type;
      f_break_label = None;
      f_continue_label = None;
      f_regs =
(* Cyclone *)      
      T.rs_set_tla
(* End Cyclone *)      
        T.rs_empty
(* Cyclone *)      
        (T.cprod_b [T.cfield cg_c T.ReadWrite])
(* End Cyclone *)      
    }
  end

(**********************************Utilities::Exp******************************)

let pop_exit_label   = Id.id_of_string "_tal_exit";;
let new_array_label  = Id.id_of_string "_new_array";;
let never_null_label = Id.id_of_string "_pop_never_null";;
let exn_handler_label = Id.id_of_string "_pop_exn_handler";;
let main_label       = Id.id_of_string "__main$";;

let main_id = "main";;
let (tal_main_code_block,tal_main_con) = 
  begin
    let tal_main_label = Id.id_of_string "_tal_main" in
    let tal_main_con =
      T.ccode_l_tla [(T.Esp,T.csptr T.cempty)]
(* Cyclone *)
        (T.cprod_b [ T.cfield (dc T.Ctempty) T.ReadWrite ])
(* End Cyclone *)
    in
    let tal_main_code = 
      [|T.Push (T.Addr exn_handler_label,[]);
	T.Mov (T.Reg T.Ebp, (T.Reg T.Esp,[]));
	T.Call (T.Addr main_label,[
(* Cyclone *)
                T.Tapp (dc T.Ctempty);
(* End Cyclone *)
                T.Tapp T.cempty;
                T.Tapp T.cempty]);
	T.Pop (T.Reg T.Ebx); 
	T.Push (T.Immed i32_0,[]);
	T.Jmp (T.Addr pop_exit_label,[T.Tapp T.cempty])
      |] 
    in
    ((tal_main_label,Some tal_main_con,tal_main_code),tal_main_con)
  end

let bool b = (T.Immed (if b then i32_1 else i32_0),[T.Tosum bool_con]);;

let exp2typ e = deSome e.P.exp_typ
let exp2con e = typ2con (exp2typ e)

let rec is_value e =
  begin
    match e.P.raw_exp with
      P.Const _ -> true
    | P.Var _ -> true
    | P.StructMember (e',_) -> is_value e'
    | P.TupleMember(e',i) -> is_value e'
    | P.Primop(p,[e']) ->
	(is_value e' & 
	 match p with
	   P.Bitnot -> true
	 | P.Size -> true
	 | P.Ord -> true
	 | P.Chr -> true
	 | _ -> false)
    | P.NewUnion(nt,_,f,eo) ->
	(match eo with
	  None -> true
	| _ -> false)
    | _ -> false
  end

(* roll_struct: struct_info -> P.string -> T.con list -> T.coercion list
   Coerces a value to a struct name. *)
let roll_struct s_info name cs =
  begin
    let coerce_to_mem = T.Roll (app_cons s_info.struct_con cs ) in
    let coerce_to_sum = T.RollTosum (name_con name cs) in
    let coerce = T.Roll (name_con name cs) in
    if s_info.struct_null
    then [coerce_to_sum;coerce_to_mem]
    else [coerce;coerce_to_mem]
  end

(**********************************Utilities::Env******************************)

(* push_con : env -> reg -> con -> env, pushes reg onto the stack, giving the
 * type con to the value.  Sort of like declaring a temporary variable
 * of type con.
 *)
let push_con (env:env) reg reg_con =
  let new_local_env = ("*BOGUS*",(int_con,0)) ::
    (List.map (fun (v,(c,i)) -> (v,(c,i+1))) env.local_env) 
  in
  let new_stack1_type = T.ccons reg_con env.stack1_type in
  emit (T.Push (T.Reg reg, []));
  { env with local_env = new_local_env; stack1_type = new_stack1_type }

(* push : env -> reg -> typ -> env. Pushes a reg of typ onto the stack, *)
let push (env:env) reg (t:P.typ) = push_con (env:env) reg (typ2con t) 

(* Records that a register has a given type.  This is rarely used as it's
 * only necessary when we need to preserve a register across a label.  
 * For example, when doing a switch that involves a bunch of tests, we
 * need to record the type of Eax as we flow across the tests.
 *)
let add_reg env reg c =
  { env with regs = T.rs_set_reg env.regs reg c }

(* 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_stack1_type = T.ccons con env.stack1_type in    
    { env with local_env = new_local_env; stack1_type = new_stack1_type }
  end

let set_loop_labels env loopend looptest = 
  begin
  let stack_depth = List.length env.local_env in
  { env with break_label = Some (loopend,stack_depth); 
          continue_label = Some(looptest,stack_depth) }     
  end

(* We call this on entry to a try block. 
   The stack has shape handler::old_ebp::.... but env does not record the
   handler yet. We need to record the location of old_ebp. *)
let try_body_env env =
  begin
    let new_stack1 = T.cempty in
    let new_stack2 = T.cappend env.stack1_type (exn_stack_con env.stack2_type)
    in
    (* We have pushed the handler but it doesn't show up in stack1 or stack2.
       So we have to update the offsets for all the variables on the stack. *)
    let new_local_env = ("*BOGUS*",(int_con,0)) :: 
      (List.map (fun (x,(c,i)) -> (x,(c,i+1))) env.local_env) 
    in
    let old_ebp_offset = List.length env.local_env in
    { env with local_env = new_local_env; 
             stack1_type = new_stack1; 
             stack2_type = new_stack2;
            sptr_offsets = old_ebp_offset :: env.sptr_offsets
    }
  end

(*********************************Code Generation******************************)
(*****************************Code Generation::Support*************************)

let add_string s = 
  begin
    let lab = Id.id_new "string" in
    let len = to_i32 (String.length s) in
          (* Fix by Dan *)
    let l   = if (String.length s) = 0 then [] else [T.Dbytes s] in 
    gen_data_block (lab,None,
		    (T.D4bytes (len,[]):: T.Dup ::l,
		     [ T.Pack (T.pcint len,string_con);
		       T.Toarray (i32_4,0,T.cfield (T.pcbytes T.Byte1)
				    T.ReadWrite)
		     ]));
    lab
  end

let emit_lab env l = 
  begin
    let stack_state = 
      let esp_set = T.rs_set_reg env.regs T.Esp 
	  (T.csptr(T.cappend env.stack1_type (exn_stack_con env.stack2_type))) 
      in
      T.rs_set_reg esp_set T.Ebp (T.csptr (exn_stack_con env.stack2_type))
    in
    let l_con = close_code env.tyvars (T.ccode stack_state) in
    emit_label l (Some l_con)
  end
let emit_lab_nocon env l =
(* Cyclone *)
  if not(outermost env)
  then (fallthru env; emit_lab env l)
  else
(* End Cyclone *)
    emit_label l None

let emit_handler env l =
  begin
    let code = 
      T.ccode_l [ (T.Eax,exn_con);
		  (T.Esp,T.csptr(handler_con env.stack1_type env.stack2_type))]
    in
    let l_con = close_code env.tyvars code in
    emit_label l (Some l_con)
  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 (to_i32 (4*i)))))

(* 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,[]),to_i32 (4*i)),[])))

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

let arith_op p =
  begin 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
  | _ -> impos "arith_op: Expected arithmetic operator."
  end

let arithsr_op p =
  begin match p with
    P.Bitlshift -> T.Shl | P.Bitlrshift -> T.Shr | P.Bitarshift -> T.Sar
  | _ -> impos "arithsr_op: Expected arith_sr operator."
  end

let cond_op p = 
  begin 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
  | _ -> impos "cond_op : Expect conditional op."
  end
    
(******************************Code Generation::Main***************************)
(* cg_bop : env -> P.Primop -> stack_or_reg -> con option
 * Code generate a binary operator.
 * 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 = arith_op p 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 = arithsr_op p 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 reg2 = get_val T.Ecx in
	  emit(T.Conv T.Cdq);
	  emit(T.ArithMD (T.Idiv,T.Reg reg2));
	  begin
	    match p with 
	      P.Mod -> emit(T.Mov (T.Reg T.Eax, (T.Reg T.Edx,[])))
	    | P.Div -> ()
	    | _ -> impos "cg_binop3"
	  end;
	  None
	end		
    | (P.Gt | P.Lt | P.Gte | P.Lte | P.Eq | P.Neq) ->
	begin
	  let op = cond_op p 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
    | _ -> impos "cg_exp: Binary Primop"  
  end

(* EAX is "caller"-save. Results are returned in EAX *)
let rec cg_exp_push env e = (cg_exp env e; push env T.Eax (exp2typ e))
and cg_exp env e = 
  begin
    match e.P.raw_exp with
      P.Const c ->
	begin
	  let cgop = 
	    match c with
	      P.Int i    -> (T.Immed i,[])
	    | P.Bool b   -> (bool b)
	    | P.String s -> (T.Addr (add_string s),[])
	    | P.Char c   -> (T.Immed (to_i32 (Char.code c)),[])
	    | P.Null     -> (T.Immed i32_0,[T.RollTosum (exp2con e)])
	  in 
	  emit(T.Mov(T.Reg T.Eax,cgop))
	end  
    | P.ConstArray (es,ot) -> 
	begin
	  let length = List.length es in
	  let scale = 4 in
	  let real_size = to_i32 ((length * scale) + 4) in
	  let typ = 
	    match (es,ot) with
	      (_,Some t) -> t 
	    | (hd::tl,None) -> exp2typ hd
	    | _ -> (impos "cg_exp : ConstArray without type.") 
	  in
	  let con = typ2con typ in
	  let cons = (* List of cons equal to length of constant array *) 
	    let rec aux i a = if i=0 then a else aux (i-1) (con::a) in
	    aux length []
	  in
	  let size_con = T.csing (T.pcint (to_i32 length)) in
	  let mallocarg = T.Mprod [T.Mfield size_con; T.malloc_prod cons] in
	  (* con_uninit i = The con with the first i fields uninitialized.
	     Note we initialize from right-to-left. *)
	  let con_uninit i = 
	    let init_field = T.cfield con T.ReadWrite in
	    let uninit_field = T.cfield con T.Uninit in
	    let size_con = T.cfield size_con T.ReadWrite in
	    let rec aux pos a =
	      if pos<=0 then a 
	      else if pos>i then aux (pos-1) (init_field :: a)
	      else aux (pos-1) (uninit_field :: a)
	    in
	    T.cprod_b [size_con; T.cprod (aux length [])]
	  in
	  let rec cg_fields env' elt es =
	    begin match es with
	      [] -> env'
	    | (hd::tl) ->
		begin
		  let offset = to_i32 ((elt-1)*scale+4) (*4 for tag*) in
		  cg_exp env' hd;
		  pop T.Ebx;	    
		  emit(T.Mov (T.Prjr ((T.Ebx,[]),offset),(T.Reg T.Eax,[])));
		  let con = con_uninit (elt-1) in
		  let env'' = push_con env T.Ebx con in
		  cg_fields env'' (elt-1) tl
		end
	    end
	  in
	  emit (T.Malloc (real_size,mallocarg));
          (* Initialize the tag. *)
	  let length' = to_i32 length in
	  emit(T.Mov (T.Prjr ((T.Eax,[]),i32_0),(T.Immed length',[])));
	  let env' = push_con env T.Eax (con_uninit length) in
	  let env'' = (cg_fields env' length (List.rev es)) in
	  pop T.Eax;
	  emit(T.Coerce(T.Eax,[ T.Pack (T.pcint length',array_con con);
				T.Toarray (i32_4,0,T.cfield con T.ReadWrite)
			      ]));
	  ()
	end
    | P.Var x ->
	begin
	  try 
           let (c,offset) = List.assoc x env.local_env in
	   let offset = to_i32 (4*offset) in
	   emit (T.Mov(T.Reg T.Eax,(T.Prjr((T.Esp,[]),offset),[])))
	  with Not_found -> 
	    begin
	      try 
	      	let t = lookup_global env x in
              	let n = tid_val x in
              	let src = if needs_indirect t  then T.Prjl ((n,[]),i32_0) 
              	else  T.Addr n in
              	emit(T.Mov(T.Reg T.Eax,(src,[])))
	      with Dict.Absent -> 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))
	  | P.Size -> 
	      begin
	      	emit (T.Unpack (array_size_var,T.Eax,(T.Reg T.Eax,[])));
	      	emit (T.Mov (T.Reg T.Eax,(T.Prjr ((T.Eax,[]),i32_0),[])));
	      	emit (T.Coerce (T.Eax,[T.Subsume T.cbyte4]))
	      end
	  | P.Ord -> () (* do nothing *)
	  | P.Chr -> () (* do nothing *)
	  | _ -> impos "cg_exp: Unary op expected."
	end
    | P.Primop(p,[e1;e2]) ->
	begin
	  let env' = cg_exp_push env e2 in
	  cg_exp env' e1;
	  cg_bop env' p TopStack; ()
	end
    | P.Primop _ -> impos "cg_exp: ?? Primop"
    | P.Conditional (e1,e2,e3) ->
	begin
	  let true_lab = Id.id_new "condtrue" in
	  let false_lab = Id.id_new "condfalse" in
      	  let end_lab = Id.id_new "condend" in
	  cg_bool_exp env e1 (true_lab,[]) (false_lab,[]) true;
	  emit_lab_nocon env true_lab;
	  cg_exp env e2;
	  emit_jmp env end_lab [];
	  emit_lab_nocon env false_lab;
	  cg_exp env e3;
	  emit_lab_nocon env end_lab
	end
    | P.Assign (e1,e2) -> 
	begin
	  cg_exp env e2;
	  cg_lhs_exp env (exp2typ e2) e1 None;
	end
    | P.AssignOp (e1,p,e2) ->
	begin	
	  cg_exp env e2;
	  cg_lhs_exp env (exp2typ e2) e1 (Some p);
  	end
    | P.FunCall (e,ts,es) ->
	begin
	  let ts = deSome !ts in
	  let coercion =
            fun_coercion env.stack1_type env.stack2_type
(* Cyclone *)
              (try T.Tapp (get_cyclone_con env)
              with
                x ->
                  (match e.P.raw_exp with
                    P.Var z ->
                      (Printf.printf "Cyclone error in funcall %s\n" z;
                       raise x)
                  | _ -> raise x))
(* End Cyclone *)
              (types2cons ts) in
	  let env' = List.fold_left cg_exp_push env (List.rev es) in
	  cg_exp env' e;
	  emit(T.Call (T.Reg T.Eax,coercion));
	  pop_free (List.length es)
	end
    | P.NewStruct(n,ts,es) -> 
	begin
	  let cs = List.map typ2con (deSome(!ts)) in
	  let es_cs = List.map exp2con es in
	  let s_info = lookup_struct env n in
	  let num_fields = (List.length es) in
	  let mallocarg = T.malloc_prod es_cs in
	  let rev_es = List.rev es in
	  (* for expressions that we can't calculate easily (e.g., constants)
	   * and that might involve control-flow, we calculate the result and
	   * push it on the stack. *)
	  let cg_field envs e = 
	    if is_value e 
	    then envs 
	    else (cg_exp_push (List.hd envs) e)::envs in
	  let envs = (List.fold_left cg_field [env] rev_es) in
	  (* Do the malloc *)
	  emit (T.Malloc (to_i32 (4*num_fields),mallocarg));
	  emit (T.Mov (T.Reg T.Ebx,(T.Reg T.Eax,[])));
	  let rec store_field es offset envs = 
	    match es with
	      [] -> ()
	    | e::es ->
		  (* If we've generated t he value and pushed it on the stack,
		   * then pop it off, otherwise generate code for the value. *)
		  let envs = 
		    if is_value e 
		    then ((cg_exp (List.hd envs) e); envs)
		    else (pop T.Eax; List.tl envs) in
		  begin
		    emit (T.Mov (T.Prjr ((T.Ebx,[]),i32_4*$offset),
				 (T.Reg T.Eax,[])));
		    store_field es (offset +$ i32_1) envs
		  end
	  in store_field es i32_0 envs;
	  emit(T.Mov(T.Reg T.Eax,(T.Reg T.Ebx,roll_struct s_info n cs)))
	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
	  let unroll = [T.Unroll;T.Unroll] in
	  emit(T.Coerce(T.Eax,unroll));
	  (if s_info.struct_null then check_not_null T.Eax env);
	  emit(T.Mov (T.Reg T.Eax,
		      (T.Prjr ((T.Eax,[]),to_i32 (4*offset)),[])))
	end
    | P.NewUnion (nt,ts,f,eo) ->
	begin
	  let u_info = typ2union_info env (exp2typ e) in
	  let cs = types2cons (deSome !ts) 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.Immed tag,[T.RollTosum (name_con nt cs)])))
	      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
		let tag_con = T.csing (T.pcint tag) in
		let e'_con = exp2con e' in
		let mallocarg = T.malloc_prod [tag_con;e'_con] in 
		if is_value e' then
		  (* don't have to calculate e' until after the malloc *)
		  begin
		    emit (T.Malloc(i32_8,mallocarg));
		    emit (T.Mov(T.Reg T.Ebx,(T.Reg T.Eax,[])));
		    emit (T.Mov(T.Prjr ((T.Ebx,[]),i32_0),(T.Immed tag,[])));
		    cg_exp env e';
		    emit (T.Mov(T.Prjr ((T.Ebx,[]),i32_4),(T.Reg T.Eax,[])));
		    emit (T.Mov(T.Reg T.Eax,(T.Reg T.Ebx,
					     [T.RollTosum (name_con nt cs)])));
		  end
		else
		  (* generate code for e', push it, and then malloc *)
		  begin
		    cg_exp env e';
		    (emit (T.Push (T.Reg T.Eax,[]));
		     emit (T.Malloc (i32_8,mallocarg));
		     emit (T.Pop (T.Reg T.Ebx));
		     emit (T.Mov(T.Prjr ((T.Eax,[]),i32_4),(T.Reg T.Ebx,[])));
		     emit (T.Mov(T.Prjr ((T.Eax,[]),i32_0),(T.Immed tag,[])));
		     emit (T.Coerce (T.Eax,[T.RollTosum (name_con nt cs)])))
		  end
	      end 
	  with Not_found-> impos "cg_exp: NewUnion: No such tag."
	end
    | P.NewTuple es ->
	(* similar to NewStruct *)
	let num_fields = (List.length es) in
	let margs = List.map exp2con 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 envs = List.fold_left
	    (fun envs e -> 
	      if is_value e 
	      then envs 
	      else (cg_exp_push (List.hd envs) e)::envs)
	    [env] (List.rev es) in
	emit (T.Malloc (to_i32 (4*num_fields),mallocarg));
	emit (T.Mov (T.Reg T.Ebx,(T.Reg T.Eax,[])));
	let rec init_loop es offset envs = 
	  match es with
	    [] -> ()
	  | e::es ->
	      let envs =
		if is_value e 
		then ((cg_exp (List.hd envs) e); envs)
		else (pop T.Eax; List.tl envs) in
	      let dest = T.Prjr((T.Ebx,[]),i32_4 *$ offset) in
	      emit(T.Mov(dest,(T.Reg T.Eax,[])));
	      init_loop es (offset +$ i32_1) envs
	in
	init_loop es i32_0 envs;
	emit (T.Mov (T.Reg T.Eax,(T.Reg T.Ebx,[T.Subsume c])))
    | P.TupleMember(e,i) ->
	cg_exp env e;
	emit(T.Mov (T.Reg T.Eax,
		    (T.Prjr((T.Eax,[]),to_i32 (4*(i-1))),[])));
    | P.Subscript (e1,e2) ->
	begin
	  let env' = cg_exp_push env e2 in
	  cg_exp env' e1;
	  pop T.Ebx;
	  emit (T.Unpack (array_size_var,T.Eax,(T.Reg T.Eax,[])));
	  match exp2typ e1 with 
	    P.StringType -> 
	      emit (T.Mov (T.Reg T.Ecx,(T.Immed i32_0,[])));
	      emit (T.Asub (T.Ecx, T.Prjr ((T.Eax,[]),i32_4), i32_1, T.Ebx,
			    T.Prjr ((T.Eax,[]),i32_0)));
	      emit (T.Mov (T.Reg T.Eax,(T.Reg T.Ecx,[])))
	  | _ -> emit (T.Asub (T.Eax, T.Prjr ((T.Eax,[]),i32_4), i32_4, T.Ebx,
			       T.Prjr ((T.Eax,[]),i32_0)))
	end
    | P.NewArray(e1,e2) -> (* e1 is the size, e2 is the initializer. *)
	begin
	  let env' = cg_exp_push env e2 in
	  let env'' = cg_exp_push env' e1 in
	  (* FMS: new_array only treats EBP as callee-save.  It knows nothing 
	     about exceptions so we need the following special type 
	     applications for the call. *)
	  emit(T.Call (T.Addr new_array_label,
		       [ T.Tapp (exp2con e2); 
			 T.Tapp (T.csptr (exn_stack_con env.stack2_type));
			 T.Tapp (T.cappend env.stack1_type (exn_stack_con env.stack2_type))]));
	  pop_free 2
	end
    | P.NewExn (x,eopt) -> 
	begin	  
	  let con = 
	    try typ2con (lookup_exn env x) with Void_Type -> T.cbyte4 
	  in
	  let con' = T.cfield con T.Read in
	  let mallocarg = 
	    T.Mprod [ T.Mfield (T.capp T.pcexnname con'); T.Mfield con] 
	  in
	  (* Construct the exn *)
	  (match eopt with 
	    None -> emit (T.Mov (T.Reg T.Eax,(T.Immed i32_0,[])))
	  | Some e' -> cg_exp env e');
	  emit(T.Push (T.Reg T.Eax,[]));
	  emit(T.Malloc(i32_8,mallocarg));
	  emit(T.Pop (T.Reg T.Ebx));
	  emit(T.Mov (T.Prjr ((T.Eax,[]),i32_4),(T.Reg T.Ebx,[])));
	  emit(T.Mov (T.Reg T.Ebx,(T.Addr (tid_exn x),[])));
	  emit(T.Mov (T.Prjr ((T.Eax,[]),i32_0),(T.Reg T.Ebx,[]))); 
	  emit(T.Coerce (T.Eax,[T.Toexn]))
	end
    | P.Raise e ->
	begin
	  cg_exp env e;
	  emit (T.Mov (T.Reg T.Esp,(T.Reg T.Ebp,[])));
	  emit (T.Pop (T.Reg T.Ebx));
	  emit (T.Jmp (T.Reg T.Ebx,[]))
	end
(* Cyclone *)
    | P.Codegen fd ->
        let env = flush_vis_fenv env in
        let fn_con = abbrev_con(
          typ2con (P.FnType(fd.P.fn_tyvars,
                            fd.P.fn_ret_type,
			    List.map (fun (v,t) -> t) fd.P.fn_args)))
        in
        let cg_type = get_cyclone_con env in
        let cg_type = dc(T.Ctcons(dc(T.Ctrgn(fn_con,Some fn_con,[])),
                                  cg_type)) in
        let env = put_vis_cg_type env cg_type in
        let fenv2 = mk_fenv fd in
        let cenvs =
          match env.cenvs with
            [] -> [ Frame(fenv2); Outermost(get_vis_fenv env) ]
          | cenvs' -> Frame(fenv2)::cenvs' in
        let env2 =
          { env with
            tyvars = fenv2.f_tyvars;
            local_env = fenv2.f_local_env;
            args_on_stack = fenv2.f_args_on_stack;
            stack1_type = fenv2.f_stack1_type;
            stack2_type = fenv2.f_stack2_type;
            break_label = fenv2.f_break_label;
            continue_label = fenv2.f_continue_label;
            regs = fenv2.f_regs;
            cenvs = cenvs } in
        let pre_con = abbrev_con(mk_label_con env2) in
        emit(T.CgStart fn_con);
        gen_code_mark(M_TemplateBeg(Id.id_new "tmpl_start",
                                    Id.id_new "tmpl_end",
                                    pre_con,
                                    get_vis_fenv env));
        cg_fundecl env2 fd;
        let env3 =
          { env with
            cenvs = (Hidden fenv2)::env.cenvs } in
        cg_fill_holes env3 None true;
        emit(T.CgEnd T.Eax)
    | P.Fill e -> 
        begin
          match env.cenvs with
            [] ->
              impos "fill can only be used within a codegen or splice"
          | (Outermost _)::_ ->
              impos "fill can only be used within a codegen or splice"
          | (Frame _)::_ ->
	      let temp_id =
                let rec aux marks depth =
                  match marks with
                    [] -> impos "can't find template id"
                  | M_TemplateBeg(temp_id,_,_,_)::tl ->
                      if depth=0 then temp_id
                      else aux tl (depth-1)
                  | (M_TemplateEnd _)::tl -> aux tl (depth+1)
                  | _::tl -> aux tl depth
                in aux (gen_state.code_marks) 0 in
              let hole_id = Id.id_new "hole" in
              emit(T.CgHole(T.Eax, temp_id, hole_id));
              gen_code_mark(M_Fill(hole_id,e))
          | (Hidden _)::_ -> impos "fill cannot be used within a cut"
        end
(* End Cyclone *)
  end

(* generates code for a boolean expression that's part of a test --
 * avoids generating the boolean value and instead branches to the
 * appropriate label based on the test.  Special support for && and ||
 * is baked in to generate (surprisingly) decent code.
 *
 * true_l is the label to branch to if the expression evaluates to true,
 * false_l is the label to branch to if the expression evaluates to false.
 * true_is_fallthru = true when the true_l is the next block, whereas
 * true_is_fallthru = false when the false_l is the next block. 
 *)
and cg_bool_exp env e true_l false_l true_is_fallthru = 
  match e.P.raw_exp with
    P.Const (P.Bool b) ->
      if b & (not true_is_fallthru) then
	emit_jmp env (fst true_l) (snd true_l)
      else if (not b) & true_is_fallthru then
	emit_jmp env (fst false_l) (snd false_l)
      else ()
  | P.Primop(P.Not,[e]) -> 
      cg_bool_exp env e false_l true_l (not true_is_fallthru)
  | P.Primop(((P.Gt | P.Lt | P.Gte | P.Lte | P.Eq | P.Neq) as p),[e1;e2]) ->
      begin
      	let env' = cg_exp_push env e2 in
	cg_exp env' e1;
	emit(T.Pop (T.Reg T.Ecx));
	emit(T.Cmp (T.Reg T.Eax,T.Reg T.Ecx));
	if true_is_fallthru then
          let (lab,coerce) = false_l in
	  emit_jcc env (T.negate_condition(cond_op p)) lab coerce
	else 
          let (lab,coerce) = true_l in
	  emit_jcc env (cond_op p) lab coerce
      end
  (* special case for e1 && e2 *)
  | P.Conditional(e1,e2,{P.raw_exp = P.Const(P.Bool false)}) ->
      begin
	let true_l2 = Id.id_new "condtrue" in
	cg_bool_exp env e1 (true_l2,[]) false_l true;
	emit_lab_nocon env true_l2;
	cg_bool_exp env e2 true_l false_l true_is_fallthru;
      end
  (* special case for e1 || e2 *)
  | P.Conditional(e1,{P.raw_exp = P.Const(P.Bool true)},e2) ->
      begin
	let false_l2 = Id.id_new "condfalse" in
	cg_bool_exp env e1 true_l (false_l2,[]) false;
	emit_lab_nocon env false_l2;
	cg_bool_exp env e2 true_l false_l true_is_fallthru;
      end
  | P.Conditional(e1,e2,e3) ->
      begin
	let true_l2 = Id.id_new "condtrue" in
	let false_l2 = Id.id_new "condfalse" in
	let end_l = Id.id_new "condend" in
	cg_bool_exp env e1 (true_l2,[]) (false_l2,[]) true;
	emit_lab_nocon env true_l2;
	cg_bool_exp env e2 true_l false_l true;
	emit_jmp env end_l [];
	emit_lab_nocon env false_l2;
	cg_bool_exp env e3 true_l false_l true;
	emit_lab_nocon env end_l;
      end
  | _ ->
      begin
	cg_exp env e;
	if true_is_fallthru then
	  emit_btagi (T.Eax,i32_0,false_l,T.Eq) env
	else 
	  emit_btagi (T.Eax,i32_1,true_l,T.Eq) env
      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 e2type 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,[]),to_i32 (4*offset)))
	    with Not_found -> 
	      begin
	      	try 
                  let t = lookup_global env x in
                  let n = tid_val x in
                  if needs_indirect t 
                  then T.Prjl ((n,[]),i32_0)
                  else T.Addr n
	      	with Dict.Absent -> impos "cg_exp: Var without type."
	      end in
	  (match op_opt with
	    None -> ()
	  | Some op ->
	      let env' = push env T.Eax e2type 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 e2type 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,[]),to_i32 (4*offset)))
	  in
	  let unroll = [T.Unroll;T.Unroll] in
	  match op_opt with
	    None -> 
	      begin
		pop T.Ebx;
		emit(T.Coerce(T.Eax,unroll));
		(if struct_info.struct_null then check_not_null T.Eax env);
		emit(T.Mov (gop T.Eax,(T.Reg T.Ebx,[])))
	      end
	  | Some op ->
	      begin
		let env'' = push env' T.Eax (exp2typ e) in (* Eax has address of struct.*)
		emit (T.Coerce (T.Eax,unroll));
		(if struct_info.struct_null then check_not_null T.Eax env);
		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 env);
		emit (T.Coerce (T.Ebx,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 e2type in 
	  cg_exp env' e2;
	  let env'' = push env' T.Eax (exp2typ e2) 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,[]),i32_4), i32_4, T.Ebx, T.Eax,
			      T.Prjr ((T.Ecx,[]),i32_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,[]),i32_4), i32_4, T.Ebx,
			      T.Prjr ((T.Ecx,[]),i32_0)));
		cg_bop env op (Stack 0);
          	emit (T.Aupd (T.Prjr ((T.Ecx,[]),i32_4), i32_4, T.Ebx, T.Eax,
			      T.Prjr ((T.Ecx,[]),i32_0)));
		pop_free 1
	      end
	end
    | _ -> impos "cg_lhs_exp: Not allowed by type-checker."
  end

(* Cyclone *)
(****************************************************************)
(* cg_fill_holes is called at the end of a template to generate *)
(* code to dump the template and fill its holes.                *)
(****************************************************************)
and cg_fill_holes cenv0 post_con_opt restore_stack =
  begin
    (* Scan back in the TAL code that has been emitted so far,
    ** until we reach the beginning of the template.  Gather
    ** the labels and holes of the template, as well as 
    ** any jumps in the template.  Also gather the environment
    ** in effect just before the template code was emitted. *)
    let rec gather marks labels holes jumps depth =
      begin
        match marks with
          [] -> impos "gather"
        | M_Fill(hole_id,e)::tl ->
            if depth=0 then gather tl labels ((hole_id,e)::holes) jumps depth
            else gather tl labels holes jumps depth
        | M_Label(i,Some c)::tl -> 
            if depth=0
            then gather tl ((i,abbrev_con c)::labels) holes jumps depth
            else gather tl labels holes jumps depth
        | M_Label(i,None)::tl -> gather tl labels holes jumps depth
        | (M_Jmp _ as m)::tl ->
            if depth=0 then gather tl labels holes (m::jumps) depth
            else gather tl labels holes jumps depth
        | (M_Jcc _ as m)::tl ->
            if depth=0 then gather tl labels holes (m::jumps) depth
            else gather tl labels holes jumps depth
        | (M_Btagi _ as m)::tl ->
            if depth=0 then gather tl labels holes (m::jumps) depth
            else gather tl labels holes jumps depth
        | (M_Btagvar _ as m)::tl ->
            if depth=0 then gather tl labels holes (m::jumps) depth
            else gather tl labels holes jumps depth
        | M_TemplateBeg(tmpl_id,_,pre_con,fenv)::tl ->
            if depth=0 then (tmpl_id,pre_con,labels,holes,jumps,fenv)
            else gather tl labels holes jumps (depth-1)
        | (M_TemplateEnd _)::tl -> gather tl labels holes jumps (depth+1)
        | (M_ISeq _)::tl -> gather tl labels holes jumps depth
        | (M_TypeAbbrev _)::tl -> gather tl labels holes jumps depth
      end in
    let (this_tmpl,pre_con,labels,holes,jumps,fenv) =
      gather (gen_state.code_marks) [] [] [] 0 in
    List.iter (fun (l,_) -> Hashtbl.add tmpl_of_label l this_tmpl) labels;
    (* Type variable for the template copy *)
    let tmpl_tv = Id.id_new "tv" in
    (* Find out which jump targets are not defined in the template;
    ** these are inter-template jumps that will have to be patched. *)
    let jumps = List.concat (List.map
        (fun m ->
          match m with
            M_Jmp(t,x,c,coercion) ->
              if List.exists (fun (i,_) -> t=i) labels then []
              else begin
                let hole = Id.id_new "jump_hole" in
                x := Some(this_tmpl,hole);
                [(t,c,this_tmpl,hole,
                  fun (a,b,c,d,e,f) -> T.CgFillJmp(a,b,c,d,e,f))]
              end
        | M_Jcc(cc,t,x,c,coercion) ->
              if List.exists (fun (i,_) -> t=i) labels then []
              else begin
                let hole = Id.id_new "jcc_hole" in
                x := Some(this_tmpl,hole);
                [(t,c,this_tmpl,hole,
                  fun (a,b,c,d,e,f) -> T.CgFillJcc(a,b,c,d,e,f))]
              end
        | M_Btagi(_,_,(t,_),_,x,c) ->
              if List.exists (fun (i,_) -> t=i) labels then []
              else begin
                let hole = Id.id_new "btagi_hole" in
                x := Some(this_tmpl,hole);
                [(t,c,this_tmpl,hole,
                  fun (a,b,c,d,e,f) -> T.CgFillBtag(a,b,c,d,e,f))]
              end
        | M_Btagvar(_,_,_,(t,_),_,x,c) ->
              if List.exists (fun (i,_) -> t=i) labels then []
              else begin
                let hole = Id.id_new "btagvar_hole" in
                x := Some(this_tmpl,hole);
                [(t,c,this_tmpl,hole,
                     fun (a,b,c,d,e,f) -> T.CgFillBtag(a,b,c,d,e,f))]
              end
        | _ -> impos "cg_fill_holes: mark is not a jump")
        jumps) in
    (* Get a list of all the holes and their cons *)
    let holes2 =
      (List.map (fun (v,e) -> (v,abbrev_con(exp2con e))) holes)
        @ (List.map (fun (_,c,_,h,_) -> (h,c)) jumps) in
    (match post_con_opt with
      None -> ()
    | Some _ -> (* Emit gratuitous fallthru needed by the verifier for now *)
        fallthru cenv0);
    (* Mark the end of the template *)
    let template_con =
      abbrev_con(dc(T.Ctmpl(pre_con,post_con_opt,labels,holes2))) in
    gen_code_mark(M_TemplateEnd template_con);
    (* Restore the stack and cg type from before the last template *)
    let cenv = put_vis_fenv fenv cenv0 in 
    (* Dump the template *)
    emit(T.CgDump(tmpl_tv, T.Ebx, this_tmpl));
    let cenv = cg_push cenv tmpl_tv labels holes2 post_con_opt in
    (* Push the pointer to the template copy *)
    emit(T.Push(T.Reg T.Ebx,[]));
    let cenv =
      add_local_var (Id.id_to_string this_tmpl) (dc(T.Ctptr tmpl_tv)) cenv in
    (* Fill the move holes *)
    let cenv = 
      List.fold_left
        (fun cenv (hole,e) ->
          cg_exp cenv e; (* Value to fill hole in goes in EAX *)
          peek T.Ebx 0;  (* Get the pointer to the temp. from top of stack *)
          emit (T.CgFill(T.Ebx, this_tmpl, hole, T.Eax));
          cg_pop_hole cenv hole)
        cenv holes in

    (*** INVARIANT: T.EBX HOLDS THE POINTER TO THE TEMPLATE COPY ***)

    (* Patch forward jumps to this template *)
    let cenv =           
      List.fold_left                (* for every label in this template *)
        (fun cenv (label,_) ->
          List.fold_left            (* for every forward itj to the label *)
            (fun cenv (back_tmpl,back_hole,fill_inst) ->
              let (_,i) =
                (* Can this fail? *)
                List.assoc (Id.id_to_string back_tmpl) cenv.local_env in
              peek T.Eax i;
              emit(fill_inst(T.Eax,back_tmpl,back_hole,T.Ebx,this_tmpl,label));
              cg_pop_hole cenv back_hole)
            cenv
            (Hashtbl.find_all forward_itjs label)
          )
        cenv labels in

    (*** STILL INVARIANT: T.EBX HOLDS THE POINTER TO THE TEMPLATE COPY ***)

    (* Patch backward jumps from this template, mark fwd jumps as such *)
    let cenv =  
      List.fold_left
        (fun cenv (t,_,_,hole,fill_inst) ->
          try 
            let back_tmpl = Hashtbl.find tmpl_of_label t in
            let (_,i) =
              (* Can this fail? *)
              List.assoc (Id.id_to_string back_tmpl) cenv.local_env in
            peek T.Eax i;
            emit(fill_inst(T.Ebx,this_tmpl,hole,T.Eax,back_tmpl,t));
            cg_pop_hole cenv hole
          with Not_found ->
            (* Not a backward jump, must be a forward jump *)
            Hashtbl.add forward_itjs t (this_tmpl,hole,fill_inst);
            cenv)
        cenv jumps in

    (* Finally, restore the stack if asked *)
    if restore_stack then begin
        let n = stack_height cenv - stack_height cenv0 in
        pop_free n;
        cg_pop_free cenv n
    end;
    (* The returned cenv is not correct if restore_stack=true, because
    ** it doesn't take the pop_free into account.  But it is only used
    ** if restore_stack=false. *)
    cenv
  end
(* End Cyclone *)

(* cg_stmt env -> P.stmt -> bool *)
(* bool = true if stmt returns, false otherwise. *)
and cg_stmt env (s,loc) = 
  begin
    let cg_control_flow env n =
      let local_depth = List.length env.local_env in 
      let ebp_opt = 
	let rec aux old_ebp ebps =
	  match ebps with
	    hd::tl when hd>n -> aux (Some hd) tl 
	  | _ -> old_ebp
	in
	aux None env.sptr_offsets 
      in
      begin match ebp_opt with None -> ()
      |	Some offset -> 
	  let d = local_depth - offset in
	  peek T.Ebp d
      end;
      let d = local_depth - n in
      pop_free d;
    in
    let cg_goto env (label,n) =
      cg_control_flow env n;
      emit_jmp env label []
    in
    match s with
      P.Skip -> false
    | P.Exp e -> cg_exp env e; 
	begin match e.P.raw_exp with
	  P.Raise _ -> true
	| _ -> false
	end
    | 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*)
	  cg_control_flow env env.args_on_stack;
	  emit(T.Retn None); 
	  true
      	end
    | P.IfThenElse(e,s1,s2) ->
      	begin
	  let true_lab = Id.id_new "iftrue" in
      	  let false_lab = Id.id_new "iffalse" in
      	  let end_lab = Id.id_new "ifend" in
	  cg_bool_exp env e (true_lab,[]) (false_lab,[]) true;
	  emit_lab_nocon env true_lab;
	  let s1_returns = cg_stmt env s1 in
	  (if not s1_returns
	  then emit_jmp env end_lab []);
	  emit_lab_nocon env false_lab;
	  let s2_returns = cg_stmt env s2 in
	  if not (s1_returns & s2_returns)
	  then (emit_lab_nocon 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_jmp env looptest [];
	  emit_lab env' loopbody;
	  cg_stmt env' s;
	  emit_lab_nocon env' looptest;
	  cg_bool_exp env' e 
	    (loopbody,branch_coercion env') (loopend,[]) false;
	  emit_lab_nocon env' loopend;
	  false
      	end
    | P.Break -> cg_goto env (deSome env.break_label); false
    | P.Continue -> cg_goto env (deSome env.continue_label); true
    | P.For(e1,e2,e3,s) ->
      	begin
	  cg_exp env e1;
	  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
	  emit_jmp env looptest [];
	  emit_lab env' loopbody;
	  cg_stmt env' s;
	  emit_lab_nocon env' loopcount;
	  cg_exp env' e3;
	  emit_lab_nocon env' looptest;
	  cg_bool_exp env' e2 
	    (loopbody,branch_coercion env') (loopend,[]) false;
	  emit_lab_nocon 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) -> (to_i32 (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 env2 = add_reg env T.Eax int_con in
      	  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
	      	  if (not s_returns) then fallthru env;
	      	  (if not (s_returns & returns)  
                  then (emit_lab env end_label; false)
		  else true)
	      	end
	    | (i,s)::rest -> 
	      	begin
	      	  let l' = Id.id_new ("l" ^ (string_of_int32 i)) in
	      	  emit(T.Cmp(T.Reg r,T.Immed i));
	      	  emit_jcc env2 T.NotEq l' [];
	      	  let s_returns = cg_stmt env s in
	      	  (if not s_returns
                   then emit_jmp env end_label (branch_coercion env));
	      	  emit_lab_nocon 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) when (compress(deSome e.P.exp_typ) <> P.ExnType)->
	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 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
	      	  emit_lab_nocon env default_label; 
	      	  (if not (cg_stmt env s)
	      	  then (fallthru env; false)
		  else true)
	      	end) in
      	  let cg_void_case (tag,lab,s) = 
	    begin
	      emit_lab_nocon env lab; 
	      (if not (cg_stmt env s)
	      then (emit_jmp env end_label (branch_coercion env); false)
	      else true)
	    end in
	  let cg_void_branch (tag,lab,s) =
            begin
	      emit_btagi (r,tag,(lab,[]),T.Eq) env
	    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
	      let env' = add_reg env r rc in
	      emit_lab_nocon env' lab;
	      emit(T.Mov(T.Reg T.Eax,(T.Prjr((r,[T.Fromsum]),i32_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_jmp env end_label (branch_coercion env); 
		    false)
	      else true
	    end in
	  let cg_value_branch (tag,con,lab,x,s) =
	    begin
	      emit_btagvar (r,i32_0,tag,(lab,[]),T.Eq) env
	    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 -> impos "cg_exp: Unionswitch: Value case without tag."
		  in
		  (* Dan fix for UnionSwitch *)
		  let ts   = 
		    (match deSome e.P.exp_typ with 
		      P.NamedType(n,tl) -> List.map typ2con tl
		    | _ -> impos "cg_exp: Unionswitch: type not named") in
 		  let inst = 
		    Dict.inserts (Dict.empty Id.id_compare)
		      (List.combine u_info.union_tyvars ts) in
		  let con =  Talcon.substs inst con 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 -> 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_btagi (T.Eax,tag,(default_label,[]),T.Below) env
	  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_jmp env default_label []
	      end
	  | None -> 
	      begin
		match value_cases with
		  [] ->
		    begin
		      match void_cases with
			[] -> impos "...."
		      |	(hd::tl) ->
			  begin
			    List.iter cg_void_branch tl
			  end

		    end
		| hd::tl ->
		    begin
		      List.iter cg_void_branch void_cases;
		      List.iter cg_value_branch tl
		    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
	    (emit_lab env end_label;
	    false)
	  else true  
	end
    | P.UnionSwitch(e,ss,d) -> (* Exception switch. *)
	begin 
	  let default_label = Id.id_new "default_block" in
	  let end_label = Id.id_new "switchend" in

	  let env' = add_reg env T.Eax exn_con in

	  let cg_arm (exn,vopt,s) label next_label =
	    let typ = lookup_exn env exn in
	    emit_lab env' label;
	    emit(T.Bexn (T.Eax,T.Addr (tid_exn exn), 
			 (next_label,branch_coercion env')));
	    let (env',closing_code)  = 
	      match vopt with 
	      	None -> (env', fun x -> ())
	      | Some v -> 
		  begin
		    let con = typ2con typ in
		    emit (T.Push (T.Prjr ((T.Eax,[]),i32_4),[]));
		    (add_local_var v con env',fun x -> pop_free 1)
		  end
	    in
	    let arm_returns = cg_stmt env' s in
	    closing_code ();
	    if not arm_returns 
	    then emit_jmp env end_label (branch_coercion env);
	    arm_returns
	  in
	  let cg_default () = 
	    emit_lab env' default_label;
	    let default_returns = cg_stmt env' (deSome d) in
	    if not default_returns then fallthru env;
	    default_returns
	  in
	  let labels =
	    let block (exn,_,_) = Id.id_new (exn ^ "_block") in
	    let rec aux xs =
	      match xs with
		[] -> [default_label]
	      |	(hd::tl) -> (block hd) :: aux tl
	    in
	    aux ss
	  in
	  cg_exp env e;
	  fallthru env';
	  let returns = 
	    let rec aux ss labels =
	      match (ss,labels) with
		(s::stl,(l1::l2::tl)) -> 
		  let ret = cg_arm s l1 l2 in
		  ret :: (aux stl (l2::tl))
	      | ([],[default]) -> [cg_default ()]
	      |	([],[]) -> []
	      |	(_,_) -> impos "cg_stmt: exception switch: returns: aux"
	    in
	   List.for_all (fun x->x) (aux ss labels)
	  in
	  if not returns then (emit_lab env end_label);
	  returns
	end
    | P.Decl(x,t,roe,s) ->
      	begin
	  let e = 
	    (match !roe with
	      None -> 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 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 env;
          let env' = set_loop_labels env loopend loopstart in
          emit_lab env' loopstart;
	  cg_stmt env' s;
          emit_lab_nocon env' looptest;
          cg_bool_exp env' e 
	    (loopstart,branch_coercion env') (loopend,[]) false;
          emit_lab_nocon env' loopend;
          false
        end
    | P.Try(s1,x,s2) ->
	begin
	  let trycatch = Id.id_new "trycatch" in
	  let tryend = Id.id_new "tryend" in
	  
	  let env' = 
	    push_con env T.Ebp (T.csptr (exn_stack_con env.stack2_type)) 
	  in
	  let handler_coercion = branch_coercion env' in 
	  emit(T.Push (T.Addr trycatch, handler_coercion));
	  emit(T.Mov (T.Reg T.Ebp,(T.Reg T.Esp,[])));
	  emit_comment("Begin try body.");

	  let env'' = try_body_env env' in
	  let s1_returns = cg_stmt env'' s1 in
	  emit_comment("End try body.");
	  if not s1_returns 
	  then begin
	    pop_free 1; (* pop handler *)
	    pop T.Ebp; (* restore EBP *)
	    emit_jmp env tryend (branch_coercion env);
	  end;
	  emit_handler env trycatch;
	  pop T.Ebp; (* restore EBP *)
	  emit(T.Push (T.Reg T.Eax,[]));
	  let env' = add_local_var x exn_con env in
	  let s2_returns = cg_stmt env' s2 in
	  if not s2_returns
	  then begin 
	    pop_free 1;
	    (* Raise already pops the handler *)
	    fallthru env;
	  end;
	  let s_returns = s1_returns & s2_returns in
	  if not s_returns then emit_lab env tryend;
	  s_returns
	end
(* Cyclone *)
    | P.Cut stmt ->
        begin
          let env = flush_vis_fenv env in
          match env.cenvs with
            [] ->
              impos "cut can only be used within a codgen or splice"
          | (Outermost _)::_ ->
              impos "cut can only be used within a codgen or splice"
          | (Hidden _)::_ ->
              impos "cut cannot be used within a cut"
          | Frame(fenv)::cenvs ->
              (* Hack with type abbrevs to avoid MASM string too long *)
              let post_con = mk_label_con env in
              let post_con_abbrev = abbrev_con post_con in
              (* Find the next visible frame. *)
              (* This is too convoluted, but requires less modification
                 of the original environment type.  Someday we should just
                 go for it. *)
              let fenv2 =
                let rec aux cs =
                  match cs with
                    [] -> impos "cut: can't find previous env"
                  | (Outermost fenv2)::_ -> fenv2
                  | (Frame fenv2)::_ -> fenv2
                  | (Hidden _)::tl -> aux tl in
                aux cenvs in
              let env2 =
                { env with
                  tyvars = fenv2.f_tyvars;
                  local_env = fenv2.f_local_env;
                  args_on_stack = fenv2.f_args_on_stack;
                  stack1_type = fenv2.f_stack1_type;
                  stack2_type = fenv2.f_stack2_type;
                  break_label = fenv2.f_break_label;
                  continue_label = fenv2.f_continue_label;
                  regs = fenv2.f_regs;
                  cenvs = (Hidden fenv)::cenvs } in
              (* This is tricky... 
              ** here returns is true if the CUT statement
              ** lays out templates that all return *)
              let returns = PT.doesSpliceRet stmt in
              let post_con_opt =
                if returns then None else (Some post_con_abbrev) in
              (* Type of ECG will change as we dump and fill *)
              let env3 =
                cg_fill_holes
                  env2
                  post_con_opt
                  false in
              (* WATCH OUT: can the type of ECG change if there are
              ** splices in stmt?? *)
              cg_stmt env3 stmt;
              (* Note, the post-condition of the last template becomes
                 the pre-condition of the next template *)
              gen_code_mark(M_TemplateBeg(Id.id_new "tmpl_start",
                                          Id.id_new "tmpl_end",
                                          post_con_abbrev,
                                          get_vis_fenv env3));
              (* The TAL parser wants a label at the beginning of each
              ** template; the label serves no other purpose. *)
              (* We can't use the abbreviated post_con here because of
              ** talverify; maybe talverify should be changed. *)
              gen_code_mark(M_Label(Id.id_new "cut",Some post_con));
              returns
        end
    | P.Splice stmt ->
        begin
          let env = flush_vis_fenv env in
          match env.cenvs with
            [] -> impos "splice can only be used within a cut"
          | (Outermost _)::_ ->
              impos "splice cannot be used within a codegen or splice 1"
          | (Frame _)::_ ->
              impos "splice cannot be used within a codegen or splice 2"
          | (Hidden fenv2)::cenvs ->
              let fenv0 = get_vis_fenv env in
              let env2 =
                { env with
                  tyvars = fenv2.f_tyvars;
                  local_env = fenv2.f_local_env;
                  args_on_stack = fenv2.f_args_on_stack;
                  stack1_type = fenv2.f_stack1_type;
                  stack2_type = fenv2.f_stack2_type;
                  break_label = fenv2.f_break_label;
                  continue_label = fenv2.f_continue_label;
                  regs = fenv2.f_regs;
                  cenvs = (Frame fenv2)::cenvs } in
              let pre_con = abbrev_con(mk_label_con env2) in
              gen_code_mark(M_TemplateBeg(Id.id_new "tmpl_start",
                                          Id.id_new "tmpl_end",
                                          pre_con,
                                          fenv0));
              (* The TAL parser wants a label at the beginning of each
              ** template; the label serves no other purpose. *)
              emit_lab env2 (Id.id_new "splice");
              let returns = cg_stmt env2 stmt in
              let post_con_opt = if returns then None else Some pre_con in
              cg_fill_holes env post_con_opt true;
              false
        end
(* End Cyclone *)
  end (* cg_stmt *)

(* Cyclone *)
(* cg_fundecl has been changed so that whoever calls it is required
   to set up the environment properly.  This is needed by Cyclone. *)
(* End Cyclone *)
and cg_fundecl env fd =
  begin
    let name = fd.P.fn_name in
    let tyargs = fd.P.fn_tyvars 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,stack1_type,stack2_type) = fun_con tyargs ret_typ params in
    let lab = if name = main_id then main_label else (tid_val name) in
    if fd.P.fn_static then begin
      let (con,_,_) = fun_con tyargs ret_typ params in
      gen_export_val (lab,con)
    end;
    gen_set_label (lab,Some con);
    (if (not (cg_stmt env body)) then emit(T.Retn None));
    flush_code ();
    if (name = main_id) then true else false 
  end


(* cg_typedecls : env -> P.top_decl list -> T,con_block list -> 
   (env * T.con_block list)

   Generates the tal constructors for popcorn type declarations.
*)
let rec cg_typedecls env tds con_blocks = 
  begin 
    let rec aux tds con_blocks structs unions =
      begin match tds with
	[] -> (con_blocks,structs,unions)
      | ((P.StructDecl sd,_) :: tl) ->
	  begin
	    let (label,mem_label)=(tid_type sd.P.st_name, tid_mem sd.P.st_name) in
	    let s_info = info_structdecl env sd in
	    let mem_kind = s_info.struct_mem_kind in
	    let kind = s_info.struct_kind in
	    let real_mem = 
	      (mem_label,mem_kind,T.ConcCon s_info.struct_mem_con) 
	    in
	    let mem = (mem_label, mem_kind, s_info.struct_mem_con) in	    
	    let int_con = (label,kind, T.ConcCon s_info.struct_con) in
	    let con = (label,kind, s_info.struct_con) in
	    let abs_con = (label, kind, T.AbsCon) in
	    let abs_mem = (mem_label, mem_kind, T.AbsCon) in
		
	    let aux' cons = 
	      aux tl cons ((sd.P.st_name,s_info)::structs) unions 
	    in
	    match sd.P.st_scope with
	      P.Public -> 
		begin 
		  gen_export_con int_con; 
		  gen_export_con real_mem;
		  aux' (con::mem::con_blocks)
		end
	    | P.Abstract -> 
		if s_info.struct_null 
		then 
		  begin (* We export null for all option types. *)
		    gen_export_con int_con;
		    gen_export_con abs_mem
		  end
		else gen_export_con (abs_con);
		aux' (con::mem::con_blocks)
	    | P.Extern -> 
		begin 
		  gen_import_con int_con; 
		  gen_import_con real_mem;
		  aux' con_blocks
		end
	    | P.Static -> aux' (con::mem::con_blocks) 
	  end
      | ((P.UnionDecl ud,_) :: tl) ->
	  begin
	    let label= tid_type ud.P.un_name in
	    let u_info = info_uniondecl env ud in
	    let kind = u_info.union_kind in
	    let real_con = 
	      (label,kind,T.ConcCon u_info.union_con) 
	    in
	    let con = (label,kind, u_info.union_con) in
	    let abs_con = (label, kind, T.AbsCon) in
	    let aux' cons = 
	      aux tl cons structs ((ud.P.un_name,u_info)::unions) 
	    in
	    match ud.P.un_scope with
	      P.Public -> gen_export_con real_con; aux' (con::con_blocks)
	    | P.Abstract -> gen_export_con abs_con; aux' (con::con_blocks)
	    | P.Extern -> gen_import_con real_con; aux' con_blocks
	    | P.Static -> aux' (con::con_blocks)
	  end 
      | ((P.ExternType (tn,tyvs,opt),_)::tl) ->
	    begin
	      let kind_con = tyvars_to_kind tyvs T.k4byte in
	      let kind_mem = tyvars_to_kind tyvs T.Kmem in
	      let tylam = tyvars_to_lam tyvs in
	      let label = tid_type tn in
	      let mem_label = tid_mem tn in
	      let abs_con = (label,kind_con,T.AbsCon) in
	      let abs_mem = (mem_label,kind_mem,T.AbsCon) in
	      let tycons = tyvars_to_cons tyvs in
	      let conc_con = tylam (opt_con (mem_name_con tn tycons)) in
	      let con = (label,kind_con,T.ConcCon conc_con) in
	      begin
		if opt 
		then (gen_import_con con; gen_import_con abs_mem)
		else (gen_import_con abs_con)
	      end;
	      aux tl con_blocks structs unions
	    end
      | ((P.ExternVal (v,t),_) :: tl) ->
            begin
              (* Dan fix to be consistent with imports for link checking *)
              let ptr_to con = T.cprod_b [T.cfield con T.ReadWrite] in
              let con' = typ2con t in
              let con = if needs_indirect t then ptr_to con' else con' in
              gen_import_val  (tid_val v,con);
              aux tl con_blocks structs unions
	    end
      | _ -> impos "cg_typedecl : This is not a type declaration."
      end
    in
    let (con_blocks,structs,unions) = aux tds [] [] [] in
    let struct_dict = Dict.inserts env.type_info.structs structs in
    let union_dict = Dict.inserts env.type_info.unions unions in
    let new_env = { env with
		    sptr_offsets = [];
		    type_info = { unions=union_dict; structs=struct_dict}
		  } 
    in
    (new_env,con_blocks)
  end

(* cg_global_decls:env->(scope*var*typ*exp option ref) list->data_block list *)
let cg_global_decls env globals =
  let cg_global dbs (scope,n,typ,eor) =
    begin
      let return con data blocks =
	let label = Id.id_unique (tid_val n) in
	(((label, Some con, data)::blocks), con, T.Dlabel(label,[])) 
      in
      let rec compile_data e =
	let con = exp2con e in
	match e.P.raw_exp with
	  P.Const(P.Int  i) ->
	    ([], con, T.D4bytes (i,[T.Subsume T.cbyte4]))
	| P.Const(P.Char c) ->
	    ([], con, T.D4bytes (to_i32 (Char.code c),
				      [T.Subsume T.cbyte4]))
	| P.Const(P.Bool b)-> 
	    ([], con, T.D4bytes ((if b then i32_1 else i32_0),
				      [T.Tosum con]))
	| P.Const(P.Null)->
	    ([], con, T.D4bytes (i32_0, [T.RollTosum con]))
	| P.Const(P.String s) -> ([], con, T.Dlabel (add_string s,[])) 
	| P.ConstArray(es,ot) ->
	    let typ = 
	      match (es,ot) with
		(_,Some t) -> t 
	      | (hd::tl,None) -> exp2typ hd
	      | _ -> (impos "cg_global_decls : ConstArray without type.") 
	    in
	    let len = to_i32 (List.length es) in
	    let (blocks, _, datas) = compile_datas es in
	    let c = typ2con typ in
	    let this_data = 
	      (((T.D4bytes (len,[]))::(T.Dup)::datas),
 	       [(T.Pack(T.pcint len,con));
		 (T.Toarray(i32_4,0,T.cfield c T.ReadWrite)) ])
	    in 
	    return con this_data blocks
	| P.NewStruct(tn, tsor, es) ->
	    let ts = deSome !tsor in
	    let cs = types2cons ts in
	    let s_info = lookup_struct env tn in
	    let (blocks, _, datas) = compile_datas es in
	    let coerce = roll_struct s_info tn cs  in
	    return con (datas, coerce) blocks 
	| P.NewUnion(tn,tsor,f,eopt) ->
	    let ts = deSome !tsor in
	    let cs = types2cons ts in
	    let u_info = lookup_union env tn in
	    let coerce = T.RollTosum con in
	    begin match eopt with
	      None   -> 
                 let tag = try List.assoc f u_info.void_infos
		 with Not_found -> impos "cg_global_decls: Missing field." 
		 in
		([],con,T.D4bytes (tag, [coerce]))
	    | Some e ->
		let (blocks, _, data) = compile_data e in
		let (tag,_) = try List.assoc f u_info.value_infos
		    with Not_found -> impos "cg_global_decls: Missing field."
		in
		(return con ([(T.D4bytes (tag,[])); data], [coerce]) blocks)
	    end
	| P.NewTuple es ->
	    let (blocks, cons, datas) = compile_datas es in
	    let con = T.cprod_b (List.map (fun c -> (T.cfield c T.Read)) cons) in
	    return con (datas,[]) blocks 
	| _ -> impos "cg_global_decl: Expected a global variable declaration"
      and compile_datas es =
	let aux elt (blocks, cons, datas) =  
	  let (subBlocks, con, data) = compile_data elt in
	  ((subBlocks@blocks), (con::cons), (data::datas))
	in
	List.fold_right aux es ([], [], []) 
      in
      let (blocks, con, data) = compile_data (deSome !eor) in

      let con' = T.cprod_b [T.cfield con T.ReadWrite] in
      let nt = tid_val n in
      if scope = P.Public then gen_export_val (nt,con');
      (nt,Some con', ([data],[])) :: (blocks@dbs)
    end
  in  
  List.fold_left cg_global [] globals

(* cg_exn_decls : (var * scope * typ) list -> data_block list *)
let cg_exn_decls exns = 
  begin
    let rec aux exns =
      match exns with
	((v,sc,typ)::tl) ->
	  let con = try typ2con typ with Void_Type -> T.cbyte4 in
	  let con' = T.cfield con T.Read in
	  let con'' = T.capp T.pcexnname con' in
	  let label = tid_exn v in
	  let data_item =  (label, Some con'', ([T.Dexnname con'],[])) in
	  begin match sc with
	    P.Static -> data_item :: (aux tl)
	  | P.Public -> 
	      gen_export_val (label,con'');
	      data_item :: (aux tl)
	  | P.Extern ->
	      gen_import_val (label,con'');
	      aux tl
	  | P.Abstract -> impos "cg_exn_decls: Abstract exception declaration."
	  end	   
      |	[] -> []
    in
    aux exns
  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,fun_decls,global_decls,exn_decls) = 
      let rec sort_decls ds ts fs gs xs = 
	match ds with
	  [] -> (ts,fs,gs,xs)
	| ((P.FunDecl fd,_)::tl) -> sort_decls tl ts (fd::fs) gs xs
      	| ((P.GlobalDecl g,_)::tl) -> sort_decls tl ts fs (g :: gs) xs
	| ((P.ExceptionDecl x,_)::tl) -> sort_decls tl ts fs gs (x::xs)
	| ((P.OpenDecl(prefix,decls),_)::tl) ->
	    let (ts,fs,gs,xs) = sort_decls decls ts fs gs xs in
	    sort_decls tl ts fs gs xs
	| ( hd :: tl) -> sort_decls tl (hd::ts) fs gs xs
      in
      sort_decls topdecls [] [] [] []
    in
    reset_generator ();
    let (env',con_blocks) = cg_typedecls env type_decls [] in 
    let data_blocks = 
      (cg_exn_decls exn_decls) @ (cg_global_decls env' global_decls) 
    in
    List.iter gen_data_block data_blocks;
    let has_main_list =
      List.map
        (fun fd ->
          let fenv2 = mk_fenv fd in
          let env'' =
            { env' with
              tyvars = fenv2.f_tyvars;
              local_env = fenv2.f_local_env;
              args_on_stack = fenv2.f_args_on_stack;
              stack1_type = fenv2.f_stack1_type;
              stack2_type = fenv2.f_stack2_type;
              break_label = fenv2.f_break_label;
              continue_label = fenv2.f_continue_label;
              regs = fenv2.f_regs
(* Cyclone *)
                ;
              cenvs = []
(* End Cyclone *)
            } in
          cg_fundecl env'' fd)
        fun_decls in
    let has_main = List.exists (fun x -> x) has_main_list in
    if has_main then gen_code_block tal_main_code_block;
    (con_blocks,has_main)
  end


(* Note: marks are processed in *REVERSE* order. *)
let postprocess marks =
  let rec pp marks cbs istack tmps cuts tcons abbrevs =
    match marks with
      [] ->
        begin
          match istack,cuts with
            [],[] -> (tmps,cbs,abbrevs)
          | _,[] -> impos "instructions without label"
          | [],_ -> impos "cuts not empty"
          | _ -> impos "instructions without label, cuts not empty"
        end
    | m::ms ->
        begin
          let issue x =
            pp ms cbs ([|x|]::istack) tmps cuts tcons abbrevs
          in
          match m with
            M_Label(id,con) ->
              let cb = (id,con,Array.concat istack) in
              pp ms (cb::cbs) [] tmps cuts tcons abbrevs
          | M_ISeq i ->
              pp ms cbs (i::istack) tmps cuts tcons abbrevs
          | M_TypeAbbrev(v,c) ->
              pp ms cbs istack tmps cuts tcons ((v,c)::abbrevs)
(* Cyclone *)
          | M_Jmp(label,{contents=None},target_con,coercion) ->
              issue (T.Jmp(T.Addr label,coercion))
          | M_Jmp(_,{contents=Some(temp,hole)},target_con,coercion) ->
              issue (T.CgHoleJmp(temp,(hole,coercion)))
          | M_Jcc(cc,label,{contents=None},target_con,coercion) ->
              issue (T.Jcc(cc,(label,coercion)))
          | M_Jcc(cc,_,{contents=Some(temp,hole)},target_con,coercion) ->
              issue (T.CgHoleJcc(cc,temp,(hole,coercion)))
          | M_Btagi(reg,i,lc,cc,{contents=None},target_con) ->
              issue (T.Btagi(reg,i,lc,cc))
          | M_Btagi(reg,i,(_,c),cc,{contents=Some(temp,hole)},target_con) ->
              issue (T.CgHoleBtagi(reg,i,temp,(hole,c),cc))
          | M_Btagvar(reg,i1,i2,lc,cc,{contents=None},target_con) ->
              issue (T.Btagvar(reg,i1,i2,lc,cc))
          | M_Btagvar(reg,i1,i2,(_,c),cc,
                      {contents=Some(temp,hole)},target_con) ->
              issue (T.CgHoleBtagvar(reg,i1,i2,temp,(hole,c),cc))
          | M_TemplateEnd c ->
              pp ms [] [] tmps ((cbs,istack)::cuts) (c::tcons) abbrevs
          | M_TemplateBeg(id1,id2,pre_con,_) ->
              begin
                match istack,cuts,tcons with
                  [],(cbs0,istack0)::tl,c::tcons ->
                    pp ms cbs0 istack0 ((id1,id2,c,cbs)::tmps) tl tcons abbrevs
                | _,_,_ -> impos "pp M_TemplateBeg"
              end
          | M_Fill _ -> pp ms cbs istack tmps cuts tcons abbrevs
(* End Cyclone *)
        end
  in pp marks [] [] [] [] [] []


(************************************Entry Point*******************************)
let code_gen mod_name import_file export_file (td,global_env) =
  begin
    let dict_empty () = Dict.empty compare in
    let env = { global_env = global_env;
		tyvars = [];
		local_env = [];
		args_on_stack = 0;
		stack1_type = tal_main_con;
		stack2_type = T.cempty;
		break_label = None;
		continue_label = None;
		sptr_offsets = [];
		type_info = { unions=dict_empty (); structs=dict_empty () };
		regs = T.rs_empty
(* Cyclone *)
                  ;
                cenvs = []
(* End Cyclone *)
	      }	in
    let (con_blocks,has_main) = cg_all env td in
    let (templates,code_blocks,abbrevs) = postprocess (gen_state.code_marks) in
    let abbrevs =
      Array.of_list
        ([array_abbrev;string_abbrev; handle_abbrev; exn_stack_abbrev;
	   stack_abbrev;stack_abbrev_void; handler_abbrev] @
         abbrevs) 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 = [||];
      	T.con_blocks = Array.of_list (bogus_option_con_block :: con_blocks);
      	T.code_blocks = Array.of_list code_blocks;
      	T.data_blocks = Array.of_list gen_state.data_blocks
(* Cyclone *)
          ;
      	T.templates = Array.of_list templates
(* End Cyclone *)
      } in
    let export_interface = 
      { T.int_abbrevs = abbrevs;
	T.int_cons = (Array.of_list gen_state.export_cons);
	T.int_vals = (Array.of_list gen_state.export_vals)
      }	in
    let import_interface = 
      { T.int_abbrevs = abbrevs;
	T.int_cons = (Array.of_list gen_state.import_cons);
	T.int_vals = (Array.of_list gen_state.import_vals)
      }	in
    (implementation,import_interface,export_interface)
  end



