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

open Semant;;
open Common;;

(*
 * Resolution passes:
 *
 *   - build multiple 'scope' hashtables mapping slot_key -> node_id
 *   - build single 'type inference' hashtable mapping node_id -> slot
 *
 *   (note: not every slot is identified; only those that are declared
 *    in statements and/or can participate in local type inference.
 *    Those in function signatures are not, f.e. Also no type values
 *    are identified, though module items are. )
 *
 *)


let log cx = Session.log "resolve"
  cx.ctxt_sess.Session.sess_log_resolve
  cx.ctxt_sess.Session.sess_log_out
;;

let iflog cx thunk =
  if cx.ctxt_sess.Session.sess_log_resolve
  then thunk ()
  else ()
;;


let block_scope_forming_visitor
    (cx:ctxt)
    (inner:Walk.visitor)
    : Walk.visitor =
  let visit_block_pre b =
    if not (Hashtbl.mem cx.ctxt_block_items b.id)
    then htab_put cx.ctxt_block_items b.id (Hashtbl.create 0);
    if not (Hashtbl.mem cx.ctxt_block_slots b.id)
    then htab_put cx.ctxt_block_slots b.id (Hashtbl.create 0);
    inner.Walk.visit_block_pre b
  in
    { inner with Walk.visit_block_pre = visit_block_pre }
;;


let stmt_collecting_visitor
    (cx:ctxt)
    (inner:Walk.visitor)
    : Walk.visitor =
  let block_ids = Stack.create () in
  let visit_block_pre (b:Ast.block) =
    Stack.push b.id block_ids;
    inner.Walk.visit_block_pre b
  in
  let visit_block_post (b:Ast.block) =
    inner.Walk.visit_block_post b;
    ignore (Stack.pop block_ids)
  in

  let visit_for_block
      ((si:Ast.slot identified),(ident:Ast.ident))
      (block_id:node_id)
      : unit =
    let slots = Hashtbl.find cx.ctxt_block_slots block_id in
    let key = Ast.KEY_ident ident in
      log cx "found decl of '%s' in for-loop block header" ident;
      htab_put slots key si.id;
      htab_put cx.ctxt_slot_keys si.id key
  in

  let visit_stmt_pre stmt =
    begin
      htab_put cx.ctxt_all_stmts stmt.id stmt;
      match stmt.node with
          Ast.STMT_decl d ->
            begin
              let bid = Stack.top block_ids in
              let items = Hashtbl.find cx.ctxt_block_items bid in
              let slots = Hashtbl.find cx.ctxt_block_slots bid in
              let check_and_log_ident id ident =
                if Hashtbl.mem items ident ||
                  Hashtbl.mem slots (Ast.KEY_ident ident)
                then
                  err (Some id)
                    "duplicate declaration '%s' in block" ident
                else
                  log cx "found decl of '%s' in block" ident
              in
              let check_and_log_tmp id tmp =
                if Hashtbl.mem slots (Ast.KEY_temp tmp)
                then
                  err (Some id)
                    "duplicate declaration of temp #%d in block"
                    (int_of_temp tmp)
                else
                  log cx "found decl of temp #%d in block" (int_of_temp tmp)
              in
              let check_and_log_key id key =
                match key with
                    Ast.KEY_ident i -> check_and_log_ident id i
                  | Ast.KEY_temp t -> check_and_log_tmp id t
              in
                match d with
                    Ast.DECL_mod_item (ident, item) ->
                      check_and_log_ident item.id ident;
                      htab_put items ident item.id
                  | Ast.DECL_slot (key, sid) ->
                      check_and_log_key sid.id key;
                      htab_put slots key sid.id;
                      htab_put cx.ctxt_slot_keys sid.id key
            end
        | Ast.STMT_for f ->
            visit_for_block f.Ast.for_slot f.Ast.for_body.id
        | Ast.STMT_for_each f ->
            visit_for_block f.Ast.for_each_slot f.Ast.for_each_head.id
        | Ast.STMT_alt_tag { Ast.alt_tag_arms = arms } ->
            let rec resolve_pat block pat =
              match pat with
                  Ast.PAT_slot ({ id = slot_id }, ident) ->
                    let slots = Hashtbl.find cx.ctxt_block_slots block.id in
                    let key = Ast.KEY_ident ident in
                    htab_put slots key slot_id;
                    htab_put cx.ctxt_slot_keys slot_id key
                | Ast.PAT_tag (_, pats) -> Array.iter (resolve_pat block) pats
                | Ast.PAT_lit _ | Ast.PAT_wild -> ()
            in
            Array.iter (fun { node = (p, b) } -> resolve_pat b p) arms
        | _ -> ()
    end;
    inner.Walk.visit_stmt_pre stmt
  in
    { inner with
        Walk.visit_block_pre = visit_block_pre;
        Walk.visit_block_post = visit_block_post;
        Walk.visit_stmt_pre = visit_stmt_pre }
