path: root/src/boot/me/semant.ml

open Common;;

type slots_table = (Ast.slot_key,node_id) Hashtbl.t
type items_table = (Ast.ident,node_id) Hashtbl.t
type block_slots_table = (node_id,slots_table) Hashtbl.t
type block_items_table = (node_id,items_table) Hashtbl.t
;;


type code = {
  code_fixup: fixup;
  code_quads: Il.quads;
  code_vregs_and_spill: (int * fixup) option;
}
;;

type glue =
    GLUE_activate
  | GLUE_yield
  | GLUE_exit_main_task
  | GLUE_exit_task
  | GLUE_copy of Ast.ty           (* One-level copy.                    *)
  | GLUE_drop of Ast.ty           (* De-initialize interior memory.     *)
  | GLUE_free of Ast.ty           (* Drop body + free() exterior ptr.   *)
  | GLUE_sever of Ast.ty          (* Null all exterior state slots.     *)
  | GLUE_mark of Ast.ty           (* Mark all exterior state slots.     *)
  | GLUE_clone of Ast.ty          (* Deep copy.                         *)
  | GLUE_compare of Ast.ty
  | GLUE_hash of Ast.ty
  | GLUE_write of Ast.ty
  | GLUE_read of Ast.ty
  | GLUE_unwind
  | GLUE_gc
  | GLUE_get_next_pc
  | GLUE_mark_frame of node_id    (* Node is the frame.                 *)
  | GLUE_drop_frame of node_id    (* Node is the frame.                 *)
  | GLUE_reloc_frame of node_id   (* Node is the frame.                 *)
  | GLUE_fn_binding of node_id    (* Node is the 'bind' stmt.           *)
  | GLUE_obj_drop of node_id      (* Node is the obj.                   *)
  | GLUE_loop_body of node_id     (* Node is the 'for each' body block. *)
  | GLUE_forward of (Ast.ident * Ast.ty_obj * Ast.ty_obj)
;;

type data =
    DATA_str of string
  | DATA_name of Ast.name
  | DATA_tydesc of Ast.ty
  | DATA_frame_glue_fns of node_id
  | DATA_obj_vtbl of node_id
  | DATA_forwarding_vtbl of (Ast.ty_obj * Ast.ty_obj)
  | DATA_crate
;;

type defn =
    DEFN_slot of Ast.slot
  | DEFN_item of Ast.mod_item_decl
  | DEFN_ty_param of Ast.ty_param
  | DEFN_obj_fn of (node_id * Ast.fn)
  | DEFN_obj_drop of node_id
  | DEFN_loop_body of node_id
;;

type glue_code = (glue, code) Hashtbl.t;;
type item_code = (node_id, code) Hashtbl.t;;
type file_code = (node_id, item_code) Hashtbl.t;;
type data_frags = (data, (fixup * Asm.frag)) Hashtbl.t;;

let string_of_name (n:Ast.name) : string =
  Fmt.fmt_to_str Ast.fmt_name n
;;

(* The only need for a carg is to uniquely identify a constraint-arg
 * in a scope-independent fashion. So we just look up the node that's
 * used as the base of any such arg and glue it on the front of the 
 * symbolic name.
 *)

type constr_key_arg = Constr_arg_node of (node_id * Ast.carg_path)
                      | Constr_arg_lit of Ast.lit
type constr_key =
    Constr_pred of (node_id * constr_key_arg array)
  | Constr_init of node_id

type ctxt =
    { ctxt_sess: Session.sess;
      ctxt_frame_args: (node_id,node_id list) Hashtbl.t;
      ctxt_frame_blocks: (node_id,node_id list) Hashtbl.t;
      ctxt_block_slots: block_slots_table;
      ctxt_block_items: block_items_table;
      ctxt_slot_is_arg: (node_id,unit) Hashtbl.t;
      ctxt_slot_keys: (node_id,Ast.slot_key) Hashtbl.t;
      ctxt_node_referenced: (node_id, unit) Hashtbl.t;
      ctxt_all_item_names: (node_id,Ast.name) Hashtbl.t;
      ctxt_all_item_types: (node_id,Ast.ty) Hashtbl.t;
      ctxt_all_lval_types: (node_id,Ast.ty) Hashtbl.t;
      ctxt_all_cast_types: (node_id,Ast.ty) Hashtbl.t;
      ctxt_all_type_items: (node_id,Ast.ty) Hashtbl.t;
      ctxt_all_stmts: (node_id,Ast.stmt) Hashtbl.t;
      ctxt_item_files: (node_id,filename) Hashtbl.t;
      ctxt_all_lvals: (node_id,Ast.lval) Hashtbl.t;

      (* definition id --> definition *)
      ctxt_all_defns: (node_id,defn) Hashtbl.t;

      (* reference id --> definition id *)
      ctxt_lval_to_referent: (node_id,node_id) Hashtbl.t;

      ctxt_required_items: (node_id, (required_lib * nabi_conv)) Hashtbl.t;
      ctxt_required_syms: (node_id, string) Hashtbl.t;

      (* Layout-y stuff. *)
      ctxt_slot_aliased: (node_id,unit) Hashtbl.t;
      ctxt_slot_is_obj_state: (node_id,unit) Hashtbl.t;
      ctxt_slot_vregs: (node_id,((int option) ref)) Hashtbl.t;
      ctxt_slot_offsets: (node_id,size) Hashtbl.t;
      ctxt_frame_sizes: (node_id,size) Hashtbl.t;
      ctxt_call_sizes: (node_id,size) Hashtbl.t;
      ctxt_block_is_loop_body: (node_id,unit) Hashtbl.t;
      ctxt_stmt_loop_depths: (node_id,int) Hashtbl.t;
      ctxt_slot_loop_depths: (node_id,int) Hashtbl.t;

      (* Typestate-y stuff. *)
      ctxt_constrs: (constr_id,constr_key) Hashtbl.t;
      ctxt_constr_ids: (constr_key,constr_id) Hashtbl.t;
      ctxt_preconditions: (node_id,Bits.t) Hashtbl.t;
      ctxt_postconditions: (node_id,Bits.t) Hashtbl.t;
      ctxt_prestates: (node_id,Bits.t) Hashtbl.t;
      ctxt_poststates: (node_id,Bits.t) Hashtbl.t;
      ctxt_call_lval_params: (node_id,Ast.ty array) Hashtbl.t;
      ctxt_copy_stmt_is_init: (node_id,unit) Hashtbl.t;
      ctxt_post_stmt_slot_drops: (node_id,node_id list) Hashtbl.t;

      (* Translation-y stuff. *)
      ctxt_fn_fixups: (node_id,fixup) Hashtbl.t;
      ctxt_block_fixups: (node_id,fixup) Hashtbl.t;
      ctxt_file_fixups: (node_id,fixup) Hashtbl.t;
      ctxt_spill_fixups: (node_id,fixup) Hashtbl.t;
      ctxt_abi: Abi.abi;
      ctxt_activate_fixup: fixup;
      ctxt_gc_fixup: fixup;
      ctxt_yield_fixup: fixup;
      ctxt_unwind_fixup: fixup;
      ctxt_exit_task_fixup: fixup;

      ctxt_debug_aranges_fixup: fixup;
      ctxt_debug_pubnames_fixup: fixup;
      ctxt_debug_info_fixup: fixup;
      ctxt_debug_abbrev_fixup: fixup;
      ctxt_debug_line_fixup: fixup;
      ctxt_debug_frame_fixup: fixup;

      ctxt_image_base_fixup: fixup;
      ctxt_crate_fixup: fixup;

      ctxt_file_code: file_code;
      ctxt_all_item_code: item_code;
      ctxt_glue_code: glue_code;
      ctxt_data: data_frags;

      ctxt_native_required:
        (required_lib,((string,fixup) Hashtbl.t)) Hashtbl.t;
      ctxt_native_provided:
        (segment,((string, fixup) Hashtbl.t)) Hashtbl.t;

      ctxt_required_rust_sym_num: (node_id, int) Hashtbl.t;
      ctxt_required_c_sym_num: ((required_lib * string), int) Hashtbl.t;
      ctxt_required_lib_num: (required_lib, int) Hashtbl.t;

      ctxt_main_fn_fixup: fixup option;
      ctxt_main_name: string option;
    }
;;

