infer_clone/infer/src/IR/Tenv.ml

(*
 * Copyright (c) 2016 - present Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD style license found in the
 * LICENSE file in the root directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *)
open! IStd
module Hashtbl = Caml.Hashtbl

(** Module for Type Environments. *)

(** Hash tables on strings. *)
module TypenameHash = Hashtbl.Make (struct
  type t = Typ.Name.t

  let equal tn1 tn2 = Typ.Name.equal tn1 tn2

  let hash = Hashtbl.hash
end)

(** Type for type environment. *)
type t = Typ.Struct.t TypenameHash.t

let pp fmt (tenv: t) =
  TypenameHash.iter
    (fun name typ ->
      Format.fprintf fmt "@[<6>NAME: %s@." (Typ.Name.to_string name) ;
      Format.fprintf fmt "@[<6>TYPE: %a@." (Typ.Struct.pp Pp.text name) typ)
    tenv

(** Create a new type environment. *)
let create () = TypenameHash.create 1000

(** Construct a struct type in a type environment *)
let mk_struct tenv ?default ?fields ?statics ?methods ?supers ?annots name =
  let struct_typ =
    Typ.Struct.internal_mk_struct ?default ?fields ?statics ?methods ?supers ?annots ()
  in
  TypenameHash.replace tenv name struct_typ ; struct_typ

(** Check if typename is found in tenv *)
let mem tenv name = TypenameHash.mem tenv name

(** Look up a name in the global type environment. *)
let lookup tenv name : Typ.Struct.t option =
  try Some (TypenameHash.find tenv name)
  with Not_found ->
    (* ToDo: remove the following additional lookups once C/C++ interop is resolved *)
    match (name : Typ.Name.t) with
    | CStruct m -> (
      try Some (TypenameHash.find tenv (CppClass (m, NoTemplate)))
      with Not_found -> None )
    | CppClass (m, NoTemplate) -> (
      try Some (TypenameHash.find tenv (CStruct m))
      with Not_found -> None )
    | _
     -> None

(** Add a (name,type) pair to the global type environment. *)
let add tenv name struct_typ = TypenameHash.replace tenv name struct_typ

(** Add a field to a given struct in the global type environment. *)
let add_field tenv class_tn_name field =
  match lookup tenv class_tn_name with
  | Some ({fields} as struct_typ)
   -> let field_equal (f1, _, _) (f2, _, _) = Typ.Fieldname.equal f1 f2 in
      if not (List.mem ~equal:field_equal fields field) then
        let new_fields = field :: fields in
        ignore (mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name)
  | _
   -> ()

(** Get method that is being overriden by java_pname (if any) **)
let get_overriden_method tenv pname_java =
  let struct_typ_get_method_by_name (struct_typ: Typ.Struct.t) method_name =
    List.find_exn
      ~f:(fun meth -> String.equal method_name (Typ.Procname.get_method meth))
      struct_typ.methods
  in
  let rec get_overriden_method_in_supers pname_java supers =
    match supers with
    | superclass :: supers_tail -> (
      match lookup tenv superclass with
      | Some struct_typ -> (
        try
          Some (struct_typ_get_method_by_name struct_typ (Typ.Procname.java_get_method pname_java))
        with Not_found ->
          get_overriden_method_in_supers pname_java (supers_tail @ struct_typ.supers) )
      | None
       -> get_overriden_method_in_supers pname_java supers_tail )
    | []
     -> None
  in
  match lookup tenv (Typ.Procname.java_get_class_type_name pname_java) with
  | Some {supers}
   -> get_overriden_method_in_supers pname_java supers
  | _
   -> None

(** Serializer for type environments *)
let tenv_serializer : t Serialization.serializer =
  Serialization.create_serializer Serialization.Key.tenv

let global_tenv : t option ref = ref None

(** Load a type environment from a file *)
let load_from_file (filename: DB.filename) : t option =
  if DB.equal_filename filename DB.global_tenv_fname then (
    if is_none !global_tenv then global_tenv
      := Serialization.read_from_file tenv_serializer DB.global_tenv_fname ;
    !global_tenv )
  else Serialization.read_from_file tenv_serializer filename

(** Save a type environment into a file *)
let store_to_file (filename: DB.filename) (tenv: t) =
  (* update in-memory global tenv for later uses by this process, e.g. in single-core mode the
     frontend and backend run in the same process *)
  if DB.equal_filename filename DB.global_tenv_fname then global_tenv := Some tenv ;
  Serialization.write_to_file tenv_serializer filename ~data:tenv ;
  if Config.debug_mode then
    let debug_filename = DB.filename_to_string (DB.filename_add_suffix filename ".debug") in
    let out_channel = Out_channel.create debug_filename in
    let fmt = Format.formatter_of_out_channel out_channel in
    Format.fprintf fmt "%a" pp tenv ; Out_channel.close out_channel

let iter f tenv = TypenameHash.iter f tenv

let fold f tenv = TypenameHash.fold f tenv