;;


let all_item_collecting_visitor
    (cx:ctxt)
    (path:Ast.name_component Stack.t)
    (inner:Walk.visitor)
    : Walk.visitor =

  let items = Stack.create () in

  let push_on_item_arg_list item_id arg_id =
    let existing =
      match htab_search cx.ctxt_frame_args item_id with
          None -> []
        | Some x -> x
    in
      htab_put cx.ctxt_slot_is_arg arg_id ();
      Hashtbl.replace cx.ctxt_frame_args item_id (arg_id :: existing)
  in

  let note_header item_id header =
    Array.iter
      (fun (sloti,ident) ->
         let key = Ast.KEY_ident ident in
           htab_put cx.ctxt_slot_keys sloti.id key;
           push_on_item_arg_list item_id sloti.id)
      header;
  in

  let visit_mod_item_pre n p i =
    Stack.push i.id items;
    Array.iter (fun p -> htab_put cx.ctxt_all_defns p.id
                  (DEFN_ty_param p.node)) p;
    htab_put cx.ctxt_all_defns i.id (DEFN_item i.node);
    htab_put cx.ctxt_all_item_names i.id (Walk.path_to_name path);
    log cx "collected item #%d: %s" (int_of_node i.id) n;
    begin
      match i.node.Ast.decl_item with
          Ast.MOD_ITEM_fn f ->
            note_header i.id f.Ast.fn_input_slots;
        | Ast.MOD_ITEM_obj ob ->
            note_header i.id ob.Ast.obj_state;
        | Ast.MOD_ITEM_tag (header_slots, _, _) ->
            let skey i = Printf.sprintf "_%d" i in
              note_header i.id
                (Array.mapi (fun i s -> (s, skey i)) header_slots)
        | _ -> ()
    end;
      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;
    ignore (Stack.pop items)
  in

  let visit_obj_fn_pre obj ident fn =
    htab_put cx.ctxt_all_defns fn.id (DEFN_obj_fn (obj.id, fn.node));
    htab_put cx.ctxt_all_item_names fn.id (Walk.path_to_name path);
    note_header fn.id fn.node.Ast.fn_input_slots;
    inner.Walk.visit_obj_fn_pre obj ident fn
  in

  let visit_obj_drop_pre obj b =
    htab_put cx.ctxt_all_defns b.id (DEFN_obj_drop obj.id);
    htab_put cx.ctxt_all_item_names b.id (Walk.path_to_name path);
    inner.Walk.visit_obj_drop_pre obj b
  in

  let visit_stmt_pre s =
    begin
      match s.node with
          Ast.STMT_for_each fe ->
            let id = fe.Ast.for_each_body.id in
              htab_put cx.ctxt_all_defns id
                (DEFN_loop_body (Stack.top items));
              htab_put cx.ctxt_all_item_names id
                (Walk.path_to_name path);
        | _ -> ()
    end;
    inner.Walk.visit_stmt_pre s;
  in

    { inner with
        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_drop_pre = visit_obj_drop_pre;
        Walk.visit_stmt_pre = visit_stmt_pre; }
;;


let lookup_type_node_by_name
    (cx:ctxt)
    (scopes:scope list)
    (name:Ast.name)
    : node_id =
  iflog cx (fun _ ->
              log cx "lookup_simple_type_by_name %a"
                Ast.sprintf_name name);
  match lookup_by_name cx scopes name with
      None -> err None "unknown name: %a" Ast.sprintf_name name
    | Some (_, id) ->
        match htab_search cx.ctxt_all_defns id with
            Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type _ })
          | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj _ })
          | Some (DEFN_ty_param _) -> id
          | _ ->
              err None "Found non-type binding for %a"
                Ast.sprintf_name name
;;


let get_ty_references
    (t:Ast.ty)
    (cx:ctxt)
    (scopes:scope list)
    : node_id list =
  let base = ty_fold_list_concat () in
  let ty_fold_named n =
    [ lookup_type_node_by_name cx scopes n ]
  in
  let fold = { base with ty_fold_named = ty_fold_named } in
    fold_ty fold t
;;