let new_ctxt sess abi crate =
  { ctxt_sess = sess;
    ctxt_frame_args = Hashtbl.create 0;
    ctxt_frame_blocks = Hashtbl.create 0;
    ctxt_block_slots = Hashtbl.create 0;
    ctxt_block_items = Hashtbl.create 0;
    ctxt_slot_is_arg = Hashtbl.create 0;
    ctxt_slot_keys = Hashtbl.create 0;
    ctxt_node_referenced = Hashtbl.create 0;
    ctxt_all_item_names = Hashtbl.create 0;
    ctxt_all_item_types = Hashtbl.create 0;
    ctxt_all_lval_types = Hashtbl.create 0;
    ctxt_all_cast_types = Hashtbl.create 0;
    ctxt_all_type_items = Hashtbl.create 0;
    ctxt_all_stmts = Hashtbl.create 0;
    ctxt_item_files = crate.Ast.crate_files;
    ctxt_all_lvals = Hashtbl.create 0;
    ctxt_all_defns = Hashtbl.create 0;
    ctxt_lval_to_referent = Hashtbl.create 0;
    ctxt_required_items = crate.Ast.crate_required;
    ctxt_required_syms = crate.Ast.crate_required_syms;

    ctxt_constrs = Hashtbl.create 0;
    ctxt_constr_ids = Hashtbl.create 0;
    ctxt_preconditions = Hashtbl.create 0;
    ctxt_postconditions = Hashtbl.create 0;
    ctxt_prestates = Hashtbl.create 0;
    ctxt_poststates = Hashtbl.create 0;
    ctxt_copy_stmt_is_init = Hashtbl.create 0;
    ctxt_post_stmt_slot_drops = Hashtbl.create 0;
    ctxt_call_lval_params = Hashtbl.create 0;

    ctxt_slot_aliased = Hashtbl.create 0;
    ctxt_slot_is_obj_state = Hashtbl.create 0;
    ctxt_slot_vregs = Hashtbl.create 0;
    ctxt_slot_offsets = Hashtbl.create 0;
    ctxt_frame_sizes = Hashtbl.create 0;
    ctxt_call_sizes = Hashtbl.create 0;

    ctxt_block_is_loop_body = Hashtbl.create 0;
    ctxt_slot_loop_depths = Hashtbl.create 0;
    ctxt_stmt_loop_depths = Hashtbl.create 0;

    ctxt_fn_fixups = Hashtbl.create 0;
    ctxt_block_fixups = Hashtbl.create 0;
    ctxt_file_fixups = Hashtbl.create 0;
    ctxt_spill_fixups = Hashtbl.create 0;
    ctxt_abi = abi;
    ctxt_activate_fixup = new_fixup "activate glue";
    ctxt_yield_fixup = new_fixup "yield glue";
    ctxt_unwind_fixup = new_fixup "unwind glue";
    ctxt_gc_fixup = new_fixup "gc glue";
    ctxt_exit_task_fixup = new_fixup "exit-task glue";

    ctxt_debug_aranges_fixup = new_fixup "debug_aranges section";
    ctxt_debug_pubnames_fixup = new_fixup "debug_pubnames section";
    ctxt_debug_info_fixup = new_fixup "debug_info section";
    ctxt_debug_abbrev_fixup = new_fixup "debug_abbrev section";
    ctxt_debug_line_fixup = new_fixup "debug_line section";
    ctxt_debug_frame_fixup = new_fixup "debug_frame section";

    ctxt_image_base_fixup = new_fixup "loaded image base";
    ctxt_crate_fixup = new_fixup "root crate structure";
    ctxt_file_code = Hashtbl.create 0;
    ctxt_all_item_code = Hashtbl.create 0;
    ctxt_glue_code = Hashtbl.create 0;
    ctxt_data = Hashtbl.create 0;

    ctxt_native_required = Hashtbl.create 0;
    ctxt_native_provided = Hashtbl.create 0;

    ctxt_required_rust_sym_num = Hashtbl.create 0;
    ctxt_required_c_sym_num = Hashtbl.create 0;
    ctxt_required_lib_num = Hashtbl.create 0;

    ctxt_main_fn_fixup =
      (match crate.Ast.crate_main with
           None -> None
         | Some n -> Some (new_fixup (string_of_name n)));

    ctxt_main_name =
      (match crate.Ast.crate_main with
           None -> None
         | Some n -> Some (string_of_name n));
  }
;;

let report_err cx ido str =
  let sess = cx.ctxt_sess in
  let spano = match ido with
      None -> None
    | Some id -> (Session.get_span sess id)
  in
    match spano with
        None ->
          Session.fail sess "Error: %s\n%!" str
      | Some span ->
          Session.fail sess "%s:E:Error: %s\n%!"
            (Session.string_of_span span) str
;;

let bugi (cx:ctxt) (i:node_id) =
  let k s =
    report_err cx (Some i) s;
    failwith s
  in Printf.ksprintf k
;;

(* Convenience accessors. *)

(* resolve an lval reference id to the id of its definition *)
let lval_to_referent (cx:ctxt) (id:node_id) : node_id =
  if Hashtbl.mem cx.ctxt_lval_to_referent id
  then Hashtbl.find cx.ctxt_lval_to_referent id
  else bug () "unresolved lval"
;;

(* resolve an lval reference id to its definition *)
let resolve_lval_id (cx:ctxt) (id:node_id) : defn =
  Hashtbl.find cx.ctxt_all_defns (lval_to_referent cx id)
;;

let referent_is_slot (cx:ctxt) (id:node_id) : bool =
  match Hashtbl.find cx.ctxt_all_defns id with
      DEFN_slot _ -> true
    | _ -> false
;;

let referent_is_item (cx:ctxt) (id:node_id) : bool =
  match Hashtbl.find cx.ctxt_all_defns id with
      DEFN_item _ -> true
    | _ -> false
;;

(* coerce an lval definition id to a slot *)
let referent_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
  match Hashtbl.find cx.ctxt_all_defns id with
      DEFN_slot slot -> slot
    | _ -> bugi cx id "unknown slot"
;;

(* coerce an lval reference id to its definition slot *)
let lval_to_slot (cx:ctxt) (id:node_id) : Ast.slot =
  match resolve_lval_id cx id with
      DEFN_slot slot -> slot
    | _ -> bugi cx id "unknown slot"
;;

let get_stmt_depth (cx:ctxt) (id:node_id) : int =
  Hashtbl.find cx.ctxt_stmt_loop_depths id
;;

let get_slot_depth (cx:ctxt) (id:node_id) : int =
  Hashtbl.find cx.ctxt_slot_loop_depths id
;;

let get_fn_fixup (cx:ctxt) (id:node_id) : fixup =
  if Hashtbl.mem cx.ctxt_fn_fixups id
  then Hashtbl.find cx.ctxt_fn_fixups id
  else bugi cx id "fn without fixup"
;;

let get_framesz (cx:ctxt) (id:node_id) : size =
  if Hashtbl.mem cx.ctxt_frame_sizes id
  then Hashtbl.find cx.ctxt_frame_sizes id
  else bugi cx id "missing framesz"
;;

let get_callsz (cx:ctxt) (id:node_id) : size =
  if Hashtbl.mem cx.ctxt_call_sizes id
  then Hashtbl.find cx.ctxt_call_sizes id
  else bugi cx id "missing callsz"
;;

let rec n_item_ty_params (cx:ctxt) (id:node_id) : int =
  match Hashtbl.find cx.ctxt_all_defns id with
      DEFN_item i -> Array.length i.Ast.decl_params
    | DEFN_obj_fn (oid,_) -> n_item_ty_params cx oid
    | DEFN_obj_drop oid -> n_item_ty_params cx oid
    | DEFN_loop_body fid -> n_item_ty_params cx fid
    | _ -> bugi cx id "n_item_ty_params on non-item"
;;

let item_is_obj_fn (cx:ctxt) (id:node_id) : bool =
  match Hashtbl.find cx.ctxt_all_defns id with
      DEFN_obj_fn _
    | DEFN_obj_drop _ -> true
    | _ -> false
;;

let get_spill (cx:ctxt) (id:node_id) : fixup =
  if Hashtbl.mem cx.ctxt_spill_fixups id
  then Hashtbl.find cx.ctxt_spill_fixups id
  else bugi cx id "missing spill fixup"
;;

let require_native (cx:ctxt) (lib:required_lib) (name:string) : fixup =
  let lib_tab = (htab_search_or_add cx.ctxt_native_required lib
                   (fun _ -> Hashtbl.create 0))
  in
    htab_search_or_add lib_tab name
      (fun _ -> new_fixup ("require: " ^ name))
;;

let provide_native (cx:ctxt) (seg:segment) (name:string) : fixup =
  let seg_tab = (htab_search_or_add cx.ctxt_native_provided seg
                   (fun _ -> Hashtbl.create 0))
  in
    htab_search_or_add seg_tab name
      (fun _ -> new_fixup ("provide: " ^ name))
;;

let provide_existing_native
    (cx:ctxt)
    (seg:segment)
    (name:string)
    (fix:fixup)
    : unit =
  let seg_tab = (htab_search_or_add cx.ctxt_native_provided seg
                   (fun _ -> Hashtbl.create 0))
  in
    htab_put seg_tab name fix
;;

let slot_ty (s:Ast.slot) : Ast.ty =
  match s.Ast.slot_ty with
      Some t -> t
    | None -> bug () "untyped slot"
;;

let fn_output_ty (fn_ty:Ast.ty) : Ast.ty =
  match fn_ty with
      Ast.TY_fn ({ Ast.sig_output_slot = slot }, _) ->
        begin
          match slot.Ast.slot_ty with
              Some ty -> ty
            | None -> bug () "function has untyped output slot"
        end
    | _ -> bug () "fn_output_ty on non-TY_fn"
;;

(* name of tag constructor function -> name for indexing in the ty_tag *)
let rec tag_ctor_name_to_tag_name (name:Ast.name) : Ast.name =
  match name with
      Ast.NAME_base nb ->
        begin
          match nb with
              Ast.BASE_ident _ -> name
            | Ast.BASE_app (id, _) -> Ast.NAME_base (Ast.BASE_ident id)
            | _ ->
                bug () "tag_or_iso_ty_tup_by_name with non-tag-ctor name"
        end
    | Ast.NAME_ext (inner_name, _) -> tag_ctor_name_to_tag_name inner_name
;;

let tag_or_iso_ty_tup_by_name (ty:Ast.ty) (name:Ast.name) : Ast.ty_tup =
  let tagname = tag_ctor_name_to_tag_name name in
    match ty with
        Ast.TY_tag tags ->
          Hashtbl.find tags tagname
      | Ast.TY_iso { Ast.iso_index = i; Ast.iso_group = gp } ->
          Hashtbl.find gp.(i) tagname
      | _ ->
          bug () "tag_or_iso_ty_tup_by_name called with non-tag or -iso type"
;;

let defn_is_slot (d:defn) : bool =
  match d with
      DEFN_slot _ -> true
    | _ -> false
;;

let defn_is_item (d:defn) : bool =
  match d with
      DEFN_item _ -> true
    | _ -> false
;;

let slot_is_obj_state (cx:ctxt) (sid:node_id) : bool =
  Hashtbl.mem cx.ctxt_slot_is_obj_state sid
;;


(* determines whether d defines a statically-known value *)
let defn_is_static (d:defn) : bool =
  not (defn_is_slot d)
;;

let defn_is_callable (d:defn) : bool =
  match d with
      DEFN_slot { Ast.slot_ty = Some Ast.TY_fn _ }
    | DEFN_item { Ast.decl_item = (Ast.MOD_ITEM_fn _ ) } -> true
    | _ -> false
;;

(* Constraint manipulation. *)

