infer_clone/infer/src/java/jContext.ml

(*
 * Copyright (c) 2009 - 2013 Monoidics ltd.
 * Copyright (c) 2013 - 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! Utils

open Javalib_pack
open Sawja_pack

module NodeTbl = Cfg.NodeHash

type jump_kind =
  | Next
  | Jump of int
  | Exit

type meth_kind =
  | Normal
  | Init

(** data  *)
type icfg = {
  tenv : Tenv.t;
  cg : Cg.t;
  cfg : Cfg.cfg;
}

type t =
  { icfg : icfg;
    procdesc : Cfg.Procdesc.t;
    impl : JBir.t;
    mutable var_map : (Pvar.t * Typ.t * Typ.t) JBir.VarMap.t;
    if_jumps : int NodeTbl.t;
    goto_jumps : (int, jump_kind) Hashtbl.t;
    cn : JBasics.class_name;
    meth_kind : meth_kind;
    node : JCode.jcode Javalib.interface_or_class;
    program : JClasspath.program;
  }

let create_context icfg procdesc impl cn meth_kind node program =
  { icfg = icfg;
    procdesc = procdesc;
    impl = impl;
    var_map = JBir.VarMap.empty;
    if_jumps = NodeTbl.create 10;
    goto_jumps = Hashtbl.create 10;
    cn = cn;
    meth_kind = meth_kind;
    node = node;
    program = program;
  }

let get_icfg context = context.icfg
let get_cfg context = context.icfg.cfg
let get_cg context = context.icfg.cg
let get_tenv context = context.icfg.tenv
let get_procdesc context = context.procdesc
let get_cn context = context.cn
let get_node context = context.node
let get_program context = context.program
let get_impl context = context.impl
let get_var_map context = context.var_map
let set_var_map context var_map = context.var_map <- var_map
let get_meth_kind context = context.meth_kind

let get_or_set_pvar_type context var typ =
  let var_map = get_var_map context in
  try
    let (pvar, otyp, _) = (JBir.VarMap.find var var_map) in
    let tenv = get_tenv context in
    if Prover.Subtyping_check.check_subtype tenv typ otyp ||
       Prover.Subtyping_check.check_subtype tenv otyp typ then
      set_var_map context (JBir.VarMap.add var (pvar, otyp, typ) var_map)
    else set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
    (pvar, typ)
  with Not_found ->
    let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in
    let varname = Mangled.from_string (JBir.var_name_g var) in
    let pvar = Pvar.mk varname procname in
    set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
    (pvar, typ)

let set_pvar context var typ = fst (get_or_set_pvar_type context var typ)

let reset_pvar_type context =
  let var_map = get_var_map context in
  let aux var item =
    match item with (pvar, otyp, _) ->
      set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in
  JBir.VarMap.iter aux var_map

let get_var_type context var =
  try
    let (_, _, otyp) = JBir.VarMap.find var (get_var_map context) in
    Some otyp
  with Not_found -> None

let get_if_jumps context = context.if_jumps
let get_goto_jumps context = context.goto_jumps

let add_if_jump context node pc =
  NodeTbl.add (get_if_jumps context) node pc

let get_if_jump context node =
  try
    Some (NodeTbl.find (get_if_jumps context) node)
  with Not_found -> None

let add_goto_jump context pc jump =
  Hashtbl.add (get_goto_jumps context) pc jump

let get_goto_jump context pc =
  try
    Hashtbl.find (get_goto_jumps context) pc
  with Not_found -> Next

let is_goto_jump context pc =
  try
    match Hashtbl.find (get_goto_jumps context) pc with
    | Jump _ -> true
    | _ -> false
  with Not_found -> false

let exn_node_table = Procname.Hash.create 100

let reset_exn_node_table () =
  Procname.Hash.clear exn_node_table

let add_exn_node procname (exn_node : Cfg.Node.t) =
  Procname.Hash.add exn_node_table procname exn_node

let get_exn_node procdesc =
  try
    Some (Procname.Hash.find exn_node_table (Cfg.Procdesc.get_proc_name procdesc))
  with Not_found -> None