let type_reference_and_tag_extracting_visitor
    (cx:ctxt)
    (scopes:(scope list) ref)
    (node_to_references:(node_id,node_id list) Hashtbl.t)
    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
    (inner:Walk.visitor)
    : Walk.visitor =
  let visit_mod_item_pre id params item =
    begin
      match item.node.Ast.decl_item with
          Ast.MOD_ITEM_type ty ->
            begin
              log cx "extracting references for type node %d"
                (int_of_node item.id);
              let referenced = get_ty_references ty cx (!scopes) in
                List.iter
                  (fun i -> log cx "type %d references type %d"
                     (int_of_node item.id) (int_of_node i)) referenced;
                htab_put node_to_references item.id referenced;
                match ty with
                    Ast.TY_tag ttag ->
                      htab_put all_tags item.id (ttag, (!scopes))
                  | _ -> ()
            end
        | _ -> ()
    end;
    inner.Walk.visit_mod_item_pre id params item
  in
    { inner with
        Walk.visit_mod_item_pre = visit_mod_item_pre }
;;


type recur_info =
    { recur_all_nodes: node_id list;
      recur_curr_iso: (node_id array) option; }
;;

let empty_recur_info =
  { recur_all_nodes = [];
    recur_curr_iso = None }
;;

let push_node r n =
  { r with recur_all_nodes = n :: r.recur_all_nodes }
;;

let set_iso r i =
  { r with recur_curr_iso = Some i }
;;


let index_in_curr_iso (recur:recur_info) (node:node_id) : int option =
  match recur.recur_curr_iso with
      None -> None
    | Some iso ->
        let rec search i =
          if i >= (Array.length iso)
          then None
          else
            if iso.(i) = node
            then Some i
            else search (i+1)
        in
          search 0
;;

let need_ty_tag t =
  match t with
      Ast.TY_tag ttag -> ttag
    | _ -> err None "needed ty_tag"
;;


let rec ty_iso_of
    (cx:ctxt)
    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
    (n:node_id)
    : Ast.ty =
  let _ = iflog cx (fun _ -> log cx "+++ ty_iso_of #%d" (int_of_node n)) in
  let group_table = Hashtbl.find recursive_tag_groups n in
  let group_array = Array.of_list (htab_keys group_table) in
  let compare_nodes a_id b_id =
    let a_name = Hashtbl.find cx.ctxt_all_item_names a_id in
    let b_name = Hashtbl.find cx.ctxt_all_item_names b_id in
      compare a_name b_name
  in
  let recur = set_iso (push_node empty_recur_info n) group_array in
  let resolve_member member =
    let (tag, scopes) = Hashtbl.find all_tags member in
    let ty = Ast.TY_tag tag in
    let ty = resolve_type cx scopes recursive_tag_groups all_tags recur ty in
      need_ty_tag ty
  in
    Array.sort compare_nodes group_array;
    log cx "resolving node %d, %d-member iso group"
      (int_of_node n) (Array.length group_array);
    Array.iteri (fun i n -> log cx "member %d: %d" i
                   (int_of_node n)) group_array;
    let group = Array.map resolve_member group_array in
    let rec search i =
      if i >= (Array.length group_array)
      then err None "node is not a member of its own iso group"
      else
        if group_array.(i) = n
        then i
        else search (i+1)
    in
    let iso =
      Ast.TY_iso { Ast.iso_index = (search 0);
                   Ast.iso_group = group }
    in
    iflog cx (fun _ ->
                log cx "--- ty_iso_of #%d ==> %a"
                  (int_of_node n) Ast.sprintf_ty iso);
      iso


