(* (c) Microsoft Corporation 2005-2006.   *)

open Microsoft.AbstractIL
open Microsoft.AbstractIL.Internal

open Printf
open Microsoft.AbstractIL.IL
open Microsoft.AbstractIL.BoundIL

(*-------------------------------------------------------------------------
 * Define an assembly loader.
 *----------------------------------------------------------------------- *)

let includes = ref [Microsoft.AbstractIL.Internal.Support.clrInstallationDirectory(); "." ]
let pdb_includes = ref []

let loader = AssemblyBinder.mk_assembly_binder (fun () -> !includes, !pdb_includes)

(*-------------------------------------------------------------------------
 * The analysis: this analysis simply counts the number of times
 * the constructor System.Object() is the target of a 'newobj'
 * or 'call' instruction.
 *----------------------------------------------------------------------- *)

let total = ref 0
let count = ref 0

let do_typ mdscope ilty =
  ignore (bind_typ loader mdscope ilty)

let do_fspec mdscope fspec =
  ignore (bind_fspec loader mdscope fspec)

let do_mspec mdscope mspec =
  let bmeth = bind_mspec loader mdscope mspec in

  (* Bind the argument and return types in the thing we just bound to, just for fun. *)
  (* The bound method and its associated metadata might lie in a *)
  (* different module so the resolution scope must be adjusted accoridingly. *)
  (* The new scope is the scope of the bound method. *)
  let mdscope' = mdscope_of_bmeth bmeth in
  List.iter (fun param -> do_typ mdscope' param.paramType) (mdef_of_bmeth bmeth).mdParams;
  do_typ mdscope' (mdef_of_bmeth bmeth).mdReturn.returnType;

  (* Count the total *)
  incr total;

  (* Check if the bound method is the same as the constructor for System.Object *)
  (* Note we rebind bmeth_Object_ctor on each call, which is very inefficient.  *)
  (* If we loaded mscorlib once and for all at the start of the file we can *)
  (* bind it at the top level. *)
  let mspec_Object_ctor = mk_ctor_mspec_for_nongeneric_boxed_tref(mscorlib.tref_Object,[]) in
  let bmeth_Object_ctor = bind_mspec loader mscorlib_mdscope mspec_Object_ctor in
  if bmeth_eq bmeth bmeth_Object_ctor then
    incr count;

  (* Rebind the enclosing type and any instantiation,just for fun. *)
  (* The metadata for these is in the original module. *)
  mspec.EnclosingType |> do_typ mdscope;
  mspec.GenericArguments |> List.iter (do_typ mdscope)

let do_instr mdscope i =
  match i with
  | I_calli (_,mr,_) -> () (* TODO: callsig *)

  | I_call (_,mspec,_)
  | I_callvirt (_,mspec,_)
  | I_callconstraint (_,_,mspec,_)
  | I_newobj (mspec,_)
  | I_ldftn mspec  -> do_mspec mdscope mspec;

  | I_ldfld (_,_,fr)
  | I_ldsfld (_,fr)
  | I_ldsflda fr
  | I_ldflda fr
  | I_stfld (_,_,fr)
  | I_stsfld (_,fr) -> do_fspec mdscope fr

  | I_castclass typ
  | I_isinst typ
  | I_initobj typ
  | I_cpobj typ
  | I_stobj (_,_,typ)
  | I_ldobj (_,_,typ)
  | I_box typ
  | I_unbox typ
  | I_unbox_any typ
  | I_ldelem_any (_,typ)
  | I_stelem_any (_,typ)
  | I_newarr (_,typ)
  | I_sizeof typ
  | I_ldelema (_,_,typ) -> do_typ mdscope typ

  | x -> ()
let rec do_code mdscope x =
  match x with
  | BasicBlock bb -> Array.iter (do_instr mdscope) bb.bblockInstrs
  | GroupBlock (locs,l) -> List.iter (do_code mdscope) l
  | TryBlock (tryb,seh) ->
      do_code mdscope tryb;
      begin match seh with
      | FaultBlock b -> do_code mdscope b
      | FinallyBlock b -> do_code mdscope b
      | FilterCatchBlock clsl ->
      List.iter
            (fun (flt,ctch) ->
          (match flt with
          | CodeFilter fltcode -> do_code mdscope fltcode
          | TypeFilter ty -> do_typ mdscope ty);
          do_code mdscope ctch)
        clsl
      end
  | RestrictBlock (ls,c) -> do_code mdscope c

let do_bmeth bmeth =
  let mdscope = mdscope_of_bmeth bmeth in
  let mdef = mdef_of_bmeth bmeth in
  match dest_mbody mdef.mdBody with
  | MethodBody_il il ->
      do_code mdscope il.ilCode
  | b -> ()

let do_btycon btycon =
  let btyp = generalize_btycon btycon in
  let td = tdef_of_btycon btycon in
  List.iter (mk_generalized_bmeth btyp >> do_bmeth) (dest_mdefs td.tdMethodDefs)

let rec do_btycons_for_tdefs bmodul nesting tdefs =
  List.iter (do_btycons_for_tdef bmodul nesting) (dest_tdefs tdefs)
and do_btycons_for_tdef bmodul nesting tdef =
  do_btycon (mk_btycon (bmodul,nesting,tdef));
  do_btycons_for_tdefs bmodul (nesting @ [tdef]) tdef.tdNested

let do_bassem bassem =
  let bmainmod = mainmod_of_bassem bassem in
  do_btycons_for_tdefs bmainmod [] (modul_of_bmodul bmainmod).modulTypeDefs


(*-------------------------------------------------------------------------
 * Do the analysis for each assembly
 *----------------------------------------------------------------------- *)

let per_assembly assem =
  try
    (* Bind the assembly name using the loader.  This will search the given paths. *)
    let bassem = bind_assem loader assem in
    (* Fetch the main module of the assembly and bind its contents.  *)
    do_bassem bassem;
    (* Print results *)
    print_endline ("There are "^string_of_int !total^" call/newobj instructions.");
    print_endline ("System.Object::.ctor() is the target of "^string_of_int !count^" of them.");
  with
  | MethodNotFound (bencl,(s,n)) ->
      eprintf "No method found with name '%s' and arity '%d' in type %a.\n" s n output_any bencl;
      exit 1
  | TypeNotFound (a,m, info, nesting, tyname) ->
      eprintf "The type %s could not be found in assembly/module %s when being referenced from assembly/module '%s'" (String.concat "." (nesting @ [tyname])) info a;
      exit 1
  | e -> (*F# rethrow(); F#*) raise e

(*-------------------------------------------------------------------------
 * Top level stuff
 *----------------------------------------------------------------------- *)

let usage = [("--include", Arg.String (fun s -> includes := !includes @ [s]), "include files");
             ("--symbol-path", Arg.String (fun s -> pdb_includes := !pdb_includes @ [s]), "pdb include files"); ]

let _ =
  try Arg.parse usage per_assembly "bindall <options> <assembly-name>"
  with e -> Printf.eprintf "%s\n" (Printexc.to_string e); exit 1