let rec apply_names_to_carg_path
    (names:(Ast.name_base option) array)
    (cp:Ast.carg_path)
    : Ast.carg_path =
  match cp with
      Ast.CARG_ext (Ast.CARG_base Ast.BASE_formal,
                    Ast.COMP_idx i) ->
        begin
          match names.(i) with
              Some nb ->
                Ast.CARG_base (Ast.BASE_named nb)
            | None -> bug () "Indexing off non-named carg"
        end
    | Ast.CARG_ext (cp', e) ->
        Ast.CARG_ext (apply_names_to_carg_path names cp', e)
    | _ -> cp
;;

let apply_names_to_carg
    (names:(Ast.name_base option) array)
    (carg:Ast.carg)
    : Ast.carg =
  match carg with
      Ast.CARG_path cp ->
        Ast.CARG_path (apply_names_to_carg_path names cp)
    | Ast.CARG_lit _ -> carg
;;

let apply_names_to_constr
    (names:(Ast.name_base option) array)
    (constr:Ast.constr)
    : Ast.constr =
  { constr with
      Ast.constr_args =
      Array.map (apply_names_to_carg names) constr.Ast.constr_args }
;;

let atoms_to_names (atoms:Ast.atom array)
    : (Ast.name_base option) array =
  Array.map
    begin
      fun atom ->
        match atom with
            Ast.ATOM_lval (Ast.LVAL_base nbi) -> Some nbi.node
          | _ -> None
    end
    atoms
;;

let rec lval_to_name (lv:Ast.lval) : Ast.name =
  match lv with
      Ast.LVAL_base { node = nb } ->
        Ast.NAME_base nb
    | Ast.LVAL_ext (lv, lv_comp) ->
        let comp =
          begin
            match lv_comp with
                Ast.COMP_named comp -> comp
              | _ -> bug ()
                  "lval_to_name with lval that contains non-name components"
          end
        in
          Ast.NAME_ext (lval_to_name lv, comp)
;;

let rec lval_base_id (lv:Ast.lval) : node_id =
  match lv with
      Ast.LVAL_base nbi -> nbi.id
    | Ast.LVAL_ext (lv, _) -> lval_base_id lv
;;

let rec lval_base_slot (cx:ctxt) (lv:Ast.lval) : node_id option =
  match lv with
      Ast.LVAL_base nbi ->
        let referent = lval_to_referent cx nbi.id in
          if referent_is_slot cx referent
          then Some referent
          else None
    | Ast.LVAL_ext (lv, _) -> lval_base_slot cx lv
;;

let rec lval_slots (cx:ctxt) (lv:Ast.lval) : node_id array =
  match lv with
      Ast.LVAL_base nbi ->
        let referent = lval_to_referent cx nbi.id in
          if referent_is_slot cx referent
          then [| referent |]
          else [| |]
    | Ast.LVAL_ext (lv, Ast.COMP_named _) -> lval_slots cx lv
    | Ast.LVAL_ext (lv, Ast.COMP_atom a) ->
        Array.append (lval_slots cx lv) (atom_slots cx a)

and atom_slots (cx:ctxt) (a:Ast.atom) : node_id array =
  match a with
      Ast.ATOM_literal _ -> [| |]
    | Ast.ATOM_lval lv -> lval_slots cx lv
;;

let lval_option_slots (cx:ctxt) (lv:Ast.lval option) : node_id array =
  match lv with
      None -> [| |]
    | Some lv -> lval_slots cx lv
;;

let resolve_lval (cx:ctxt) (lv:Ast.lval) : defn =
  resolve_lval_id cx (lval_base_id lv)
;;

let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array =
  Array.concat (List.map (atom_slots cx) (Array.to_list az))
;;

let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array =
  Array.concat (List.map (atom_slots cx) (Array.to_list az))
;;

let rec_inputs_slots (cx:ctxt)
    (inputs:Ast.rec_input array) : node_id array =
  Array.concat (List.map
                  (fun (_, atom) -> atom_slots cx atom)
                  (Array.to_list inputs))
;;

let expr_slots (cx:ctxt) (e:Ast.expr) : node_id array =
    match e with
        Ast.EXPR_binary (_, a, b) ->
          Array.append (atom_slots cx a) (atom_slots cx b)
      | Ast.EXPR_unary (_, u) -> atom_slots cx u
      | Ast.EXPR_atom a -> atom_slots cx a
;;


(* Type extraction. *)

let interior_slot_full mut ty : Ast.slot =
  let ty =
    if mut
    then Ast.TY_mutable ty
    else ty
  in
    { Ast.slot_mode = Ast.MODE_interior;
      Ast.slot_ty = Some ty }
;;

let exterior_slot_full mut ty : Ast.slot =
  let ty =
    match ty with
        Ast.TY_exterior _ -> ty
      | _ -> Ast.TY_exterior ty
  in
  let ty =
    if mut
    then Ast.TY_mutable ty
    else ty
  in
  { Ast.slot_mode = Ast.MODE_interior;
    Ast.slot_ty = Some ty }
;;

let interior_slot ty : Ast.slot = interior_slot_full false ty
;;

let exterior_slot ty : Ast.slot = exterior_slot_full false ty
;;


(* General folds of Ast.ty. *)

type ('ty, 'tys, 'slot, 'slots, 'tag) ty_fold =
    {
      (* Functions that correspond to interior nodes in Ast.ty. *)
      ty_fold_slot : (Ast.mode * 'ty) -> 'slot;
      ty_fold_slots : ('slot array) -> 'slots;
      ty_fold_tys : ('ty array) -> 'tys;
      ty_fold_tags : (Ast.name, 'tys) Hashtbl.t -> 'tag;

      (* Functions that correspond to the Ast.ty constructors. *)
      ty_fold_any: unit -> 'ty;
      ty_fold_nil : unit -> 'ty;
      ty_fold_bool : unit -> 'ty;
      ty_fold_mach : ty_mach -> 'ty;
      ty_fold_int : unit -> 'ty;
      ty_fold_uint : unit -> 'ty;
      ty_fold_char : unit -> 'ty;
      ty_fold_str : unit -> 'ty;
      ty_fold_tup : 'tys -> 'ty;
      ty_fold_vec : 'ty -> 'ty;
      ty_fold_rec : (Ast.ident * 'ty) array -> 'ty;
      ty_fold_tag : 'tag -> 'ty;
      ty_fold_iso : (int * 'tag array) -> 'ty;
      ty_fold_idx : int -> 'ty;
      ty_fold_fn : (('slots * Ast.constrs * 'slot) * Ast.ty_fn_aux) -> 'ty;
      ty_fold_obj : (Ast.effect
                     * (Ast.ident, (('slots * Ast.constrs * 'slot) *
                                      Ast.ty_fn_aux)) Hashtbl.t) -> 'ty;
      ty_fold_chan : 'ty -> 'ty;
      ty_fold_port : 'ty -> 'ty;
      ty_fold_task : unit -> 'ty;
      ty_fold_native : opaque_id -> 'ty;
      ty_fold_param : (int * Ast.effect) -> 'ty;
      ty_fold_named : Ast.name -> 'ty;
      ty_fold_type : unit -> 'ty;
      ty_fold_exterior : 'ty -> 'ty;
      ty_fold_mutable : 'ty -> 'ty;
      ty_fold_constrained : ('ty * Ast.constrs) -> 'ty }
;;

let rec fold_ty
    (f:('ty, 'tys, 'slot, 'slots, 'tag) ty_fold)
    (ty:Ast.ty)
    : 'ty =
  let fold_slot (s:Ast.slot) : 'slot =
    f.ty_fold_slot (s.Ast.slot_mode,
                    fold_ty f (slot_ty s))
  in

  let fold_slots (slots:Ast.slot array) : 'slots =
    f.ty_fold_slots (Array.map fold_slot slots)
  in

  let fold_tys (tys:Ast.ty array) : 'tys =
    f.ty_fold_tys (Array.map (fold_ty f) tys)
  in

  let fold_tags (ttag:Ast.ty_tag) : 'tag =
    f.ty_fold_tags (htab_map ttag (fun k v -> (k, fold_tys v)))
  in

  let fold_sig tsig =
    (fold_slots tsig.Ast.sig_input_slots,
     tsig.Ast.sig_input_constrs,
     fold_slot tsig.Ast.sig_output_slot)
  in
  let fold_obj fns =
    htab_map fns (fun i (tsig, taux) -> (i, (fold_sig tsig, taux)))
  in
    match ty with
    Ast.TY_any -> f.ty_fold_any ()
  | Ast.TY_nil -> f.ty_fold_nil ()
  | Ast.TY_bool -> f.ty_fold_bool ()
  | Ast.TY_mach m -> f.ty_fold_mach m
  | Ast.TY_int -> f.ty_fold_int ()
  | Ast.TY_uint -> f.ty_fold_uint ()
  | Ast.TY_char -> f.ty_fold_char ()
  | Ast.TY_str -> f.ty_fold_str ()

  | Ast.TY_tup t -> f.ty_fold_tup (fold_tys t)
  | Ast.TY_vec t -> f.ty_fold_vec (fold_ty f t)
  | Ast.TY_rec r ->
      f.ty_fold_rec (Array.map (fun (k,v) -> (k,fold_ty f v)) r)

  | Ast.TY_tag tt -> f.ty_fold_tag (fold_tags tt)
  | Ast.TY_iso ti ->
      f.ty_fold_iso (ti.Ast.iso_index,
                     (Array.map fold_tags ti.Ast.iso_group))
  | Ast.TY_idx i -> f.ty_fold_idx i

  | Ast.TY_fn (tsig,taux) -> f.ty_fold_fn (fold_sig tsig, taux)
  | Ast.TY_chan t -> f.ty_fold_chan (fold_ty f t)
  | Ast.TY_port t -> f.ty_fold_port (fold_ty f t)

  | Ast.TY_obj (eff,t) -> f.ty_fold_obj (eff, (fold_obj t))
  | Ast.TY_task -> f.ty_fold_task ()

  | Ast.TY_native x -> f.ty_fold_native x
  | Ast.TY_param x -> f.ty_fold_param x
  | Ast.TY_named n -> f.ty_fold_named n
  | Ast.TY_type -> f.ty_fold_type ()

  | Ast.TY_exterior t -> f.ty_fold_exterior (fold_ty f t)
  | Ast.TY_mutable t -> f.ty_fold_mutable (fold_ty f t)

  | Ast.TY_constrained (t, constrs) ->
      f.ty_fold_constrained (fold_ty f t, constrs)

;;

type 'a simple_ty_fold = ('a, 'a, 'a, 'a, 'a) ty_fold
;;

let ty_fold_default (default:'a) : 'a simple_ty_fold =
    { ty_fold_tys = (fun _ -> default);
      ty_fold_slot = (fun _ -> default);
      ty_fold_slots = (fun _ -> default);
      ty_fold_tags = (fun _ -> default);
      ty_fold_any = (fun _ -> default);
      ty_fold_nil = (fun _ -> default);
      ty_fold_bool = (fun _ -> default);
      ty_fold_mach = (fun _ -> default);
      ty_fold_int = (fun _ -> default);
      ty_fold_uint = (fun _ -> default);
      ty_fold_char = (fun _ -> default);
      ty_fold_str = (fun _ -> default);
      ty_fold_tup = (fun _ -> default);
      ty_fold_vec = (fun _ -> default);
      ty_fold_rec = (fun _ -> default);
      ty_fold_tag = (fun _ -> default);
      ty_fold_iso = (fun _ -> default);
      ty_fold_idx = (fun _ -> default);
      ty_fold_fn = (fun _ -> default);
      ty_fold_obj = (fun _ -> default);
      ty_fold_chan = (fun _ -> default);
      ty_fold_port = (fun _ -> default);
      ty_fold_task = (fun _ -> default);
      ty_fold_native = (fun _ -> default);
      ty_fold_param = (fun _ -> default);
      ty_fold_named = (fun _ -> default);
      ty_fold_type = (fun _ -> default);
      ty_fold_exterior = (fun _ -> default);
      ty_fold_mutable = (fun _ -> default);
      ty_fold_constrained = (fun _ -> default) }
;;

let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
    : (Ast.ty, Ast.ty array, Ast.slot, Ast.slot array, Ast.ty_tag) ty_fold =
  let rebuild_fn ((islots, constrs, oslot), aux) =
    ({ Ast.sig_input_slots = islots;
       Ast.sig_input_constrs = constrs;
       Ast.sig_output_slot = oslot }, aux)
  in
    {
    ty_fold_tys = (fun ts -> ts);
    ty_fold_slot = (fun (mode, t) ->
                      { Ast.slot_mode = mode;
                        Ast.slot_ty = Some t });
    ty_fold_slots = (fun slots -> slots);
    ty_fold_tags = (fun htab -> htab);
    ty_fold_any = (fun _ -> id Ast.TY_any);
    ty_fold_nil = (fun _ -> id Ast.TY_nil);
    ty_fold_bool = (fun _ -> id Ast.TY_bool);
    ty_fold_mach = (fun m -> id (Ast.TY_mach m));
    ty_fold_int = (fun _ -> id Ast.TY_int);
    ty_fold_uint = (fun _ -> id Ast.TY_uint);
    ty_fold_char = (fun _ -> id Ast.TY_char);
    ty_fold_str = (fun _ -> id Ast.TY_str);
    ty_fold_tup =  (fun slots -> id (Ast.TY_tup slots));
    ty_fold_vec = (fun t -> id (Ast.TY_vec t));
    ty_fold_rec = (fun entries -> id (Ast.TY_rec entries));
    ty_fold_tag = (fun tag -> id (Ast.TY_tag tag));
    ty_fold_iso = (fun (i, tags) -> id (Ast.TY_iso { Ast.iso_index = i;
                                                     Ast.iso_group = tags }));
    ty_fold_idx = (fun i -> id (Ast.TY_idx i));
    ty_fold_fn = (fun t -> id (Ast.TY_fn (rebuild_fn t)));
    ty_fold_obj = (fun (eff,fns) ->
                     id (Ast.TY_obj
                           (eff, (htab_map fns
                                    (fun id fn -> (id, rebuild_fn fn))))));
    ty_fold_chan = (fun t -> id (Ast.TY_chan t));
    ty_fold_port = (fun t -> id (Ast.TY_port t));
    ty_fold_task = (fun _ -> id Ast.TY_task);
    ty_fold_native = (fun oid -> id (Ast.TY_native oid));
    ty_fold_param = (fun (i, mut) -> id (Ast.TY_param (i, mut)));
    ty_fold_named = (fun n -> id (Ast.TY_named n));
    ty_fold_type = (fun _ -> id (Ast.TY_type));
    ty_fold_exterior = (fun t -> id (Ast.TY_exterior t));
    ty_fold_mutable = (fun t -> id (Ast.TY_mutable t));
    ty_fold_constrained = (fun (t, constrs) ->
                             id (Ast.TY_constrained (t, constrs))) }
;;

let rebuild_ty_under_params
    (ty:Ast.ty)
    (params:Ast.ty_param array)
    (args:Ast.ty array)
    (resolve_names:bool)
    : Ast.ty =
  if (Array.length params) <> (Array.length args)
  then err None "mismatched type-params"
  else
    let nmap = Hashtbl.create (Array.length args) in
    let pmap = Hashtbl.create (Array.length args) in
    let _ =
      Array.iteri
        begin
          fun i (ident, param) ->
            htab_put pmap (Ast.TY_param param) args.(i);
            if resolve_names
            then
              htab_put nmap ident args.(i)
        end
        params
    in
    let rec rebuild_ty t =
      let base = ty_fold_rebuild (fun t -> t) in
      let ty_fold_param (i, mut) =
        let param = Ast.TY_param (i, mut) in
          match htab_search pmap param with
              None -> param
            | Some arg -> arg
      in
      let ty_fold_named n =
        let rec rebuild_name n =
          match n with
              Ast.NAME_base nb ->
                Ast.NAME_base (rebuild_name_base nb)
            | Ast.NAME_ext (n, nc) ->
                Ast.NAME_ext (rebuild_name n,
                              rebuild_name_component nc)

        and rebuild_name_base nb =
          match nb with
              Ast.BASE_ident i ->
                Ast.BASE_ident i
            | Ast.BASE_temp t ->
                Ast.BASE_temp t
            | Ast.BASE_app (i, tys) ->
                Ast.BASE_app (i, rebuild_tys tys)

        and rebuild_name_component nc =
          match nc with
              Ast.COMP_ident i ->
                Ast.COMP_ident i
            | Ast.COMP_app (i, tys) ->
                Ast.COMP_app (i, rebuild_tys tys)
            | Ast.COMP_idx i ->
                Ast.COMP_idx i

        and rebuild_tys tys =
          Array.map (fun t -> rebuild_ty t) tys
        in
        let n = rebuild_name n in
          match n with
              Ast.NAME_base (Ast.BASE_ident id)
                when resolve_names ->
                  begin
                    match htab_search nmap id with
                        None -> Ast.TY_named n
                      | Some arg -> arg
                  end
            | _ -> Ast.TY_named n
      in
      let fold =
        { base with
            ty_fold_param = ty_fold_param;
            ty_fold_named = ty_fold_named;
        }
      in
        fold_ty fold t
    in
      rebuild_ty ty
;;

let associative_binary_op_ty_fold
    (default:'a)
    (fn:'a -> 'a -> 'a)
    : 'a simple_ty_fold =
  let base = ty_fold_default default in
  let reduce ls =
    match ls with
        [] -> default
      | x::xs -> List.fold_left fn x xs
  in
  let reduce_fn ((islots, _, oslot), _) =
    fn islots oslot
  in
    { base with
        ty_fold_slots = (fun slots -> reduce (Array.to_list slots));
        ty_fold_slot = (fun (_, a) -> a);
        ty_fold_tags = (fun tab -> reduce (htab_vals tab));
        ty_fold_tup = (fun a -> a);
        ty_fold_vec = (fun a -> a);
        ty_fold_rec = (fun sz ->
                         reduce (Array.to_list
                                   (Array.map (fun (_, s) -> s) sz)));
        ty_fold_tag = (fun a -> a);
        ty_fold_iso = (fun (_,iso) -> reduce (Array.to_list iso));
        ty_fold_fn = reduce_fn;
        ty_fold_obj = (fun (_,fns) ->
                         reduce (List.map reduce_fn (htab_vals fns)));
        ty_fold_chan = (fun a -> a);
        ty_fold_port = (fun a -> a);
        ty_fold_constrained = (fun (a, _) -> a) }

let ty_fold_bool_and (default:bool) : bool simple_ty_fold =
  associative_binary_op_ty_fold default (fun a b -> a & b)
;;

let ty_fold_bool_or (default:bool) : bool simple_ty_fold =
  associative_binary_op_ty_fold default (fun a b -> a || b)
;;

let ty_fold_int_max (default:int) : int simple_ty_fold =
  associative_binary_op_ty_fold default (fun a b -> max a b)
;;

let ty_fold_list_concat _ : ('a list) simple_ty_fold =
  associative_binary_op_ty_fold [] (fun a b -> a @ b)
;;

let type_is_structured (t:Ast.ty) : bool =
  let fold = ty_fold_bool_or false in
  let fold = { fold with
                 ty_fold_tup = (fun _ -> true);
                 ty_fold_vec = (fun _ -> true);
                 ty_fold_rec = (fun _ -> true);
                 ty_fold_tag = (fun _ -> true);
                 ty_fold_iso = (fun _ -> true);
                 ty_fold_idx = (fun _ -> true);
                 ty_fold_fn = (fun _ -> true);
                 ty_fold_obj = (fun _ -> true) }
  in
    fold_ty fold t
;;

(* Effect analysis. *)
let effect_le x y =
  match (x,y) with
      (Ast.UNSAFE, _) -> true
    | (Ast.STATE, Ast.PURE) -> true
    | (Ast.STATE, Ast.IO) -> true
    | (Ast.STATE, Ast.STATE) -> true
    | (Ast.IO, Ast.PURE) -> true
    | (Ast.IO, Ast.IO) -> true
    | (Ast.PURE, Ast.PURE) -> true
    | _ -> false
;;

let lower_effect_of x y =
  if effect_le x y then x else y
;;

let type_effect (t:Ast.ty) : Ast.effect =
  let fold_mutable _ = Ast.STATE in
  let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in
  let fold = { fold with ty_fold_mutable = fold_mutable } in
    fold_ty fold t
;;

let type_has_state (t:Ast.ty) : bool =
  effect_le (type_effect t) Ast.STATE
;;


(* Various type analyses. *)

let is_prim_type (t:Ast.ty) : bool =
  match t with
      Ast.TY_int
    | Ast.TY_uint
    | Ast.TY_char
    | Ast.TY_mach _
    | Ast.TY_bool -> true
    | _ -> false
;;

let type_contains_chan (t:Ast.ty) : bool =
  let fold_chan _ = true in
  let fold = ty_fold_bool_or false in
  let fold = { fold with ty_fold_chan = fold_chan } in
    fold_ty fold t
;;


let type_is_unsigned_2s_complement t =
  match t with
      Ast.TY_mach TY_u8
    | Ast.TY_mach TY_u16
    | Ast.TY_mach TY_u32
    | Ast.TY_mach TY_u64
    | Ast.TY_char
    | Ast.TY_uint
    | Ast.TY_bool -> true
    | _ -> false
;;


let type_is_signed_2s_complement t =
  match t with
      Ast.TY_mach TY_i8
    | Ast.TY_mach TY_i16
    | Ast.TY_mach TY_i32
    | Ast.TY_mach TY_i64
    | Ast.TY_int -> true
    | _ -> false
;;


let type_is_2s_complement t =
  (type_is_unsigned_2s_complement t)
  || (type_is_signed_2s_complement t)
;;

let n_used_type_params t =
  let fold_param (i,_) = i+1 in
  let fold = ty_fold_int_max 0 in
  let fold = { fold with ty_fold_param = fold_param } in
    fold_ty fold t
;;



let check_concrete params thing =
  if Array.length params = 0
  then thing
  else bug () "unhandled parametric binding"
;;

let rec simplified_ty (t:Ast.ty) : Ast.ty =
  match t with
      Ast.TY_exterior t
    | Ast.TY_mutable t
    | Ast.TY_constrained (t, _) -> simplified_ty t
    | _ -> t
;;

let project_type
    (base_ty:Ast.ty)
    (comp:Ast.lval_component)
    : Ast.ty =
  match (simplified_ty base_ty, comp) with
      (Ast.TY_rec elts, Ast.COMP_named (Ast.COMP_ident id)) ->
        begin
          match atab_search elts id with
              Some ty -> ty
            | None -> err None "unknown record-member '%s'" id
        end

    | (Ast.TY_tup elts, Ast.COMP_named (Ast.COMP_idx i)) ->
        if 0 <= i && i < (Array.length elts)
        then elts.(i)
        else err None "out-of-range tuple index %d" i

    | (Ast.TY_vec ty, Ast.COMP_atom _) -> ty
    | (Ast.TY_str, Ast.COMP_atom _) -> (Ast.TY_mach TY_u8)
    | (Ast.TY_obj (_, fns), Ast.COMP_named (Ast.COMP_ident id)) ->
        (Ast.TY_fn (Hashtbl.find fns id))

    | (_,_) ->
        bug ()
          "project_ty: bad lval-ext: %a indexed by %a"
          Ast.sprintf_ty base_ty Ast.sprintf_lval_component comp
;;

let exports_permit (view:Ast.mod_view) (ident:Ast.ident) : bool =
  (Hashtbl.mem view.Ast.view_exports Ast.EXPORT_all_decls) ||
    (Hashtbl.mem view.Ast.view_exports (Ast.EXPORT_ident ident))
;;

(* NB: this will fail if lval is not an item. *)
let rec lval_item (cx:ctxt) (lval:Ast.lval) : Ast.mod_item =
  match lval with
      Ast.LVAL_base nb ->
        begin
          let referent = lval_to_referent cx nb.id in
            match htab_search cx.ctxt_all_defns referent with
                Some (DEFN_item item) -> {node=item; id=referent}
              | _ -> err (Some (lval_base_id lval))
                  "lval does not name an item"
        end
    | Ast.LVAL_ext (base, comp) ->
        let base_item = lval_item cx base in
        match base_item.node.Ast.decl_item with
            Ast.MOD_ITEM_mod (view, items) ->
              begin
                let i, args =
                  match comp with
                      Ast.COMP_named (Ast.COMP_ident i) -> (i, [||])
                    | Ast.COMP_named (Ast.COMP_app (i, args)) -> (i, args)
                    | _ ->
                        bug ()
                          "unhandled lval-component '%a' in Semant.lval_item"
                          Ast.sprintf_lval_component comp
                in
                  match htab_search items i with
                    | Some sub when exports_permit view i ->
                        assert
                          ((Array.length sub.node.Ast.decl_params) =
                              (Array.length args));
                        check_concrete base_item.node.Ast.decl_params sub
                    | _ -> err (Some (lval_base_id lval))
                        "unknown module item '%s'" i
              end
          | _ -> err (Some (lval_base_id lval))
              "lval base %a does not name a module" Ast.sprintf_lval base
;;

let lval_is_slot (cx:ctxt) (lval:Ast.lval) : bool =
  match resolve_lval cx lval with
      DEFN_slot _ -> true
    | _ -> false
;;

let lval_is_item (cx:ctxt) (lval:Ast.lval) : bool =
  match resolve_lval cx lval with
      DEFN_item _ -> true
    | _ -> false
;;

let lval_is_direct_fn (cx:ctxt) (lval:Ast.lval) : bool =
  let defn = resolve_lval cx lval in
    (defn_is_static defn) && (defn_is_callable defn)
;;

let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool =
  let defn = resolve_lval cx lval in
    if not (defn_is_static defn)
    then false
    else
      match defn with
          DEFN_item { Ast.decl_item = Ast.MOD_ITEM_mod _ } -> true
        | _ -> false
;;

let get_item (cx:ctxt) (node:node_id) : Ast.mod_item_decl =
  match htab_search cx.ctxt_all_defns node with
      Some (DEFN_item item) -> item
    | Some _ -> bugi cx node "defn is not an item"
    | None -> bugi cx node "missing defn"
;;

let get_slot (cx:ctxt) (node:node_id) : Ast.slot =
  match htab_search cx.ctxt_all_defns node with
      Some (DEFN_slot slot) -> slot
    | Some _ -> bugi cx node "defn is not a slot"
    | None -> bugi cx node "missing defn"
;;

let lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty =
  (*
    FIXME: The correct definition of this function is just: 
    
       Hashtbl.find cx.ctxt_all_lval_types (lval_base_id lval)
    
    However, since the typechecker is not presently handling
    every stmt, we have a fallback mode to "pick out the slot
    type and hope for the best".
  *)
  match htab_search cx.ctxt_all_lval_types (lval_base_id lval) with
      Some t -> t
    | None ->
        let rec type_of (lval:Ast.lval) : Ast.ty =
          match lval with
              Ast.LVAL_base nbi ->
                let referent = lval_to_referent cx nbi.id in
                  if lval_is_slot cx lval
                  then slot_ty (get_slot cx referent)
                  else Hashtbl.find cx.ctxt_all_item_types nbi.id
            | Ast.LVAL_ext (base, comp) ->
                let base_ty = type_of base in
                  project_type base_ty comp
        in
          type_of lval
;;

let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool =
  defn_is_static (resolve_lval cx lval)
;;

let lval_is_callable (cx:ctxt) (lval:Ast.lval) : bool =
  defn_is_callable (resolve_lval cx lval)
;;

let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool =
  if lval_is_slot cx lval
  then
    match lval with
        Ast.LVAL_ext (base, _) ->
          begin
            match lval_ty cx base with
                Ast.TY_obj _ -> true
              | _ -> false
          end
      | _ -> false
  else false
;;

let rec atom_type (cx:ctxt) (at:Ast.atom) : Ast.ty =
  match at with
      Ast.ATOM_literal {node=(Ast.LIT_int _); id=_} -> Ast.TY_int
    | Ast.ATOM_literal {node=(Ast.LIT_uint _); id=_} -> Ast.TY_uint
    | Ast.ATOM_literal {node=(Ast.LIT_bool _); id=_} -> Ast.TY_bool
    | Ast.ATOM_literal {node=(Ast.LIT_char _); id=_} -> Ast.TY_char
    | Ast.ATOM_literal {node=(Ast.LIT_nil); id=_} -> Ast.TY_nil
    | Ast.ATOM_literal {node=(Ast.LIT_mach (m,_,_)); id=_} -> Ast.TY_mach m
    | Ast.ATOM_lval lv -> lval_ty cx lv
;;

let expr_type (cx:ctxt) (e:Ast.expr) : Ast.ty =
  match e with
      Ast.EXPR_binary (op, a, _) ->
        begin
          match op with
              Ast.BINOP_eq | Ast.BINOP_ne | Ast.BINOP_lt  | Ast.BINOP_le
            | Ast.BINOP_ge | Ast.BINOP_gt -> Ast.TY_bool
            | _ -> atom_type cx a
        end
    | Ast.EXPR_unary (Ast.UNOP_not, _) -> Ast.TY_bool
    | Ast.EXPR_unary (_, a) -> atom_type cx a
    | Ast.EXPR_atom a -> atom_type cx a
;;

(* Mappings between mod items and their respective types. *)

let arg_slots (slots:Ast.header_slots) : Ast.slot array =
  Array.map (fun (sid,_) -> sid.node) slots
;;

let tup_slots (slots:Ast.header_tup) : Ast.slot array =
  Array.map (fun sid -> sid.node) slots
;;

let ty_fn_of_fn (fn:Ast.fn) : Ast.ty_fn =
  ({ Ast.sig_input_slots = arg_slots fn.Ast.fn_input_slots;
     Ast.sig_input_constrs = fn.Ast.fn_input_constrs;
     Ast.sig_output_slot = fn.Ast.fn_output_slot.node },
   fn.Ast.fn_aux )
;;

let ty_obj_of_obj (obj:Ast.obj) : Ast.ty_obj =
  (obj.Ast.obj_effect,
   htab_map obj.Ast.obj_fns (fun i f -> (i, ty_fn_of_fn f.node)))
;;

let ty_of_mod_item ((*inside*)_:bool) (item:Ast.mod_item) : Ast.ty =
  match item.node.Ast.decl_item with
      Ast.MOD_ITEM_type _ -> Ast.TY_type
    | Ast.MOD_ITEM_fn f -> (Ast.TY_fn (ty_fn_of_fn f))
    | Ast.MOD_ITEM_mod _ -> bug () "Semant.ty_of_mod_item on mod"
    | Ast.MOD_ITEM_obj ob ->
        let taux = { Ast.fn_effect = Ast.PURE;
                     Ast.fn_is_iter = false }
        in
        let tobj = Ast.TY_obj (ty_obj_of_obj ob) in
        let tsig = { Ast.sig_input_slots = arg_slots ob.Ast.obj_state;
                     Ast.sig_input_constrs = ob.Ast.obj_constrs;
                     Ast.sig_output_slot = interior_slot tobj }
        in
          (Ast.TY_fn (tsig, taux))

    | Ast.MOD_ITEM_tag (htup, ttag, _) ->
        let taux = { Ast.fn_effect = Ast.PURE;
                     Ast.fn_is_iter = false }
        in
        let tsig = { Ast.sig_input_slots = tup_slots htup;
                     Ast.sig_input_constrs = [| |];
                     Ast.sig_output_slot = interior_slot (Ast.TY_tag ttag) }
        in
          (Ast.TY_fn (tsig, taux))
;;

(* Scopes and the visitor that builds them. *)

type scope =
    SCOPE_block of node_id
  | SCOPE_mod_item of Ast.mod_item
  | SCOPE_obj_fn of (Ast.fn identified)
  | SCOPE_crate of Ast.crate
;;

let id_of_scope (sco:scope) : node_id =
  match sco with
      SCOPE_block id -> id
    | SCOPE_mod_item i -> i.id
    | SCOPE_obj_fn f -> f.id
    | SCOPE_crate c -> c.id
;;

let scope_stack_managing_visitor
    (scopes:(scope list) ref)
    (inner:Walk.visitor)
    : Walk.visitor =
  let push s =
    scopes := s :: (!scopes)
  in
  let pop _ =
    scopes := List.tl (!scopes)
  in
  let visit_block_pre b =
    push (SCOPE_block b.id);
    inner.Walk.visit_block_pre b
  in
  let visit_block_post b =
    inner.Walk.visit_block_post b;
    pop();
  in
  let visit_mod_item_pre n p i =
    push (SCOPE_mod_item i);
    inner.Walk.visit_mod_item_pre n p i
  in
  let visit_mod_item_post n p i =
    inner.Walk.visit_mod_item_post n p i;
    pop();
  in
  let visit_obj_fn_pre obj ident fn =
    push (SCOPE_obj_fn fn);
    inner.Walk.visit_obj_fn_pre obj ident fn
  in
  let visit_obj_fn_post obj ident fn =
    inner.Walk.visit_obj_fn_post obj ident fn;
    pop();
  in
  let visit_crate_pre c =
    push (SCOPE_crate c);
    inner.Walk.visit_crate_pre c
  in
  let visit_crate_post c =
    inner.Walk.visit_crate_post c;
    pop()
  in
    { inner with
        Walk.visit_block_pre = visit_block_pre;
        Walk.visit_block_post = visit_block_post;
        Walk.visit_mod_item_pre = visit_mod_item_pre;
        Walk.visit_mod_item_post = visit_mod_item_post;
        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
        Walk.visit_obj_fn_post = visit_obj_fn_post;
        Walk.visit_crate_pre = visit_crate_pre;
        Walk.visit_crate_post = visit_crate_post; }
;;

let unreferenced_required_item_ignoring_visitor
    (cx:ctxt)
    (inner:Walk.visitor)
    : Walk.visitor =

  let inhibition = ref 0 in

  let directly_inhibited i =
    (Hashtbl.mem cx.ctxt_required_items i.id) &&
      (not (Hashtbl.mem cx.ctxt_node_referenced i.id))
  in

  let indirectly_inhibited _ =
    (!inhibition) <> 0
  in

  let should_visit i =
    not ((directly_inhibited i) || (indirectly_inhibited()))
  in

  let inhibit_pre i =
    if directly_inhibited i
    then incr inhibition
  in

  let inhibit_post i =
    if directly_inhibited i
    then decr inhibition
  in

  let visit_mod_item_pre n p i =
    if should_visit i
    then inner.Walk.visit_mod_item_pre n p i;
    inhibit_pre i
  in

  let visit_mod_item_post n p i =
    if should_visit i
    then inner.Walk.visit_mod_item_post n p i;
    inhibit_post i
  in

  let visit_obj_fn_pre oid ident fn =
    if not (indirectly_inhibited())
    then inner.Walk.visit_obj_fn_pre oid ident fn;
  in

  let visit_obj_fn_post oid ident fn =
    if not (indirectly_inhibited())
    then inner.Walk.visit_obj_fn_post oid ident fn;
  in

  let visit_obj_drop_pre oid d =
    if not (indirectly_inhibited())
    then inner.Walk.visit_obj_drop_pre oid d;
  in

  let visit_obj_drop_post oid d =
    if not (indirectly_inhibited())
    then inner.Walk.visit_obj_drop_post oid d;
  in

  let visit_constr_pre n c =
    if not (indirectly_inhibited())
    then inner.Walk.visit_constr_pre n c;
  in

  let visit_constr_post n c =
    if not (indirectly_inhibited())
    then inner.Walk.visit_constr_post n c;
  in

  let wrap1 fn =
    fun x ->
      if not (indirectly_inhibited())
      then fn x
  in

    { inner with
        Walk.visit_stmt_pre = wrap1 inner.Walk.visit_stmt_pre;
        Walk.visit_stmt_post = wrap1 inner.Walk.visit_stmt_post;
        Walk.visit_slot_identified_pre =
        wrap1 inner.Walk.visit_slot_identified_pre;
        Walk.visit_slot_identified_post =
        wrap1 inner.Walk.visit_slot_identified_post;
        Walk.visit_expr_pre = wrap1 inner.Walk.visit_expr_pre;
        Walk.visit_expr_post = wrap1 inner.Walk.visit_expr_post;
        Walk.visit_ty_pre = wrap1 inner.Walk.visit_ty_pre;
        Walk.visit_ty_post = wrap1 inner.Walk.visit_ty_post;
        Walk.visit_constr_pre = visit_constr_pre;
        Walk.visit_constr_post = visit_constr_post;
        Walk.visit_pat_pre = wrap1 inner.Walk.visit_pat_pre;
        Walk.visit_pat_post = wrap1 inner.Walk.visit_pat_post;
        Walk.visit_block_pre = wrap1 inner.Walk.visit_block_pre;
        Walk.visit_block_post = wrap1 inner.Walk.visit_block_post;
        Walk.visit_lit_pre = wrap1 inner.Walk.visit_lit_pre;
        Walk.visit_lit_post = wrap1 inner.Walk.visit_lit_post;
        Walk.visit_lval_pre = wrap1 inner.Walk.visit_lval_pre;
        Walk.visit_lval_post = wrap1 inner.Walk.visit_lval_post;
        Walk.visit_mod_item_pre = visit_mod_item_pre;
        Walk.visit_mod_item_post = visit_mod_item_post;
        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
        Walk.visit_obj_fn_post = visit_obj_fn_post;
        Walk.visit_obj_drop_pre = visit_obj_drop_pre;
        Walk.visit_obj_drop_post = visit_obj_drop_post; }
;;


(* Generic lookup, used for slots, items, types, etc. *)

type resolved = ((scope list * node_id) option) ;;

let get_mod_item
    (cx:ctxt)
    (node:node_id)
    : (Ast.mod_view * Ast.mod_items) =
  match get_item cx node with
      { Ast.decl_item = Ast.MOD_ITEM_mod md } -> md
    | _ -> bugi cx node "defn is not a mod"
;;

let get_name_comp_ident
    (comp:Ast.name_component)
    : Ast.ident =
  match comp with
      Ast.COMP_ident i -> i
    | Ast.COMP_app (i, _) -> i
    | Ast.COMP_idx i -> string_of_int i
;;

let get_name_base_ident
    (comp:Ast.name_base)
    : Ast.ident =
  match comp with
      Ast.BASE_ident i -> i
    | Ast.BASE_app (i, _) -> i
    | Ast.BASE_temp _ ->
        bug () "get_name_base_ident on BASE_temp"
;;

let rec project_ident_from_items
    (cx:ctxt)
    (scopes:scope list)
    ((view:Ast.mod_view),(items:Ast.mod_items))
    (ident:Ast.ident)
    (inside:bool)
    : resolved =
  if not (inside || (exports_permit view ident))
  then None
  else
    match htab_search items ident with
        Some i ->
          found cx scopes i.id
      | None ->
          match htab_search view.Ast.view_imports ident with
              None -> None
            | Some name -> lookup_by_name cx scopes name

and found cx scopes id =
  Hashtbl.replace cx.ctxt_node_referenced id ();
  Some (scopes, id)

and project_name_comp_from_resolved
    (cx:ctxt)
    (mod_res:resolved)
    (ext:Ast.name_component)
    : resolved =
  match mod_res with
      None -> None
    | Some (scopes, id) ->
        let scope = (SCOPE_mod_item {id=id; node=get_item cx id}) in
        let scopes = scope :: scopes in
        let ident = get_name_comp_ident ext in
        let md = get_mod_item cx id in
          Hashtbl.replace cx.ctxt_node_referenced id ();
          project_ident_from_items cx scopes md ident false

and lookup_by_name
    (cx:ctxt)
    (scopes:scope list)
    (name:Ast.name)
    : resolved =
  assert (Ast.sane_name name);
  match name with
      Ast.NAME_base nb ->
        let ident = get_name_base_ident nb in
          lookup_by_ident cx scopes ident
    | Ast.NAME_ext (name, ext) ->
        let base_res = lookup_by_name cx scopes name in
          project_name_comp_from_resolved cx base_res ext

and lookup_by_ident
    (cx:ctxt)
    (scopes:scope list)
    (ident:Ast.ident)
    : resolved =

  let check_slots scopes islots =
    arr_search islots
      (fun _ (sloti,ident') ->
         if ident = ident'
         then found cx scopes sloti.id
         else None)
  in

  let check_params scopes params =
    arr_search params
      (fun _ {node=(i,_); id=id} ->
         if i = ident
         then found cx scopes id
         else None)
  in

  let passed_capture_scope = ref false in

  let would_capture r =
    match r with
        None -> None
      | Some _ ->
          if !passed_capture_scope
          then err None "attempted dynamic environment-capture"
          else r
  in

  let check_scope scopes scope =
    match scope with
        SCOPE_block block_id ->
          let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
          let block_items = Hashtbl.find cx.ctxt_block_items block_id in
            begin
              match htab_search block_slots (Ast.KEY_ident ident) with
                  Some id -> would_capture (found cx scopes id)
                | None ->
                    match htab_search block_items ident with
                        Some id -> found cx scopes id
                      | None -> None
            end

      | SCOPE_crate crate ->
          project_ident_from_items
            cx scopes crate.node.Ast.crate_items ident true

      | SCOPE_obj_fn fn ->
          would_capture (check_slots scopes fn.node.Ast.fn_input_slots)

      | SCOPE_mod_item item ->
          begin
            let item_match =
              match item.node.Ast.decl_item with
                  Ast.MOD_ITEM_fn f ->
                    check_slots scopes f.Ast.fn_input_slots

                | Ast.MOD_ITEM_obj obj ->
                    begin
                      match htab_search obj.Ast.obj_fns ident with
                          Some fn -> found cx scopes fn.id
                        | None -> check_slots scopes obj.Ast.obj_state
                    end

                | Ast.MOD_ITEM_mod md ->
                    project_ident_from_items cx scopes md ident true

                | _ -> None
            in
              match item_match with
                  Some _ -> item_match
                | None ->
                    would_capture
                      (check_params scopes item.node.Ast.decl_params)
          end
  in
  let rec search scopes =
    match scopes with
        [] -> None
      | scope::rest ->
          match check_scope scopes scope with
              None ->
                begin
                  let is_ty_item i =
                    match i.node.Ast.decl_item with
                        Ast.MOD_ITEM_type _ -> true
                      | _ -> false
                  in
                    match scope with
                        SCOPE_block _
                      | SCOPE_obj_fn _ ->
                          search rest

                      | SCOPE_mod_item item when is_ty_item item ->
                          search rest

                      | _ ->
                          passed_capture_scope := true;
                          search rest
                end
            | x -> x
  in
    search scopes
;;

let lookup_by_temp
    (cx:ctxt)
    (scopes:scope list)
    (temp:temp_id)
    : ((scope list * node_id) option) =
  let passed_item_scope = ref false in
  let check_scope scope =
    if !passed_item_scope
    then None
    else
      match scope with
          SCOPE_block block_id ->
            let block_slots = Hashtbl.find cx.ctxt_block_slots block_id in
              htab_search block_slots (Ast.KEY_temp temp)
        | _ ->
            passed_item_scope := true;
            None
  in
    list_search_ctxt scopes check_scope
;;

let lookup
    (cx:ctxt)
    (scopes:scope list)
    (key:Ast.slot_key)
    : ((scope list * node_id) option) =
  match key with
      Ast.KEY_temp temp -> lookup_by_temp cx scopes temp
    | Ast.KEY_ident ident -> lookup_by_ident cx scopes ident
;;


let run_passes
    (cx:ctxt)
    (name:string)
    (path:Ast.name_component Stack.t)
    (passes:Walk.visitor array)
    (log:string->unit)
    (crate:Ast.crate)
    : unit =
  let do_pass i pass =
    let logger s = log (Printf.sprintf "pass %d: %s" i s) in
      Walk.walk_crate
        (Walk.path_managing_visitor path
           (Walk.mod_item_logging_visitor logger path pass))
        crate
  in
  let sess = cx.ctxt_sess in
    if sess.Session.sess_failed
    then ()
    else
      try
        Session.time_inner name sess
          (fun _ -> Array.iteri do_pass passes)
      with
          Semant_err (ido, str) -> report_err cx ido str
;;

(* Rust type -> IL type conversion. *)

let word_sty (abi:Abi.abi) : Il.scalar_ty =
  Il.ValTy abi.Abi.abi_word_bits
;;

let word_rty (abi:Abi.abi) : Il.referent_ty =
  Il.ScalarTy (word_sty abi)
;;

let tydesc_rty (abi:Abi.abi) : Il.referent_ty =
  (* 
   * NB: must match corresponding tydesc structure
   * in trans and offsets in ABI exactly.
   *)
  Il.StructTy
    [|
      word_rty abi;                      (* Abi.tydesc_field_first_param   *)
      word_rty abi;                      (* Abi.tydesc_field_size          *)
      word_rty abi;                      (* Abi.tydesc_field_align         *)
      Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_copy_glue     *)
      Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_drop_glue     *)
      Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_free_glue     *)
      Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_sever_glue    *)
      Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_mark_glue     *)
      Il.ScalarTy (Il.AddrTy Il.CodeTy); (* Abi.tydesc_field_obj_drop_glue *)
    |]
;;

let obj_closure_rty (abi:Abi.abi) : Il.referent_ty =
  Il.StructTy [| word_rty abi;
                 Il.ScalarTy (Il.AddrTy (tydesc_rty abi));
                 word_rty abi (* A lie: it's opaque, but this permits
                               * GEP'ing to it. *)
              |]
;;

let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty =
  let s t = Il.ScalarTy t in
  let v b = Il.ValTy b in
  let p t = Il.AddrTy t in
  let sv b = s (v b) in
  let sp t = s (p t) in

  let word = word_rty abi in
  let ptr = sp Il.OpaqueTy in
  let rc_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
  let codeptr = sp Il.CodeTy in
  let tup ttup = Il.StructTy (Array.map (referent_type abi) ttup) in
  let tag ttag =
    let union =
      Il.UnionTy
        (Array.map
           (fun key -> tup (Hashtbl.find ttag key))
           (sorted_htab_keys ttag))
    in
    let discriminant = word in
      Il.StructTy [| discriminant; union |]
  in

    match t with
        Ast.TY_any -> Il.StructTy [| word;  ptr |]
      | Ast.TY_nil -> Il.NilTy
      | Ast.TY_int
      | Ast.TY_uint -> word

      | Ast.TY_bool -> sv Il.Bits8

      | Ast.TY_mach (TY_u8)
      | Ast.TY_mach (TY_i8) -> sv Il.Bits8

      | Ast.TY_mach (TY_u16)
      | Ast.TY_mach (TY_i16) -> sv Il.Bits16

      | Ast.TY_mach (TY_u32)
      | Ast.TY_mach (TY_i32)
      | Ast.TY_mach (TY_f32)
      | Ast.TY_char -> sv Il.Bits32

      | Ast.TY_mach (TY_u64)
      | Ast.TY_mach (TY_i64)
      | Ast.TY_mach (TY_f64) -> sv Il.Bits64

      | Ast.TY_str -> sp (Il.StructTy [| word; word; word; ptr |])
      | Ast.TY_vec _ -> sp (Il.StructTy [| word; word; word; ptr |])
      | Ast.TY_tup tt -> tup tt
      | Ast.TY_rec tr -> tup (Array.map snd tr)

      | Ast.TY_fn _ ->
          let fn_closure_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
            Il.StructTy [| codeptr; fn_closure_ptr |]

      | Ast.TY_obj _ ->
          let obj_closure_ptr = sp (obj_closure_rty abi) in
            Il.StructTy [| ptr; obj_closure_ptr |]

      | Ast.TY_tag ttag -> tag ttag
      | Ast.TY_iso tiso -> tag tiso.Ast.iso_group.(tiso.Ast.iso_index)

      | Ast.TY_idx _ -> word (* A lie, but permits GEP'ing to it. *)

      | Ast.TY_chan _
      | Ast.TY_port _
      | Ast.TY_task -> rc_ptr

      | Ast.TY_type -> sp (tydesc_rty abi)

      | Ast.TY_native _ -> ptr

      | Ast.TY_exterior t ->
          sp (Il.StructTy [| word; referent_type abi t |])

      | Ast.TY_mutable t -> referent_type abi t

      | Ast.TY_param (i, _) -> Il.ParamTy i

      | Ast.TY_named _ -> bug () "named type in referent_type"
      | Ast.TY_constrained (t, _) -> referent_type abi t

and slot_referent_type (abi:Abi.abi) (sl:Ast.slot) : Il.referent_ty =
  let s t = Il.ScalarTy t in
  let p t = Il.AddrTy t in
  let sp t = s (p t) in

  let rty = referent_type abi (slot_ty sl) in
    match sl.Ast.slot_mode with
      | Ast.MODE_interior _ -> rty
      | Ast.MODE_alias _ -> sp rty
;;

let task_rty (abi:Abi.abi) : Il.referent_ty =
  Il.StructTy
    begin
      Array.init
        Abi.n_visible_task_fields
        (fun _ -> word_rty abi)
    end
;;

let call_args_referent_type_full
    (abi:Abi.abi)
    (out_slot:Ast.slot)
    (n_ty_params:int)
    (in_slots:Ast.slot array)
    (iterator_arg_rtys:Il.referent_ty array)
    (indirect_arg_rtys:Il.referent_ty array)
    : Il.referent_ty =
  let out_slot_rty = slot_referent_type abi out_slot in
  let out_ptr_rty = Il.ScalarTy (Il.AddrTy out_slot_rty) in
  let task_ptr_rty = Il.ScalarTy (Il.AddrTy (task_rty abi)) in
  let ty_param_rtys =
    let td = Il.ScalarTy (Il.AddrTy (tydesc_rty abi)) in
      Il.StructTy (Array.init n_ty_params (fun _ -> td))
  in
  let arg_rtys = Il.StructTy (Array.map (slot_referent_type abi) in_slots) in
    (* 
     * NB: must match corresponding calltup structure in trans and
     * member indices in ABI exactly.
     *)
    Il.StructTy
      [|
        out_ptr_rty;                   (* Abi.calltup_elt_out_ptr       *)
        task_ptr_rty;                  (* Abi.calltup_elt_task_ptr      *)
        ty_param_rtys;                 (* Abi.calltup_elt_ty_params     *)
        arg_rtys;                      (* Abi.calltup_elt_args          *)
        Il.StructTy iterator_arg_rtys; (* Abi.calltup_elt_iterator_args *)
        Il.StructTy indirect_arg_rtys  (* Abi.calltup_elt_indirect_args *)
      |]
;;

let call_args_referent_type
    (cx:ctxt)
    (n_ty_params:int)
    (callee_ty:Ast.ty)
    (closure:Il.referent_ty option)
    : Il.referent_ty =
  let indirect_arg_rtys =
    match closure with
        None -> [| |]
      | Some c ->
          [|
            (* Abi.indirect_args_elt_closure *)
            Il.ScalarTy (Il.AddrTy c)
          |]
  in
  let iterator_arg_rtys _ =
    [|
      (* Abi.iterator_args_elt_loop_size *)
      Il.ScalarTy (Il.ValTy cx.ctxt_abi.Abi.abi_word_bits);
      (* Abi.iterator_args_elt_loop_info_ptr *)
      Il.ScalarTy (Il.AddrTy Il.OpaqueTy)
    |]
  in
    match callee_ty with
        Ast.TY_fn (tsig, taux) ->
          call_args_referent_type_full
            cx.ctxt_abi
            tsig.Ast.sig_output_slot
            n_ty_params
            tsig.Ast.sig_input_slots
            (if taux.Ast.fn_is_iter then (iterator_arg_rtys()) else [||])
            indirect_arg_rtys

      | _ -> bug cx "Semant.call_args_referent_type on non-callable type"
;;

let indirect_call_args_referent_type
    (cx:ctxt)
    (n_ty_params:int)
    (callee_ty:Ast.ty)
    (closure:Il.referent_ty)
    : Il.referent_ty =
  call_args_referent_type cx n_ty_params callee_ty (Some closure)
;;

let direct_call_args_referent_type
    (cx:ctxt)
    (callee_node:node_id)
    : Il.referent_ty =
  let ity = Hashtbl.find cx.ctxt_all_item_types callee_node in
  let n_ty_params =
    if item_is_obj_fn cx callee_node
    then 0
    else n_item_ty_params cx callee_node
  in
    call_args_referent_type cx n_ty_params ity None
;;

let ty_sz (abi:Abi.abi) (t:Ast.ty) : int64 =
  force_sz (Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi t))
;;

let ty_align (abi:Abi.abi) (t:Ast.ty) : int64 =
  force_sz (Il.referent_ty_align abi.Abi.abi_word_bits (referent_type abi t))
;;

let slot_sz (abi:Abi.abi) (s:Ast.slot) : int64 =
  force_sz (Il.referent_ty_size abi.Abi.abi_word_bits
              (slot_referent_type abi s))
;;

let word_slot (abi:Abi.abi) : Ast.slot =
  interior_slot (Ast.TY_mach abi.Abi.abi_word_ty)
;;

let alias_slot (ty:Ast.ty) : Ast.slot =
  { Ast.slot_mode = Ast.MODE_alias;
    Ast.slot_ty = Some ty }
;;

let mutable_alias_slot (ty:Ast.ty) : Ast.slot =
  let ty =
    match ty with
        Ast.TY_mutable _ -> ty
      | _ -> Ast.TY_mutable ty
  in
    { Ast.slot_mode = Ast.MODE_alias;
      Ast.slot_ty = Some ty }
;;

let mk_ty_fn_or_iter
    (out_slot:Ast.slot)
    (arg_slots:Ast.slot array)
    (is_iter:bool)
    : Ast.ty =
  (* In some cases we don't care what aux or constrs are. *)
  let taux = { Ast.fn_effect = Ast.PURE;
               Ast.fn_is_iter = is_iter; }
  in
  let tsig = { Ast.sig_input_slots = arg_slots;
               Ast.sig_input_constrs = [| |];
               Ast.sig_output_slot = out_slot; }
  in
    Ast.TY_fn (tsig, taux)
;;

let mk_ty_fn
    (out_slot:Ast.slot)
    (arg_slots:Ast.slot array)
    : Ast.ty =
  mk_ty_fn_or_iter out_slot arg_slots false
;;

let mk_simple_ty_fn
    (arg_slots:Ast.slot array)
    : Ast.ty =
  (* In some cases we don't care what the output slot is. *)
  let out_slot = interior_slot Ast.TY_nil in
    mk_ty_fn out_slot arg_slots
;;

let mk_simple_ty_iter
    (arg_slots:Ast.slot array)
    : Ast.ty =
  (* In some cases we don't care what the output slot is. *)
  let out_slot = interior_slot Ast.TY_nil in
    mk_ty_fn_or_iter out_slot arg_slots true
;;


(* name mangling support. *)

let item_name (cx:ctxt) (id:node_id) : Ast.name =
  Hashtbl.find cx.ctxt_all_item_names id
;;

let item_str (cx:ctxt) (id:node_id) : string =
    string_of_name (item_name cx id)
;;

let ty_str (ty:Ast.ty) : string =
  let base = associative_binary_op_ty_fold "" (fun a b -> a ^ b) in
  let fold_slot (mode,ty) =
    (match mode with
         Ast.MODE_alias -> "a"
       | Ast.MODE_interior -> "")
    ^ ty
  in
  let num n = (string_of_int n) ^ "$" in
  let len a = num (Array.length a) in
  let join az = Array.fold_left (fun a b -> a ^ b) "" az in
  let fold_slots slots =
    "t"
    ^ (len slots)
    ^ (join slots)
  in
  let fold_rec entries =
    "r"
    ^ (len entries)
    ^ (Array.fold_left
         (fun str (ident, s) -> str ^ "$" ^ ident ^ "$" ^ s)
         "" entries)
  in
  let fold_tags tags =
    "g"
    ^ (num (Hashtbl.length tags))
    ^ (Array.fold_left
         (fun str key -> str ^ (string_of_name key) ^ (Hashtbl.find tags key))
         "" (sorted_htab_keys tags))
  in
  let fold_iso (n, tags) =
    "G"
    ^ (num n)
    ^ (len tags)
    ^ (join tags)
  in
  let fold_mach m =
    match m with
        TY_u8 -> "U0"
      | TY_u16 -> "U1"
      | TY_u32 -> "U2"
      | TY_u64 -> "U3"
      | TY_i8 -> "I0"
      | TY_i16 -> "I1"
      | TY_i32 -> "I2"
      | TY_i64 -> "I3"
      | TY_f32 -> "F2"
      | TY_f64 -> "F3"
  in
  let fold =
     { base with
         (* Structural types. *)
         ty_fold_slot = fold_slot;
         ty_fold_slots = fold_slots;
         ty_fold_tags = fold_tags;
         ty_fold_rec = fold_rec;
         ty_fold_nil = (fun _ -> "n");
         ty_fold_bool = (fun _ -> "b");
         ty_fold_mach = fold_mach;
         ty_fold_int = (fun _ -> "i");
         ty_fold_uint = (fun _ -> "u");
         ty_fold_char = (fun _ -> "c");
         ty_fold_obj = (fun _ -> "o");
         ty_fold_str = (fun _ -> "s");
         ty_fold_vec = (fun s -> "v" ^ s);
         ty_fold_iso = fold_iso;
         ty_fold_idx = (fun i -> "x" ^ (string_of_int i));
         (* FIXME (issue #78): encode constrs, aux as well. *)
         ty_fold_fn = (fun ((ins,_,out),_) -> "f" ^ ins ^ out);

         (* Built-in special types. *)
         ty_fold_any = (fun _ -> "A");
         ty_fold_chan = (fun t -> "H" ^ t);
         ty_fold_port = (fun t -> "R" ^ t);
         ty_fold_task = (fun _ -> "T");
         ty_fold_native = (fun _ -> "N");
         ty_fold_param = (fun _ -> "P");
         ty_fold_type = (fun _ -> "Y");
         ty_fold_mutable = (fun t -> "m" ^ t);
         ty_fold_exterior = (fun t -> "e" ^ t);

         (* FIXME (issue #78): encode obj types. *)
         (* FIXME (issue #78): encode opaque and param numbers. *)
         ty_fold_named = (fun _ -> bug () "string-encoding named type");
         (* FIXME (issue #78): encode constrs as well. *)
         ty_fold_constrained = (fun (t,_)-> t) }
  in
    fold_ty fold ty
;;

let glue_str (cx:ctxt) (g:glue) : string =
  match g with
      GLUE_activate -> "glue$activate"
    | GLUE_yield -> "glue$yield"
    | GLUE_exit_main_task -> "glue$exit_main_task"
    | GLUE_exit_task -> "glue$exit_task"
    | GLUE_copy ty -> "glue$copy$" ^ (ty_str ty)
    | GLUE_drop ty -> "glue$drop$" ^ (ty_str ty)
    | GLUE_free ty -> "glue$free$" ^ (ty_str ty)
    | GLUE_sever ty -> "glue$sever$" ^ (ty_str ty)
    | GLUE_mark ty -> "glue$mark$" ^ (ty_str ty)
    | GLUE_clone ty -> "glue$clone$" ^ (ty_str ty)
    | GLUE_compare ty -> "glue$compare$" ^ (ty_str ty)
    | GLUE_hash ty -> "glue$hash$" ^ (ty_str ty)
    | GLUE_write ty -> "glue$write$" ^ (ty_str ty)
    | GLUE_read ty -> "glue$read$" ^ (ty_str ty)
    | GLUE_unwind -> "glue$unwind"
    | GLUE_gc -> "glue$gc"
    | GLUE_get_next_pc -> "glue$get_next_pc"
    | GLUE_mark_frame i -> "glue$mark_frame$" ^ (item_str cx i)
    | GLUE_drop_frame i -> "glue$drop_frame$" ^ (item_str cx i)
    | GLUE_reloc_frame i -> "glue$reloc_frame$" ^ (item_str cx i)
        (* 
         * FIXME (issue #78): the node_id here isn't an item, it's 
         * a statement; lookup bind target and encode bound arg 
         * tuple type.
         *)
    | GLUE_fn_binding i
      -> "glue$fn_binding$" ^ (string_of_int (int_of_node i))
    | GLUE_obj_drop oid
      -> (item_str cx oid) ^ ".drop"
    | GLUE_loop_body i
      -> "glue$loop_body$" ^ (string_of_int (int_of_node i))
    | GLUE_forward (id, oty1, oty2)
      -> "glue$forward$"
        ^ id
        ^ "$" ^ (ty_str (Ast.TY_obj oty1))
        ^ "$" ^ (ty_str (Ast.TY_obj oty2))
;;


(*
 * Local Variables:
 * fill-column: 78;
 * indent-tabs-mode: nil
 * buffer-file-coding-system: utf-8-unix
 * compile-command: "make -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
 * End:
 *)