and lookup_type_by_name
    (cx:ctxt)
    (scopes:scope list)
    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
    (recur:recur_info)
    (name:Ast.name)
    : ((scope list) * node_id * Ast.ty) =
  iflog cx (fun _ ->
              log cx "+++ lookup_type_by_name %a"
                Ast.sprintf_name name);
  match lookup_by_name cx scopes name with
      None -> err None "unknown name: %a" Ast.sprintf_name name
    | Some (scopes', id) ->
        let ty, params =
          match htab_search cx.ctxt_all_defns id with
              Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_type t;
                                Ast.decl_params = params }) ->
                (t, Array.map (fun p -> p.node) params)
            | Some (DEFN_item { Ast.decl_item = Ast.MOD_ITEM_obj ob;
                                Ast.decl_params = params }) ->
                (Ast.TY_obj (ty_obj_of_obj ob),
                 Array.map (fun p -> p.node) params)
            | Some (DEFN_ty_param (_, x)) ->
                (Ast.TY_param x, [||])
            | _ ->
                err None "Found non-type binding for %a"
                  Ast.sprintf_name name
        in
        let args =
          match name with
              Ast.NAME_ext (_, Ast.COMP_app (_, args)) -> args
            | Ast.NAME_base (Ast.BASE_app (_, args)) -> args
            | _ -> [| |]
        in
        let args =
          iflog cx (fun _ -> log cx
                      "lookup_type_by_name %a resolving %d type args"
                      Ast.sprintf_name name
                      (Array.length args));
          Array.mapi
            begin
              fun i t ->
                let t =
                  resolve_type cx scopes recursive_tag_groups
                    all_tags recur t
                in
                  iflog cx (fun _ -> log cx
                              "lookup_type_by_name resolved arg %d to %a" i
                              Ast.sprintf_ty t);
                  t
            end
            args
        in
          iflog cx
            begin
              fun _ ->
                log cx
                  "lookup_type_by_name %a found ty %a"
                  Ast.sprintf_name name Ast.sprintf_ty ty;
                log cx "applying %d type args to %d params"
                  (Array.length args) (Array.length params);
                log cx "params: %s"
                  (Fmt.fmt_to_str Ast.fmt_decl_params params);
                log cx "args: %s"
                  (Fmt.fmt_to_str Ast.fmt_app_args args);
            end;
          let ty = rebuild_ty_under_params ty params args true in
            iflog cx (fun _ -> log cx "--- lookup_type_by_name %a ==> %a"
                        Ast.sprintf_name name
                        Ast.sprintf_ty ty);
            (scopes', id, ty)

and resolve_type
    (cx:ctxt)
    (scopes:(scope list))
    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
    (recur:recur_info)
    (t:Ast.ty)
    : Ast.ty =
  let _ = iflog cx (fun _ -> log cx "+++ resolve_type %a" Ast.sprintf_ty t) in
  let base = ty_fold_rebuild (fun t -> t) in
  let ty_fold_named name =
    let (scopes, node, t) =
      lookup_type_by_name cx scopes recursive_tag_groups all_tags recur name
    in
      iflog cx (fun _ ->
                  log cx "resolved type name '%a' to item %d with ty %a"
                  Ast.sprintf_name name (int_of_node node) Ast.sprintf_ty t);
      match index_in_curr_iso recur node with
          Some i -> Ast.TY_idx i
        | None ->
            if Hashtbl.mem recursive_tag_groups node
            then
              begin
                let ttag = need_ty_tag t in
                  Hashtbl.replace all_tags node (ttag, scopes);
                  ty_iso_of cx recursive_tag_groups all_tags node
              end
            else
              if List.mem node recur.recur_all_nodes
              then (err (Some node) "infinite recursive type definition: '%a'"
                      Ast.sprintf_name name)
              else
                let recur = push_node recur node in
                  iflog cx (fun _ -> log cx "recursively resolving type %a"
                              Ast.sprintf_ty t);
                  resolve_type cx scopes recursive_tag_groups all_tags recur t
  in
  let fold =
    { base with
        ty_fold_named = ty_fold_named; }
  in
  let t' = fold_ty fold t in
    iflog cx (fun _ ->
                log cx "--- resolve_type %a ==> %a"
                  Ast.sprintf_ty t Ast.sprintf_ty t');
    t'
;;


let type_resolving_visitor
    (cx:ctxt)
    (scopes:(scope list) ref)
    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
    (all_tags:(node_id,(Ast.ty_tag * (scope list))) Hashtbl.t)
    (inner:Walk.visitor)
    : Walk.visitor =

  let resolve_ty (t:Ast.ty) : Ast.ty =
    resolve_type cx (!scopes) recursive_tag_groups all_tags empty_recur_info t
  in

  let resolve_slot (s:Ast.slot) : Ast.slot =
    match s.Ast.slot_ty with
        None -> s
      | Some ty -> { s with Ast.slot_ty = Some (resolve_ty ty) }
  in

  let resolve_slot_identified
      (s:Ast.slot identified)
      : (Ast.slot identified) =
    try
      let slot = resolve_slot s.node in
        { s with node = slot }
    with
        Semant_err (None, e) -> raise (Semant_err ((Some s.id), e))
  in

  let visit_slot_identified_pre slot =
    let slot = resolve_slot_identified slot in
      htab_put cx.ctxt_all_defns slot.id (DEFN_slot slot.node);
      log cx "collected resolved slot #%d with type %s" (int_of_node slot.id)
        (match slot.node.Ast.slot_ty with
             None -> "??"
           | Some t -> (Fmt.fmt_to_str Ast.fmt_ty t));
      inner.Walk.visit_slot_identified_pre slot
  in

  let visit_mod_item_pre id params item =
    begin
      try
        match item.node.Ast.decl_item with
            Ast.MOD_ITEM_type ty ->
              let ty =
                resolve_type cx (!scopes) recursive_tag_groups
                  all_tags empty_recur_info ty
              in
                log cx "resolved item %s, defining type %a"
                  id Ast.sprintf_ty ty;
                htab_put cx.ctxt_all_type_items item.id ty;
                htab_put cx.ctxt_all_item_types item.id Ast.TY_type

          (* 
           * Don't resolve the "type" of a mod item; just resolve its
           * members.
           *)
          | Ast.MOD_ITEM_mod _ -> ()

          | Ast.MOD_ITEM_tag (header_slots, _, nid)
              when Hashtbl.mem recursive_tag_groups nid ->
              begin
                match ty_of_mod_item true item with
                    Ast.TY_fn (tsig, taux) ->
                      let input_slots =
                        Array.map
                          (fun sloti -> resolve_slot sloti.node)
                          header_slots
                      in
                      let output_slot =
                        interior_slot (ty_iso_of cx recursive_tag_groups
                                         all_tags nid)
                      in
                      let ty =
                        Ast.TY_fn
                          ({tsig with
                              Ast.sig_input_slots = input_slots;
                              Ast.sig_output_slot = output_slot }, taux)
                      in
                        log cx "resolved recursive tag %s, type as %a"
                          id Ast.sprintf_ty ty;
                        htab_put cx.ctxt_all_item_types item.id ty
                  | _ -> bug () "recursive tag with non-function type"
              end

          | _ ->
              let t = ty_of_mod_item true item in
              let ty =
                resolve_type cx (!scopes) recursive_tag_groups
                  all_tags empty_recur_info t
              in
                log cx "resolved item %s, type as %a" id Ast.sprintf_ty ty;
                htab_put cx.ctxt_all_item_types item.id ty;
      with
          Semant_err (None, e) -> raise (Semant_err ((Some item.id), e))
    end;
    inner.Walk.visit_mod_item_pre id params item
  in

  let visit_obj_fn_pre obj ident fn =
    let fty =
      resolve_type cx (!scopes) recursive_tag_groups all_tags
        empty_recur_info (Ast.TY_fn (ty_fn_of_fn fn.node))
    in
      log cx "resolved obj fn %s as %a" ident Ast.sprintf_ty fty;
      htab_put cx.ctxt_all_item_types fn.id fty;
      inner.Walk.visit_obj_fn_pre obj ident fn
  in

  let visit_obj_drop_pre obj b =
    let fty = mk_simple_ty_fn [| |] in
      htab_put cx.ctxt_all_item_types b.id fty;
      inner.Walk.visit_obj_drop_pre obj b
  in

  let visit_stmt_pre stmt =
    begin
      match stmt.node with
          Ast.STMT_for_each fe ->
            let id = fe.Ast.for_each_body.id in
            let fty = mk_simple_ty_iter [| |] in
              htab_put cx.ctxt_all_item_types id fty;
        | Ast.STMT_copy (_, Ast.EXPR_unary (Ast.UNOP_cast t, _)) ->
            let ty = resolve_ty t.node in
              htab_put cx.ctxt_all_cast_types t.id ty
        | _ -> ()
    end;
    inner.Walk.visit_stmt_pre stmt
  in

  let visit_lval_pre lv =
    let rec rebuild_lval' lv =
      match lv with
          Ast.LVAL_ext (base, ext) ->
            let ext =
              match ext with
                  Ast.COMP_named (Ast.COMP_ident _)
                | Ast.COMP_named (Ast.COMP_idx _)
                | Ast.COMP_atom (Ast.ATOM_literal _) -> ext
                | Ast.COMP_atom (Ast.ATOM_lval lv) ->
                    Ast.COMP_atom (Ast.ATOM_lval (rebuild_lval lv))
                | Ast.COMP_named (Ast.COMP_app (ident, params)) ->
                    Ast.COMP_named
                      (Ast.COMP_app (ident, Array.map resolve_ty params))
            in
              Ast.LVAL_ext (rebuild_lval' base, ext)

        | Ast.LVAL_base nb ->
            let node =
              match nb.node with
                  Ast.BASE_ident _
                | Ast.BASE_temp _ -> nb.node
                | Ast.BASE_app (ident, params) ->
                    Ast.BASE_app (ident, Array.map resolve_ty params)
            in
              Ast.LVAL_base {nb with node = node}

    and rebuild_lval lv =
      let id = lval_base_id lv in
      let lv' = rebuild_lval' lv in
        iflog cx (fun _ -> log cx "rebuilt lval %a as %a (#%d)"
                    Ast.sprintf_lval lv Ast.sprintf_lval lv'
                    (int_of_node id));
        htab_put cx.ctxt_all_lvals id lv';
        lv'
    in
      ignore (rebuild_lval lv);
      inner.Walk.visit_lval_pre lv
  in

    { inner with
        Walk.visit_slot_identified_pre = visit_slot_identified_pre;
        Walk.visit_mod_item_pre = visit_mod_item_pre;
        Walk.visit_obj_fn_pre = visit_obj_fn_pre;
        Walk.visit_obj_drop_pre = visit_obj_drop_pre;
        Walk.visit_stmt_pre = visit_stmt_pre;
        Walk.visit_lval_pre = visit_lval_pre; }
;;


let lval_base_resolving_visitor
    (cx:ctxt)
    (scopes:(scope list) ref)
    (inner:Walk.visitor)
    : Walk.visitor =
  let lookup_referent_by_ident id ident =
    log cx "looking up slot or item with ident '%s'" ident;
    match lookup cx (!scopes) (Ast.KEY_ident ident) with
        None -> err (Some id) "unresolved identifier '%s'" ident
      | Some (_, id) -> (log cx "resolved to node id #%d"
                           (int_of_node id); id)
  in
  let lookup_slot_by_temp id temp =
    log cx "looking up temp slot #%d" (int_of_temp temp);
    let res = lookup cx (!scopes) (Ast.KEY_temp temp) in
      match res with
          None -> err
            (Some id) "unresolved temp node #%d" (int_of_temp temp)
        | Some (_, id) ->
            (log cx "resolved to node id #%d" (int_of_node id); id)
  in
  let lookup_referent_by_name_base id nb =
    match nb with
        Ast.BASE_ident ident
      | Ast.BASE_app (ident, _) -> lookup_referent_by_ident id ident
      | Ast.BASE_temp temp -> lookup_slot_by_temp id temp
  in

  let visit_lval_pre lv =
    let rec lookup_lval lv =
      iflog cx (fun _ ->
                  log cx "looking up lval #%d"
                    (int_of_node (lval_base_id lv)));
      match lv with
          Ast.LVAL_ext (base, ext) ->
            begin
              lookup_lval base;
              match ext with
                  Ast.COMP_atom (Ast.ATOM_lval lv') -> lookup_lval lv'
                | _ -> ()
            end
        | Ast.LVAL_base nb ->
            let referent_id = lookup_referent_by_name_base nb.id nb.node in
              iflog cx (fun _ -> log cx "resolved lval #%d to referent #%d"
                          (int_of_node nb.id) (int_of_node referent_id));
              htab_put cx.ctxt_lval_to_referent nb.id referent_id
    in

    (*
     * The point here is just to tickle the reference-a-name machinery in
     * lookup that makes sure that all and only those items referenced get
     * processed by later stages. An lval that happens to be an item will
     * mark the item in question here.
     *)
    let reference_any_name lv =
      let rec lval_is_name lv =
        match lv with
            Ast.LVAL_base {node = Ast.BASE_ident _}
          | Ast.LVAL_base {node = Ast.BASE_app _} -> true
          | Ast.LVAL_ext (lv', Ast.COMP_named (Ast.COMP_ident _))
          | Ast.LVAL_ext (lv', Ast.COMP_named (Ast.COMP_app _))
            -> lval_is_name lv'
          | _ -> false
      in
        if lval_is_name lv && lval_is_item cx lv
        then ignore (lookup_by_name cx (!scopes) (lval_to_name lv))
    in

      lookup_lval lv;
      reference_any_name lv;
      inner.Walk.visit_lval_pre lv
  in
    { inner with
        Walk.visit_lval_pre = visit_lval_pre };
;;



(*
 * iso-recursion groups are very complicated.
 * 
 *   - iso groups are always rooted at *named* ty_tag nodes
 * 
 *   - consider: 
 * 
 *    type colour = tag(red, green, blue);
 *    type list = tag(cons(colour, @list), nil())
 * 
 *    this should include list as an iso but not colour,
 *    should result in:
 * 
 *    type list = iso[<0>:tag(cons(tag(red,green,blue),@#1))]
 * 
 *   - consider:
 * 
 *    type colour = tag(red, green, blue);
 *    type tree = tag(children(@list), leaf(colour))
 *    type list = tag(cons(@tree, @list), nil())
 * 
 *    this should result in:
 * 
 *    type list = iso[<0>:tag(cons(@#2, @#1),nil());
 *                    1: tag(children(@#1),leaf(tag(red,green,blue)))]
 * 
 *  - how can you calculate these?
 * 
 *    - start by making a map from named-tag-node-id -> referenced-other-nodes
 *    - for each member in the set, if you can get from itself to itself, keep
 *      it, otherwise it's non-recursive => non-interesting, delete it.
 *    - group the members (now all recursive) by dependency
 *    - assign index-number to each elt of group
 *    - fully resolve each elt of group, turning names into numbers or chasing
 *      through to fully-resolving targets as necessary
 *    - place group in iso, store differently-indexed value in table for each
 * 
 * 
 *  - what are the illegal forms?
 *    - recursion that takes indefinite storage to form a tag, eg.
 * 
 *      type t = tag(foo(t));
 *
 *    - recursion that makes a tag unconstructable, eg:
 * 
 *      type t = tag(foo(@t));
 *)

let resolve_recursion
    (cx:ctxt)
    (node_to_references:(node_id,node_id list) Hashtbl.t)
    (recursive_tag_groups:(node_id,(node_id,unit) Hashtbl.t) Hashtbl.t)
    : unit =

  let recursive_tag_types = Hashtbl.create 0 in

  let rec can_reach
      (target:node_id)
      (visited:node_id list)
      (curr:node_id)
      : bool =
    if List.mem curr visited
    then false
    else
      match htab_search node_to_references curr with
          None -> false
        | Some referenced ->
            if List.mem target referenced
            then true
            else List.exists (can_reach target (curr :: visited)) referenced
  in

  let extract_recursive_tags _ =
    Hashtbl.iter
      begin fun id _ ->
        if can_reach id [] id
        then begin
          match Hashtbl.find cx.ctxt_all_defns id with
              DEFN_item
                { Ast.decl_item = Ast.MOD_ITEM_type (Ast.TY_tag _) } ->
                log cx "type %d is a recursive tag" (int_of_node id);
                Hashtbl.replace recursive_tag_types id ()
            | _ ->
                log cx "type %d is recursive, but not a tag" (int_of_node id);
        end
        else log cx "type %d is non-recursive" (int_of_node id);
      end
      node_to_references
  in

  let group_recursive_tags _ =
    while (Hashtbl.length recursive_tag_types) != 0 do
      let keys = htab_keys recursive_tag_types in
      let root = List.hd keys in
      let group = Hashtbl.create 0 in
      let rec walk visited node =
        if List.mem node visited
        then ()
        else
          begin
            if Hashtbl.mem recursive_tag_types node
            then
              begin
                Hashtbl.remove recursive_tag_types node;
                htab_put recursive_tag_groups node group;
                htab_put group node ();
                log cx "recursion group rooted at tag %d contains tag %d"
                  (int_of_node root) (int_of_node node);
              end;
            match htab_search node_to_references node with
                None -> ()
              | Some referenced ->
                  List.iter (walk (node :: visited)) referenced
          end
      in
        walk [] root;
    done
  in

    begin
      extract_recursive_tags ();
      group_recursive_tags ();
      log cx "found %d independent type-recursion groups"
        (Hashtbl.length recursive_tag_groups);
    end
;;

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

  let not_tag_ctor nm id : unit =
    err (Some id) "'%s' is not a tag constructor" (string_of_name nm)
  in

  let resolve_pat_tag
      (name:Ast.name)
      (id:node_id)
      (pats:Ast.pat array)
      (tag_ctor_id:node_id)
      : unit =

    (* NB this isn't really the proper tag type, since we aren't applying any
     * type parameters from the tag constructor in the pattern, but since we
     * are only looking at the fact that it's a tag-like type at all, and
     * asking for its arity, it doesn't matter that the possibly parametric
     * tag type has its parameters unbound here. *)
    let tag_ty =
      fn_output_ty (Hashtbl.find cx.ctxt_all_item_types tag_ctor_id)
    in
      begin
        match tag_ty with
            Ast.TY_tag _
          | Ast.TY_iso _ ->
              let tag_ty_tup = tag_or_iso_ty_tup_by_name tag_ty name in
              let arity = Array.length tag_ty_tup in
                if (Array.length pats) != arity
                then
                  err (Some id)
                    "tag pattern '%s' with wrong number of components"
                    (string_of_name name)
                else ()
          | _ -> not_tag_ctor name id
      end
  in

  let resolve_arm { node = arm } =
    match fst arm with
        Ast.PAT_tag (lval, pats) ->
          let lval_nm = lval_to_name lval in
          let lval_id = lval_base_id lval in
          let tag_ctor_id = lval_to_referent cx lval_id in
            if referent_is_item cx tag_ctor_id

            (* FIXME (issue #76): we should actually check here that the
             * function is a tag value-ctor.  For now this actually allows
             * any function returning a tag type to pass as a tag
             * pattern.  *)
            then resolve_pat_tag lval_nm lval_id pats tag_ctor_id
            else not_tag_ctor lval_nm lval_id
      | _ -> ()
  in

  let visit_stmt_pre stmt =
    begin
      match stmt.node with
          Ast.STMT_alt_tag { Ast.alt_tag_lval = _;
                             Ast.alt_tag_arms = arms } ->
            Array.iter resolve_arm arms
        | _ -> ()
    end;
    inner.Walk.visit_stmt_pre stmt
  in
    { inner with Walk.visit_stmt_pre = visit_stmt_pre }
;;

let export_referencing_visitor
    (cx:ctxt)
    (inner:Walk.visitor)
    : Walk.visitor =
  let visit_mod_item_pre id params item =
    begin
      match item.node.Ast.decl_item with
          Ast.MOD_ITEM_mod (view, items) ->
            let is_defining_mod =
              (* auto-ref the default-export cases only if
               * the containing mod is 'defining', meaning
               * not-native / not-use
               *)
                 not (Hashtbl.mem cx.ctxt_required_items item.id)
              in
              let reference _ item =
                Hashtbl.replace cx.ctxt_node_referenced item.id ();
              in
              let reference_export e _ =
                match e with
                    Ast.EXPORT_ident ident ->
                      let item = Hashtbl.find items ident in
                        reference ident item
                  | Ast.EXPORT_all_decls ->
                      if is_defining_mod
                      then Hashtbl.iter reference items
              in
                Hashtbl.iter reference_export view.Ast.view_exports
          | _ -> ()
      end;
      inner.Walk.visit_mod_item_pre id params item
    in
      { inner with Walk.visit_mod_item_pre = visit_mod_item_pre }


;;

let process_crate
    (cx:ctxt)
    (crate:Ast.crate)
    : unit =
  let (scopes:(scope list) ref) = ref [] in
  let path = Stack.create () in

  let node_to_references = Hashtbl.create 0 in
  let all_tags = Hashtbl.create 0 in
  let recursive_tag_groups = Hashtbl.create 0 in

  let passes_0 =
    [|
      (block_scope_forming_visitor cx Walk.empty_visitor);
      (stmt_collecting_visitor cx
         (all_item_collecting_visitor cx path
            Walk.empty_visitor));
      (scope_stack_managing_visitor scopes
         (type_reference_and_tag_extracting_visitor
            cx scopes node_to_references all_tags
            Walk.empty_visitor))
    |]
  in

  let passes_1 =
    [|
      (scope_stack_managing_visitor scopes
         (type_resolving_visitor cx scopes
            recursive_tag_groups all_tags
            (lval_base_resolving_visitor cx scopes
               Walk.empty_visitor)));
    |]
  in

  let passes_2 =
    [|
      (scope_stack_managing_visitor scopes
         (pattern_resolving_visitor cx
            Walk.empty_visitor));
      export_referencing_visitor cx Walk.empty_visitor
    |]
  in

    log cx "running primary resolve passes";
    run_passes cx "resolve collect" path passes_0 (log cx "%s") crate;
    resolve_recursion cx node_to_references recursive_tag_groups;
    log cx "running secondary resolve passes";
    run_passes cx "resolve bind" path passes_1 (log cx "%s") crate;
    log cx "running tertiary resolve passes";
    run_passes cx "resolve patterns" path passes_2 (log cx "%s") crate;

    iflog cx
      begin
        fun _ ->
          Hashtbl.iter
            begin
              fun n _ ->
                if referent_is_item cx n
                then
                  log cx "referenced: %a"
                    Ast.sprintf_name
                    (Hashtbl.find cx.ctxt_all_item_names n)
            end
            cx.ctxt_node_referenced;
      end
;;

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