diff --git a/configure.ac b/configure.ac index b322857d4..d7439ca96 100644 --- a/configure.ac +++ b/configure.ac @@ -17,7 +17,7 @@ AC_PREREQ([2.63]) AC_INIT([Infer], [0.8.1], [https://github.com/facebook/infer/issues/]) -AC_CONFIG_SRCDIR([infer/src/IR/sil.ml]) +AC_CONFIG_SRCDIR([infer/src/IR/Sil.re]) # WARNING: keep in sync with above INFER_MAJOR=0 diff --git a/infer/src/IR/AttributesTable.re b/infer/src/IR/AttributesTable.re new file mode 100644 index 000000000..ce78f00e7 --- /dev/null +++ b/infer/src/IR/AttributesTable.re @@ -0,0 +1,86 @@ +/* + * Copyright (c) 2015 - 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; + +let module F = Format; + +let module L = Logging; + + +/** Module to manage the table of attributes. */ +let serializer: Serialization.serializer ProcAttributes.t = Serialization.create_serializer Serialization.attributes_key; + +let attributes_filename pname => { + let pname_file = Procname.to_filename pname; + pname_file ^ ".attr" +}; + + +/** path to the .attr file for the given procedure in the current results directory */ +let res_dir_attr_filename pname => { + let attr_fname = attributes_filename pname; + let bucket_dir = { + let base = Filename.chop_extension attr_fname; + let len = String.length base; + if (len < 2) { + Filename.current_dir_name + } else { + String.sub base (len - 2) 2 + } + }; + let filename = + DB.Results_dir.path_to_filename + DB.Results_dir.Abs_root [Config.attributes_dir_name, bucket_dir, attr_fname]; + DB.filename_create_dir filename; + filename +}; + +let store_attributes proc_attributes => { + let proc_name = proc_attributes.ProcAttributes.proc_name; + let attributes_file = res_dir_attr_filename proc_name; + let should_write = + /* only overwrite defined procedures */ + proc_attributes.ProcAttributes.is_defined || not (DB.file_exists attributes_file); + if should_write { + Serialization.to_file serializer attributes_file proc_attributes + } +}; + +let load_attributes proc_name => { + let attributes_file = res_dir_attr_filename proc_name; + Serialization.from_file serializer attributes_file +}; + + +/** Given a procdesure name, find the file where it is defined and */ +/** its corresponding type environment */ +let find_tenv_from_class_of_proc procname => + switch (load_attributes procname) { + | None => None + | Some attrs => + let source_file = attrs.ProcAttributes.loc.Location.file; + let source_dir = DB.source_dir_from_source_file source_file; + let tenv_fname = DB.source_dir_get_internal_file source_dir ".tenv"; + Tenv.load_from_file tenv_fname + }; + + +/** Given an ObjC class c, extract the type from the tenv where the class was */ +/** defined. We do this by adding a method that is unique to each class, and then */ +/** finding the tenv that corresponds to the class definition. */ +let get_correct_type_from_objc_class_name c => { + let class_method = Procname.get_default_objc_class_method (Mangled.to_string c); + switch (find_tenv_from_class_of_proc class_method) { + | None => None + | Some tenv => + let type_name = Typename.TN_csu (Csu.Class Csu.Objc) c; + Option.map (fun st => Sil.Tstruct st) (Tenv.lookup tenv type_name) + } +}; diff --git a/infer/src/IR/AttributesTable.rei b/infer/src/IR/AttributesTable.rei new file mode 100644 index 000000000..177defe00 --- /dev/null +++ b/infer/src/IR/AttributesTable.rei @@ -0,0 +1,30 @@ +/* + * Copyright (c) 2015 - 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; + + +/** Module to manage the table of attributes. */ +/** Save .attr file for the procedure into the attributes database. */ +let store_attributes: ProcAttributes.t => unit; + + +/** Load the attributes for the procedure from the attributes database. */ +let load_attributes: Procname.t => option ProcAttributes.t; + + +/** Given a procdesure name, find the file where it is defined and */ +/** its corresponding type environment */ +let find_tenv_from_class_of_proc: Procname.t => option Tenv.t; + + +/** Given an ObjC class c, extract the type from the tenv where the class was */ +/** defined. We do this by adding a method that is unique to each class, and then */ +/** finding the tenv that corresponds to the class definition. */ +let get_correct_type_from_objc_class_name: Mangled.t => option Sil.typ; diff --git a/infer/src/IR/Cfg.re b/infer/src/IR/Cfg.re new file mode 100644 index 000000000..cde767e73 --- /dev/null +++ b/infer/src/IR/Cfg.re @@ -0,0 +1,1302 @@ +/* + * 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; + +let module L = Logging; + +let module F = Format; + +/* ============== START of ADT node and proc_desc ============== */ +/* =============== START of module Node =============== */ +let module Node = { + type id = int; + type nodekind = + | Start_node of proc_desc + | Exit_node of proc_desc + | Stmt_node of string + | Join_node + | Prune_node of bool Sil.if_kind string /** (true/false branch, if_kind, comment) */ + | Skip_node of string + /** a node */ + and t = { + /** unique id of the node */ + nd_id: id, + /** distance to the exit node */ + mutable nd_dist_exit: option int, + /** dead program variables after executing the instructions */ + mutable nd_dead_pvars_after: list Pvar.t, + /** dead program variables before executing the instructions */ + mutable nd_deads_before: list Pvar.t, + /** exception nodes in the cfg */ + mutable nd_exn: list t, + /** instructions for symbolic execution */ + mutable nd_instrs: list Sil.instr, + /** kind of node */ + mutable nd_kind: nodekind, + /** location in the source code */ + mutable nd_loc: Location.t, + /** predecessor nodes in the cfg */ + mutable nd_preds: list t, + /** proc desc from cil */ + mutable nd_proc: option proc_desc, + /** successor nodes in the cfg */ + mutable nd_succs: list t + } + /** procedure description */ + and proc_desc = { + pd_attributes: ProcAttributes.t, /** attributes of the procedure */ + pd_id: int, /** unique proc_desc identifier */ + mutable pd_nodes: list t, /** list of nodes of this procedure */ + mutable pd_start_node: t, /** start node of this procedure */ + mutable pd_exit_node: t /** exit node of ths procedure */ + }; + let exn_handler_kind = Stmt_node "exception handler"; + let exn_sink_kind = Stmt_node "exceptions sink"; + let throw_kind = Stmt_node "throw"; + + /** data type for the control flow graph */ + type cfg = { + node_id: ref int, + node_list: ref (list t), + name_pdesc_tbl: Procname.Hash.t proc_desc, /** Map proc name to procdesc */ + mutable priority_set: Procname.Set.t + /** set of function names to be analyzed first */ + }; + let create_cfg () => + /** create a new empty cfg */ + { + node_id: ref 0, + node_list: ref [], + name_pdesc_tbl: Procname.Hash.create 1000, + priority_set: Procname.Set.empty + }; + + /** compute the list of procedures added or changed in [cfg_new] over [cfg_old] */ + let mark_unchanged_pdescs cfg_new cfg_old => { + let pdescs_eq pd1 pd2 => + /* map of exp names in pd1 -> exp names in pd2 */ + { + let exp_map = ref Sil.ExpMap.empty; + /* map of node id's in pd1 -> node id's in pd2 */ + let id_map = ref IntMap.empty; + /* formals are the same if their types are the same */ + let formals_eq formals1 formals2 => + IList.equal (fun (_, typ1) (_, typ2) => Sil.typ_compare typ1 typ2) formals1 formals2; + let nodes_eq n1s n2s => + /* nodes are the same if they have the same id, instructions, and succs/preds up to renaming + with [exp_map] and [id_map] */ + { + let node_eq n1 n2 => { + let id_compare n1 n2 => { + let (id1, id2) = (n1.nd_id, n2.nd_id); + try { + let id1_mapping = IntMap.find id1 !id_map; + Pervasives.compare id1_mapping id2 + } { + | Not_found => + /* assume id's are equal and enforce by adding to [id_map] */ + id_map := IntMap.add id1 id2 !id_map; + 0 + } + }; + let instrs_eq instrs1 instrs2 => + IList.equal + ( + fun i1 i2 => { + let (n, exp_map') = Sil.instr_compare_structural i1 i2 !exp_map; + exp_map := exp_map'; + n + } + ) + instrs1 + instrs2; + id_compare n1 n2 == 0 && + IList.equal id_compare n1.nd_succs n2.nd_succs && + IList.equal id_compare n1.nd_preds n2.nd_preds && + instrs_eq n1.nd_instrs n2.nd_instrs + }; + try (IList.for_all2 node_eq n1s n2s) { + | Invalid_argument _ => false + } + }; + let att1 = pd1.pd_attributes + and att2 = pd2.pd_attributes; + att1.ProcAttributes.is_defined == att2.ProcAttributes.is_defined && + Sil.typ_equal att1.ProcAttributes.ret_type att2.ProcAttributes.ret_type && + formals_eq att1.ProcAttributes.formals att2.ProcAttributes.formals && + nodes_eq pd1.pd_nodes pd2.pd_nodes + }; + let old_procs = cfg_old.name_pdesc_tbl; + let new_procs = cfg_new.name_pdesc_tbl; + let mark_pdesc_if_unchanged pname new_pdesc => + try { + let old_pdesc = Procname.Hash.find old_procs pname; + let changed = + /* in continue_capture mode keep the old changed bit */ + Config.continue_capture && old_pdesc.pd_attributes.ProcAttributes.changed || + not (pdescs_eq old_pdesc new_pdesc); + new_pdesc.pd_attributes.changed = changed + } { + | Not_found => () + }; + Procname.Hash.iter mark_pdesc_if_unchanged new_procs + }; + let node_id_gen cfg => { + incr cfg.node_id; + !cfg.node_id + }; + let pdesc_tbl_add cfg proc_name proc_desc => + Procname.Hash.add cfg.name_pdesc_tbl proc_name proc_desc; + let pdesc_tbl_remove cfg proc_name => Procname.Hash.remove cfg.name_pdesc_tbl proc_name; + let pdesc_tbl_find cfg proc_name => Procname.Hash.find cfg.name_pdesc_tbl proc_name; + let iter_proc_desc cfg f => Procname.Hash.iter f cfg.name_pdesc_tbl; + let dummy () => { + nd_id: 0, + nd_dist_exit: None, + nd_dead_pvars_after: [], + nd_deads_before: [], + nd_instrs: [], + nd_kind: Skip_node "dummy", + nd_loc: Location.dummy, + nd_proc: None, + nd_succs: [], + nd_preds: [], + nd_exn: [] + }; + let compare node1 node2 => int_compare node1.nd_id node2.nd_id; + let hash node => Hashtbl.hash node.nd_id; + let equal node1 node2 => compare node1 node2 == 0; + let get_all_nodes cfg => !cfg.node_list; + let create cfg loc kind instrs pdesc => { + let node_id = node_id_gen cfg; + let node = { + nd_id: node_id, + nd_dist_exit: None, + nd_dead_pvars_after: [], + nd_deads_before: [], + nd_instrs: instrs, + nd_kind: kind, + nd_loc: loc, + nd_preds: [], + nd_proc: Some pdesc, + nd_succs: [], + nd_exn: [] + }; + cfg.node_list := [node, ...!cfg.node_list]; + pdesc.pd_nodes = [node, ...pdesc.pd_nodes]; + node + }; + + /** Get the unique id of the node */ + let get_id node => node.nd_id; + + /** compare node ids */ + let id_compare = int_compare; + let get_succs node => node.nd_succs; + type node = t; + let module NodeSet = Set.Make { + type t = node; + let compare = compare; + }; + let module NodeMap = Map.Make { + type t = node; + let compare = compare; + }; + let module IdMap = Map.Make { + type t = id; + let compare = id_compare; + }; + let get_sliced_succs node f => { + let visited = ref NodeSet.empty; + let rec slice_nodes nodes :NodeSet.t => { + let do_node acc n => { + visited := NodeSet.add n !visited; + if (f n) { + NodeSet.singleton n + } else { + NodeSet.union + acc (slice_nodes (IList.filter (fun s => not (NodeSet.mem s !visited)) n.nd_succs)) + } + }; + IList.fold_left do_node NodeSet.empty nodes + }; + NodeSet.elements (slice_nodes node.nd_succs) + }; + let get_sliced_preds node f => { + let visited = ref NodeSet.empty; + let rec slice_nodes nodes :NodeSet.t => { + let do_node acc n => { + visited := NodeSet.add n !visited; + if (f n) { + NodeSet.singleton n + } else { + NodeSet.union + acc (slice_nodes (IList.filter (fun s => not (NodeSet.mem s !visited)) n.nd_preds)) + } + }; + IList.fold_left do_node NodeSet.empty nodes + }; + NodeSet.elements (slice_nodes node.nd_preds) + }; + let get_exn node => node.nd_exn; + let set_proc_desc node proc => node.nd_proc = Some proc; + + /** Get the proc desc of the node */ + let get_proc_desc node => + switch node.nd_proc { + | None => + L.out "node_get_proc_desc: at node %d@\n" node.nd_id; + assert false + | Some proc_desc => proc_desc + }; + + /** Set the successor nodes and exception nodes, and build predecessor links */ + let set_succs_exn_base node succs exn => { + node.nd_succs = succs; + node.nd_exn = exn; + IList.iter (fun n => n.nd_preds = [node, ...n.nd_preds]) succs + }; + + /** Set the successor and exception nodes. + If this is a join node right before the exit node, add an extra node in the middle, + otherwise nullify and abstract instructions cannot be added after a conditional. */ + let set_succs_exn cfg node succs exn => + switch (node.nd_kind, succs) { + | (Join_node, [{nd_kind: Exit_node _} as exit_node]) => + let kind = Stmt_node "between_join_and_exit"; + let pdesc = get_proc_desc node; + let node' = create cfg node.nd_loc kind node.nd_instrs pdesc; + set_succs_exn_base node [node'] exn; + set_succs_exn_base node' [exit_node] exn + | _ => set_succs_exn_base node succs exn + }; + + /** Get the predecessors of the node */ + let get_preds node => node.nd_preds; + + /** Generates a list of nodes starting at a given node + and recursively adding the results of the generator */ + let get_generated_slope start_node generator => { + let visited = ref NodeSet.empty; + let rec nodes n => { + visited := NodeSet.add n !visited; + let succs = IList.filter (fun n => not (NodeSet.mem n !visited)) (generator n); + switch (IList.length succs) { + | 1 => [n, ...nodes (IList.hd succs)] + | _ => [n] + } + }; + nodes start_node + }; + + /** Get the node kind */ + let get_kind node => node.nd_kind; + + /** Set the node kind */ + let set_kind node kind => node.nd_kind = kind; + + /** Comparison for node kind */ + let kind_compare k1 k2 => + switch (k1, k2) { + | (Start_node pd1, Start_node pd2) => int_compare pd1.pd_id pd2.pd_id + | (Start_node _, _) => (-1) + | (_, Start_node _) => 1 + | (Exit_node pd1, Exit_node pd2) => int_compare pd1.pd_id pd2.pd_id + | (Exit_node _, _) => (-1) + | (_, Exit_node _) => 1 + | (Stmt_node s1, Stmt_node s2) => string_compare s1 s2 + | (Stmt_node _, _) => (-1) + | (_, Stmt_node _) => 1 + | (Join_node, Join_node) => 0 + | (Join_node, _) => (-1) + | (_, Join_node) => 1 + | (Prune_node is_true_branch1 if_kind1 descr1, Prune_node is_true_branch2 if_kind2 descr2) => + let n = bool_compare is_true_branch1 is_true_branch2; + if (n != 0) { + n + } else { + let n = Pervasives.compare if_kind1 if_kind2; + if (n != 0) { + n + } else { + string_compare descr1 descr2 + } + } + | (Prune_node _, _) => (-1) + | (_, Prune_node _) => 1 + | (Skip_node s1, Skip_node s2) => string_compare s1 s2 + }; + + /** Get the instructions to be executed */ + let get_instrs node => node.nd_instrs; + + /** Get the list of callee procnames from the node */ + let get_callees node => { + let collect callees instr => + switch instr { + | Sil.Call _ exp _ _ _ => + switch exp { + | Sil.Const (Sil.Cfun procname) => [procname, ...callees] + | _ => callees + } + | _ => callees + }; + IList.fold_left collect [] (get_instrs node) + }; + + /** Get the location of the node */ + let get_loc n => n.nd_loc; + + /** Get the source location of the last instruction in the node */ + let get_last_loc n => + switch (IList.rev (get_instrs n)) { + | [instr, ..._] => Sil.instr_get_loc instr + | [] => n.nd_loc + }; + + /** Set the location of the node */ + let set_loc n loc => n.nd_loc = loc; + let pp_id f id => F.fprintf f "%d" id; + let pp f node => pp_id f (get_id node); + let proc_desc_from_name cfg proc_name => + try (Some (pdesc_tbl_find cfg proc_name)) { + | Not_found => None + }; + let set_dead_pvars node after dead => + if after { + node.nd_dead_pvars_after = dead + } else { + node.nd_deads_before = dead + }; + let get_dead_pvars node after => + if after { + node.nd_dead_pvars_after + } else { + node.nd_deads_before + }; + let get_distance_to_exit node => node.nd_dist_exit; + + /** Append the instructions to the list of instructions to execute */ + let append_instrs node instrs => node.nd_instrs = node.nd_instrs @ instrs; + + /** Add the instructions at the beginning of the list of instructions to execute */ + let prepend_instrs node instrs => node.nd_instrs = instrs @ node.nd_instrs; + + /** Replace the instructions to be executed. */ + let replace_instrs node instrs => node.nd_instrs = instrs; + let proc_desc_get_ret_var pdesc => Pvar.get_ret_pvar pdesc.pd_attributes.ProcAttributes.proc_name; + + /** Add declarations for local variables and return variable to the node */ + let add_locals_ret_declaration node locals => { + let loc = get_loc node; + let pdesc = get_proc_desc node; + let proc_name = pdesc.pd_attributes.ProcAttributes.proc_name; + let ret_var = { + let ret_type = pdesc.pd_attributes.ProcAttributes.ret_type; + (proc_desc_get_ret_var pdesc, ret_type) + }; + let construct_decl (x, typ) => (Pvar.mk x proc_name, typ); + let ptl = [ret_var, ...IList.map construct_decl locals]; + let instr = Sil.Declare_locals ptl loc; + prepend_instrs node [instr] + }; + + /** Counter for identifiers of procdescs */ + let proc_desc_id_counter = ref 0; + let proc_desc_create cfg proc_attributes => { + incr proc_desc_id_counter; + let pdesc = { + pd_attributes: proc_attributes, + pd_id: !proc_desc_id_counter, + pd_nodes: [], + pd_start_node: dummy (), + pd_exit_node: dummy () + }; + pdesc_tbl_add cfg proc_attributes.ProcAttributes.proc_name pdesc; + pdesc + }; + let remove_node' filter_out_fun cfg => { + let remove_node_in_cfg nodes => IList.filter filter_out_fun nodes; + cfg.node_list := remove_node_in_cfg !cfg.node_list + }; + let remove_node_set cfg nodes => remove_node' (fun node' => not (NodeSet.mem node' nodes)) cfg; + let proc_desc_remove cfg name remove_nodes => { + if remove_nodes { + let pdesc = pdesc_tbl_find cfg name; + let proc_nodes = + IList.fold_right (fun node set => NodeSet.add node set) pdesc.pd_nodes NodeSet.empty; + remove_node_set cfg proc_nodes + }; + pdesc_tbl_remove cfg name + }; + let proc_desc_get_start_node proc_desc => proc_desc.pd_start_node; + let proc_desc_get_err_log proc_desc => proc_desc.pd_attributes.ProcAttributes.err_log; + let proc_desc_get_attributes proc_desc => proc_desc.pd_attributes; + let proc_desc_get_exit_node proc_desc => proc_desc.pd_exit_node; + + /** Compute the distance of each node to the exit node, if not computed already */ + let proc_desc_compute_distance_to_exit_node proc_desc => { + let exit_node = proc_desc.pd_exit_node; + let rec mark_distance dist nodes => { + let next_nodes = ref []; + let do_node node => + switch node.nd_dist_exit { + | Some _ => () + | None => + node.nd_dist_exit = Some dist; + next_nodes := node.nd_preds @ !next_nodes + }; + IList.iter do_node nodes; + if (!next_nodes !== []) { + mark_distance (dist + 1) !next_nodes + } + }; + mark_distance 0 [exit_node] + }; + + /** Set the start node of the proc desc */ + let proc_desc_set_start_node pdesc node => pdesc.pd_start_node = node; + + /** Set the exit node of the proc desc */ + let proc_desc_set_exit_node pdesc node => pdesc.pd_exit_node = node; + + /** Set a flag for the proc desc */ + let proc_desc_set_flag pdesc key value => + proc_flags_add pdesc.pd_attributes.ProcAttributes.proc_flags key value; + + /** Return the return type of the procedure */ + let proc_desc_get_ret_type proc_desc => proc_desc.pd_attributes.ProcAttributes.ret_type; + let proc_desc_get_proc_name proc_desc => proc_desc.pd_attributes.ProcAttributes.proc_name; + + /** Return [true] iff the procedure is defined, and not just declared */ + let proc_desc_is_defined proc_desc => proc_desc.pd_attributes.ProcAttributes.is_defined; + let proc_desc_get_loc proc_desc => proc_desc.pd_attributes.ProcAttributes.loc; + + /** Return name and type of formal parameters */ + let proc_desc_get_formals proc_desc => proc_desc.pd_attributes.ProcAttributes.formals; + + /** Return name and type of local variables */ + let proc_desc_get_locals proc_desc => proc_desc.pd_attributes.ProcAttributes.locals; + + /** Return name and type of captured variables */ + let proc_desc_get_captured proc_desc => proc_desc.pd_attributes.ProcAttributes.captured; + + /** Return the visibility attribute */ + let proc_desc_get_access proc_desc => proc_desc.pd_attributes.ProcAttributes.access; + let proc_desc_get_nodes proc_desc => proc_desc.pd_nodes; + + /** List of nodes in the procedure up to the first branching */ + let proc_desc_get_slope proc_desc => + get_generated_slope (proc_desc_get_start_node proc_desc) get_succs; + + /** List of nodes in the procedure sliced by a predicate up to the first branching */ + let proc_desc_get_sliced_slope proc_desc f => + get_generated_slope (proc_desc_get_start_node proc_desc) (fun n => get_sliced_succs n f); + + /** Get flags for the proc desc */ + let proc_desc_get_flags proc_desc => proc_desc.pd_attributes.ProcAttributes.proc_flags; + + /** Append the locals to the list of local variables */ + let proc_desc_append_locals proc_desc new_locals => + proc_desc.pd_attributes.ProcAttributes.locals = + proc_desc.pd_attributes.ProcAttributes.locals @ new_locals; + + /** Print extended instructions for the node, + highlighting the given subinstruction if present */ + let pp_instrs pe0 sub_instrs::sub_instrs instro fmt node => { + let pe = + switch instro { + | None => pe0 + | Some instr => pe_extend_colormap pe0 (Obj.repr instr) Red + }; + let instrs = get_instrs node; + let pp_loc fmt () => F.fprintf fmt " %a " Location.pp (get_loc node); + let print_sub_instrs () => F.fprintf fmt "%a" (Sil.pp_instr_list pe) instrs; + switch (get_kind node) { + | Stmt_node s => + if sub_instrs { + print_sub_instrs () + } else { + F.fprintf fmt "statements (%s) %a" s pp_loc () + } + | Prune_node _ _ descr => + if sub_instrs { + print_sub_instrs () + } else { + F.fprintf fmt "assume %s %a" descr pp_loc () + } + | Exit_node _ => + if sub_instrs { + print_sub_instrs () + } else { + F.fprintf fmt "exit %a" pp_loc () + } + | Skip_node s => + if sub_instrs { + print_sub_instrs () + } else { + F.fprintf fmt "skip (%s) %a" s pp_loc () + } + | Start_node _ => + if sub_instrs { + print_sub_instrs () + } else { + F.fprintf fmt "start %a" pp_loc () + } + | Join_node => + if sub_instrs { + print_sub_instrs () + } else { + F.fprintf fmt "join %a" pp_loc () + } + } + }; + + /** Dump extended instructions for the node */ + let d_instrs sub_instrs::(sub_instrs: bool) (curr_instr: option Sil.instr) (node: t) => L.add_print_action ( + L.PTnode_instrs, + Obj.repr (sub_instrs, curr_instr, node) + ); + + /** Return a description of the cfg node */ + let get_description pe node => { + let str = + switch (get_kind node) { + | Stmt_node _ => "Instructions" + | Prune_node _ _ descr => "Conditional" ^ " " ^ descr + | Exit_node _ => "Exit" + | Skip_node _ => "Skip" + | Start_node _ => "Start" + | Join_node => "Join" + }; + let pp fmt () => F.fprintf fmt "%s\n%a@?" str (pp_instrs pe None sub_instrs::true) node; + pp_to_string pp () + }; + let proc_desc_iter_nodes f proc_desc => IList.iter f (IList.rev (proc_desc_get_nodes proc_desc)); + let proc_desc_fold_nodes f acc proc_desc => + IList.fold_left f acc (IList.rev (proc_desc_get_nodes proc_desc)); + let proc_desc_fold_calls f acc pdesc => { + let do_node a node => + IList.fold_left (fun b callee_pname => f b (callee_pname, get_loc node)) a (get_callees node); + IList.fold_left do_node acc (proc_desc_get_nodes pdesc) + }; + + /** iterate over the calls from the procedure: (callee,location) pairs */ + let proc_desc_iter_calls f pdesc => proc_desc_fold_calls (fun _ call => f call) () pdesc; + let proc_desc_iter_slope f proc_desc => { + let visited = ref NodeSet.empty; + let rec do_node node => { + visited := NodeSet.add node !visited; + f node; + switch (get_succs node) { + | [n] => + if (not (NodeSet.mem n !visited)) { + do_node n + } + | _ => () + } + }; + do_node (proc_desc_get_start_node proc_desc) + }; + + /** iterate between two nodes or until we reach a branching structure */ + let proc_desc_iter_slope_range f src_node dst_node => { + let visited = ref NodeSet.empty; + let rec do_node node => { + visited := NodeSet.add node !visited; + f node; + switch (get_succs node) { + | [n] => + if (not (NodeSet.mem n !visited) && not (equal node dst_node)) { + do_node n + } + | _ => () + } + }; + do_node src_node + }; + let proc_desc_iter_slope_calls f proc_desc => { + let do_node node => IList.iter (fun callee_pname => f callee_pname) (get_callees node); + proc_desc_iter_slope do_node proc_desc + }; + let proc_desc_iter_instrs f proc_desc => { + let do_node node => IList.iter (fun i => f node i) (get_instrs node); + proc_desc_iter_nodes do_node proc_desc + }; + let proc_desc_fold_instrs f acc proc_desc => { + let fold_node acc node => + IList.fold_left (fun acc instr => f acc node instr) acc (get_instrs node); + proc_desc_fold_nodes fold_node acc proc_desc + }; + /* + let remove_node cfg node = + remove_node' (fun node' -> not (equal node node')) + cfg node + */ + /* clone a procedure description and apply the type substitutions where + the parameters are used */ + let proc_desc_specialize_types callee_proc_desc resolved_attributes substitutions => { + let cfg = create_cfg (); + let resolved_proc_desc = proc_desc_create cfg resolved_attributes; + let resolved_proc_name = proc_desc_get_proc_name resolved_proc_desc + and callee_start_node = proc_desc_get_start_node callee_proc_desc + and callee_exit_node = proc_desc_get_exit_node callee_proc_desc; + let convert_pvar pvar => Pvar.mk (Pvar.get_name pvar) resolved_proc_name; + let convert_exp = + fun + | Sil.Lvar origin_pvar => Sil.Lvar (convert_pvar origin_pvar) + | exp => exp; + let extract_class_name = + fun + | Sil.Tptr (Sil.Tstruct {Sil.struct_name: struct_name}) _ when struct_name != None => + Mangled.to_string (Option.get struct_name) + | _ => failwith "Expecting classname for Java types"; + let subst_map = ref Ident.IdentMap.empty; + let redirected_class_name origin_id => + try (Some (Ident.IdentMap.find origin_id !subst_map)) { + | Not_found => None + }; + let convert_instr instrs => + fun + | Sil.Letderef id (Sil.Lvar origin_pvar as origin_exp) origin_typ loc => { + let (_, specialized_typ) = { + let pvar_name = Pvar.get_name origin_pvar; + try (IList.find (fun (n, _) => Mangled.equal n pvar_name) substitutions) { + | Not_found => (pvar_name, origin_typ) + } + }; + subst_map := Ident.IdentMap.add id specialized_typ !subst_map; + [Sil.Letderef id (convert_exp origin_exp) specialized_typ loc, ...instrs] + } + | Sil.Letderef id (Sil.Var origin_id as origin_exp) origin_typ loc => { + let updated_typ = + switch (Ident.IdentMap.find origin_id !subst_map) { + | Sil.Tptr typ _ => typ + | _ => failwith "Expecting a pointer type" + | exception Not_found => origin_typ + }; + [Sil.Letderef id (convert_exp origin_exp) updated_typ loc, ...instrs] + } + | Sil.Letderef id origin_exp origin_typ loc => [ + Sil.Letderef id (convert_exp origin_exp) origin_typ loc, + ...instrs + ] + | Sil.Set assignee_exp origin_typ origin_exp loc => { + let set_instr = + Sil.Set (convert_exp assignee_exp) origin_typ (convert_exp origin_exp) loc; + [set_instr, ...instrs] + } + | Sil.Call + return_ids + (Sil.Const (Sil.Cfun (Procname.Java callee_pname_java))) + [(Sil.Var id, _), ...origin_args] + loc + call_flags + when call_flags.Sil.cf_virtual && redirected_class_name id != None => { + let redirected_typ = Option.get (redirected_class_name id); + let redirected_pname = + Procname.replace_class + (Procname.Java callee_pname_java) (extract_class_name redirected_typ) + and args = { + let other_args = IList.map (fun (exp, typ) => (convert_exp exp, typ)) origin_args; + [(Sil.Var id, redirected_typ), ...other_args] + }; + let call_instr = + Sil.Call return_ids (Sil.Const (Sil.Cfun redirected_pname)) args loc call_flags; + [call_instr, ...instrs] + } + | Sil.Call return_ids origin_call_exp origin_args loc call_flags => { + let converted_args = IList.map (fun (exp, typ) => (convert_exp exp, typ)) origin_args; + let call_instr = + Sil.Call return_ids (convert_exp origin_call_exp) converted_args loc call_flags; + [call_instr, ...instrs] + } + | Sil.Prune origin_exp loc is_true_branch if_kind => [ + Sil.Prune (convert_exp origin_exp) loc is_true_branch if_kind, + ...instrs + ] + | Sil.Nullify origin_pvar loc => [Sil.Nullify (convert_pvar origin_pvar) loc, ...instrs] + | Sil.Declare_locals typed_vars loc => { + let new_typed_vars = IList.map (fun (pvar, typ) => (convert_pvar pvar, typ)) typed_vars; + [Sil.Declare_locals new_typed_vars loc, ...instrs] + } + | instr => [instr, ...instrs]; + let convert_node_kind = + fun + | Start_node _ => Start_node resolved_proc_desc + | Exit_node _ => Exit_node resolved_proc_desc + | node_kind => node_kind; + let node_map = ref NodeMap.empty; + let rec convert_node node => { + let loc = get_loc node + and kind = convert_node_kind (get_kind node) + and instrs = IList.fold_left convert_instr [] (get_instrs node) |> IList.rev; + create cfg loc kind instrs resolved_proc_desc + } + and loop callee_nodes => + switch callee_nodes { + | [] => [] + | [node, ...other_node] => + let converted_node = + try (NodeMap.find node !node_map) { + | Not_found => + let new_node = convert_node node + and successors = get_succs node + and exn_nodes = get_exn node; + node_map := NodeMap.add node new_node !node_map; + if (equal node callee_start_node) { + proc_desc_set_start_node resolved_proc_desc new_node + }; + if (equal node callee_exit_node) { + proc_desc_set_exit_node resolved_proc_desc new_node + }; + set_succs_exn cfg new_node (loop successors) (loop exn_nodes); + new_node + }; + [converted_node, ...loop other_node] + }; + ignore (loop [callee_start_node]); + resolved_proc_desc + }; +}; + +/* =============== END of module Node =============== */ +type node = Node.t; + +type cfg = Node.cfg; + +/* =============== START of module Procdesc =============== */ +let module Procdesc = { + type t = Node.proc_desc; + let compute_distance_to_exit_node = Node.proc_desc_compute_distance_to_exit_node; + let create = Node.proc_desc_create; + let remove = Node.proc_desc_remove; + let find_from_name = Node.proc_desc_from_name; + let get_attributes = Node.proc_desc_get_attributes; + let get_err_log = Node.proc_desc_get_err_log; + let get_exit_node = Node.proc_desc_get_exit_node; + let get_flags = Node.proc_desc_get_flags; + let get_formals = Node.proc_desc_get_formals; + let get_loc = Node.proc_desc_get_loc; + let get_locals = Node.proc_desc_get_locals; + let get_captured = Node.proc_desc_get_captured; + let get_access = Node.proc_desc_get_access; + let get_nodes = Node.proc_desc_get_nodes; + let get_slope = Node.proc_desc_get_slope; + let get_sliced_slope = Node.proc_desc_get_sliced_slope; + let get_proc_name = Node.proc_desc_get_proc_name; + let get_ret_type = Node.proc_desc_get_ret_type; + let get_ret_var pdesc => Pvar.mk Ident.name_return (get_proc_name pdesc); + let get_start_node = Node.proc_desc_get_start_node; + let is_defined = Node.proc_desc_is_defined; + let iter_nodes = Node.proc_desc_iter_nodes; + let fold_calls = Node.proc_desc_fold_calls; + let iter_calls = Node.proc_desc_iter_calls; + let iter_instrs = Node.proc_desc_iter_instrs; + let fold_instrs = Node.proc_desc_fold_instrs; + let iter_slope = Node.proc_desc_iter_slope; + let iter_slope_calls = Node.proc_desc_iter_slope_calls; + let iter_slope_range = Node.proc_desc_iter_slope_range; + let set_exit_node = Node.proc_desc_set_exit_node; + let set_flag = Node.proc_desc_set_flag; + let set_start_node = Node.proc_desc_set_start_node; + let append_locals = Node.proc_desc_append_locals; + let specialize_types = Node.proc_desc_specialize_types; +}; + +/* =============== END of module Procdesc =============== */ +/** Hash table with nodes as keys. */ +let module NodeHash = Hashtbl.Make Node; + + +/** Set of nodes. */ +let module NodeSet = Node.NodeSet; + + +/** Map with node id keys. */ +let module IdMap = Node.IdMap; + +let iter_proc_desc = Node.iter_proc_desc; + +let rec pp_node_list f => + fun + | [] => () + | [node] => Node.pp f node + | [node, ...nodes] => F.fprintf f "%a, %a" Node.pp node pp_node_list nodes; + + +/** Get all the procdescs (defined and declared) */ +let get_all_procs cfg => { + let procs = ref []; + let f _ pdesc => procs := [pdesc, ...!procs]; + iter_proc_desc cfg f; + !procs +}; + + +/** Get the procedures whose body is defined in this cfg */ +let get_defined_procs cfg => IList.filter Procdesc.is_defined (get_all_procs cfg); + + +/** get the function names which should be analyzed before the other ones */ +let get_priority_procnames cfg => cfg.Node.priority_set; + + +/** set the function names whose address has been taken in this file */ +let set_procname_priority cfg pname => + cfg.Node.priority_set = Procname.Set.add pname cfg.Node.priority_set; + +let get_name_of_local (curr_f: Procdesc.t) (x, _) => Pvar.mk x (Procdesc.get_proc_name curr_f); + +/* returns a list of local static variables (ie local variables defined static) in a proposition */ +let get_name_of_objc_static_locals (curr_f: Procdesc.t) p => { + let pname = Procname.to_string (Procdesc.get_proc_name curr_f); + let local_static e => + switch e { + /* is a local static if it's a global and it has a static local name */ + | Sil.Lvar pvar when Pvar.is_global pvar && Sil.is_static_local_name pname pvar => [pvar] + | _ => [] + }; + let hpred_local_static hpred => + switch hpred { + | Sil.Hpointsto e _ _ => [local_static e] + | _ => [] + }; + let vars_sigma = IList.map hpred_local_static (Prop.get_sigma p); + IList.flatten (IList.flatten vars_sigma) +}; + +/* returns a list of local variables that points to an objc block in a proposition */ +let get_name_of_objc_block_locals p => { + let local_blocks e => + switch e { + | Sil.Lvar pvar when Sil.is_block_pvar pvar => [pvar] + | _ => [] + }; + let hpred_local_blocks hpred => + switch hpred { + | Sil.Hpointsto e _ _ => [local_blocks e] + | _ => [] + }; + let vars_sigma = IList.map hpred_local_blocks (Prop.get_sigma p); + IList.flatten (IList.flatten vars_sigma) +}; + +let remove_abducted_retvars p => + /* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] */ + { + let compute_reachable p seed_exps => { + let (sigma, pi) = (Prop.get_sigma p, Prop.get_pi p); + let rec collect_exps exps => + fun + | Sil.Eexp (Sil.Const (Sil.Cexn e)) _ => Sil.ExpSet.add e exps + | Sil.Eexp e _ => Sil.ExpSet.add e exps + | Sil.Estruct flds _ => + IList.fold_left (fun exps (_, strexp) => collect_exps exps strexp) exps flds + | Sil.Earray _ elems _ => + IList.fold_left (fun exps (_, strexp) => collect_exps exps strexp) exps elems; + let rec compute_reachable_hpreds_rec sigma (reach, exps) => { + let add_hpred_if_reachable (reach, exps) => + fun + | Sil.Hpointsto lhs rhs _ as hpred when Sil.ExpSet.mem lhs exps => { + let reach' = Sil.HpredSet.add hpred reach; + let exps' = collect_exps exps rhs; + (reach', exps') + } + | _ => (reach, exps); + let (reach', exps') = IList.fold_left add_hpred_if_reachable (reach, exps) sigma; + if (Sil.HpredSet.cardinal reach == Sil.HpredSet.cardinal reach') { + (reach, exps) + } else { + compute_reachable_hpreds_rec sigma (reach', exps') + } + }; + let (reach_hpreds, reach_exps) = + compute_reachable_hpreds_rec sigma (Sil.HpredSet.empty, seed_exps); + /* filter away the pure atoms without reachable exps */ + let reach_pi = { + let rec exp_contains = + fun + | exp when Sil.ExpSet.mem exp reach_exps => true + | Sil.UnOp _ e _ + | Sil.Cast _ e + | Sil.Lfield e _ _ => exp_contains e + | Sil.BinOp _ e0 e1 + | Sil.Lindex e0 e1 => exp_contains e0 || exp_contains e1 + | _ => false; + IList.filter + ( + fun + | Sil.Aeq lhs rhs + | Sil.Aneq lhs rhs => exp_contains lhs || exp_contains rhs + ) + pi + }; + (Sil.HpredSet.elements reach_hpreds, reach_pi) + }; + /* separate the abducted pvars from the normal ones, deallocate the abducted ones*/ + let (abducteds, normal_pvars) = + IList.fold_left + ( + fun pvars hpred => + switch hpred { + | Sil.Hpointsto (Sil.Lvar pvar) _ _ => + let (abducteds, normal_pvars) = pvars; + if (Pvar.is_abducted pvar) { + ([pvar, ...abducteds], normal_pvars) + } else { + (abducteds, [pvar, ...normal_pvars]) + } + | _ => pvars + } + ) + ([], []) + (Prop.get_sigma p); + let (_, p') = Prop.deallocate_stack_vars p abducteds; + let normal_pvar_set = + IList.fold_left + (fun normal_pvar_set pvar => Sil.ExpSet.add (Sil.Lvar pvar) normal_pvar_set) + Sil.ExpSet.empty + normal_pvars; + /* walk forward from non-abducted pvars, keep everything reachable. remove everything else */ + let (sigma_reach, pi_reach) = compute_reachable p' normal_pvar_set; + Prop.normalize (Prop.replace_pi pi_reach (Prop.replace_sigma sigma_reach p')) + }; + +let remove_locals (curr_f: Procdesc.t) p => { + let names_of_locals = IList.map (get_name_of_local curr_f) (Procdesc.get_locals curr_f); + let names_of_locals' = + switch !Config.curr_language { + | Config.Clang => + /* in ObjC to deal with block we need to remove static locals */ + let names_of_static_locals = get_name_of_objc_static_locals curr_f p; + let names_of_block_locals = get_name_of_objc_block_locals p; + names_of_block_locals @ names_of_locals @ names_of_static_locals + | _ => names_of_locals + }; + let (removed, p') = Prop.deallocate_stack_vars p names_of_locals'; + ( + removed, + if Config.angelic_execution { + remove_abducted_retvars p' + } else { + p' + } + ) +}; + +let remove_formals (curr_f: Procdesc.t) p => { + let pname = Procdesc.get_proc_name curr_f; + let formal_vars = IList.map (fun (n, _) => Pvar.mk n pname) (Procdesc.get_formals curr_f); + Prop.deallocate_stack_vars p formal_vars +}; + + +/** remove the return variable from the prop */ +let remove_ret (curr_f: Procdesc.t) (p: Prop.t Prop.normal) => { + let pname = Procdesc.get_proc_name curr_f; + let name_of_ret = Procdesc.get_ret_var curr_f; + let (_, p') = Prop.deallocate_stack_vars p [Pvar.to_callee pname name_of_ret]; + p' +}; + + +/** remove locals and return variable from the prop */ +let remove_locals_ret (curr_f: Procdesc.t) p => snd (remove_locals curr_f (remove_ret curr_f p)); + + +/** Remove locals and formal parameters from the prop. + Return the list of stack variables whose address was still present after deallocation. */ +let remove_locals_formals (curr_f: Procdesc.t) p => { + let (pvars1, p1) = remove_formals curr_f p; + let (pvars2, p2) = remove_locals curr_f p1; + (pvars1 @ pvars2, p2) +}; + + +/** remove seed vars from a prop */ +let remove_seed_vars (prop: Prop.t 'a) :Prop.t Prop.normal => { + let hpred_not_seed = + fun + | Sil.Hpointsto (Sil.Lvar pv) _ _ => not (Pvar.is_seed pv) + | _ => true; + let sigma = Prop.get_sigma prop; + let sigma' = IList.filter hpred_not_seed sigma; + Prop.normalize (Prop.replace_sigma sigma' prop) +}; + + +/** checks whether a cfg is connected or not */ +let check_cfg_connectedness cfg => { + let is_exit_node n => + switch (Node.get_kind n) { + | Node.Exit_node _ => true + | _ => false + }; + let broken_node n => { + let succs = Node.get_succs n; + let preds = Node.get_preds n; + switch (Node.get_kind n) { + | Node.Start_node _ => IList.length succs == 0 || IList.length preds > 0 + | Node.Exit_node _ => IList.length succs > 0 || IList.length preds == 0 + | Node.Stmt_node _ + | Node.Prune_node _ + | Node.Skip_node _ => IList.length succs == 0 || IList.length preds == 0 + | Node.Join_node => + /* Join node has the exception that it may be without predecessors + and pointing to an exit node */ + /* if the if brances end with a return */ + switch succs { + | [n'] when is_exit_node n' => false + | _ => IList.length preds == 0 + } + } + }; + let do_pdesc pd => { + let pname = Procname.to_string (Procdesc.get_proc_name pd); + let nodes = Procdesc.get_nodes pd; + let broken = IList.exists broken_node nodes; + if broken { + L.out "\n ***BROKEN CFG: '%s'\n" pname + } else { + L.out "\n ***CONNECTED CFG: '%s'\n" pname + } + }; + let pdescs = get_all_procs cfg; + IList.iter do_pdesc pdescs +}; + + +/** Removes seeds variables from a prop corresponding to captured variables in an objc block */ +let remove_seed_captured_vars_block captured_vars prop => { + let is_captured pname vn => Mangled.equal pname vn; + let hpred_seed_captured = + fun + | Sil.Hpointsto (Sil.Lvar pv) _ _ => { + let pname = Pvar.get_name pv; + Pvar.is_seed pv && IList.mem is_captured pname captured_vars + } + | _ => false; + let sigma = Prop.get_sigma prop; + let sigma' = IList.filter (fun hpred => not (hpred_seed_captured hpred)) sigma; + Prop.normalize (Prop.replace_sigma sigma' prop) +}; + + +/** Serializer for control flow graphs */ +let cfg_serializer: Serialization.serializer cfg = Serialization.create_serializer Serialization.cfg_key; + + +/** Load a cfg from a file */ +let load_cfg_from_file (filename: DB.filename) :option cfg => + Serialization.from_file cfg_serializer filename; + + +/** save a copy in the results dir of the source files of procedures defined in the cfg, + unless an updated copy already exists */ +let save_source_files cfg => { + let process_proc _ pdesc => { + let loc = Node.proc_desc_get_loc pdesc; + let source_file = loc.Location.file; + let source_file_str = DB.source_file_to_abs_path source_file; + let dest_file = DB.source_file_in_resdir source_file; + let dest_file_str = DB.filename_to_string dest_file; + let needs_copy = + Node.proc_desc_is_defined pdesc && + Sys.file_exists source_file_str && + ( + not (Sys.file_exists dest_file_str) || + DB.file_modified_time (DB.filename_from_string source_file_str) > + DB.file_modified_time dest_file + ); + if needs_copy { + switch (copy_file source_file_str dest_file_str) { + | Some _ => () + | None => L.err "Error cannot create copy of source file %s@." source_file_str + } + } + }; + Node.iter_proc_desc cfg process_proc +}; + + +/** Save the .attr files for the procedures in the cfg. */ +let save_attributes cfg => { + let save_proc proc_desc => { + let attributes = Procdesc.get_attributes proc_desc; + let loc = attributes.ProcAttributes.loc; + let attributes' = + if (Location.equal loc Location.dummy) { + let loc' = {...loc, Location.file: !DB.current_source}; + {...attributes, ProcAttributes.loc: loc'} + } else { + attributes + }; + /* + L.stderr "save_proc@. proc_name:%a@. filename:%s@. current_source:%s@. loc:%s@." + Procname.pp (Procdesc.get_proc_name proc_desc) + (DB.filename_to_string filename) + (DB.source_file_to_string !DB.current_source) + (Location.to_string loc); + */ + AttributesTable.store_attributes attributes' + }; + IList.iter save_proc (get_all_procs cfg) +}; + + +/** Inline a synthetic (access or bridge) method. */ +let inline_synthetic_method ret_ids etl proc_desc loc_call :option Sil.instr => { + let modified = ref None; + let debug = false; + let found instr instr' => { + modified := Some instr'; + if debug { + L.stderr "XX inline_synthetic_method found instr: %a@." (Sil.pp_instr pe_text) instr; + L.stderr "XX inline_synthetic_method instr': %a@." (Sil.pp_instr pe_text) instr' + } + }; + let do_instr _ instr => + switch (instr, ret_ids, etl) { + | ( + Sil.Letderef _ (Sil.Lfield (Sil.Var _) fn ft) bt _, + [ret_id], + [(e1, _)] /* getter for fields */ + ) => + let instr' = Sil.Letderef ret_id (Sil.Lfield e1 fn ft) bt loc_call; + found instr instr' + | (Sil.Letderef _ (Sil.Lfield (Sil.Lvar pvar) fn ft) bt _, [ret_id], []) + when Pvar.is_global pvar => + /* getter for static fields */ + let instr' = Sil.Letderef ret_id (Sil.Lfield (Sil.Lvar pvar) fn ft) bt loc_call; + found instr instr' + | ( + Sil.Set (Sil.Lfield _ fn ft) bt _ _, + _, + [(e1, _), (e2, _)] /* setter for fields */ + ) => + let instr' = Sil.Set (Sil.Lfield e1 fn ft) bt e2 loc_call; + found instr instr' + | (Sil.Set (Sil.Lfield (Sil.Lvar pvar) fn ft) bt _ _, _, [(e1, _)]) when Pvar.is_global pvar => + /* setter for static fields */ + let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar) fn ft) bt e1 loc_call; + found instr instr' + | (Sil.Call ret_ids' (Sil.Const (Sil.Cfun pn)) etl' _ cf, _, _) + when IList.length ret_ids == IList.length ret_ids' && IList.length etl' == IList.length etl => + let instr' = Sil.Call ret_ids (Sil.Const (Sil.Cfun pn)) etl loc_call cf; + found instr instr' + | (Sil.Call ret_ids' (Sil.Const (Sil.Cfun pn)) etl' _ cf, _, _) + when + IList.length ret_ids == IList.length ret_ids' && + IList.length etl' + 1 == IList.length etl => + let etl1 = + switch (IList.rev etl) { + /* remove last element */ + | [_, ...l] => IList.rev l + | [] => assert false + }; + let instr' = Sil.Call ret_ids (Sil.Const (Sil.Cfun pn)) etl1 loc_call cf; + found instr instr' + | _ => () + }; + Procdesc.iter_instrs do_instr proc_desc; + !modified +}; + + +/** Find synthetic (access or bridge) Java methods in the procedure and inline them in the cfg. */ +let proc_inline_synthetic_methods cfg proc_desc :unit => { + let instr_inline_synthetic_method = + fun + | Sil.Call ret_ids (Sil.Const (Sil.Cfun pn)) etl loc _ => + switch (Procdesc.find_from_name cfg pn) { + | Some pd => + let is_access = Procname.java_is_access_method pn; + let attributes = Procdesc.get_attributes pd; + let is_synthetic = attributes.ProcAttributes.is_synthetic_method; + let is_bridge = attributes.ProcAttributes.is_bridge_method; + if (is_access || is_bridge || is_synthetic) { + inline_synthetic_method ret_ids etl pd loc + } else { + None + } + | None => None + } + | _ => None; + let node_inline_synthetic_methods node => { + let modified = ref false; + let do_instr instr => + switch (instr_inline_synthetic_method instr) { + | None => instr + | Some instr' => + modified := true; + instr' + }; + let instrs = Node.get_instrs node; + let instrs' = IList.map do_instr instrs; + if !modified { + Node.replace_instrs node instrs' + } + }; + Procdesc.iter_nodes node_inline_synthetic_methods proc_desc +}; + + +/** Inline the java synthetic methods in the cfg */ +let inline_java_synthetic_methods cfg => { + let f proc_name proc_desc => + if (Procname.is_java proc_name) { + proc_inline_synthetic_methods cfg proc_desc + }; + iter_proc_desc cfg f +}; + + +/** Save a cfg into a file */ +let store_cfg_to_file (filename: DB.filename) (save_sources: bool) (cfg: cfg) => { + inline_java_synthetic_methods cfg; + if save_sources { + save_source_files cfg + }; + if Config.incremental_procs { + switch (load_cfg_from_file filename) { + | Some old_cfg => Node.mark_unchanged_pdescs cfg old_cfg + | None => () + } + }; + save_attributes cfg; + Serialization.to_file cfg_serializer filename cfg +}; + + +/** Creates a copy of a procedure description and a list of type substitutions of the form + (name, typ) where name is a parameter. The resulting proc desc is isomorphic but + all the type of the parameters are replaced in the instructions according to the list. + The virtual calls are also replaced to match the parameter types */ +let specialize_types callee_proc_desc resolved_proc_name args => + /** TODO (#9333890): This currently only works when the callee is defined in the same file. + Add support to search for the callee procedure description in the execution environment */ + { + let callee_attributes = Procdesc.get_attributes callee_proc_desc; + let resolved_formals = + IList.fold_left2 + (fun accu (name, _) (_, arg_typ) => [(name, arg_typ), ...accu]) + [] + callee_attributes.ProcAttributes.formals + args |> IList.rev; + let resolved_attributes = { + ...callee_attributes, + ProcAttributes.formals: resolved_formals, + proc_name: resolved_proc_name + }; + AttributesTable.store_attributes resolved_attributes; + Procdesc.specialize_types callee_proc_desc resolved_attributes resolved_formals + }; diff --git a/infer/src/IR/Cfg.rei b/infer/src/IR/Cfg.rei new file mode 100644 index 000000000..b73ff3bbe --- /dev/null +++ b/infer/src/IR/Cfg.rei @@ -0,0 +1,328 @@ +/* + * 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; + + +/** Control Flow Graph for Interprocedural Analysis */ +/** {2 ADT node and proc_desc} */ +type node; + +type cfg; + + +/** Load a cfg from a file */ +let load_cfg_from_file: DB.filename => option cfg; + + +/** Save a cfg into a file, and save a copy of the source files if the boolean is true */ +let store_cfg_to_file: DB.filename => bool => cfg => unit; + + +/** proc description */ +let module Procdesc: { + /** proc description */ + type t; + + /** Compute the distance of each node to the exit node, if not computed already */ + let compute_distance_to_exit_node: t => unit; + + /** Create a procdesc */ + let create: cfg => ProcAttributes.t => t; + + /** [remove cfg name remove_nodes] remove the procdesc [name] + from the control flow graph [cfg]. */ + /** It also removes all the nodes from the procedure from the cfg if remove_nodes is true */ + let remove: cfg => Procname.t => bool => unit; + + /** Find the procdesc given the proc name. Return None if not found. */ + let find_from_name: cfg => Procname.t => option t; + + /** Get the attributes of the procedure. */ + let get_attributes: t => ProcAttributes.t; + let get_err_log: t => Errlog.t; + let get_exit_node: t => node; + + /** Get flags for the proc desc */ + let get_flags: t => proc_flags; + + /** Return name and type of formal parameters */ + let get_formals: t => list (Mangled.t, Sil.typ); + + /** Return loc information for the procedure */ + let get_loc: t => Location.t; + + /** Return name and type of local variables */ + let get_locals: t => list (Mangled.t, Sil.typ); + + /** Return name and type of block's captured variables */ + let get_captured: t => list (Mangled.t, Sil.typ); + + /** Return the visibility attribute */ + let get_access: t => Sil.access; + let get_nodes: t => list node; + + /** Get the procedure's nodes up until the first branching */ + let get_slope: t => list node; + + /** Get the sliced procedure's nodes up until the first branching */ + let get_sliced_slope: t => (node => bool) => list node; + let get_proc_name: t => Procname.t; + + /** Return the return type of the procedure and type string */ + let get_ret_type: t => Sil.typ; + let get_ret_var: t => Pvar.t; + let get_start_node: t => node; + + /** Return [true] iff the procedure is defined, and not just declared */ + let is_defined: t => bool; + + /** iterate over all the nodes of a procedure */ + let iter_nodes: (node => unit) => t => unit; + + /** fold over the calls from the procedure: (callee, location) pairs */ + let fold_calls: ('a => (Procname.t, Location.t) => 'a) => 'a => t => 'a; + + /** iterate over the calls from the procedure: (callee, location) pairs */ + let iter_calls: ((Procname.t, Location.t) => unit) => t => unit; + + /** iterate over all nodes and their instructions */ + let iter_instrs: (node => Sil.instr => unit) => t => unit; + + /** fold over all nodes and their instructions */ + let fold_instrs: ('a => node => Sil.instr => 'a) => 'a => t => 'a; + + /** iterate over all nodes until we reach a branching structure */ + let iter_slope: (node => unit) => t => unit; + + /** iterate over all calls until we reach a branching structure */ + let iter_slope_calls: (Procname.t => unit) => t => unit; + + /** iterate between two nodes or until we reach a branching structure */ + let iter_slope_range: (node => unit) => node => node => unit; + let set_exit_node: t => node => unit; + + /** Set a flag for the proc desc */ + let set_flag: t => string => string => unit; + let set_start_node: t => node => unit; + + /** append a list of new local variables to the existing list of local variables */ + let append_locals: t => list (Mangled.t, Sil.typ) => unit; +}; + + +/** node of the control flow graph */ +let module Node: { + type t = node; /** type of nodes */ + type id = private int; + + /** kind of cfg node */ + type nodekind = + | Start_node of Procdesc.t + | Exit_node of Procdesc.t + | Stmt_node of string + | Join_node + | Prune_node of bool Sil.if_kind string /** (true/false branch, if_kind, comment) */ + | Skip_node of string; + + /** kind of Stmt_node for an exception handler. */ + let exn_handler_kind: nodekind; + + /** kind of Stmt_node for an exceptions sink. */ + let exn_sink_kind: nodekind; + + /** kind of Stmt_node for a throw instruction. */ + let throw_kind: nodekind; + + /** Append the instructions to the list of instructions to execute */ + let append_instrs: t => list Sil.instr => unit; + + /** Add the instructions at the beginning of the list of instructions to execute */ + let prepend_instrs: t => list Sil.instr => unit; + + /** Add declarations for local variables and return variable to the node */ + let add_locals_ret_declaration: t => list (Mangled.t, Sil.typ) => unit; + + /** Compare two nodes */ + let compare: t => t => int; + + /** [create cfg loc kind instrs proc_desc] create a new cfg node + with the given location, kind, list of instructions, + procdesc */ + let create: cfg => Location.t => nodekind => list Sil.instr => Procdesc.t => t; + + /** create a new empty cfg */ + let create_cfg: unit => cfg; + + /** Dump extended instructions for the node */ + let d_instrs: sub_instrs::bool => option Sil.instr => t => unit; + + /** Create a dummy node */ + let dummy: unit => t; + + /** Check if two nodes are equal */ + let equal: t => t => bool; + + /** Get all the nodes */ + let get_all_nodes: cfg => list t; + + /** Get the (after/before) dead program variables. + After/before indicated with the true/false flag. */ + let get_dead_pvars: t => bool => list Pvar.t; + + /** Get the distance to the exit node, if it has been computed */ + let get_distance_to_exit: t => option int; + + /** Return a description of the node */ + let get_description: printenv => t => string; + + /** Get the exception nodes from the current node */ + let get_exn: t => list t; + + /** Get the unique id of the node */ + let get_id: t => id; + + /** compare node ids */ + let id_compare: id => id => int; + + /** Get the source location of the node */ + let get_loc: t => Location.t; + + /** Get the source location of the last instruction in the node */ + let get_last_loc: t => Location.t; + + /** Get the kind of the current node */ + let get_kind: t => nodekind; + + /** Get the predecessor nodes of the current node */ + let get_preds: t => list t; + + /** Get a list of unique nodes until the first branch starting + from a node with subsequent applications of a generator function */ + let get_generated_slope: t => (t => list t) => list t; + + /** Get the proc desc associated to the node */ + let get_proc_desc: t => Procdesc.t; + + /** Get the instructions to be executed */ + let get_instrs: t => list Sil.instr; + + /** Get the list of callee procnames from the node */ + let get_callees: t => list Procname.t; + + /** Get the successor nodes of the current node */ + let get_succs: t => list t; + + /** Get the successor nodes of a node where the given predicate evaluates to true */ + let get_sliced_succs: t => (t => bool) => list t; + + /** Get the predecessor nodes of a node where the given predicate evaluates to true */ + let get_sliced_preds: t => (t => bool) => list t; + + /** Hash function for nodes */ + let hash: t => int; + + /** Comparison for node kind */ + let kind_compare: nodekind => nodekind => int; + + /** Pretty print the node */ + let pp: Format.formatter => t => unit; + let pp_id: Format.formatter => id => unit; + + /** Print extended instructions for the node, + highlighting the given subinstruction if present */ + let pp_instrs: printenv => sub_instrs::bool => option Sil.instr => Format.formatter => t => unit; + + /** Replace the instructions to be executed. */ + let replace_instrs: t => list Sil.instr => unit; + + /** Set the (after/before) dead program variables. + After/before indicated with the true/false flag. */ + let set_dead_pvars: t => bool => list Pvar.t => unit; + + /** Set the node kind */ + let set_kind: t => nodekind => unit; + + /** Set the source location of the node */ + let set_loc: t => Location.t => unit; + + /** Set the proc desc associated to the node */ + let set_proc_desc: t => Procdesc.t => unit; + + /** Set the successor nodes and exception nodes, and build predecessor links */ + let set_succs_exn: cfg => t => list t => list t => unit; +}; + + +/** Hash table with nodes as keys. */ +let module NodeHash: Hashtbl.S with type key = Node.t; + + +/** Set of nodes. */ +let module NodeSet: Set.S with type elt = Node.t; + + +/** Map with node id keys. */ +let module IdMap: Map.S with type key = Node.id; + +let pp_node_list: Format.formatter => list Node.t => unit; + + +/** {2 Functions for manipulating an interprocedural CFG} */ +/** Iterate over all the procdesc's */ +let iter_proc_desc: cfg => (Procname.t => Procdesc.t => unit) => unit; + + +/** Get all the procedures (defined and declared) */ +let get_all_procs: cfg => list Procdesc.t; + + +/** Get the procedures whose body is defined in this cfg */ +let get_defined_procs: cfg => list Procdesc.t; + + +/** get the function names which should be analyzed before the other ones */ +let get_priority_procnames: cfg => Procname.Set.t; + + +/** set the function names whose address has been taken in this file */ +let set_procname_priority: cfg => Procname.t => unit; + + +/** remove the return variable from the prop */ +let remove_ret: Procdesc.t => Prop.t Prop.normal => Prop.t Prop.normal; + + +/** remove locals and return variable from the prop */ +let remove_locals_ret: Procdesc.t => Prop.t Prop.normal => Prop.t Prop.normal; + + +/** Deallocate the stack variables in [pvars], and replace them by normal variables. + Return the list of stack variables whose address was still present after deallocation. */ +let remove_locals_formals: Procdesc.t => Prop.t Prop.normal => (list Pvar.t, Prop.t Prop.normal); + + +/** remove seed vars from a prop */ +let remove_seed_vars: Prop.t 'a => Prop.t Prop.normal; + + +/** checks whether a cfg is connected or not */ +let check_cfg_connectedness: cfg => unit; + + +/** Removes seeds variables from a prop corresponding to captured variables in an objc block */ +let remove_seed_captured_vars_block: list Mangled.t => Prop.t Prop.normal => Prop.t Prop.normal; + + +/** Creates a copy of a procedure description and a list of type substitutions of the form + (name, typ) where name is a parameter. The resulting procdesc is isomorphic but + all the type of the parameters are replaced in the instructions according to the list. + The virtual calls are also replaced to match the parameter types */ +let specialize_types: Procdesc.t => Procname.t => list (Sil.exp, Sil.typ) => Procdesc.t; diff --git a/infer/src/IR/Cg.re b/infer/src/IR/Cg.re new file mode 100644 index 000000000..d08239c5b --- /dev/null +++ b/infer/src/IR/Cg.re @@ -0,0 +1,435 @@ +/* + * 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; + + +/** Module for call graphs */ +let module L = Logging; + +let module F = Format; + +type node = Procname.t; + +type in_out_calls = { + in_calls: int, /** total number of in calls transitively */ + out_calls: int /** total number of out calls transitively */ +}; + +type node_info = { + /** defined procedure as opposed to just declared */ + mutable defined: bool, + mutable parents: Procname.Set.t, + mutable children: Procname.Set.t, + /** ancestors are computed lazily */ + mutable ancestors: option Procname.Set.t, + /** heirs are computed lazily */ + mutable heirs: option Procname.Set.t, + /** recursive dependents are computed lazily */ + mutable recursive_dependents: option Procname.Set.t, + /** calls are computed lazily */ + mutable in_out_calls: option in_out_calls +}; + + +/** Type for call graph */ +type t = { + mutable source: DB.source_file, /** path for the source file */ + mutable nLOC: int, /** number of LOC */ + node_map: Procname.Hash.t node_info /** map from node to node_info */ +}; + +let create () => {source: !DB.current_source, nLOC: !Config.nLOC, node_map: Procname.Hash.create 3}; + +let add_node g n defined::defined => + try { + let info = Procname.Hash.find g.node_map n; + /* defined and disabled only go from false to true + to avoid accidental overwrite to false by calling add_edge */ + if defined { + info.defined = true + } + } { + | Not_found => + let info = { + defined, + parents: Procname.Set.empty, + children: Procname.Set.empty, + ancestors: None, + heirs: None, + recursive_dependents: None, + in_out_calls: None + }; + Procname.Hash.add g.node_map n info + }; + +let add_defined_node g n => add_node g n defined::true; + + +/** Compute the ancestors of the node, if not already computed */ +let compute_ancestors g node => { + let todo = ref (Procname.Set.singleton node); + let seen = ref Procname.Set.empty; + let result = ref Procname.Set.empty; + while (not (Procname.Set.is_empty !todo)) { + let current = Procname.Set.choose !todo; + todo := Procname.Set.remove current !todo; + if (not (Procname.Set.mem current !seen)) { + seen := Procname.Set.add current !seen; + let info = Procname.Hash.find g current; + switch info.ancestors { + | Some ancestors => result := Procname.Set.union !result ancestors + | None => + result := Procname.Set.union !result info.parents; + todo := Procname.Set.union !todo info.parents + } + } + }; + !result +}; + + +/** Compute the heirs of the node, if not already computed */ +let compute_heirs g node => { + let todo = ref (Procname.Set.singleton node); + let seen = ref Procname.Set.empty; + let result = ref Procname.Set.empty; + while (not (Procname.Set.is_empty !todo)) { + let current = Procname.Set.choose !todo; + todo := Procname.Set.remove current !todo; + if (not (Procname.Set.mem current !seen)) { + seen := Procname.Set.add current !seen; + let info = Procname.Hash.find g current; + switch info.heirs { + | Some heirs => result := Procname.Set.union !result heirs + | None => + result := Procname.Set.union !result info.children; + todo := Procname.Set.union !todo info.children + } + } + }; + !result +}; + + +/** Compute the ancestors of the node, if not pre-computed already */ +let get_ancestors (g: t) node => { + let info = Procname.Hash.find g.node_map node; + switch info.ancestors { + | None => + let ancestors = compute_ancestors g.node_map node; + info.ancestors = Some ancestors; + let size = Procname.Set.cardinal ancestors; + if (size > 1000) { + L.err "%a has %d ancestors@." Procname.pp node size + }; + ancestors + | Some ancestors => ancestors + } +}; + + +/** Compute the heirs of the node, if not pre-computed already */ +let get_heirs (g: t) node => { + let info = Procname.Hash.find g.node_map node; + switch info.heirs { + | None => + let heirs = compute_heirs g.node_map node; + info.heirs = Some heirs; + let size = Procname.Set.cardinal heirs; + if (size > 1000) { + L.err "%a has %d heirs@." Procname.pp node size + }; + heirs + | Some heirs => heirs + } +}; + +let node_defined (g: t) n => + try { + let info = Procname.Hash.find g.node_map n; + info.defined + } { + | Not_found => false + }; + +let add_edge g nfrom nto => { + add_node g nfrom defined::false; + add_node g nto defined::false; + let info_from = Procname.Hash.find g.node_map nfrom; + let info_to = Procname.Hash.find g.node_map nto; + info_from.children = Procname.Set.add nto info_from.children; + info_to.parents = Procname.Set.add nfrom info_to.parents +}; + + +/** iterate over the elements of a node_map in node order */ +let node_map_iter f g => { + let table = ref []; + Procname.Hash.iter (fun node info => table := [(node, info), ...!table]) g.node_map; + let cmp (n1: Procname.t, _) (n2: Procname.t, _) => Procname.compare n1 n2; + IList.iter (fun (n, info) => f n info) (IList.sort cmp !table) +}; + +let get_nodes (g: t) => { + let nodes = ref Procname.Set.empty; + let f node _ => nodes := Procname.Set.add node !nodes; + node_map_iter f g; + !nodes +}; + +let compute_calls g node => { + in_calls: Procname.Set.cardinal (get_ancestors g node), + out_calls: Procname.Set.cardinal (get_heirs g node) +}; + + +/** Compute the calls of the node, if not pre-computed already */ +let get_calls (g: t) node => { + let info = Procname.Hash.find g.node_map node; + switch info.in_out_calls { + | None => + let calls = compute_calls g node; + info.in_out_calls = Some calls; + calls + | Some calls => calls + } +}; + +let get_all_nodes (g: t) => { + let nodes = Procname.Set.elements (get_nodes g); + IList.map (fun node => (node, get_calls g node)) nodes +}; + +let get_nodes_and_calls (g: t) => IList.filter (fun (n, _) => node_defined g n) (get_all_nodes g); + +let node_get_num_ancestors g n => (n, Procname.Set.cardinal (get_ancestors g n)); + +let get_edges (g: t) :list ((node, int), (node, int)) => { + let edges = ref []; + let f node info => + Procname.Set.iter + ( + fun nto => edges := [ + (node_get_num_ancestors g node, node_get_num_ancestors g nto), + ...!edges + ] + ) + info.children; + node_map_iter f g; + !edges +}; + + +/** Return all the children of [n], whether defined or not */ +let get_all_children (g: t) n => (Procname.Hash.find g.node_map n).children; + + +/** Return the children of [n] which are defined */ +let get_defined_children (g: t) n => Procname.Set.filter (node_defined g) (get_all_children g n); + + +/** Return the parents of [n] */ +let get_parents (g: t) n => (Procname.Hash.find g.node_map n).parents; + + +/** Check if [source] recursively calls [dest] */ +let calls_recursively (g: t) source dest => Procname.Set.mem source (get_ancestors g dest); + + +/** Return the children of [n] which are not heirs of [n] */ +let get_nonrecursive_dependents (g: t) n => { + let is_not_recursive pn => not (Procname.Set.mem pn (get_ancestors g n)); + let res0 = Procname.Set.filter is_not_recursive (get_all_children g n); + let res = Procname.Set.filter (node_defined g) res0; + res +}; + + +/** Return the ancestors of [n] which are also heirs of [n] */ +let compute_recursive_dependents (g: t) n => { + let reached_from_n pn => Procname.Set.mem n (get_ancestors g pn); + let res0 = Procname.Set.filter reached_from_n (get_ancestors g n); + let res = Procname.Set.filter (node_defined g) res0; + res +}; + + +/** Compute the ancestors of [n] which are also heirs of [n], if not pre-computed already */ +let get_recursive_dependents (g: t) n => { + let info = Procname.Hash.find g.node_map n; + switch info.recursive_dependents { + | None => + let recursive_dependents = compute_recursive_dependents g n; + info.recursive_dependents = Some recursive_dependents; + recursive_dependents + | Some recursive_dependents => recursive_dependents + } +}; + + +/** Return the nodes dependent on [n] */ +let get_dependents (g: t) n => + Procname.Set.union (get_nonrecursive_dependents g n) (get_recursive_dependents g n); + + +/** Return all the nodes with their defined children */ +let get_nodes_and_defined_children (g: t) => { + let nodes = ref Procname.Set.empty; + node_map_iter + ( + fun n info => + if info.defined { + nodes := Procname.Set.add n !nodes + } + ) + g; + let nodes_list = Procname.Set.elements !nodes; + IList.map (fun n => (n, get_defined_children g n)) nodes_list +}; + + +/** nodes with defined flag, and edges */ +type nodes_and_edges = (list (node, bool), list (node, node)); + + +/** Return the list of nodes, with defined+disabled flags, and the list of edges */ +let get_nodes_and_edges (g: t) :nodes_and_edges => { + let nodes = ref []; + let edges = ref []; + let do_children node nto => edges := [(node, nto), ...!edges]; + let f node info => { + nodes := [(node, info.defined), ...!nodes]; + Procname.Set.iter (do_children node) info.children + }; + node_map_iter f g; + (!nodes, !edges) +}; + + +/** Return the list of nodes which are defined */ +let get_defined_nodes (g: t) => { + let (nodes, _) = get_nodes_and_edges g; + let get_node (node, _) => node; + IList.map get_node (IList.filter (fun (_, defined) => defined) nodes) +}; + + +/** Return the path of the source file */ +let get_source (g: t) => g.source; + + +/** Return the number of LOC of the source file */ +let get_nLOC (g: t) => g.nLOC; + + +/** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2]; + undefined nodes become defined if at least one side is. */ +let extend cg_old cg_new => { + let (nodes, edges) = get_nodes_and_edges cg_new; + IList.iter (fun (node, defined) => add_node cg_old node defined::defined) nodes; + IList.iter (fun (nfrom, nto) => add_edge cg_old nfrom nto) edges +}; + + +/** Begin support for serialization */ +let callgraph_serializer: Serialization.serializer (DB.source_file, int, nodes_and_edges) = Serialization.create_serializer Serialization.cg_key; + + +/** Load a call graph from a file */ +let load_from_file (filename: DB.filename) :option t => { + let g = create (); + switch (Serialization.from_file callgraph_serializer filename) { + | None => None + | Some (source, nLOC, (nodes, edges)) => + IList.iter + ( + fun (node, defined) => + if defined { + add_defined_node g node + } + ) + nodes; + IList.iter (fun (nfrom, nto) => add_edge g nfrom nto) edges; + g.source = source; + g.nLOC = nLOC; + Some g + } +}; + + +/** Save a call graph into a file */ +let store_to_file (filename: DB.filename) (call_graph: t) => + Serialization.to_file + callgraph_serializer + filename + (call_graph.source, call_graph.nLOC, get_nodes_and_edges call_graph); + +let pp_graph_dotty get_specs (g: t) fmt => { + let nodes_with_calls = get_all_nodes g; + let num_specs n => + try (IList.length (get_specs n)) { + | exn when SymOp.exn_not_failure exn => (-1) + }; + let get_color (n, _) => + if (num_specs n !== 0) { + "green" + } else { + "red" + }; + let get_shape (n, _) => + if (node_defined g n) { + "box" + } else { + "diamond" + }; + let pp_node fmt (n, _) => F.fprintf fmt "\"%s\"" (Procname.to_filename n); + let pp_node_label fmt (n, calls) => + F.fprintf + fmt + "\"%a | calls=%d %d | specs=%d)\"" + Procname.pp + n + calls.in_calls + calls.out_calls + (num_specs n); + F.fprintf fmt "digraph {@\n"; + IList.iter + ( + fun nc => + F.fprintf + fmt + "%a [shape=box,label=%a,color=%s,shape=%s]@\n" + pp_node + nc + pp_node_label + nc + (get_color nc) + (get_shape nc) + ) + nodes_with_calls; + IList.iter (fun (s, d) => F.fprintf fmt "%a -> %a@\n" pp_node s pp_node d) (get_edges g); + F.fprintf fmt "}@." +}; + + +/** Print the current call graph as a dotty file. + If the filename is [None], use the current file dir inside the DB dir. */ +let save_call_graph_dotty fname_opt get_specs (g: t) => { + let fname_dot = + switch fname_opt { + | None => DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir ["call_graph.dot"] + | Some fname => fname + }; + let outc = open_out (DB.filename_to_string fname_dot); + let fmt = F.formatter_of_out_channel outc; + pp_graph_dotty get_specs g fmt; + close_out outc +}; diff --git a/infer/src/IR/Cg.rei b/infer/src/IR/Cg.rei new file mode 100644 index 000000000..1fbb19349 --- /dev/null +++ b/infer/src/IR/Cg.rei @@ -0,0 +1,125 @@ +/* + * 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; + + +/** Module for call graphs */ +type in_out_calls = { + in_calls: int, /** total number of in calls transitively */ + out_calls: int /** total number of out calls transitively */ +}; + +type t; /** the type of a call graph */ + + +/** A call graph consists of a set of nodes (Procname.t), and edges between them. + A node can be defined or undefined (to represent whether we have code for it). + In an edge from [n1] to [n2], indicating that [n1] calls [n2], + [n1] is the parent and [n2] is the child. + Node [n1] is dependent on [n2] if there is a path from [n1] to [n2] + using the child relationship. */ +/** [add_edge cg f t] adds an edge from [f] to [t] in the call graph [cg]. + The nodes are also added as undefined, unless already present. */ +let add_edge: t => Procname.t => Procname.t => unit; + + +/** Add a node to the call graph as defined */ +let add_defined_node: t => Procname.t => unit; + + +/** Check if [source] recursively calls [dest] */ +let calls_recursively: t => Procname.t => Procname.t => bool; + + +/** Create an empty call graph */ +let create: unit => t; + + +/** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2]; + undefined nodes become defined if at least one side is. */ +let extend: t => t => unit; + + +/** Return all the children of [n], whether defined or not */ +let get_all_children: t => Procname.t => Procname.Set.t; + + +/** Compute the ancestors of the node, if not pre-computed already */ +let get_ancestors: t => Procname.t => Procname.Set.t; + + +/** Compute the heirs of the node, if not pre-computed already */ +let get_heirs: t => Procname.t => Procname.Set.t; + + +/** Return the in/out calls of the node */ +let get_calls: t => Procname.t => in_out_calls; + + +/** Return the list of nodes which are defined */ +let get_defined_nodes: t => list Procname.t; + + +/** Return the children of [n] which are defined */ +let get_defined_children: t => Procname.t => Procname.Set.t; + + +/** Return the nodes dependent on [n] */ +let get_dependents: t => Procname.t => Procname.Set.t; + + +/** Return the number of LOC of the source file */ +let get_nLOC: t => int; + + +/** Return the list of nodes with calls */ +let get_nodes_and_calls: t => list (Procname.t, in_out_calls); + + +/** Return all the nodes with their defined children */ +let get_nodes_and_defined_children: t => list (Procname.t, Procname.Set.t); + + +/** Return the list of nodes, with defined flag, and the list of edges */ +let get_nodes_and_edges: t => (list (Procname.t, bool), list (Procname.t, Procname.t)); + + +/** Return the children of [n] which are not heirs of [n] and are defined */ +let get_nonrecursive_dependents: t => Procname.t => Procname.Set.t; + + +/** Return the parents of [n] */ +let get_parents: t => Procname.t => Procname.Set.t; + + +/** Return the ancestors of [n] which are also heirs of [n] */ +let get_recursive_dependents: t => Procname.t => Procname.Set.t; + + +/** Return the path of the source file */ +let get_source: t => DB.source_file; + + +/** Load a call graph from a file */ +let load_from_file: DB.filename => option t; + + +/** Returns true if the node is defined */ +let node_defined: t => Procname.t => bool; + + +/** Print the current call graph as a dotty file. If the filename is [None], + use the current file dir inside the DB dir. */ +let save_call_graph_dotty: option DB.filename => (Procname.t => list 'a) => t => unit; + + +/** Save a call graph into a file */ +let store_to_file: DB.filename => t => unit; diff --git a/infer/src/IR/Csu.re b/infer/src/IR/Csu.re new file mode 100644 index 000000000..2983bbdf9 --- /dev/null +++ b/infer/src/IR/Csu.re @@ -0,0 +1,49 @@ +/* + * Copyright (c) 2015 - 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; + + +/** Internal representation of data structure for Java, Objective-C and C++ classes, + C-style structs struct and union, + And Objective C protocol */ +type class_kind = | CPP | Java | Objc; + +type t = | Class of class_kind | Struct | Union | Protocol; + +let name = + fun + | Class _ => "class" + | Struct => "struct" + | Union => "union" + | Protocol => "protocol"; + +let class_kind_num = + fun + | CPP => 1 + | Java => 2 + | Objc => 3; + +let class_kind_compare ck1 ck2 => class_kind_num ck1 - class_kind_num ck2; + +let compare dstruct1 dstruct2 => + switch (dstruct1, dstruct2) { + | (Class ck1, Class ck2) => class_kind_compare ck1 ck2 + | (Class _, _) => (-1) + | (_, Class _) => 1 + | (Struct, Struct) => 0 + | (Struct, _) => (-1) + | (_, Struct) => 1 + | (Union, Union) => 0 + | (Union, _) => (-1) + | (_, Union) => 1 + | (Protocol, Protocol) => 0 + }; + +let equal tn1 tn2 => compare tn1 tn2 == 0; diff --git a/infer/src/IR/csu.mli b/infer/src/IR/Csu.rei similarity index 54% rename from infer/src/IR/csu.mli rename to infer/src/IR/Csu.rei index 5822dfa92..433f2c46f 100644 --- a/infer/src/IR/csu.mli +++ b/infer/src/IR/Csu.rei @@ -1,31 +1,24 @@ -(* +/* * Copyright (c) 2015 - 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! Utils; -(** Internal representation of data structure for Java, Objective-C and C++ classes, - C-style structs struct and union, - And Objective C protocol *) -type class_kind = - | CPP - | Java - | Objc +/** Internal representation of data structure for Java, Objective-C and C++ classes, + C-style structs struct and union, + And Objective C protocol */ +type class_kind = | CPP | Java | Objc; -type t = - | Class of class_kind - | Struct - | Union - | Protocol +type t = | Class of class_kind | Struct | Union | Protocol; -val name : t -> string +let name: t => string; -val compare : t -> t -> int +let compare: t => t => int; -val equal : t -> t -> bool +let equal: t => t => bool; diff --git a/infer/src/IR/Ident.re b/infer/src/IR/Ident.re new file mode 100644 index 000000000..cc92ce04c --- /dev/null +++ b/infer/src/IR/Ident.re @@ -0,0 +1,415 @@ +/* + * 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; + + +/** Module for Names and Identifiers */ +let module L = Logging; + +let module F = Format; + +type name = string; + +type fieldname = {fpos: int, fname: Mangled.t}; + +type kind = int; + +let kprimed = (-1); + +let knormal = 0; + +let kfootprint = 1; + +type t = {kind: int, name: name, stamp: int}; + +type _ident = t; + + +/** {2 Comparison Functions} */ +let name_compare = string_compare; + +let fieldname_compare fn1 fn2 => { + let n = int_compare fn1.fpos fn2.fpos; + if (n != 0) { + n + } else { + Mangled.compare fn1.fname fn2.fname + } +}; + +let name_equal = string_equal; + +let kind_equal k1 k2 => k1 === k2; + +let compare i1 i2 => { + let n = i2.kind - i1.kind; + if (n != 0) { + n + } else { + let n = name_compare i1.name i2.name; + if (n != 0) { + n + } else { + int_compare i1.stamp i2.stamp + } + } +}; + +let equal i1 i2 => + i1.stamp === i2.stamp && i1.kind === i2.kind && name_equal i1.name i2.name + /* most unlikely first */; + +let fieldname_equal fn1 fn2 => fieldname_compare fn1 fn2 == 0; + +let rec ident_list_compare il1 il2 => + switch (il1, il2) { + | ([], []) => 0 + | ([], _) => (-1) + | (_, []) => 1 + | ([i1, ...l1], [i2, ...l2]) => + let n = compare i1 i2; + if (n != 0) { + n + } else { + ident_list_compare l1 l2 + } + }; + +let ident_list_equal ids1 ids2 => ident_list_compare ids1 ids2 == 0; + + +/** {2 Set for identifiers} */ +let module IdentSet = Set.Make { + type t = _ident; + let compare = compare; +}; + +let module IdentMap = Map.Make { + type t = _ident; + let compare = compare; +}; + +let module IdentHash = Hashtbl.Make { + type t = _ident; + let equal = equal; + let hash (id: t) => Hashtbl.hash id; +}; + +let module FieldSet = Set.Make { + type t = fieldname; + let compare = fieldname_compare; +}; + +let module FieldMap = Map.Make { + type t = fieldname; + let compare = fieldname_compare; +}; + +let idlist_to_idset ids => IList.fold_left (fun set id => IdentSet.add id set) IdentSet.empty ids; + + +/** {2 Conversion between Names and Strings} */ +let module StringHash = Hashtbl.Make { + type t = string; + let equal (s1: string) (s2: string) => s1 == s2; + let hash = Hashtbl.hash; +}; + +let module NameHash = Hashtbl.Make { + type t = name; + let equal = name_equal; + let hash = Hashtbl.hash; +}; + + +/** Convert a string to a name */ +let string_to_name (s: string) => s; + + +/** Create a field name with the given position (field number in the CSU) */ +let create_fieldname (n: Mangled.t) (position: int) => {fpos: position, fname: n}; + + +/** Convert a name to a string. */ +let name_to_string (name: name) => name; + + +/** Convert a fieldname to a string. */ +let fieldname_to_string fn => Mangled.to_string fn.fname; + + +/** Convert a fieldname to a simplified string with at most one-level path. */ +let fieldname_to_simplified_string fn => { + let s = Mangled.to_string fn.fname; + switch (string_split_character s '.') { + | (Some s1, s2) => + switch (string_split_character s1 '.') { + | (Some _, s4) => s4 ^ "." ^ s2 + | _ => s + } + | _ => s + } +}; + + +/** Convert a fieldname to a flat string without path. */ +let fieldname_to_flat_string fn => { + let s = Mangled.to_string fn.fname; + switch (string_split_character s '.') { + | (Some _, s2) => s2 + | _ => s + } +}; + + +/** Returns the class part of the fieldname */ +let java_fieldname_get_class fn => { + let fn = fieldname_to_string fn; + let ri = String.rindex fn '.'; + String.sub fn 0 ri +}; + + +/** Returns the last component of the fieldname */ +let java_fieldname_get_field fn => { + let fn = fieldname_to_string fn; + let ri = 1 + String.rindex fn '.'; + String.sub fn ri (String.length fn - ri) +}; + + +/** Check if the field is the synthetic this$n of a nested class, used to access the n-th outher instance. */ +let java_fieldname_is_outer_instance fn => { + let fn = fieldname_to_string fn; + let fn_len = String.length fn; + let this = ".this$"; + let this_len = String.length this; + let zero_to_nine s => s >= "0" && s <= "9"; + fn_len > this_len && + String.sub fn (fn_len - this_len - 1) this_len == this && + zero_to_nine (String.sub fn (fn_len - 1) 1) +}; + +let fieldname_offset fn => fn.fpos; + + +/** hidded fieldname constant */ +let fieldname_hidden = create_fieldname (Mangled.from_string ".hidden") 0; + + +/** hidded fieldname constant */ +let fieldname_is_hidden fn => fieldname_equal fn fieldname_hidden; + + +/** {2 Functions and Hash Tables for Managing Stamps} */ +/** Set the stamp of the identifier */ +let set_stamp i stamp => {...i, stamp}; + + +/** Get the stamp of the identifier */ +let get_stamp i => i.stamp; + +let module NameGenerator = { + type t = NameHash.t int; + let create () :t => NameHash.create 17; + + /** Map from names to stamps. */ + let name_map = ref (create ()); + let get_current () => !name_map; + let set_current map => name_map := map; + + /** Reset the name generator */ + let reset () => name_map := create (); + + /** Create a fresh identifier with the given kind and name. */ + let create_fresh_ident kind name => { + let stamp = + try { + let stamp = NameHash.find !name_map name; + NameHash.replace !name_map name (stamp + 1); + stamp + 1 + } { + | Not_found => + NameHash.add !name_map name 0; + 0 + }; + {kind, name, stamp} + }; + + /** Make sure that fresh ids after whis one will be with different stamps */ + let update_name_hash name stamp => + try { + let curr_stamp = NameHash.find !name_map name; + let new_stamp = max curr_stamp stamp; + NameHash.replace !name_map name new_stamp + } { + | Not_found => NameHash.add !name_map name stamp + }; +}; + + +/** Name used for primed tmp variables */ +let name_primed = string_to_name "t"; + + +/** Name used for normal tmp variables */ +let name_normal = string_to_name "n"; + + +/** Name used for footprint tmp variables */ +let name_footprint = string_to_name "f"; + + +/** Name used for spec variables */ +let name_spec = string_to_name "val"; + + +/** Name used for the return variable */ +let name_return = Mangled.from_string "return"; + + +/** Return the standard name for the given kind */ +let standard_name kind => + if (kind === knormal) { + name_normal + } else if (kind === kfootprint) { + name_footprint + } else { + name_primed + }; + + +/** Every identifier with a given stamp should unltimately be created using this function */ +let create_with_stamp kind name stamp => { + NameGenerator.update_name_hash name stamp; + {kind, name, stamp} +}; + + +/** Create an identifier with default name for the given kind */ +let create kind stamp => create_with_stamp kind (standard_name kind) stamp; + + +/** Generate a normal identifier with the given name and stamp */ +let create_normal name stamp => create_with_stamp knormal name stamp; + + +/** Generate a primed identifier with the given name and stamp */ +let create_primed name stamp => create_with_stamp kprimed name stamp; + + +/** Generate a footprint identifier with the given name and stamp */ +let create_footprint name stamp => create_with_stamp kfootprint name stamp; + + +/** {2 Functions for Identifiers} */ +/** Get a name of an identifier */ +let get_name id => id.name; + +let get_kind id => id.kind; + +let is_primed (id: t) => id.kind === kprimed; + +let is_normal (id: t) => id.kind === knormal; + +let is_footprint (id: t) => id.kind === kfootprint; + +/* timestamp for a path identifier */ +let path_ident_stamp = (-3); + +let is_path (id: t) => id.kind === knormal && id.stamp == path_ident_stamp; + +let make_unprimed id => + if (id.kind != kprimed) { + assert false + } else { + {...id, kind: knormal} + }; + + +/** Update the name generator so that the given id's are not generated again */ +let update_name_generator ids => { + let upd id => ignore (create_with_stamp id.kind id.name id.stamp); + IList.iter upd ids +}; + + +/** Create a fresh identifier with default name for the given kind. */ +let create_fresh kind => NameGenerator.create_fresh_ident kind (standard_name kind); + + +/** Generate a normal identifier whose name encodes a path given as a string. */ +let create_path pathstring => + create_normal (string_to_name ("%path%" ^ pathstring)) path_ident_stamp; + + +/** {2 Pretty Printing} */ +/** Convert an identifier to a string. */ +let to_string id => { + let base_name = name_to_string id.name; + let prefix = + if (id.kind === kfootprint) { + "@" + } else if (id.kind === knormal) { + "" + } else { + "_" + }; + let suffix = "$" ^ string_of_int id.stamp; + prefix ^ base_name ^ suffix +}; + + +/** Pretty print a name. */ +let pp_name f name => F.fprintf f "%s" (name_to_string name); + +let pp_fieldname f fn => + /* only use for debug F.fprintf f "%a#%d" pp_name fn.fname fn.fpos */ + Mangled.pp f fn.fname; + + +/** Pretty print a name in latex. */ +let pp_name_latex style f (name: name) => Latex.pp_string style f (name_to_string name); + +let pp_fieldname_latex style f fn => Latex.pp_string style f (Mangled.to_string fn.fname); + + +/** Pretty print an identifier. */ +let pp pe f id => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => F.fprintf f "%s" (to_string id) + | PP_LATEX => + let base_name = name_to_string id.name; + let style = + if (id.kind == kfootprint) { + Latex.Boldface + } else if (id.kind == knormal) { + Latex.Roman + } else { + Latex.Roman + }; + F.fprintf f "%a_{%s}" (Latex.pp_string style) base_name (string_of_int id.stamp) + }; + + +/** pretty printer for lists of identifiers */ +let pp_list pe => pp_comma_seq (pp pe); + + +/** pretty printer for lists of names */ +let pp_name_list = pp_comma_seq pp_name; + +/* + let make_ident_primed id = + if id.kind == kprimed then assert false + else { id with kind = kprimed } + */ \ No newline at end of file diff --git a/infer/src/IR/Ident.rei b/infer/src/IR/Ident.rei new file mode 100644 index 000000000..f6953b6fd --- /dev/null +++ b/infer/src/IR/Ident.rei @@ -0,0 +1,269 @@ +/* + * 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; + + +/** Identifiers: program variables and logical variables */ +/** Program and logical variables. */ +type t; + + +/** Names used to replace strings. */ +type name; + + +/** Names for fields of class/struct/union */ +type fieldname; + + +/** Kind of identifiers. */ +type kind; + + +/** Set for identifiers. */ +let module IdentSet: Set.S with type elt = t; + + +/** Hash table with ident as key. */ +let module IdentHash: Hashtbl.S with type key = t; + + +/** Map with ident as key. */ +let module IdentMap: Map.S with type key = t; + + +/** Set for fieldnames */ +let module FieldSet: Set.S with type elt = fieldname; + + +/** Map for fieldnames */ +let module FieldMap: Map.S with type key = fieldname; + +let module NameGenerator: { + type t; + + /** Get the current name generator. */ + let get_current: unit => t; + + /** Reset the name generator. */ + let reset: unit => unit; + + /** Set the current name generator. */ + let set_current: t => unit; +}; + + +/** Convert an identfier list to an identifier set */ +let idlist_to_idset: list t => IdentSet.t; + +let kprimed: kind; + +let knormal: kind; + +let kfootprint: kind; + + +/** hash table with names as keys */ +let module NameHash: Hashtbl.S with type key = name; + + +/** Name used for primed tmp variables */ +let name_primed: name; + + +/** Name used for spec variables */ +let name_spec: name; + + +/** Name used for the return variable */ +let name_return: Mangled.t; + + +/** Convert a string to a name. */ +let string_to_name: string => name; + + +/** Create a field name at the given position */ +let create_fieldname: Mangled.t => int => fieldname; + + +/** Convert a name to a string. */ +let name_to_string: name => string; + + +/** Convert a field name to a string. */ +let fieldname_to_string: fieldname => string; + + +/** Convert a fieldname to a simplified string with at most one-level path. */ +let fieldname_to_simplified_string: fieldname => string; + + +/** Convert a fieldname to a flat string without path. */ +let fieldname_to_flat_string: fieldname => string; + + +/** The class part of the fieldname */ +let java_fieldname_get_class: fieldname => string; + + +/** The last component of the fieldname */ +let java_fieldname_get_field: fieldname => string; + + +/** Check if the field is the synthetic this$n of a nested class, used to access the n-th outher instance. */ +let java_fieldname_is_outer_instance: fieldname => bool; + + +/** get the offset of a fieldname */ +let fieldname_offset: fieldname => int; + + +/** hidded fieldname constant */ +let fieldname_hidden: fieldname; + + +/** hidded fieldname constant */ +let fieldname_is_hidden: fieldname => bool; + + +/** Name of the identifier. */ +let get_name: t => name; + + +/** Kind of the identifier. */ +let get_kind: t => kind; + + +/** Create an identifier with default name for the given kind */ +let create: kind => int => t; + + +/** Generate a normal identifier with the given name and stamp. */ +let create_normal: name => int => t; + + +/** Generate a primed identifier with the given name and stamp. */ +let create_primed: name => int => t; + + +/** Generate a footprint identifier with the given name and stamp. */ +let create_footprint: name => int => t; + + +/** Update the name generator so that the given id's are not generated again */ +let update_name_generator: list t => unit; + + +/** Create a fresh identifier with default name for the given kind. */ +let create_fresh: kind => t; + + +/** Generate a normal identifier whose name encodes a path given as a string. */ +let create_path: string => t; + + +/** Check whether an identifier is primed or not. */ +let is_primed: t => bool; + + +/** Check whether an identifier is normal or not. */ +let is_normal: t => bool; + + +/** Check whether an identifier is footprint or not. */ +let is_footprint: t => bool; + + +/** Check whether an identifier represents a path or not. */ +let is_path: t => bool; + + +/** Convert a primed ident into a nonprimed one, keeping the stamp. */ +let make_unprimed: t => t; + + +/** Get the stamp of the identifier */ +let get_stamp: t => int; + + +/** Set the stamp of the identifier */ +let set_stamp: t => int => t; + + +/** {2 Comparision Functions} */ +/** Comparison for names. */ +let name_compare: name => name => int; + + +/** Comparison for field names. */ +let fieldname_compare: fieldname => fieldname => int; + + +/** Equality for names. */ +let name_equal: name => name => bool; + + +/** Equality for field names. */ +let fieldname_equal: fieldname => fieldname => bool; + + +/** Equality for kind. */ +let kind_equal: kind => kind => bool; + + +/** Comparison for identifiers. */ +let compare: t => t => int; + + +/** Equality for identifiers. */ +let equal: t => t => bool; + + +/** Comparison for lists of identities */ +let ident_list_compare: list t => list t => int; + + +/** Equality for lists of identities */ +let ident_list_equal: list t => list t => bool; + + +/** {2 Pretty Printing} */ +/** Pretty print a name. */ +let pp_name: Format.formatter => name => unit; + + +/** Pretty print a field name. */ +let pp_fieldname: Format.formatter => fieldname => unit; + + +/** Pretty print a name in latex. */ +let pp_name_latex: Latex.style => Format.formatter => name => unit; + + +/** Pretty print a field name in latex. */ +let pp_fieldname_latex: Latex.style => Format.formatter => fieldname => unit; + + +/** Pretty print an identifier. */ +let pp: printenv => Format.formatter => t => unit; + + +/** Convert an identifier to a string. */ +let to_string: t => string; + + +/** Pretty print a list of identifiers. */ +let pp_list: printenv => Format.formatter => list t => unit; + + +/** Pretty print a list of names. */ +let pp_name_list: Format.formatter => list name => unit; diff --git a/infer/src/IR/Location.re b/infer/src/IR/Location.re new file mode 100644 index 000000000..7b54e07a6 --- /dev/null +++ b/infer/src/IR/Location.re @@ -0,0 +1,55 @@ +/* + * Copyright (c) 2015 - 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; + +let module F = Format; + +let module L = Logging; + + +/** Location in the original source file */ +type t = { + line: int, /** The line number. -1 means "do not know" */ + col: int, /** The column number. -1 means "do not know" */ + file: DB.source_file, /** The name of the source file */ + nLOC: int /** Lines of code in the source file */ +}; + +let compare loc1 loc2 => { + let n = int_compare loc1.line loc2.line; + if (n != 0) { + n + } else { + DB.source_file_compare loc1.file loc2.file + } +}; + + +/** Dump a location */ +let d (loc: t) => L.add_print_action (L.PTloc, Obj.repr loc); + + +/** Dummy location */ +let dummy = {line: (-1), col: (-1), file: DB.source_file_empty, nLOC: (-1)}; + +let equal loc1 loc2 => compare loc1 loc2 == 0; + + +/** Pretty print a location */ +let pp f (loc: t) => F.fprintf f "[line %d]" loc.line; + +let to_string loc => { + let s = string_of_int loc.line; + if (loc.col !== (-1)) { + s ^ ":" ^ string_of_int loc.col + } else { + s + } +}; diff --git a/infer/src/IR/Location.rei b/infer/src/IR/Location.rei new file mode 100644 index 000000000..d97e65e9f --- /dev/null +++ b/infer/src/IR/Location.rei @@ -0,0 +1,39 @@ +/* + * Copyright (c) 2015 - 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; + + +/** Location in the original source file */ +type t = { + line: int, /** The line number. -1 means "do not know" */ + col: int, /** The column number. -1 means "do not know" */ + file: DB.source_file, /** The name of the source file */ + nLOC: int /** Lines of code in the source file */ +}; + +let compare: t => t => int; + + +/** Dump a location. */ +let d: t => unit; + + +/** Dummy location */ +let dummy: t; + +let equal: t => t => bool; + + +/** Pretty print a location. */ +let pp: Format.formatter => t => unit; + + +/** String representation of a location. */ +let to_string: t => string; diff --git a/infer/src/IR/Mangled.re b/infer/src/IR/Mangled.re new file mode 100644 index 000000000..70ec9755e --- /dev/null +++ b/infer/src/IR/Mangled.re @@ -0,0 +1,87 @@ +/* + * 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; + + +/** Module for Mangled Names */ +let module F = Format; + +type t = {plain: string, mangled: option string}; + +let mangled_compare so1 so2 => + switch (so1, so2) { + | (None, None) => 0 + | (None, Some _) => (-1) + | (Some _, None) => 1 + | (Some s1, Some s2) => string_compare s1 s2 + }; + +let compare pn1 pn2 => { + let n = string_compare pn1.plain pn2.plain; + if (n != 0) { + n + } else { + mangled_compare pn1.mangled pn2.mangled + } +}; + +let equal pn1 pn2 => compare pn1 pn2 == 0; + + +/** Convert a string to a mangled name */ +let from_string (s: string) => {plain: s, mangled: None}; + + +/** Create a mangled name from a plain and mangled string */ +let mangled (plain: string) (mangled: string) => { + plain, + mangled: Some (plain ^ "{" ^ mangled ^ "}") +}; + + +/** Convert a mangled name to a string */ +let to_string (pn: t) => pn.plain; + + +/** Convert a full mangled name to a string */ +let to_string_full (pn: t) => + switch pn.mangled { + | Some mangled => pn.plain ^ "{" ^ mangled ^ "}" + | None => pn.plain + }; + + +/** Get mangled string if given */ +let get_mangled pn => + switch pn.mangled { + | Some s => s + | None => pn.plain + }; + + +/** Create a mangled type name from a package name and a class name */ +let from_package_class package_name class_name => + if (package_name == "") { + from_string class_name + } else { + from_string (package_name ^ "." ^ class_name) + }; + + +/** Pretty print a mangled name */ +let pp f pn => F.fprintf f "%s" (to_string pn); + +type mangled_t = t; + +let module MangledSet = Set.Make { + type t = mangled_t; + let compare = compare; +}; diff --git a/infer/src/IR/Mangled.rei b/infer/src/IR/Mangled.rei new file mode 100644 index 000000000..023306b9e --- /dev/null +++ b/infer/src/IR/Mangled.rei @@ -0,0 +1,56 @@ +/* + * 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; + + +/** Module for Mangled Names */ +/** Type of mangled names */ +type t; + + +/** Comparison for mangled names */ +let compare: t => t => int; + + +/** Equality for mangled names */ +let equal: t => t => bool; + + +/** Convert a string to a mangled name */ +let from_string: string => t; + + +/** Create a mangled type name from a package name and a class name */ +let from_package_class: string => string => t; + + +/** Create a mangled name from a plain and mangled string */ +let mangled: string => string => t; + + +/** Convert a mangled name to a string */ +let to_string: t => string; + + +/** Convert a full mangled name to a string */ +let to_string_full: t => string; + + +/** Get mangled string if given */ +let get_mangled: t => string; + + +/** Pretty print a mangled name */ +let pp: Format.formatter => t => unit; + + +/** Set of Mangled. */ +let module MangledSet: Set.S with type elt = t; diff --git a/infer/src/IR/ProcAttributes.re b/infer/src/IR/ProcAttributes.re new file mode 100644 index 000000000..cb4a3abe7 --- /dev/null +++ b/infer/src/IR/ProcAttributes.re @@ -0,0 +1,68 @@ +/* + * Copyright (c) 2015 - 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; + + +/** Attributes of a procedure. */ +let module L = Logging; + +let module F = Format; + + +/** Type for ObjC accessors */ +type objc_accessor_type = | Objc_getter of Ident.fieldname | Objc_setter of Ident.fieldname; + +type t = { + access: Sil.access, /** visibility access */ + captured: list (Mangled.t, Sil.typ), /** name and type of variables captured in blocks */ + mutable changed: bool, /** true if proc has changed since last analysis */ + err_log: Errlog.t, /** Error log for the procedure */ + exceptions: list string, /** exceptions thrown by the procedure */ + formals: list (Mangled.t, Sil.typ), /** name and type of formal parameters */ + func_attributes: list Sil.func_attribute, + is_abstract: bool, /** the procedure is abstract */ + mutable is_bridge_method: bool, /** the procedure is a bridge method */ + is_defined: bool, /** true if the procedure is defined, and not just declared */ + is_objc_instance_method: bool, /** the procedure is an objective-C instance method */ + is_cpp_instance_method: bool, /** the procedure is an C++ instance method */ + mutable is_synthetic_method: bool, /** the procedure is a synthetic method */ + language: Config.language, /** language of the procedure */ + loc: Location.t, /** location of this procedure in the source code */ + mutable locals: list (Mangled.t, Sil.typ), /** name and type of local variables */ + method_annotation: Sil.method_annotation, /** annotations for java methods */ + objc_accessor: option objc_accessor_type, /** type of ObjC accessor, if any */ + proc_flags: proc_flags, /** flags of the procedure */ + proc_name: Procname.t, /** name of the procedure */ + ret_type: Sil.typ /** return type */ +}; + +let default proc_name language => { + access: Sil.Default, + captured: [], + changed: true, + err_log: Errlog.empty (), + exceptions: [], + formals: [], + func_attributes: [], + is_abstract: false, + is_bridge_method: false, + is_cpp_instance_method: false, + is_defined: false, + is_objc_instance_method: false, + is_synthetic_method: false, + language, + loc: Location.dummy, + locals: [], + method_annotation: Sil.method_annotation_empty, + objc_accessor: None, + proc_flags: proc_flags_empty (), + proc_name, + ret_type: Sil.Tvoid +}; diff --git a/infer/src/IR/ProcAttributes.rei b/infer/src/IR/ProcAttributes.rei new file mode 100644 index 000000000..f39b71aa0 --- /dev/null +++ b/infer/src/IR/ProcAttributes.rei @@ -0,0 +1,42 @@ +/* + * Copyright (c) 2015 - 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; + + +/** Attributes of a procedure. */ +type objc_accessor_type = | Objc_getter of Ident.fieldname | Objc_setter of Ident.fieldname; + +type t = { + access: Sil.access, /** visibility access */ + captured: list (Mangled.t, Sil.typ), /** name and type of variables captured in blocks */ + mutable changed: bool, /** true if proc has changed since last analysis */ + err_log: Errlog.t, /** Error log for the procedure */ + exceptions: list string, /** exceptions thrown by the procedure */ + formals: list (Mangled.t, Sil.typ), /** name and type of formal parameters */ + func_attributes: list Sil.func_attribute, + is_abstract: bool, /** the procedure is abstract */ + mutable is_bridge_method: bool, /** the procedure is a bridge method */ + is_defined: bool, /** true if the procedure is defined, and not just declared */ + is_objc_instance_method: bool, /** the procedure is an objective-C instance method */ + is_cpp_instance_method: bool, /** the procedure is an C++ instance method */ + mutable is_synthetic_method: bool, /** the procedure is a synthetic method */ + language: Config.language, /** language of the procedure */ + loc: Location.t, /** location of this procedure in the source code */ + mutable locals: list (Mangled.t, Sil.typ), /** name and type of local variables */ + method_annotation: Sil.method_annotation, /** annotations for java methods */ + objc_accessor: option objc_accessor_type, /** type of ObjC accessor, if any */ + proc_flags: proc_flags, /** flags of the procedure */ + proc_name: Procname.t, /** name of the procedure */ + ret_type: Sil.typ /** return type */ +}; + + +/** Create a proc_attributes with default values. */ +let default: Procname.t => Config.language => t; diff --git a/infer/src/IR/Procname.re b/infer/src/IR/Procname.re new file mode 100644 index 000000000..b14b15a8b --- /dev/null +++ b/infer/src/IR/Procname.re @@ -0,0 +1,576 @@ +/* + * 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; + + +/** Module for Procedure Names */ +let module L = Logging; + +let module F = Format; + +type java_type = (option string, string); /* e.g. ("", "int") for primitive types or ("java.io", "PrintWriter") for objects */ + +type method_kind = + | Static /* in Java, procedures called with invokestatic */ + | Non_Static /* in Java, procedures called with invokevirtual, invokespecial, and invokeinterface */; + + +/** Type of java procedure names. */ +type java = { + class_name: java_type, + return_type: option java_type, /* option because constructors have no return type */ + method_name: string, + parameters: list java_type, + kind: method_kind +}; + + +/** Type of c procedure names. */ +type c = (string, option string); + + +/** Type of Objective C and C++ procedure names: method signatures. */ +type objc_cpp = {class_name: string, method_name: string, mangled: option string}; + + +/** Type of Objective C block names. */ +type block = string; + + +/** Type of procedure names. */ +type t = | Java of java | C of c | ObjC_Cpp of objc_cpp | Block of block; + + +/** Level of verbosity of some to_string functions. */ +type detail_level = | Verbose | Non_verbose | Simple; + +type objc_method_kind = | Instance_objc_method | Class_objc_method; + +let mangled_of_objc_method_kind kind => + switch kind { + | Instance_objc_method => Some "instance" + | Class_objc_method => Some "class" + }; + +let objc_method_kind_of_bool is_instance => + if is_instance { + Instance_objc_method + } else { + Class_objc_method + }; + +let empty_block = Block ""; + +let is_verbose v => + switch v { + | Verbose => true + | _ => false + }; + +type proc_name = t; + +let mangled_compare so1 so2 => + switch (so1, so2) { + | (None, None) => 0 + | (None, Some _) => (-1) + | (Some _, None) => 1 + | (Some s1, Some s2) => string_compare s1 s2 + }; + +let method_kind_compare k0 k1 => + switch (k0, k1) { + | _ when k0 == k1 => 0 + | (Static, _) => 1 + | (Non_Static, _) => (-1) + }; + + +/** A type is a pair (package, type_name) that is translated in a string package.type_name */ +let java_type_to_string_verbosity p verbosity => + switch p { + | (None, typ) => typ + | (Some p, cls) => + if (is_verbose verbosity) { + p ^ "." ^ cls + } else { + cls + } + }; + +let java_type_to_string p => java_type_to_string_verbosity p Verbose; + + +/** Given a list of types, it creates a unique string of types separated by commas */ +let rec java_param_list_to_string inputList verbosity => + switch inputList { + | [] => "" + | [head] => java_type_to_string_verbosity head verbosity + | [head, ...rest] => + java_type_to_string_verbosity head verbosity ^ "," ^ java_param_list_to_string rest verbosity + }; + + +/** It is the same as java_type_to_string, but Java return types are optional because of constructors without type */ +let java_return_type_to_string j verbosity => + switch j.return_type { + | None => "" + | Some typ => java_type_to_string_verbosity typ verbosity + }; + +let java_type_compare (p1, c1) (p2, c2) => string_compare c1 c2 |> next mangled_compare p1 p2; + +let rec java_type_list_compare jt1 jt2 => + switch (jt1, jt2) { + | ([], []) => 0 + | ([], _) => (-1) + | (_, []) => 1 + | ([x1, ...rest1], [x2, ...rest2]) => + java_type_compare x1 x2 |> next java_type_list_compare rest1 rest2 + }; + +let java_return_type_compare jr1 jr2 => + switch (jr1, jr2) { + | (None, None) => 0 + | (None, Some _) => (-1) + | (Some _, None) => 1 + | (Some jt1, Some jt2) => java_type_compare jt1 jt2 + }; + + +/** Compare java procedure names. */ +let java_compare (j1: java) (j2: java) => + string_compare j1.method_name j2.method_name |> + next java_type_list_compare j1.parameters j2.parameters |> + next java_type_compare j1.class_name j2.class_name |> + next java_return_type_compare j1.return_type j2.return_type |> + next method_kind_compare j1.kind j2.kind; + +let c_function_mangled_compare mangled1 mangled2 => + switch (mangled1, mangled2) { + | (Some _, None) => 1 + | (None, Some _) => (-1) + | (None, None) => 0 + | (Some mangled1, Some mangled2) => string_compare mangled1 mangled2 + }; + + +/** Compare c_method signatures. */ +let c_meth_sig_compare osig1 osig2 => + string_compare osig1.method_name osig2.method_name |> + next string_compare osig1.class_name osig2.class_name |> + next c_function_mangled_compare osig1.mangled osig2.mangled; + + +/** Given a package.class_name string, it looks for the latest dot and split the string + in two (package, class_name) */ +let split_classname package_classname => string_split_character package_classname '.'; + +let from_string_c_fun (s: string) => C (s, None); + +let c (plain: string) (mangled: string) => (plain, Some mangled); + +let java class_name return_type method_name parameters kind => { + class_name, + return_type, + method_name, + parameters, + kind +}; + + +/** Create an objc procedure name from a class_name and method_name. */ +let objc_cpp class_name method_name mangled => {class_name, method_name, mangled}; + +let get_default_objc_class_method objc_class => { + let objc_cpp = objc_cpp objc_class "__find_class_" (Some "internal"); + ObjC_Cpp objc_cpp +}; + + +/** Create an objc procedure name from a class_name and method_name. */ +let mangled_objc_block name => Block name; + +let is_java = + fun + | Java _ => true + | _ => false; + +let is_c_method = + fun + | ObjC_Cpp _ => true + | _ => false; + + +/** Replace the class name component of a procedure name. + In case of Java, replace package and class name. */ +let replace_class t new_class => + switch t { + | Java j => Java {...j, class_name: split_classname new_class} + | ObjC_Cpp osig => ObjC_Cpp {...osig, class_name: new_class} + | C _ + | Block _ => t + }; + + +/** Get the class name of a Objective-C/C++ procedure name. */ +let objc_cpp_get_class_name objc_cpp => objc_cpp.class_name; + + +/** Return the package.classname of a java procname. */ +let java_get_class_name (j: java) => java_type_to_string j.class_name; + + +/** Return the class name of a java procedure name. */ +let java_get_simple_class_name (j: java) => snd j.class_name; + + +/** Return the package of a java procname. */ +let java_get_package (j: java) => fst j.class_name; + + +/** Return the method of a java procname. */ +let java_get_method (j: java) => j.method_name; + + +/** Replace the method of a java procname. */ +let java_replace_method (j: java) mname => {...j, method_name: mname}; + + +/** Replace the return type of a java procname. */ +let java_replace_return_type j ret_type => {...j, return_type: Some ret_type}; + + +/** Replace the parameters of a java procname. */ +let java_replace_parameters j parameters => {...j, parameters}; + + +/** Return the method/function of a procname. */ +let get_method = + fun + | ObjC_Cpp name => name.method_name + | C (name, _) => name + | Block name => name + | Java j => j.method_name; + + +/** Return the language of the procedure. */ +let get_language = + fun + | ObjC_Cpp _ => Config.Clang + | C _ => Config.Clang + | Block _ => Config.Clang + | Java _ => Config.Java; + + +/** Return the return type of a java procname. */ +let java_get_return_type (j: java) => java_return_type_to_string j Verbose; + + +/** Return the parameters of a java procname. */ +let java_get_parameters j => j.parameters; + + +/** Return the parameters of a java procname as strings. */ +let java_get_parameters_as_strings j => + IList.map (fun param => java_type_to_string param) j.parameters; + + +/** Return true if the java procedure is static */ +let java_is_static = + fun + | Java j => j.kind == Static + | _ => false; + + +/** Prints a string of a java procname with the given level of verbosity */ +let java_to_string withclass::withclass=false (j: java) verbosity => + switch verbosity { + | Verbose + | Non_verbose => + /* if verbose, then package.class.method(params): rtype, + else rtype package.class.method(params) + verbose is used for example to create unique filenames, non_verbose to create reports */ + let return_type = java_return_type_to_string j verbosity; + let params = java_param_list_to_string j.parameters verbosity; + let class_name = java_type_to_string_verbosity j.class_name verbosity; + let separator = + switch (j.return_type, verbosity) { + | (None, _) => "" + | (Some _, Verbose) => ":" + | _ => " " + }; + let output = class_name ^ "." ^ j.method_name ^ "(" ^ params ^ ")"; + if (verbosity == Verbose) { + output ^ separator ^ return_type + } else { + return_type ^ separator ^ output + } + | Simple => + /* methodname(...) or without ... if there are no parameters */ + let cls_prefix = + if withclass { + java_type_to_string_verbosity j.class_name verbosity ^ "." + } else { + "" + }; + let params = + switch j.parameters { + | [] => "" + | _ => "..." + }; + let method_name = + if (j.method_name == "") { + java_get_simple_class_name j + } else { + cls_prefix ^ j.method_name + }; + method_name ^ "(" ^ params ^ ")" + }; + + +/** Check if the class name is for an anonymous inner class. */ +let is_anonymous_inner_class_name class_name => + switch (string_split_character class_name '$') { + | (Some _, s) => + let is_int = + try { + ignore (int_of_string (String.trim s)); + true + } { + | Failure _ => false + }; + is_int + | (None, _) => false + }; + + +/** Check if the procedure belongs to an anonymous inner class. */ +let java_is_anonymous_inner_class = + fun + | Java j => is_anonymous_inner_class_name (snd j.class_name) + | _ => false; + + +/** Check if the last parameter is a hidden inner class, and remove it if present. + This is used in private constructors, where a proxy constructor is generated + with an extra parameter and calls the normal constructor. */ +let java_remove_hidden_inner_class_parameter = + fun + | Java js => + switch (IList.rev js.parameters) { + | [(_, s), ...par'] => + if (is_anonymous_inner_class_name s) { + Some (Java {...js, parameters: IList.rev par'}) + } else { + None + } + | [] => None + } + | _ => None; + + +/** Check if the procedure name is an anonymous inner class constructor. */ +let java_is_anonymous_inner_class_constructor = + fun + | Java js => { + let (_, name) = js.class_name; + is_anonymous_inner_class_name name + } + | _ => false; + + +/** Check if the procedure name is an acess method (e.g. access$100 used to + access private members from a nested class. */ +let java_is_access_method = + fun + | Java js => + switch (string_split_character js.method_name '$') { + | (Some "access", s) => + let is_int = + try { + ignore (int_of_string s); + true + } { + | Failure _ => false + }; + is_int + | _ => false + } + | _ => false; + + +/** Check if the proc name has the type of a java vararg. + Note: currently only checks that the last argument has type Object[]. */ +let java_is_vararg = + fun + | Java js => + switch (IList.rev js.parameters) { + | [(_, "java.lang.Object[]"), ..._] => true + | _ => false + } + | _ => false; + + +/** [is_constructor pname] returns true if [pname] is a constructor */ +let is_constructor = + fun + | Java js => js.method_name == "" + | ObjC_Cpp name => name.method_name == "new" || string_is_prefix "init" name.method_name + | _ => false; + + +/** [is_objc_dealloc pname] returns true if [pname] is the dealloc method in Objective-C */ +let is_objc_dealloc = + fun + | ObjC_Cpp name => name.method_name == "dealloc" + | _ => false; + +let java_is_close = + fun + | Java js => js.method_name == "close" + | _ => false; + + +/** [is_class_initializer pname] returns true if [pname] is a class initializer */ +let is_class_initializer = + fun + | Java js => js.method_name == "" + | _ => false; + + +/** [is_infer_undefined pn] returns true if [pn] is a special Infer undefined proc */ +let is_infer_undefined pn => + switch pn { + | Java j => + let regexp = Str.regexp "com.facebook.infer.models.InferUndefined"; + Str.string_match regexp (java_get_class_name j) 0 + | _ => + /* TODO: add cases for obj-c, c, c++ */ + false + }; + + +/** to_string for C_function type */ +let to_readable_string (c1, c2) verbose => { + let plain = c1; + if verbose { + switch c2 { + | None => plain + | Some s => plain ^ "{" ^ s ^ "}" + } + } else { + plain + } +}; + +let c_method_to_string osig detail_level => + switch detail_level { + | Simple => osig.method_name + | Non_verbose => osig.class_name ^ "_" ^ osig.method_name + | Verbose => + let m_str = + switch osig.mangled { + | None => "" + | Some s => "{" ^ s ^ "}" + }; + osig.class_name ^ "_" ^ osig.method_name ^ m_str + }; + + +/** Very verbose representation of an existing Procname.t */ +let to_unique_id pn => + switch pn { + | Java j => java_to_string j Verbose + | C (c1, c2) => to_readable_string (c1, c2) true + | ObjC_Cpp osig => c_method_to_string osig Verbose + | Block name => name + }; + + +/** Convert a proc name to a string for the user to see */ +let to_string p => + switch p { + | Java j => java_to_string j Non_verbose + | C (c1, c2) => to_readable_string (c1, c2) false + | ObjC_Cpp osig => c_method_to_string osig Non_verbose + | Block name => name + }; + + +/** Convenient representation of a procname for external tools (e.g. eclipse plugin) */ +let to_simplified_string withclass::withclass=false p => + switch p { + | Java j => java_to_string withclass::withclass j Simple + | C (c1, c2) => to_readable_string (c1, c2) false ^ "()" + | ObjC_Cpp osig => c_method_to_string osig Simple + | Block _ => "block" + }; + + +/** Convert a proc name to a filename */ +let to_filename proc_name => + Escape.escape_filename @@ string_append_crc_cutoff @@ to_unique_id proc_name; + + +/** Pretty print a proc name */ +let pp f pn => F.fprintf f "%s" (to_string pn); + + +/** Compare function for Procname.t types. + These rules create an ordered set of procnames grouped with the following + priority (lowest to highest): */ +let compare pn1 pn2 => + switch (pn1, pn2) { + | (Java j1, Java j2) => java_compare j1 j2 + | (Java _, _) => (-1) + | (_, Java _) => 1 + | ( + C (c1, c2), /* Compare C_function types */ + C (c3, c4) + ) => + string_compare c1 c3 |> next mangled_compare c2 c4 + | (C _, _) => (-1) + | (_, C _) => 1 + | ( + Block s1, /* Compare ObjC_block types */ + Block s2 + ) => + string_compare s1 s2 + | (Block _, _) => (-1) + | (_, Block _) => 1 + | (ObjC_Cpp osig1, ObjC_Cpp osig2) => c_meth_sig_compare osig1 osig2 + }; + +let equal pn1 pn2 => compare pn1 pn2 == 0; + + +/** hash function for procname */ +let hash_pname = Hashtbl.hash; + +let module Hash = Hashtbl.Make { + type t = proc_name; + let equal = equal; + let hash = hash_pname; +}; + +let module Map = Map.Make { + type t = proc_name; + let compare = compare; +}; + +let module Set = Set.Make { + type t = proc_name; + let compare = compare; +}; + + +/** Pretty print a set of proc names */ +let pp_set fmt set => Set.iter (fun pname => F.fprintf fmt "%a " pp pname) set; diff --git a/infer/src/IR/Procname.rei b/infer/src/IR/Procname.rei new file mode 100644 index 000000000..5a1d716a0 --- /dev/null +++ b/infer/src/IR/Procname.rei @@ -0,0 +1,251 @@ +/* + * 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; + + +/** Module for Procedure Names. */ +/** Type of java procedure names. */ +type java; + + +/** Type of c procedure names. */ +type c; + + +/** Type of Objective C and C++ procedure names. */ +type objc_cpp; + + +/** Type of Objective C block names. */ +type block; + + +/** Type of procedure names. */ +type t = | Java of java | C of c | ObjC_Cpp of objc_cpp | Block of block; + +type java_type = (option string, string); + +type method_kind = + | Static /* in Java, procedures called with invokestatic */ + | Non_Static /* in Java, procedures called with invokevirtual, invokespecial, and invokeinterface */; + +type objc_method_kind = + | Instance_objc_method /* for instance methods in ObjC */ + | Class_objc_method /* for class methods in ObjC */; + + +/** Hash tables with proc names as keys. */ +let module Hash: Hashtbl.S with type key = t; + + +/** Maps from proc names. */ +let module Map: Map.S with type key = t; + + +/** Sets of proc names. */ +let module Set: Set.S with type elt = t; + + +/** Create a C procedure name from plain and mangled name. */ +let c: string => string => c; + + +/** Comparison for proc names. */ +let compare: t => t => int; + + +/** Empty block name. */ +let empty_block: t; + + +/** Equality for proc names. */ +let equal: t => t => bool; + + +/** Convert a string to a proc name. */ +let from_string_c_fun: string => t; + + +/** Return the language of the procedure. */ +let get_language: t => Config.language; + + +/** Return the method/function of a procname. */ +let get_method: t => string; + + +/** Hash function for procname. */ +let hash_pname: t => int; + + +/** Check if a class string is an anoynmous inner class name. */ +let is_anonymous_inner_class_name: string => bool; + + +/** Check if this is an Objective-C/C++ method name. */ +let is_c_method: t => bool; + + +/** Check if this is a constructor. */ +let is_constructor: t => bool; + + +/** Check if this is a Java procedure name. */ +let is_java: t => bool; + + +/** Check if this is a dealloc method in Objective-C. */ +let is_objc_dealloc: t => bool; + + +/** Create a Java procedure name from its + class_name method_name args_type_name return_type_name method_kind. */ +let java: java_type => option java_type => string => list java_type => method_kind => java; + + +/** Replace the parameters of a java procname. */ +let java_replace_parameters: java => list java_type => java; + + +/** Replace the method of a java procname. */ +let java_replace_return_type: java => java_type => java; + + +/** Create an objc block name. */ +let mangled_objc_block: string => t; + + +/** Mangled string for method types. */ +let mangled_of_objc_method_kind: objc_method_kind => option string; + + +/** Create an objc procedure name from a class_name and method_name. */ +let objc_cpp: string => string => option string => objc_cpp; + +let get_default_objc_class_method: string => t; + + +/** Get the class name of a Objective-C/C++ procedure name. */ +let objc_cpp_get_class_name: objc_cpp => string; + + +/** Create ObjC method type from a bool is_instance. */ +let objc_method_kind_of_bool: bool => objc_method_kind; + + +/** Return the class name of a java procedure name. */ +let java_get_class_name: java => string; + + +/** Return the simple class name of a java procedure name. */ +let java_get_simple_class_name: java => string; + + +/** Return the package name of a java procedure name. */ +let java_get_package: java => option string; + + +/** Return the method name of a java procedure name. */ +let java_get_method: java => string; + + +/** Return the return type of a java procedure name. */ +let java_get_return_type: java => string; + + +/** Return the parameters of a java procedure name. */ +let java_get_parameters: java => list java_type; + + +/** Return the parameters of a java procname as strings. */ +let java_get_parameters_as_strings: java => list string; + + +/** Check if the procedure name is an acess method (e.g. access$100 used to + access private members from a nested class. */ +let java_is_access_method: t => bool; + + +/** Check if the procedure belongs to an anonymous inner class. */ +let java_is_anonymous_inner_class: t => bool; + + +/** Check if the procedure name is an anonymous inner class constructor. */ +let java_is_anonymous_inner_class_constructor: t => bool; + + +/** Check if the method name is "close". */ +let java_is_close: t => bool; + + +/** Check if the java procedure is static. */ +let java_is_static: t => bool; + + +/** Check if the proc name has the type of a java vararg. + Note: currently only checks that the last argument has type Object[]. */ +let java_is_vararg: t => bool; + + +/** Check if the last parameter is a hidden inner class, and remove it if present. + This is used in private constructors, where a proxy constructor is generated + with an extra parameter and calls the normal constructor. */ +let java_remove_hidden_inner_class_parameter: t => option t; + + +/** Replace the method name of an existing java procname. */ +let java_replace_method: java => string => java; + + +/** Convert a java type to a string. */ +let java_type_to_string: java_type => string; + + +/** Check if this is a class initializer. */ +let is_class_initializer: t => bool; + + +/** Check if this is a special Infer undefined procedure. */ +let is_infer_undefined: t => bool; + + +/** Pretty print a proc name. */ +let pp: Format.formatter => t => unit; + + +/** Pretty print a set of proc names. */ +let pp_set: Format.formatter => Set.t => unit; + + +/** Replace the class name component of a procedure name. + In case of Java, replace package and class name. */ +let replace_class: t => string => t; + + +/** Given a package.class_name string, look for the latest dot and split the string + in two (package, class_name). */ +let split_classname: string => (option string, string); + + +/** Convert a proc name to a string for the user to see. */ +let to_string: t => string; + + +/** Convert a proc name into a easy string for the user to see in an IDE. */ +let to_simplified_string: withclass::bool? => t => string; + + +/** Convert a proc name into a unique identifier. */ +let to_unique_id: t => string; + + +/** Convert a proc name to a filename. */ +let to_filename: t => string; diff --git a/infer/src/IR/Pvar.re b/infer/src/IR/Pvar.re new file mode 100644 index 000000000..64fe8962a --- /dev/null +++ b/infer/src/IR/Pvar.re @@ -0,0 +1,306 @@ +/* + * 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; + + +/** The Smallfoot Intermediate Language */ +let module L = Logging; + +let module F = Format; + + +/** Kind of global variables */ +type pvar_kind = + | Local_var of Procname.t /** local variable belonging to a function */ + | Callee_var of Procname.t /** local variable belonging to a callee */ + | Abducted_retvar of Procname.t Location.t /** synthetic variable to represent return value */ + | Abducted_ref_param of Procname.t t Location.t + /** synthetic variable to represent param passed by reference */ + | Global_var /** gloval variable */ + | Seed_var /** variable used to store the initial value of formal parameters */ +/** Names for program variables. */ +and t = {pv_name: Mangled.t, pv_kind: pvar_kind}; + +let rec pvar_kind_compare k1 k2 => + switch (k1, k2) { + | (Local_var n1, Local_var n2) => Procname.compare n1 n2 + | (Local_var _, _) => (-1) + | (_, Local_var _) => 1 + | (Callee_var n1, Callee_var n2) => Procname.compare n1 n2 + | (Callee_var _, _) => (-1) + | (_, Callee_var _) => 1 + | (Abducted_retvar p1 l1, Abducted_retvar p2 l2) => + let n = Procname.compare p1 p2; + if (n != 0) { + n + } else { + Location.compare l1 l2 + } + | (Abducted_retvar _, _) => (-1) + | (_, Abducted_retvar _) => 1 + | (Abducted_ref_param p1 pv1 l1, Abducted_ref_param p2 pv2 l2) => + let n = Procname.compare p1 p2; + if (n != 0) { + n + } else { + let n = compare pv1 pv2; + if (n != 0) { + n + } else { + Location.compare l1 l2 + } + } + | (Abducted_ref_param _, _) => (-1) + | (_, Abducted_ref_param _) => 1 + | (Global_var, Global_var) => 0 + | (Global_var, _) => (-1) + | (_, Global_var) => 1 + | (Seed_var, Seed_var) => 0 + } +and compare pv1 pv2 => { + let n = Mangled.compare pv1.pv_name pv2.pv_name; + if (n != 0) { + n + } else { + pvar_kind_compare pv1.pv_kind pv2.pv_kind + } +}; + +let equal pvar1 pvar2 => compare pvar1 pvar2 == 0; + +let rec _pp f pv => { + let name = pv.pv_name; + switch pv.pv_kind { + | Local_var n => + if !Config.pp_simple { + F.fprintf f "%a" Mangled.pp name + } else { + F.fprintf f "%a$%a" Procname.pp n Mangled.pp name + } + | Callee_var n => + if !Config.pp_simple { + F.fprintf f "%a|callee" Mangled.pp name + } else { + F.fprintf f "%a$%a|callee" Procname.pp n Mangled.pp name + } + | Abducted_retvar n l => + if !Config.pp_simple { + F.fprintf f "%a|abductedRetvar" Mangled.pp name + } else { + F.fprintf f "%a$%a%a|abductedRetvar" Procname.pp n Location.pp l Mangled.pp name + } + | Abducted_ref_param n pv l => + if !Config.pp_simple { + F.fprintf f "%a|%a|abductedRefParam" _pp pv Mangled.pp name + } else { + F.fprintf f "%a$%a%a|abductedRefParam" Procname.pp n Location.pp l Mangled.pp name + } + | Global_var => F.fprintf f "#GB$%a" Mangled.pp name + | Seed_var => F.fprintf f "old_%a" Mangled.pp name + } +}; + + +/** Pretty print a program variable in latex. */ +let pp_latex f pv => { + let name = pv.pv_name; + switch pv.pv_kind { + | Local_var _ => Latex.pp_string Latex.Roman f (Mangled.to_string name) + | Callee_var _ => + F.fprintf + f + "%a_{%a}" + (Latex.pp_string Latex.Roman) + (Mangled.to_string name) + (Latex.pp_string Latex.Roman) + "callee" + | Abducted_retvar _ => + F.fprintf + f + "%a_{%a}" + (Latex.pp_string Latex.Roman) + (Mangled.to_string name) + (Latex.pp_string Latex.Roman) + "abductedRetvar" + | Abducted_ref_param _ => + F.fprintf + f + "%a_{%a}" + (Latex.pp_string Latex.Roman) + (Mangled.to_string name) + (Latex.pp_string Latex.Roman) + "abductedRefParam" + | Global_var => Latex.pp_string Latex.Boldface f (Mangled.to_string name) + | Seed_var => + F.fprintf + f + "%a^{%a}" + (Latex.pp_string Latex.Roman) + (Mangled.to_string name) + (Latex.pp_string Latex.Roman) + "old" + } +}; + + +/** Pretty print a pvar which denotes a value, not an address */ +let pp_value pe f pv => + switch pe.pe_kind { + | PP_TEXT => _pp f pv + | PP_HTML => _pp f pv + | PP_LATEX => pp_latex f pv + }; + + +/** Pretty print a program variable. */ +let pp pe f pv => { + let ampersand = + switch pe.pe_kind { + | PP_TEXT => "&" + | PP_HTML => "&" + | PP_LATEX => "\\&" + }; + F.fprintf f "%s%a" ampersand (pp_value pe) pv +}; + + +/** Dump a program variable. */ +let d (pvar: t) => L.add_print_action (L.PTpvar, Obj.repr pvar); + + +/** Pretty print a list of program variables. */ +let pp_list pe f pvl => F.fprintf f "%a" (pp_seq (fun f e => F.fprintf f "%a" (pp pe) e)) pvl; + + +/** Dump a list of program variables. */ +let d_list pvl => + IList.iter + ( + fun pv => { + d pv; + L.d_str " " + } + ) + pvl; + +let get_name pv => pv.pv_name; + +let to_string pv => Mangled.to_string pv.pv_name; + +let get_simplified_name pv => { + let s = Mangled.to_string pv.pv_name; + switch (string_split_character s '.') { + | (Some s1, s2) => + switch (string_split_character s1 '.') { + | (Some _, s4) => s4 ^ "." ^ s2 + | _ => s + } + | _ => s + } +}; + + +/** Check if the pvar is an abucted return var or param passed by ref */ +let is_abducted pv => + switch pv.pv_kind { + | Abducted_retvar _ + | Abducted_ref_param _ => true + | _ => false + }; + + +/** Turn a pvar into a seed pvar (which stored the initial value) */ +let to_seed pv => {...pv, pv_kind: Seed_var}; + + +/** Check if the pvar is a local var */ +let is_local pv => + switch pv.pv_kind { + | Local_var _ => true + | _ => false + }; + + +/** Check if the pvar is a callee var */ +let is_callee pv => + switch pv.pv_kind { + | Callee_var _ => true + | _ => false + }; + + +/** Check if the pvar is a seed var */ +let is_seed pv => + switch pv.pv_kind { + | Seed_var => true + | _ => false + }; + + +/** Check if the pvar is a global var */ +let is_global pv => pv.pv_kind == Global_var; + + +/** Check if a pvar is the special "this" var */ +let is_this pvar => Mangled.equal (get_name pvar) (Mangled.from_string "this"); + + +/** Check if the pvar is a return var */ +let is_return pv => get_name pv == Ident.name_return; + + +/** Turn an ordinary program variable into a callee program variable */ +let to_callee pname pvar => + switch pvar.pv_kind { + | Local_var _ => {...pvar, pv_kind: Callee_var pname} + | Global_var => pvar + | Callee_var _ + | Abducted_retvar _ + | Abducted_ref_param _ + | Seed_var => + L.d_str "Cannot convert pvar to callee: "; + d pvar; + L.d_ln (); + assert false + }; + + +/** [mk name proc_name] creates a program var with the given function name */ +let mk (name: Mangled.t) (proc_name: Procname.t) :t => { + pv_name: name, + pv_kind: Local_var proc_name +}; + +let get_ret_pvar pname => mk Ident.name_return pname; + + +/** [mk_callee name proc_name] creates a program var + for a callee function with the given function name */ +let mk_callee (name: Mangled.t) (proc_name: Procname.t) :t => { + pv_name: name, + pv_kind: Callee_var proc_name +}; + + +/** create a global variable with the given name */ +let mk_global (name: Mangled.t) :t => {pv_name: name, pv_kind: Global_var}; + + +/** create an abducted return variable for a call to [proc_name] at [loc] */ +let mk_abducted_ret (proc_name: Procname.t) (loc: Location.t) :t => { + let name = Mangled.from_string ("$RET_" ^ Procname.to_unique_id proc_name); + {pv_name: name, pv_kind: Abducted_retvar proc_name loc} +}; + +let mk_abducted_ref_param (proc_name: Procname.t) (pv: t) (loc: Location.t) :t => { + let name = Mangled.from_string ("$REF_PARAM_" ^ Procname.to_unique_id proc_name); + {pv_name: name, pv_kind: Abducted_ref_param proc_name pv loc} +}; diff --git a/infer/src/IR/Pvar.rei b/infer/src/IR/Pvar.rei new file mode 100644 index 000000000..326bd05b7 --- /dev/null +++ b/infer/src/IR/Pvar.rei @@ -0,0 +1,125 @@ +/* + * 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; + + +/** Program variables. */ +let module F = Format; + + +/** Type for program variables. There are 4 kinds of variables: + 1) local variables, used for local variables and formal parameters + 2) callee program variables, used to handle recursion ([x | callee] is distinguished from [x]) + 3) global variables + 4) seed variables, used to store the initial value of formal parameters + */ +type t; + + +/** Compare two pvar's */ +let compare: t => t => int; + + +/** Dump a program variable. */ +let d: t => unit; + + +/** Dump a list of program variables. */ +let d_list: list t => unit; + + +/** Equality for pvar's */ +let equal: t => t => bool; + + +/** Get the name component of a program variable. */ +let get_name: t => Mangled.t; + + +/** [get_ret_pvar proc_name] retuns the return pvar associated with the procedure name */ +let get_ret_pvar: Procname.t => t; + + +/** Get a simplified version of the name component of a program variable. */ +let get_simplified_name: t => string; + + +/** Check if the pvar is an abducted return var or param passed by ref */ +let is_abducted: t => bool; + + +/** Check if the pvar is a callee var */ +let is_callee: t => bool; + + +/** Check if the pvar is a global var */ +let is_global: t => bool; + + +/** Check if the pvar is a local var */ +let is_local: t => bool; + + +/** Check if the pvar is a seed var */ +let is_seed: t => bool; + + +/** Check if the pvar is a return var */ +let is_return: t => bool; + + +/** Check if a pvar is the special "this" var */ +let is_this: t => bool; + + +/** [mk name proc_name suffix] creates a program var with the given function name and suffix */ +let mk: Mangled.t => Procname.t => t; + + +/** create an abducted variable for a parameter passed by reference */ +let mk_abducted_ref_param: Procname.t => t => Location.t => t; + + +/** create an abducted return variable for a call to [proc_name] at [loc] */ +let mk_abducted_ret: Procname.t => Location.t => t; + + +/** [mk_callee name proc_name] creates a program var + for a callee function with the given function name */ +let mk_callee: Mangled.t => Procname.t => t; + + +/** create a global variable with the given name */ +let mk_global: Mangled.t => t; + + +/** Pretty print a program variable. */ +let pp: printenv => F.formatter => t => unit; + + +/** Pretty print a list of program variables. */ +let pp_list: printenv => F.formatter => list t => unit; + + +/** Pretty print a pvar which denotes a value, not an address */ +let pp_value: printenv => F.formatter => t => unit; + + +/** Turn an ordinary program variable into a callee program variable */ +let to_callee: Procname.t => t => t; + + +/** Turn a pvar into a seed pvar (which stores the initial value of a stack var) */ +let to_seed: t => t; + + +/** Convert a pvar to string. */ +let to_string: t => string; diff --git a/infer/src/IR/README.md b/infer/src/IR/README.md index 9636d7266..ac447734d 100644 --- a/infer/src/IR/README.md +++ b/infer/src/IR/README.md @@ -2,11 +2,11 @@ The Intermediate Representation is a format used by the back-end for analysis. It is produced by one of the front-ends, one for each program analyzed. -The main entry point is the intermediate language in [Sil](sil.mli). +The main entry point is the intermediate language in [Sil](sil.rei). -The control flow graph module is [Cfg](cfg.mli). +The control flow graph module is [Cfg](cfg.rei). -The call graph module is [Cg](cg.mli). +The call graph module is [Cg](cg.rei). -The type environment module is [Tenv](tenv.mli). +The type environment module is [Tenv](tenv.rei). diff --git a/infer/src/IR/Sil.re b/infer/src/IR/Sil.re new file mode 100644 index 000000000..389c63835 --- /dev/null +++ b/infer/src/IR/Sil.re @@ -0,0 +1,4755 @@ +/* + * 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; + + +/** The Smallfoot Intermediate Language */ +let module L = Logging; + +let module F = Format; + + +/** {2 Programs and Types} */ +/** Type to represent one @Annotation. */ +type annotation = { + class_name: string, /* name of the annotation */ + parameters: list string + /* currently only one string parameter */ +}; + + +/** Annotation for one item: a list of annotations with visibility. */ +type item_annotation = list (annotation, bool); + + +/** Annotation for a method: return value and list of parameters. */ +type method_annotation = (item_annotation, list item_annotation); + +type func_attribute = + | FA_sentinel of int int /** __attribute__((sentinel(int, int))) */; + + +/** Visibility modifiers. */ +type access = | Default | Public | Private | Protected; + + +/** Compare function for annotations. */ +let annotation_compare a1 a2 => { + let n = string_compare a1.class_name a2.class_name; + if (n != 0) { + n + } else { + IList.compare string_compare a1.parameters a2.parameters + } +}; + + +/** Compare function for annotation items. */ +let item_annotation_compare ia1 ia2 => { + let cmp (a1, b1) (a2, b2) => { + let n = annotation_compare a1 a2; + if (n != 0) { + n + } else { + bool_compare b1 b2 + } + }; + IList.compare cmp ia1 ia2 +}; + + +/** Compare function for Method annotations. */ +let method_annotation_compare (ia1, ial1) (ia2, ial2) => + IList.compare item_annotation_compare [ia1, ...ial1] [ia2, ...ial2]; + + +/** Empty item annotation. */ +let item_annotation_empty = []; + + +/** Empty method annotation. */ +let method_annotation_empty = ([], []); + + +/** Check if the item annodation is empty. */ +let item_annotation_is_empty ia => ia == []; + + +/** Check if the method annodation is empty. */ +let method_annotation_is_empty (ia, ial) => IList.for_all item_annotation_is_empty [ia, ...ial]; + + +/** Pretty print an annotation. */ +let pp_annotation fmt annotation => F.fprintf fmt "@@%s" annotation.class_name; + + +/** Pretty print an item annotation. */ +let pp_item_annotation fmt item_annotation => { + let pp fmt (a, _) => pp_annotation fmt a; + F.fprintf fmt "<%a>" (pp_seq pp) item_annotation +}; + +let item_annotation_to_string ann => { + let pp fmt () => pp_item_annotation fmt ann; + pp_to_string pp () +}; + + +/** Pretty print a method annotation. */ +let pp_method_annotation s fmt (ia, ial) => + F.fprintf fmt "%a %s(%a)" pp_item_annotation ia s (pp_seq pp_item_annotation) ial; + + +/** Return the value of the FA_sentinel attribute in [attr_list] if it is found */ +let get_sentinel_func_attribute_value attr_list => + switch attr_list { + | [FA_sentinel sentinel null_pos, ..._] => Some (sentinel, null_pos) + | [] => None + }; + + +/** Unary operations */ +type unop = + | Neg /** Unary minus */ + | BNot /** Bitwise complement (~) */ + | LNot /** Logical Not (!) */; + + +/** Binary operations */ +type binop = + | PlusA /** arithmetic + */ + | PlusPI /** pointer + integer */ + | MinusA /** arithmetic - */ + | MinusPI /** pointer - integer */ + | MinusPP /** pointer - pointer */ + | Mult /** * */ + | Div /** / */ + | Mod /** % */ + | Shiftlt /** shift left */ + | Shiftrt /** shift right */ + | Lt /** < (arithmetic comparison) */ + | Gt /** > (arithmetic comparison) */ + | Le /** <= (arithmetic comparison) */ + | Ge /** > (arithmetic comparison) */ + | Eq /** == (arithmetic comparison) */ + | Ne /** != (arithmetic comparison) */ + | BAnd /** bitwise and */ + | BXor /** exclusive-or */ + | BOr /** inclusive-or */ + | LAnd /** logical and. Does not always evaluate both operands. */ + | LOr /** logical or. Does not always evaluate both operands. */ + | PtrFld /** field offset via pointer to field: takes the address of a + Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) */; + + +/** Kinds of integers */ +type ikind = + | IChar /** [char] */ + | ISChar /** [signed char] */ + | IUChar /** [unsigned char] */ + | IBool /** [bool] */ + | IInt /** [int] */ + | IUInt /** [unsigned int] */ + | IShort /** [short] */ + | IUShort /** [unsigned short] */ + | ILong /** [long] */ + | IULong /** [unsigned long] */ + | ILongLong /** [long long] (or [_int64] on Microsoft Visual C) */ + | IULongLong /** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) */ + | I128 /** [__int128_t] */ + | IU128 /** [__uint128_t] */; + + +/** Kinds of floating-point numbers*/ +type fkind = + | FFloat /** [float] */ + | FDouble /** [double] */ + | FLongDouble /** [long double] */; + +type mem_kind = + | Mmalloc /** memory allocated with malloc */ + | Mnew /** memory allocated with new */ + | Mnew_array /** memory allocated with new[] */ + | Mobjc /** memory allocated with objective-c alloc */; + + +/** resource that can be allocated */ +type resource = | Rmemory of mem_kind | Rfile | Rignore | Rlock; + + +/** kind of resource action */ +type res_act_kind = | Racquire | Rrelease; + + +/** kind of dangling pointers */ +type dangling_kind = + /** pointer is dangling because it is uninitialized */ + | DAuninit + /** pointer is dangling because it is the address + of a stack variable which went out of scope */ + | DAaddr_stack_var + /** pointer is -1 */ + | DAminusone; + + +/** kind of pointer */ +type ptr_kind = + | Pk_pointer /* C/C++, Java, Objc standard/__strong pointer*/ + | Pk_reference /* C++ reference */ + | Pk_objc_weak /* Obj-C __weak pointer*/ + | Pk_objc_unsafe_unretained /* Obj-C __unsafe_unretained pointer */ + | Pk_objc_autoreleasing /* Obj-C __autoreleasing pointer */; + + +/** position in a path: proc name, node id */ +type path_pos = (Procname.t, int); + + +/** module for subtypes, to be used with Sizeof info */ +let module Subtype = { + let list_to_string list => { + let rec aux list => + switch list { + | [] => "" + | [el, ...rest] => + let s = aux rest; + if (s == "") { + Typename.name el + } else { + Typename.name el ^ ", " ^ s + } + }; + if (IList.length list == 0) { + "( sub )" + } else { + "- {" ^ aux list ^ "}" + } + }; + type t' = + | Exact /** denotes the current type only */ + | Subtypes of (list Typename.t); + + /** denotes the current type and a list of types that are not their subtypes */ + type kind = | CAST | INSTOF | NORMAL; + type t = (t', kind); + let module SubtypesPair = { + type t = (Typename.t, Typename.t); + let compare (e1: t) (e2: t) :int => pair_compare Typename.compare Typename.compare e1 e2; + }; + let module SubtypesMap = Map.Make SubtypesPair; + type subtMap = SubtypesMap.t bool; + let subtMap: ref subtMap = ref SubtypesMap.empty; + let check_subtype f c1 c2 => + try (SubtypesMap.find (c1, c2) !subtMap) { + | Not_found => + let is_subt = f c1 c2; + subtMap := SubtypesMap.add (c1, c2) is_subt !subtMap; + is_subt + }; + let flag_to_string flag => + switch flag { + | CAST => "(cast)" + | INSTOF => "(instof)" + | NORMAL => "" + }; + let pp f (t, flag) => + if Config.print_types { + switch t { + | Exact => F.fprintf f "%s" (flag_to_string flag) + | Subtypes list => F.fprintf f "%s" (list_to_string list ^ flag_to_string flag) + } + }; + let exact = (Exact, NORMAL); + let all_subtypes = Subtypes []; + let subtypes = (all_subtypes, NORMAL); + let subtypes_cast = (all_subtypes, CAST); + let subtypes_instof = (all_subtypes, INSTOF); + let is_cast t => snd t == CAST; + let is_instof t => snd t == INSTOF; + let list_intersect equal l1 l2 => { + let in_l2 a => IList.mem equal a l2; + IList.filter in_l2 l1 + }; + let join_flag flag1 flag2 => + switch (flag1, flag2) { + | (CAST, _) => CAST + | (_, CAST) => CAST + | (_, _) => NORMAL + }; + let join (s1, flag1) (s2, flag2) => { + let s = + switch (s1, s2) { + | (Exact, _) => s2 + | (_, Exact) => s1 + | (Subtypes l1, Subtypes l2) => Subtypes (list_intersect Typename.equal l1 l2) + }; + let flag = join_flag flag1 flag2; + (s, flag) + }; + let subtypes_compare l1 l2 => IList.compare Typename.compare l1 l2; + let compare_flag flag1 flag2 => + switch (flag1, flag2) { + | (CAST, CAST) => 0 + | (INSTOF, INSTOF) => 0 + | (NORMAL, NORMAL) => 0 + | (CAST, _) => (-1) + | (_, CAST) => 1 + | (INSTOF, NORMAL) => (-1) + | (NORMAL, INSTOF) => 1 + }; + let compare_subt s1 s2 => + switch (s1, s2) { + | (Exact, Exact) => 0 + | (Exact, _) => (-1) + | (_, Exact) => 1 + | (Subtypes l1, Subtypes l2) => subtypes_compare l1 l2 + }; + let compare t1 t2 => pair_compare compare_subt compare_flag t1 t2; + let equal_modulo_flag (st1, _) (st2, _) => compare_subt st1 st2 == 0; + let update_flag c1 c2 flag flag' => + switch flag { + | INSTOF => + if (Typename.equal c1 c2) { + flag + } else { + flag' + } + | _ => flag' + }; + let change_flag st_opt c1 c2 flag' => + switch st_opt { + | Some st => + switch st { + | (Exact, flag) => + let new_flag = update_flag c1 c2 flag flag'; + Some (Exact, new_flag) + | (Subtypes t, flag) => + let new_flag = update_flag c1 c2 flag flag'; + Some (Subtypes t, new_flag) + } + | None => None + }; + let normalize_subtypes t_opt c1 c2 flag1 flag2 => { + let new_flag = update_flag c1 c2 flag1 flag2; + switch t_opt { + | Some t => + switch t { + | Exact => Some (t, new_flag) + | Subtypes l => Some (Subtypes (IList.sort Typename.compare l), new_flag) + } + | None => None + } + }; + let subtypes_to_string t => + switch (fst t) { + | Exact => "ex" ^ flag_to_string (snd t) + | Subtypes l => list_to_string l ^ flag_to_string (snd t) + }; + /* c is a subtype when it does not appear in the list l of no-subtypes */ + let is_subtype f c l => + try { + ignore (IList.find (f c) l); + false + } { + | Not_found => true + }; + let is_strict_subtype f c1 c2 => f c1 c2 && not (Typename.equal c1 c2); + /* checks for redundancies when adding c to l + Xi in A - { X1,..., Xn } is redundant in two cases: + 1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A + 2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj */ + let check_redundancies f c l => { + let aux (l, add) ci => { + let (l, should_add) = + if (f ci c) { + (l, true) + } else if (f c ci) { + ([ci, ...l], false) + } else { + ([ci, ...l], true) + }; + (l, add && should_add) + }; + IList.fold_left aux ([], true) l + }; + let rec updates_head f c l => + switch l { + | [] => [] + | [ci, ...rest] => + if (is_strict_subtype f ci c) { + [ci, ...updates_head f c rest] + } else { + updates_head f c rest + } + }; + /* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur + A - { X1,..., Xn } is inconsistent if A <: Xi for some i */ + let rec add_not_subtype f c1 l1 l2 => + switch l2 { + | [] => l1 + | [c, ...rest] => + if (f c1 c) { + add_not_subtype f c1 l1 rest + } else { + /* checks for inconsistencies */ + let (l1', should_add) = check_redundancies f c l1; /* checks for redundancies */ + let rest' = add_not_subtype f c1 l1' rest; + if should_add { + [c, ...rest'] + } else { + rest' + } + } + }; + let get_subtypes (c1, (st1, flag1)) (c2, (st2, flag2)) f is_interface => { + let is_sub = f c1 c2; + let (pos_st, neg_st) = + switch (st1, st2) { + | (Exact, Exact) => + if is_sub { + (Some st1, None) + } else { + (None, Some st1) + } + | (Exact, Subtypes l2) => + if (is_sub && is_subtype f c1 l2) { + (Some st1, None) + } else { + (None, Some st1) + } + | (Subtypes l1, Exact) => + if is_sub { + (Some st1, None) + } else { + let l1' = updates_head f c2 l1; + if (is_subtype f c2 l1) { + (Some (Subtypes l1'), Some (Subtypes (add_not_subtype f c1 l1 [c2]))) + } else { + (None, Some st1) + } + } + | (Subtypes l1, Subtypes l2) => + if (is_interface c2 || is_sub) { + if (is_subtype f c1 l2) { + let l2' = updates_head f c1 l2; + (Some (Subtypes (add_not_subtype f c1 l1 l2')), None) + } else { + (None, Some st1) + } + } else if ( + (is_interface c1 || f c2 c1) && is_subtype f c2 l1 + ) { + let l1' = updates_head f c2 l1; + ( + Some (Subtypes (add_not_subtype f c2 l1' l2)), + Some (Subtypes (add_not_subtype f c1 l1 [c2])) + ) + } else { + (None, Some st1) + } + }; + (normalize_subtypes pos_st c1 c2 flag1 flag2, normalize_subtypes neg_st c1 c2 flag1 flag2) + }; + let case_analysis_basic (c1, st) (c2, (_, flag2)) f => { + let (pos_st, neg_st) = + if (f c1 c2) { + (Some st, None) + } else if (f c2 c1) { + switch st { + | (Exact, _) => + if (Typename.equal c1 c2) { + (Some st, None) + } else { + (None, Some st) + } + | (Subtypes _, _) => + if (Typename.equal c1 c2) { + (Some st, None) + } else { + (Some st, Some st) + } + } + } else { + (None, Some st) + }; + (change_flag pos_st c1 c2 flag2, change_flag neg_st c1 c2 flag2) + }; + + /** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] + according to [st1] and [st2] + where f c1 c2 is true if c1 is a subtype of c2. + get_subtypes returning a pair: + - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] + - whether [st1] and [st2] admit [not(c1 <: c2)], + and in case return the updated subtype [st1] */ + let case_analysis (c1, st1) (c2, st2) f is_interface => { + let f = check_subtype f; + if Config.subtype_multirange { + get_subtypes (c1, st1) (c2, st2) f is_interface + } else { + case_analysis_basic (c1, st1) (c2, st2) f + } + }; +}; + + +/** module for signed and unsigned integers */ +let module Int: { + type t; + let add: t => t => t; + let compare: t => t => int; + let compare_value: t => t => int; + let div: t => t => t; + let eq: t => t => bool; + let of_int: int => t; + let of_int32: int32 => t; + let of_int64: int64 => t; + let of_int64_unsigned: int64 => bool => t; + let geq: t => t => bool; + let gt: t => t => bool; + let isminusone: t => bool; + let isone: t => bool; + let isnegative: t => bool; + let isnull: t => bool; + let iszero: t => bool; + let leq: t => t => bool; + let logand: t => t => t; + let lognot: t => t; + let logor: t => t => t; + let logxor: t => t => t; + let lt: t => t => bool; + let minus_one: t; + let mul: t => t => t; + let neg: t => t; + let neq: t => t => bool; + let null: t; + let one: t; + let pp: Format.formatter => t => unit; + let rem: t => t => t; + let sub: t => t => t; + let to_int: t => int; + let to_signed: t => option t; + let to_string: t => string; + let two: t; + let zero: t; +} = { + /* the first bool indicates whether this is an unsigned value, + and the second whether it is a pointer */ + type t = (bool, Int64.t, bool); + let area u i => + switch (i < 0L, u) { + | (true, false) => 1 /* only representable as signed */ + | (false, _) => 2 /* in the intersection between signed and unsigned */ + | (true, true) => 3 /* only representable as unsigned */ + }; + let to_signed (unsigned, i, ptr) => + if (area unsigned i == 3) { + None + } else { + /* not representable as signed */ + Some (false, i, ptr) + }; + let compare (unsigned1, i1, _) (unsigned2, i2, _) => { + let n = bool_compare unsigned1 unsigned2; + if (n != 0) { + n + } else { + Int64.compare i1 i2 + } + }; + let compare_value (unsigned1, i1, _) (unsigned2, i2, _) => { + let area1 = area unsigned1 i1; + let area2 = area unsigned2 i2; + let n = int_compare area1 area2; + if (n != 0) { + n + } else { + Int64.compare i1 i2 + } + }; + let eq i1 i2 => compare_value i1 i2 == 0; + let neq i1 i2 => compare_value i1 i2 != 0; + let leq i1 i2 => compare_value i1 i2 <= 0; + let lt i1 i2 => compare_value i1 i2 < 0; + let geq i1 i2 => compare_value i1 i2 >= 0; + let gt i1 i2 => compare_value i1 i2 > 0; + let of_int64 i => (false, i, false); + let of_int32 i => of_int64 (Int64.of_int32 i); + let of_int64_unsigned i unsigned => (unsigned, i, false); + let of_int i => of_int64 (Int64.of_int i); + let to_int (_, i, _) => Int64.to_int i; + let null = (false, 0L, true); + let zero = of_int 0; + let one = of_int 1; + let two = of_int 2; + let minus_one = of_int (-1); + let isone (_, i, _) => i == 1L; + let iszero (_, i, _) => i == 0L; + let isnull (_, i, ptr) => i == 0L && ptr; + let isminusone (unsigned, i, _) => not unsigned && i == (-1L); + let isnegative (unsigned, i, _) => not unsigned && i < 0L; + let neg (unsigned, i, ptr) => (unsigned, Int64.neg i, ptr); + let lift binop (unsigned1, i1, ptr1) (unsigned2, i2, ptr2) => ( + unsigned1 || unsigned2, + binop i1 i2, + ptr1 || ptr2 + ); + let lift1 unop (unsigned, i, ptr) => (unsigned, unop i, ptr); + let add i1 i2 => lift Int64.add i1 i2; + let mul i1 i2 => lift Int64.mul i1 i2; + let div i1 i2 => lift Int64.div i1 i2; + let rem i1 i2 => lift Int64.rem i1 i2; + let logand i1 i2 => lift Int64.logand i1 i2; + let logor i1 i2 => lift Int64.logor i1 i2; + let logxor i1 i2 => lift Int64.logxor i1 i2; + let lognot i => lift1 Int64.lognot i; + let sub i1 i2 => add i1 (neg i2); + let pp f (unsigned, n, ptr) => + if (ptr && n == 0L) { + F.fprintf f "null" + } else if unsigned { + F.fprintf f "%Lu" n + } else { + F.fprintf f "%Ld" n + }; + let to_string i => pp_to_string pp i; +}; + + +/** Flags for a procedure call */ +type call_flags = { + cf_virtual: bool, + cf_interface: bool, + cf_noreturn: bool, + cf_is_objc_block: bool, + cf_targets: list Procname.t +}; + +let cf_default = { + cf_virtual: false, + cf_interface: false, + cf_noreturn: false, + cf_is_objc_block: false, + cf_targets: [] +}; + + +/** expression representing the result of decompilation */ +type dexp = + | Darray of dexp dexp + | Dbinop of binop dexp dexp + | Dconst of const + | Dsizeof of typ Subtype.t + | Dderef of dexp + | Dfcall of dexp (list dexp) Location.t call_flags + | Darrow of dexp Ident.fieldname + | Ddot of dexp Ident.fieldname + | Dpvar of Pvar.t + | Dpvaraddr of Pvar.t + | Dunop of unop dexp + | Dunknown + | Dretcall of dexp (list dexp) Location.t call_flags +/** Value paths: identify an occurrence of a value in a symbolic heap + each expression represents a path, with Dpvar being the simplest one */ +and vpath = option dexp +/** acquire/release action on a resource */ +and res_action = { + ra_kind: res_act_kind, /** kind of action */ + ra_res: resource, /** kind of resource */ + ra_pname: Procname.t, /** name of the procedure used to acquire/release the resource */ + ra_loc: Location.t, /** location of the acquire/release */ + ra_vpath: vpath /** vpath of the resource value */ +} +and taint_kind = + | Tk_unverified_SSL_socket + | Tk_shared_preferences_data + | Tk_privacy_annotation + | Tk_integrity_annotation + | Tk_unknown +and taint_info = {taint_source: Procname.t, taint_kind: taint_kind} +/** Attributes */ +and attribute = + | Aresource of res_action /** resource acquire/release */ + | Aautorelease + | Adangling of dangling_kind /** dangling pointer */ + /** undefined value obtained by calling the given procedure, plus its return value annots */ + | Aundef of Procname.t item_annotation Location.t path_pos + | Ataint of taint_info + | Auntaint + | Alocked + | Aunlocked + /** value appeared in second argument of division at given path position */ + | Adiv0 of path_pos + /** the exp. is null because of a call to a method with exp as a null receiver */ + | Aobjc_null of exp + /** value was returned from a call to the given procedure, plus the annots of the return value */ + | Aretval of Procname.t item_annotation + /** denotes an object registered as an observers to a notification center */ + | Aobserver + /** denotes an object unsubscribed from observers of a notification center */ + | Aunsubscribed_observer +/** Categories of attributes */ +and attribute_category = + | ACresource + | ACautorelease + | ACtaint + | AClock + | ACdiv0 + | ACobjc_null + | ACundef + | ACretval + | ACobserver +and closure = {name: Procname.t, captured_vars: list (exp, Pvar.t, typ)} +/** Constants */ +and const = + | Cint of Int.t /** integer constants */ + | Cfun of Procname.t /** function names */ + | Cstr of string /** string constants */ + | Cfloat of float /** float constants */ + | Cattribute of attribute /** attribute used in disequalities to annotate a value */ + | Cexn of exp /** exception */ + | Cclass of Ident.name /** class constant */ + | Cptr_to_fld of Ident.fieldname typ /** pointer to field constant, + and type of the surrounding Csu.t type */ + | Cclosure of closure /** anonymous function */ +and struct_fields = list (Ident.fieldname, typ, item_annotation) +/** Type for a structured value. */ +and struct_typ = { + instance_fields: struct_fields, /** non-static fields */ + static_fields: struct_fields, /** static fields */ + csu: Csu.t, /** class/struct/union */ + struct_name: option Mangled.t, /** name */ + superclasses: list Typename.t, /** list of superclasses */ + def_methods: list Procname.t, /** methods defined */ + struct_annotations: item_annotation /** annotations */ +} +/** types for sil (structured) expressions */ +and typ = + | Tvar of Typename.t /** named type */ + | Tint of ikind /** integer type */ + | Tfloat of fkind /** float type */ + | Tvoid /** void type */ + | Tfun of bool /** function type with noreturn attribute */ + | Tptr of typ ptr_kind /** pointer type */ + | Tstruct of struct_typ /** Type for a structured value */ + | Tarray of typ exp /** array type with fixed size */ +/** Program expressions. */ +and exp = + /** Pure variable: it is not an lvalue */ + | Var of Ident.t + /** Unary operator with type of the result if known */ + | UnOp of unop exp (option typ) + /** Binary operator */ + | BinOp of binop exp exp + /** Constants */ + | Const of const + /** Type cast */ + | Cast of typ exp + /** The address of a program variable */ + | Lvar of Pvar.t + /** A field offset, the type is the surrounding struct type */ + | Lfield of exp Ident.fieldname typ + /** An array index offset: [exp1\[exp2\]] */ + | Lindex of exp exp + /** A sizeof expression */ + | Sizeof of typ Subtype.t; + + +/** Kind of prune instruction */ +type if_kind = + | Ik_bexp /* boolean expressions, and exp ? exp : exp */ + | Ik_dowhile + | Ik_for + | Ik_if + | Ik_land_lor /* obtained from translation of && or || */ + | Ik_while + | Ik_switch; + + +/** Stack operation for symbolic execution on propsets */ +type stackop = + | Push /* copy the curreny propset to the stack */ + | Swap /* swap the current propset and the top of the stack */ + | Pop /* pop the stack and combine with the current propset */; + + +/** An instruction. */ +type instr = + /** declaration [let x = *lexp:typ] where [typ] is the root type of [lexp] */ + | Letderef of Ident.t exp typ Location.t + /** assignment [*lexp1:typ = exp2] where [typ] is the root type of [lexp1] */ + | Set of exp typ exp Location.t + /** prune the state based on [exp=1], the boolean indicates whether true branch */ + | Prune of exp Location.t bool if_kind + /** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions + [ret_id1..ret_idn = e_fun(arg_ts);] + where n = 0 for void return and n > 1 for struct return */ + | Call of (list Ident.t) exp (list (exp, typ)) Location.t call_flags + /** nullify stack variable */ + | Nullify of Pvar.t Location.t + | Abstract of Location.t /** apply abstraction */ + | Remove_temps of (list Ident.t) Location.t /** remove temporaries */ + | Stackop of stackop Location.t /** operation on the stack of propsets */ + | Declare_locals of (list (Pvar.t, typ)) Location.t /** declare local variables */; + + +/** Check if an instruction is auxiliary, or if it comes from source instructions. */ +let instr_is_auxiliary = + fun + | Letderef _ + | Set _ + | Prune _ + | Call _ => false + | Nullify _ + | Abstract _ + | Remove_temps _ + | Stackop _ + | Declare_locals _ => true; + + +/** offset for an lvalue */ +type offset = | Off_fld of Ident.fieldname typ | Off_index of exp; + + +/** {2 Components of Propositions} */ +/** an atom is a pure atomic formula */ +type atom = + | Aeq of exp exp /** equality */ + | Aneq of exp exp /** disequality*/; + + +/** kind of lseg or dllseg predicates */ +type lseg_kind = + | Lseg_NE /** nonempty (possibly circular) listseg */ + | Lseg_PE /** possibly empty (possibly circular) listseg */; + + +/** The boolean is true when the pointer was dereferenced without testing for zero. */ +type zero_flag = option bool; + + +/** True when the value was obtained by doing case analysis on null in a procedure call. */ +type null_case_flag = bool; + + +/** instrumentation of heap values */ +type inst = + | Iabstraction + | Iactual_precondition + | Ialloc + | Iformal of zero_flag null_case_flag + | Iinitial + | Ilookup + | Inone + | Inullify + | Irearrange of zero_flag null_case_flag int path_pos + | Itaint + | Iupdate of zero_flag null_case_flag int path_pos + | Ireturn_from_call of int + | Ireturn_from_pointer_wrapper_call of int; + + +/** structured expressions represent a value of structured type, such as an array or a struct. */ +type strexp = + | Eexp of exp inst /** Base case: expression with instrumentation */ + | Estruct of (list (Ident.fieldname, strexp)) inst /** C structure */ + | Earray of exp (list (exp, strexp)) inst /** Array of given size. */ +/** There are two conditions imposed / used in the array case. + First, if some index and value pair appears inside an array + in a strexp, then the index is less than the size of the array. + For instance, x |->[10 | e1: v1] implies that e1 <= 9. + Second, if two indices appear in an array, they should be different. + For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. */ +/** an atomic heap predicate */ +and hpred = + | Hpointsto of exp strexp exp + /** represents [exp|->strexp:typexp] where [typexp] + is an expression representing a type, e.h. [sizeof(t)]. */ + | Hlseg of lseg_kind hpara exp exp (list exp) + /** higher - order predicate for singly - linked lists. + Should ensure that exp1!= exp2 implies that exp1 is allocated. + This assumption is used in the rearrangement. The last [exp list] parameter + is used to denote the shared links by all the nodes in the list. */ + | Hdllseg of lseg_kind hpara_dll exp exp exp exp (list exp) +/** higher-order predicate for doubly-linked lists. */ +/** parameter for the higher-order singly-linked list predicate. + Means "lambda (root,next,svars). Exists evars. body". + Assume that root, next, svars, evars are disjoint sets of + primed identifiers, and include all the free primed identifiers in body. + body should not contain any non - primed identifiers or program + variables (i.e. pvars). */ +and hpara = { + root: Ident.t, + next: Ident.t, + svars: list Ident.t, + evars: list Ident.t, + body: list hpred +} +/** parameter for the higher-order doubly-linked list predicates. + Assume that all the free identifiers in body_dll should belong to + cell, blink, flink, svars_dll, evars_dll. */ +and hpara_dll = { + cell: Ident.t, /** address cell */ + blink: Ident.t, /** backward link */ + flink: Ident.t, /** forward link */ + svars_dll: list Ident.t, + evars_dll: list Ident.t, + body_dll: list hpred +}; + + +/** Return the lhs expression of a hpred */ +let hpred_get_lhs h => + switch h { + | Hpointsto e _ _ + | Hlseg _ _ e _ _ + | Hdllseg _ _ e _ _ _ _ => e + }; + +let objc_ref_counter_annot = [({class_name: "ref_counter", parameters: []}, false)]; + + +/** Field used for objective-c reference counting */ +let objc_ref_counter_field = (Ident.fieldname_hidden, Tint IInt, objc_ref_counter_annot); + + +/** {2 Comparision and Inspection Functions} */ +let is_objc_ref_counter_field (fld, _, a) => + Ident.fieldname_is_hidden fld && item_annotation_compare a objc_ref_counter_annot == 0; + +let has_objc_ref_counter hpred => + switch hpred { + | Hpointsto _ _ (Sizeof (Tstruct struct_typ) _) => + IList.exists is_objc_ref_counter_field struct_typ.instance_fields + | _ => false + }; + +let objc_class_str = "ObjC-Class"; + +let cpp_class_str = "Cpp-Class"; + +let class_annotation class_string => [({class_name: class_string, parameters: []}, true)]; + +let objc_class_annotation = class_annotation objc_class_str; + +let cpp_class_annotation = class_annotation cpp_class_str; + +let is_class_of_kind typ ck => + switch typ { + | Tstruct {csu: Csu.Class ck'} => ck == ck' + | _ => false + }; + +let is_objc_class typ => is_class_of_kind typ Csu.Objc; + +let is_cpp_class typ => is_class_of_kind typ Csu.CPP; + +let is_java_class typ => is_class_of_kind typ Csu.Java; + +let rec is_array_of_cpp_class typ => + switch typ { + | Tarray typ _ => is_array_of_cpp_class typ + | _ => is_cpp_class typ + }; + +let is_pointer_to_cpp_class typ => + switch typ { + | Tptr t _ => is_cpp_class t + | _ => false + }; + + +/** turn a *T into a T. fails if [typ] is not a pointer type */ +let typ_strip_ptr = + fun + | Tptr t _ => t + | _ => assert false; + +let zero_value_of_numerical_type typ => + switch typ { + | Tint _ => Const (Cint Int.zero) + | Tfloat _ => Const (Cfloat 0.0) + | Tptr _ => Const (Cint Int.null) + | _ => assert false + }; + + +/** Make a static local name in objc */ +let mk_static_local_name pname vname => pname ^ "_" ^ vname; + + +/** Check if a pvar is a local static in objc */ +let is_static_local_name pname pvar => + /* local static name is of the form procname_varname */ + { + let var_name = Mangled.to_string (Pvar.get_name pvar); + switch (Str.split_delim (Str.regexp_string pname) var_name) { + | [_, _] => true + | _ => false + } + }; + +let fld_compare (fld1: Ident.fieldname) fld2 => Ident.fieldname_compare fld1 fld2; + +let fld_equal fld1 fld2 => fld_compare fld1 fld2 == 0; + +let exp_is_zero = + fun + | Const (Cint n) => Int.iszero n + | _ => false; + +let exp_is_null_literal = + fun + | Const (Cint n) => Int.isnull n + | _ => false; + +let exp_is_this = + fun + | Lvar pvar => Pvar.is_this pvar + | _ => false; + +let ikind_is_char = + fun + | IChar + | ISChar + | IUChar => true + | _ => false; + +let ikind_is_unsigned = + fun + | IUChar + | IUInt + | IUShort + | IULong + | IULongLong => true + | _ => false; + +let int_of_int64_kind i ik => Int.of_int64_unsigned i (ikind_is_unsigned ik); + +let unop_compare o1 o2 => + switch (o1, o2) { + | (Neg, Neg) => 0 + | (Neg, _) => (-1) + | (_, Neg) => 1 + | (BNot, BNot) => 0 + | (BNot, _) => (-1) + | (_, BNot) => 1 + | (LNot, LNot) => 0 + }; + +let unop_equal o1 o2 => unop_compare o1 o2 == 0; + +let binop_compare o1 o2 => + switch (o1, o2) { + | (PlusA, PlusA) => 0 + | (PlusA, _) => (-1) + | (_, PlusA) => 1 + | (PlusPI, PlusPI) => 0 + | (PlusPI, _) => (-1) + | (_, PlusPI) => 1 + | (MinusA, MinusA) => 0 + | (MinusA, _) => (-1) + | (_, MinusA) => 1 + | (MinusPI, MinusPI) => 0 + | (MinusPI, _) => (-1) + | (_, MinusPI) => 1 + | (MinusPP, MinusPP) => 0 + | (MinusPP, _) => (-1) + | (_, MinusPP) => 1 + | (Mult, Mult) => 0 + | (Mult, _) => (-1) + | (_, Mult) => 1 + | (Div, Div) => 0 + | (Div, _) => (-1) + | (_, Div) => 1 + | (Mod, Mod) => 0 + | (Mod, _) => (-1) + | (_, Mod) => 1 + | (Shiftlt, Shiftlt) => 0 + | (Shiftlt, _) => (-1) + | (_, Shiftlt) => 1 + | (Shiftrt, Shiftrt) => 0 + | (Shiftrt, _) => (-1) + | (_, Shiftrt) => 1 + | (Lt, Lt) => 0 + | (Lt, _) => (-1) + | (_, Lt) => 1 + | (Gt, Gt) => 0 + | (Gt, _) => (-1) + | (_, Gt) => 1 + | (Le, Le) => 0 + | (Le, _) => (-1) + | (_, Le) => 1 + | (Ge, Ge) => 0 + | (Ge, _) => (-1) + | (_, Ge) => 1 + | (Eq, Eq) => 0 + | (Eq, _) => (-1) + | (_, Eq) => 1 + | (Ne, Ne) => 0 + | (Ne, _) => (-1) + | (_, Ne) => 1 + | (BAnd, BAnd) => 0 + | (BAnd, _) => (-1) + | (_, BAnd) => 1 + | (BXor, BXor) => 0 + | (BXor, _) => (-1) + | (_, BXor) => 1 + | (BOr, BOr) => 0 + | (BOr, _) => (-1) + | (_, BOr) => 1 + | (LAnd, LAnd) => 0 + | (LAnd, _) => (-1) + | (_, LAnd) => 1 + | (LOr, LOr) => 0 + | (LOr, _) => (-1) + | (_, LOr) => 1 + | (PtrFld, PtrFld) => 0 + }; + +let binop_equal o1 o2 => binop_compare o1 o2 == 0; + + +/** This function returns true if the operation is injective + wrt. each argument: op(e,-) and op(-, e) is injective for all e. + The return value false means "don't know". */ +let binop_injective = + fun + | PlusA + | PlusPI + | MinusA + | MinusPI + | MinusPP => true + | _ => false; + + +/** This function returns true if the operation can be inverted. */ +let binop_invertible = + fun + | PlusA + | PlusPI + | MinusA + | MinusPI => true + | _ => false; + + +/** This function inverts an injective binary operator + with respect to the first argument. It returns an expression [e'] such that + BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, + the function raises an exception by calling "assert false". */ +let binop_invert bop e1 e2 => { + let inverted_bop = + switch bop { + | PlusA => MinusA + | PlusPI => MinusPI + | MinusA => PlusA + | MinusPI => PlusPI + | _ => assert false + }; + BinOp inverted_bop e2 e1 +}; + + +/** This function returns true if 0 is the right unit of [binop]. + The return value false means "don't know". */ +let binop_is_zero_runit = + fun + | PlusA + | PlusPI + | MinusA + | MinusPI + | MinusPP => true + | _ => false; + +let path_pos_compare (pn1, nid1) (pn2, nid2) => { + let n = Procname.compare pn1 pn2; + if (n != 0) { + n + } else { + int_compare nid1 nid2 + } +}; + +let path_pos_equal pp1 pp2 => path_pos_compare pp1 pp2 == 0; + +let mem_kind_to_num = + fun + | Mmalloc => 0 + | Mnew => 1 + | Mnew_array => 2 + | Mobjc => 3; + + +/** name of the allocation function for the given memory kind */ +let mem_alloc_pname = + fun + | Mmalloc => Procname.from_string_c_fun "malloc" + | Mnew => Procname.from_string_c_fun "new" + | Mnew_array => Procname.from_string_c_fun "new[]" + | Mobjc => Procname.from_string_c_fun "alloc"; + + +/** name of the deallocation function for the given memory kind */ +let mem_dealloc_pname = + fun + | Mmalloc => Procname.from_string_c_fun "free" + | Mnew => Procname.from_string_c_fun "delete" + | Mnew_array => Procname.from_string_c_fun "delete[]" + | Mobjc => Procname.from_string_c_fun "dealloc"; + +let mem_kind_compare mk1 mk2 => int_compare (mem_kind_to_num mk1) (mem_kind_to_num mk2); + +let resource_compare r1 r2 => { + let res_to_num = + fun + | Rmemory mk => mem_kind_to_num mk + | Rfile => 100 + | Rignore => 200 + | Rlock => 300; + int_compare (res_to_num r1) (res_to_num r2) +}; + +let res_act_kind_compare rak1 rak2 => + switch (rak1, rak2) { + | (Racquire, Racquire) => 0 + | (Racquire, Rrelease) => (-1) + | (Rrelease, Racquire) => 1 + | (Rrelease, Rrelease) => 0 + }; + +let dangling_kind_compare dk1 dk2 => + switch (dk1, dk2) { + | (DAuninit, DAuninit) => 0 + | (DAuninit, _) => (-1) + | (_, DAuninit) => 1 + | (DAaddr_stack_var, DAaddr_stack_var) => 0 + | (DAaddr_stack_var, _) => (-1) + | (_, DAaddr_stack_var) => 1 + | (DAminusone, DAminusone) => 0 + }; + +let taint_kind_compare tk1 tk2 => + switch (tk1, tk2) { + | (Tk_unverified_SSL_socket, Tk_unverified_SSL_socket) => 0 + | (Tk_unverified_SSL_socket, _) => (-1) + | (_, Tk_unverified_SSL_socket) => 1 + | (Tk_shared_preferences_data, Tk_shared_preferences_data) => 0 + | (Tk_shared_preferences_data, _) => 1 + | (_, Tk_shared_preferences_data) => (-1) + | (Tk_privacy_annotation, Tk_privacy_annotation) => 0 + | (Tk_privacy_annotation, _) => 1 + | (_, Tk_privacy_annotation) => (-1) + | (Tk_integrity_annotation, Tk_integrity_annotation) => 0 + | (Tk_integrity_annotation, _) => 1 + | (_, Tk_integrity_annotation) => (-1) + | (Tk_unknown, Tk_unknown) => 0 + }; + +let taint_info_compare {taint_source: ts1, taint_kind: tk1} {taint_source: ts2, taint_kind: tk2} => + taint_kind_compare tk1 tk2 |> next Procname.compare ts1 ts2; + +let attribute_category_compare (ac1: attribute_category) (ac2: attribute_category) :int => + Pervasives.compare ac1 ac2; + +let attribute_category_equal att1 att2 => attribute_category_compare att1 att2 == 0; + +let attribute_to_category att => + switch att { + | Aresource _ + | Adangling _ => ACresource + | Ataint _ + | Auntaint => ACtaint + | Alocked + | Aunlocked => AClock + | Aautorelease => ACautorelease + | Adiv0 _ => ACdiv0 + | Aobjc_null _ => ACobjc_null + | Aretval _ => ACretval + | Aundef _ => ACundef + | Aobserver + | Aunsubscribed_observer => ACobserver + }; + +let attr_is_undef = + fun + | Aundef _ => true + | _ => false; + +let cname_opt_compare nameo1 nameo2 => + switch (nameo1, nameo2) { + | (None, None) => 0 + | (None, _) => (-1) + | (_, None) => 1 + | (Some n1, Some n2) => Mangled.compare n1 n2 + }; + + +/** comparison for ikind */ +let ikind_compare k1 k2 => + switch (k1, k2) { + | (IChar, IChar) => 0 + | (IChar, _) => (-1) + | (_, IChar) => 1 + | (ISChar, ISChar) => 0 + | (ISChar, _) => (-1) + | (_, ISChar) => 1 + | (IUChar, IUChar) => 0 + | (IUChar, _) => (-1) + | (_, IUChar) => 1 + | (IBool, IBool) => 0 + | (IBool, _) => (-1) + | (_, IBool) => 1 + | (IInt, IInt) => 0 + | (IInt, _) => (-1) + | (_, IInt) => 1 + | (IUInt, IUInt) => 0 + | (IUInt, _) => (-1) + | (_, IUInt) => 1 + | (IShort, IShort) => 0 + | (IShort, _) => (-1) + | (_, IShort) => 1 + | (IUShort, IUShort) => 0 + | (IUShort, _) => (-1) + | (_, IUShort) => 1 + | (ILong, ILong) => 0 + | (ILong, _) => (-1) + | (_, ILong) => 1 + | (IULong, IULong) => 0 + | (IULong, _) => (-1) + | (_, IULong) => 1 + | (ILongLong, ILongLong) => 0 + | (ILongLong, _) => (-1) + | (_, ILongLong) => 1 + | (IULongLong, IULongLong) => 0 + | (IULongLong, _) => (-1) + | (_, IULongLong) => 1 + | (I128, I128) => 0 + | (I128, _) => (-1) + | (_, I128) => 1 + | (IU128, IU128) => 0 + }; + + +/** comparison for fkind */ +let fkind_compare k1 k2 => + switch (k1, k2) { + | (FFloat, FFloat) => 0 + | (FFloat, _) => (-1) + | (_, FFloat) => 1 + | (FDouble, FDouble) => 0 + | (FDouble, _) => (-1) + | (_, FDouble) => 1 + | (FLongDouble, FLongDouble) => 0 + }; + +let ptr_kind_compare pk1 pk2 => + switch (pk1, pk2) { + | (Pk_pointer, Pk_pointer) => 0 + | (Pk_pointer, _) => (-1) + | (_, Pk_pointer) => 1 + | (Pk_reference, Pk_reference) => 0 + | (_, Pk_reference) => (-1) + | (Pk_reference, _) => 1 + | (Pk_objc_weak, Pk_objc_weak) => 0 + | (Pk_objc_weak, _) => (-1) + | (_, Pk_objc_weak) => 1 + | (Pk_objc_unsafe_unretained, Pk_objc_unsafe_unretained) => 0 + | (Pk_objc_unsafe_unretained, _) => (-1) + | (_, Pk_objc_unsafe_unretained) => 1 + | (Pk_objc_autoreleasing, Pk_objc_autoreleasing) => 0 + }; + +let const_kind_equal c1 c2 => { + let const_kind_number = + fun + | Cint _ => 1 + | Cfun _ => 2 + | Cstr _ => 3 + | Cfloat _ => 4 + | Cattribute _ => 5 + | Cexn _ => 6 + | Cclass _ => 7 + | Cptr_to_fld _ => 8 + | Cclosure _ => 9; + const_kind_number c1 == const_kind_number c2 +}; + +let rec const_compare (c1: const) (c2: const) :int => + switch (c1, c2) { + | (Cint i1, Cint i2) => Int.compare i1 i2 + | (Cint _, _) => (-1) + | (_, Cint _) => 1 + | (Cfun fn1, Cfun fn2) => Procname.compare fn1 fn2 + | (Cfun _, _) => (-1) + | (_, Cfun _) => 1 + | (Cstr s1, Cstr s2) => string_compare s1 s2 + | (Cstr _, _) => (-1) + | (_, Cstr _) => 1 + | (Cfloat f1, Cfloat f2) => float_compare f1 f2 + | (Cfloat _, _) => (-1) + | (_, Cfloat _) => 1 + | (Cattribute att1, Cattribute att2) => attribute_compare att1 att2 + | (Cattribute _, _) => (-1) + | (_, Cattribute _) => 1 + | (Cexn e1, Cexn e2) => exp_compare e1 e2 + | (Cexn _, _) => (-1) + | (_, Cexn _) => 1 + | (Cclass c1, Cclass c2) => Ident.name_compare c1 c2 + | (Cclass _, _) => (-1) + | (_, Cclass _) => 1 + | (Cptr_to_fld fn1 t1, Cptr_to_fld fn2 t2) => + let n = fld_compare fn1 fn2; + if (n != 0) { + n + } else { + typ_compare t1 t2 + } + | (Cptr_to_fld _, _) => (-1) + | (_, Cptr_to_fld _) => 1 + | (Cclosure {name: n1, captured_vars: c1}, Cclosure {name: n2, captured_vars: c2}) => + let captured_var_compare acc (e1, pvar1, typ1) (e2, pvar2, typ2) => + if (acc != 0) { + acc + } else { + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + let n = Pvar.compare pvar1 pvar2; + if (n != 0) { + n + } else { + typ_compare typ1 typ2 + } + } + }; + let n = Procname.compare n1 n2; + if (n != 0) { + n + } else { + IList.fold_left2 captured_var_compare 0 c1 c2 + } + } +and struct_typ_compare struct_typ1 struct_typ2 => + if (struct_typ1.csu == Csu.Class Csu.Java && struct_typ2.csu == Csu.Class Csu.Java) { + cname_opt_compare struct_typ1.struct_name struct_typ2.struct_name + } else { + let n = fld_typ_ann_list_compare struct_typ1.instance_fields struct_typ2.instance_fields; + if (n != 0) { + n + } else { + let n = fld_typ_ann_list_compare struct_typ1.static_fields struct_typ2.static_fields; + if (n != 0) { + n + } else { + let n = Csu.compare struct_typ1.csu struct_typ2.csu; + if (n != 0) { + n + } else { + cname_opt_compare struct_typ1.struct_name struct_typ2.struct_name + } + } + } + } +and struct_typ_equal struct_typ1 struct_typ2 => struct_typ_compare struct_typ1 struct_typ2 == 0 +/** Comparision for types. */ +and typ_compare t1 t2 => + if (t1 === t2) { + 0 + } else { + switch (t1, t2) { + | (Tvar tn1, Tvar tn2) => Typename.compare tn1 tn2 + | (Tvar _, _) => (-1) + | (_, Tvar _) => 1 + | (Tint ik1, Tint ik2) => ikind_compare ik1 ik2 + | (Tint _, _) => (-1) + | (_, Tint _) => 1 + | (Tfloat fk1, Tfloat fk2) => fkind_compare fk1 fk2 + | (Tfloat _, _) => (-1) + | (_, Tfloat _) => 1 + | (Tvoid, Tvoid) => 0 + | (Tvoid, _) => (-1) + | (_, Tvoid) => 1 + | (Tfun noreturn1, Tfun noreturn2) => bool_compare noreturn1 noreturn2 + | (Tfun _, _) => (-1) + | (_, Tfun _) => 1 + | (Tptr t1' pk1, Tptr t2' pk2) => + let n = typ_compare t1' t2'; + if (n != 0) { + n + } else { + ptr_kind_compare pk1 pk2 + } + | (Tptr _, _) => (-1) + | (_, Tptr _) => 1 + | (Tstruct struct_typ1, Tstruct struct_typ2) => struct_typ_compare struct_typ1 struct_typ2 + | (Tstruct _, _) => (-1) + | (_, Tstruct _) => 1 + | (Tarray t1 _, Tarray t2 _) => typ_compare t1 t2 + } + } +and typ_opt_compare to1 to2 => + switch (to1, to2) { + | (None, None) => 0 + | (None, Some _) => (-1) + | (Some _, None) => 1 + | (Some t1, Some t2) => typ_compare t1 t2 + } +and fld_typ_ann_compare fta1 fta2 => + triple_compare fld_compare typ_compare item_annotation_compare fta1 fta2 +and fld_typ_ann_list_compare ftal1 ftal2 => IList.compare fld_typ_ann_compare ftal1 ftal2 +and attribute_compare (att1: attribute) (att2: attribute) :int => + switch (att1, att2) { + | (Aresource ra1, Aresource ra2) => + let n = res_act_kind_compare ra1.ra_kind ra2.ra_kind; + if (n != 0) { + n + } else { + /* ignore other values beside resources: arbitrary merging into one */ + resource_compare ra1.ra_res ra2.ra_res + } + | (Aresource _, _) => (-1) + | (_, Aresource _) => 1 + | (Aautorelease, Aautorelease) => 0 + | (Aautorelease, _) => (-1) + | (_, Aautorelease) => 1 + | (Adangling dk1, Adangling dk2) => dangling_kind_compare dk1 dk2 + | (Adangling _, _) => (-1) + | (_, Adangling _) => 1 + | (Aundef pn1 _ _ _, Aundef pn2 _ _ _) => Procname.compare pn1 pn2 + | (Ataint ti1, Ataint ti2) => taint_info_compare ti1 ti2 + | (Ataint _, _) => (-1) + | (_, Ataint _) => 1 + | (Auntaint, Auntaint) => 0 + | (Auntaint, _) => (-1) + | (_, Auntaint) => 1 + | (Alocked, Alocked) => 0 + | (Alocked, _) => (-1) + | (_, Alocked) => 1 + | (Aunlocked, Aunlocked) => 0 + | (Aunlocked, _) => (-1) + | (_, Aunlocked) => 1 + | (Adiv0 pp1, Adiv0 pp2) => path_pos_compare pp1 pp2 + | (Adiv0 _, _) => (-1) + | (_, Adiv0 _) => 1 + | (Aobjc_null exp1, Aobjc_null exp2) => exp_compare exp1 exp2 + | (Aobjc_null _, _) => (-1) + | (_, Aobjc_null _) => 1 + | (Aretval pn1 annots1, Aretval pn2 annots2) => + let n = Procname.compare pn1 pn2; + if (n != 0) { + n + } else { + item_annotation_compare annots1 annots2 + } + | (Aretval _, _) => (-1) + | (_, Aretval _) => 1 + | (Aobserver, Aobserver) => 0 + | (Aobserver, _) => (-1) + | (_, Aobserver) => 1 + | (Aunsubscribed_observer, Aunsubscribed_observer) => 0 + | (Aunsubscribed_observer, _) => (-1) + | (_, Aunsubscribed_observer) => 1 + } +/** Compare epressions. Variables come before other expressions. */ +and exp_compare (e1: exp) (e2: exp) :int => + switch (e1, e2) { + | (Var id1, Var id2) => Ident.compare id2 id1 + | (Var _, _) => (-1) + | (_, Var _) => 1 + | (UnOp o1 e1 to1, UnOp o2 e2 to2) => + let n = unop_compare o1 o2; + if (n != 0) { + n + } else { + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + typ_opt_compare to1 to2 + } + } + | (UnOp _, _) => (-1) + | (_, UnOp _) => 1 + | (BinOp o1 e1 f1, BinOp o2 e2 f2) => + let n = binop_compare o1 o2; + if (n != 0) { + n + } else { + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + exp_compare f1 f2 + } + } + | (BinOp _, _) => (-1) + | (_, BinOp _) => 1 + | (Const c1, Const c2) => const_compare c1 c2 + | (Const _, _) => (-1) + | (_, Const _) => 1 + | (Cast t1 e1, Cast t2 e2) => + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + typ_compare t1 t2 + } + | (Cast _, _) => (-1) + | (_, Cast _) => 1 + | (Lvar i1, Lvar i2) => Pvar.compare i1 i2 + | (Lvar _, _) => (-1) + | (_, Lvar _) => 1 + | (Lfield e1 f1 t1, Lfield e2 f2 t2) => + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + let n = fld_compare f1 f2; + if (n != 0) { + n + } else { + typ_compare t1 t2 + } + } + | (Lfield _, _) => (-1) + | (_, Lfield _) => 1 + | (Lindex e1 f1, Lindex e2 f2) => + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + exp_compare f1 f2 + } + | (Lindex _, _) => (-1) + | (_, Lindex _) => 1 + | (Sizeof t1 s1, Sizeof t2 s2) => + let n = typ_compare t1 t2; + if (n != 0) { + n + } else { + Subtype.compare s1 s2 + } + }; + +let const_equal c1 c2 => const_compare c1 c2 == 0; + +let typ_equal t1 t2 => typ_compare t1 t2 == 0; + +let exp_equal e1 e2 => exp_compare e1 e2 == 0; + +let rec exp_is_array_index_of exp1 exp2 => + switch exp1 { + | Lindex exp _ => exp_is_array_index_of exp exp2 + | _ => exp_equal exp1 exp2 + }; + +let ident_exp_compare = pair_compare Ident.compare exp_compare; + +let ident_exp_equal ide1 ide2 => ident_exp_compare ide1 ide2 == 0; + +let exp_list_compare = IList.compare exp_compare; + +let exp_list_equal el1 el2 => exp_list_compare el1 el2 == 0; + +let attribute_equal att1 att2 => attribute_compare att1 att2 == 0; + + +/** Compare atoms. Equalities come before disequalities */ +let atom_compare a b => + if (a === b) { + 0 + } else { + switch (a, b) { + | (Aeq e1 e2, Aeq f1 f2) => + let n = exp_compare e1 f1; + if (n != 0) { + n + } else { + exp_compare e2 f2 + } + | (Aeq _, Aneq _) => (-1) + | (Aneq _, Aeq _) => 1 + | (Aneq e1 e2, Aneq f1 f2) => + let n = exp_compare e1 f1; + if (n != 0) { + n + } else { + exp_compare e2 f2 + } + } + }; + +let atom_equal x y => atom_compare x y == 0; + +let lseg_kind_compare k1 k2 => + switch (k1, k2) { + | (Lseg_NE, Lseg_NE) => 0 + | (Lseg_NE, Lseg_PE) => (-1) + | (Lseg_PE, Lseg_NE) => 1 + | (Lseg_PE, Lseg_PE) => 0 + }; + +let lseg_kind_equal k1 k2 => lseg_kind_compare k1 k2 == 0; + +/* Comparison for strexps */ +let rec strexp_compare se1 se2 => + if (se1 === se2) { + 0 + } else { + switch (se1, se2) { + | (Eexp e1 _, Eexp e2 _) => exp_compare e1 e2 + | (Eexp _, _) => (-1) + | (_, Eexp _) => 1 + | (Estruct fel1 _, Estruct fel2 _) => fld_strexp_list_compare fel1 fel2 + | (Estruct _, _) => (-1) + | (_, Estruct _) => 1 + | (Earray e1 esel1 _, Earray e2 esel2 _) => + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + exp_strexp_list_compare esel1 esel2 + } + } + } +and fld_strexp_compare fse1 fse2 => pair_compare fld_compare strexp_compare fse1 fse2 +and fld_strexp_list_compare fsel1 fsel2 => IList.compare fld_strexp_compare fsel1 fsel2 +and exp_strexp_compare ese1 ese2 => pair_compare exp_compare strexp_compare ese1 ese2 +and exp_strexp_list_compare esel1 esel2 => IList.compare exp_strexp_compare esel1 esel2 +/** Comparsion between heap predicates. Hpointsto comes before others. */ +and hpred_compare hpred1 hpred2 => + if (hpred1 === hpred2) { + 0 + } else { + switch (hpred1, hpred2) { + | (Hpointsto e1 _ _, Hlseg _ _ e2 _ _) when exp_compare e2 e1 != 0 => exp_compare e2 e1 + | (Hpointsto e1 _ _, Hdllseg _ _ e2 _ _ _ _) when exp_compare e2 e1 != 0 => exp_compare e2 e1 + | (Hlseg _ _ e1 _ _, Hpointsto e2 _ _) when exp_compare e2 e1 != 0 => exp_compare e2 e1 + | (Hlseg _ _ e1 _ _, Hdllseg _ _ e2 _ _ _ _) when exp_compare e2 e1 != 0 => exp_compare e2 e1 + | (Hdllseg _ _ e1 _ _ _ _, Hpointsto e2 _ _) when exp_compare e2 e1 != 0 => exp_compare e2 e1 + | (Hdllseg _ _ e1 _ _ _ _, Hlseg _ _ e2 _ _) when exp_compare e2 e1 != 0 => exp_compare e2 e1 + | (Hpointsto e1 se1 te1, Hpointsto e2 se2 te2) => + let n = exp_compare e2 e1; + if (n != 0) { + n + } else { + let n = strexp_compare se2 se1; + if (n != 0) { + n + } else { + exp_compare te2 te1 + } + } + | (Hpointsto _, _) => (-1) + | (_, Hpointsto _) => 1 + | (Hlseg k1 hpar1 e1 f1 el1, Hlseg k2 hpar2 e2 f2 el2) => + let n = exp_compare e2 e1; + if (n != 0) { + n + } else { + let n = lseg_kind_compare k2 k1; + if (n != 0) { + n + } else { + let n = hpara_compare hpar2 hpar1; + if (n != 0) { + n + } else { + let n = exp_compare f2 f1; + if (n != 0) { + n + } else { + exp_list_compare el2 el1 + } + } + } + } + | (Hlseg _, Hdllseg _) => (-1) + | (Hdllseg _, Hlseg _) => 1 + | (Hdllseg k1 hpar1 e1 f1 g1 h1 el1, Hdllseg k2 hpar2 e2 f2 g2 h2 el2) => + let n = exp_compare e2 e1; + if (n != 0) { + n + } else { + let n = lseg_kind_compare k2 k1; + if (n != 0) { + n + } else { + let n = hpara_dll_compare hpar2 hpar1; + if (n != 0) { + n + } else { + let n = exp_compare f2 f1; + if (n != 0) { + n + } else { + let n = exp_compare g2 g1; + if (n != 0) { + n + } else { + let n = exp_compare h2 h1; + if (n != 0) { + n + } else { + exp_list_compare el2 el1 + } + } + } + } + } + } + } + } +and hpred_list_compare l1 l2 => IList.compare hpred_compare l1 l2 +and hpara_compare hp1 hp2 => { + let n = Ident.compare hp1.root hp2.root; + if (n != 0) { + n + } else { + let n = Ident.compare hp1.next hp2.next; + if (n != 0) { + n + } else { + let n = Ident.ident_list_compare hp1.svars hp2.svars; + if (n != 0) { + n + } else { + let n = Ident.ident_list_compare hp1.evars hp2.evars; + if (n != 0) { + n + } else { + hpred_list_compare hp1.body hp2.body + } + } + } + } +} +and hpara_dll_compare hp1 hp2 => { + let n = Ident.compare hp1.cell hp2.cell; + if (n != 0) { + n + } else { + let n = Ident.compare hp1.blink hp2.blink; + if (n != 0) { + n + } else { + let n = Ident.compare hp1.flink hp2.flink; + if (n != 0) { + n + } else { + let n = Ident.ident_list_compare hp1.svars_dll hp2.svars_dll; + if (n != 0) { + n + } else { + let n = Ident.ident_list_compare hp1.evars_dll hp2.evars_dll; + if (n != 0) { + n + } else { + hpred_list_compare hp1.body_dll hp2.body_dll + } + } + } + } + } +}; + +let strexp_equal se1 se2 => strexp_compare se1 se2 == 0; + +let hpred_equal hpred1 hpred2 => hpred_compare hpred1 hpred2 == 0; + +let hpara_equal hpara1 hpara2 => hpara_compare hpara1 hpara2 == 0; + +let hpara_dll_equal hpara1 hpara2 => hpara_dll_compare hpara1 hpara2 == 0; + + +/** {2 Sets and maps of types} */ +let module StructTypSet = Set.Make { + type t = struct_typ; + let compare = struct_typ_compare; +}; + +let module TypSet = Set.Make { + type t = typ; + let compare = typ_compare; +}; + +let module TypMap = Map.Make { + type t = typ; + let compare = typ_compare; +}; + + +/** {2 Sets of expressions} */ +let module ExpSet = Set.Make { + type t = exp; + let compare = exp_compare; +}; + +let module ExpMap = Map.Make { + type t = exp; + let compare = exp_compare; +}; + +let elist_to_eset es => IList.fold_left (fun set e => ExpSet.add e set) ExpSet.empty es; + + +/** {2 Sets of heap predicates} */ +let module HpredSet = Set.Make { + type t = hpred; + let compare = hpred_compare; +}; + + +/** {2 Pretty Printing} */ +/** Begin change color if using diff printing, return updated printenv and change status */ +let color_pre_wrapper pe f x => + if (Config.print_using_diff && pe.pe_kind !== PP_TEXT) { + let color = pe.pe_cmap_norm (Obj.repr x); + if (color !== pe.pe_color) { + ( + if (pe.pe_kind === PP_HTML) { + Io_infer.Html.pp_start_color + } else { + Latex.pp_color + } + ) + f color; + if (color === Red) { + /** All subexpressiona red */ + ({...pe, pe_cmap_norm: colormap_red, pe_color: Red}, true) + } else { + ({...pe, pe_color: color}, true) + } + } else { + (pe, false) + } + } else { + (pe, false) + }; + + +/** Close color annotation if changed */ +let color_post_wrapper changed pe f => + if changed { + if (pe.pe_kind === PP_HTML) { + Io_infer.Html.pp_end_color f () + } else { + Latex.pp_color f pe.pe_color + } + }; + + +/** Print a sequence with difference mode if enabled. */ +let pp_seq_diff pp pe0 f => + if (not Config.print_using_diff) { + pp_comma_seq pp f + } else { + let rec doit = + fun + | [] => () + | [x] => { + let (_, changed) = color_pre_wrapper pe0 f x; + F.fprintf f "%a" pp x; + color_post_wrapper changed pe0 f + } + | [x, ...l] => { + let (_, changed) = color_pre_wrapper pe0 f x; + F.fprintf f "%a" pp x; + color_post_wrapper changed pe0 f; + F.fprintf f ", "; + doit l + }; + doit + }; + +let text_binop = + fun + | PlusA => "+" + | PlusPI => "+" + | MinusA + | MinusPP => "-" + | MinusPI => "-" + | Mult => "*" + | Div => "/" + | Mod => "%" + | Shiftlt => "<<" + | Shiftrt => ">>" + | Lt => "<" + | Gt => ">" + | Le => "<=" + | Ge => ">=" + | Eq => "==" + | Ne => "!=" + | BAnd => "&" + | BXor => "^" + | BOr => "|" + | LAnd => "&&" + | LOr => "||" + | PtrFld => "_ptrfld_"; + + +/** String representation of unary operator. */ +let str_unop = + fun + | Neg => "-" + | BNot => "~" + | LNot => "!"; + + +/** Pretty print a binary operator. */ +let str_binop pe binop => + switch pe.pe_kind { + | PP_HTML => + switch binop { + | Ge => " >= " + | Le => " <= " + | Gt => " > " + | Lt => " < " + | Shiftlt => " << " + | Shiftrt => " >> " + | _ => text_binop binop + } + | PP_LATEX => + switch binop { + | Ge => " \\geq " + | Le => " \\leq " + | _ => text_binop binop + } + | _ => text_binop binop + }; + +let ikind_to_string = + fun + | IChar => "char" + | ISChar => "signed char" + | IUChar => "unsigned char" + | IBool => "_Bool" + | IInt => "int" + | IUInt => "unsigned int" + | IShort => "short" + | IUShort => "unsigned short" + | ILong => "long" + | IULong => "unsigned long" + | ILongLong => "long long" + | IULongLong => "unsigned long long" + | I128 => "__int128_t" + | IU128 => "__uint128_t"; + +let fkind_to_string = + fun + | FFloat => "float" + | FDouble => "double" + | FLongDouble => "long double"; + +let ptr_kind_string = + fun + | Pk_reference => "&" + | Pk_pointer => "*" + | Pk_objc_weak => "__weak *" + | Pk_objc_unsafe_unretained => "__unsafe_unretained *" + | Pk_objc_autoreleasing => "__autoreleasing *"; + +let java () => !Config.curr_language == Config.Java; + +let eradicate_java () => Config.eradicate && java (); + + +/** convert a dexp to a string */ +let rec dexp_to_string = + fun + | Darray de1 de2 => dexp_to_string de1 ^ "[" ^ dexp_to_string de2 ^ "]" + | Dbinop op de1 de2 => "(" ^ dexp_to_string de1 ^ str_binop pe_text op ^ dexp_to_string de2 ^ ")" + | Dconst (Cfun pn) => Procname.to_simplified_string pn + | Dconst c => exp_to_string (Const c) + | Dderef de => "*" ^ dexp_to_string de + | Dfcall fun_dexp args _ {cf_virtual: isvirtual} => { + let pp_arg fmt de => F.fprintf fmt "%s" (dexp_to_string de); + let pp_args fmt des => + if (eradicate_java ()) { + if (des != []) { + F.fprintf fmt "..." + } + } else { + pp_comma_seq pp_arg fmt des + }; + let pp_fun fmt => ( + fun + | Dconst (Cfun pname) => { + let s = + switch pname { + | Procname.Java pname_java => Procname.java_get_method pname_java + | _ => Procname.to_string pname + }; + F.fprintf fmt "%s" s + } + | de => F.fprintf fmt "%s" (dexp_to_string de) + ); + let (receiver, args') = + switch args { + | [Dpvar pv, ...args'] when isvirtual && Pvar.is_this pv => (None, args') + | [a, ...args'] when isvirtual => (Some a, args') + | _ => (None, args) + }; + let pp fmt () => { + let pp_receiver fmt => ( + fun + | None => () + | Some arg => F.fprintf fmt "%a." pp_arg arg + ); + F.fprintf fmt "%a%a(%a)" pp_receiver receiver pp_fun fun_dexp pp_args args' + }; + pp_to_string pp () + } + | Darrow (Dpvar pv) f when Pvar.is_this pv => + /* this->fieldname */ + Ident.fieldname_to_simplified_string f + | Darrow de f => + if (Ident.fieldname_is_hidden f) { + dexp_to_string de + } else if (java ()) { + dexp_to_string de ^ "." ^ Ident.fieldname_to_flat_string f + } else { + dexp_to_string de ^ "->" ^ Ident.fieldname_to_string f + } + | Ddot (Dpvar _) fe when eradicate_java () => + /* static field access */ + Ident.fieldname_to_simplified_string fe + | Ddot de f => + if (Ident.fieldname_is_hidden f) { + "&" ^ dexp_to_string de + } else if (java ()) { + dexp_to_string de ^ "." ^ Ident.fieldname_to_flat_string f + } else { + dexp_to_string de ^ "." ^ Ident.fieldname_to_string f + } + | Dpvar pv => Mangled.to_string (Pvar.get_name pv) + | Dpvaraddr pv => { + let s = + if (eradicate_java ()) { + Pvar.get_simplified_name pv + } else { + Mangled.to_string (Pvar.get_name pv) + }; + let ampersand = + if (eradicate_java ()) { + "" + } else { + "&" + }; + ampersand ^ s + } + | Dunop op de => str_unop op ^ dexp_to_string de + | Dsizeof typ _ => pp_to_string (pp_typ_full pe_text) typ + | Dunknown => "unknown" + | Dretcall de _ _ _ => "returned by " ^ dexp_to_string de +/** Pretty print a dexp. */ +and pp_dexp fmt de => F.fprintf fmt "%s" (dexp_to_string de) +/** Pretty print a value path */ +and pp_vpath pe fmt vpath => { + let pp fmt => + fun + | Some de => pp_dexp fmt de + | None => (); + if (pe.pe_kind === PP_HTML) { + F.fprintf + fmt + " %a{vpath: %a}%a" + Io_infer.Html.pp_start_color + Orange + pp + vpath + Io_infer.Html.pp_end_color + () + } else { + F.fprintf fmt "%a" pp vpath + } +} +/** convert the attribute to a string */ +and attribute_to_string pe => + fun + | Aresource ra => { + let mk_name = ( + fun + | Mmalloc => "ma" + | Mnew => "ne" + | Mnew_array => "na" + | Mobjc => "oc" + ); + let name = + switch (ra.ra_kind, ra.ra_res) { + | (Racquire, Rmemory mk) => "MEM" ^ mk_name mk + | (Racquire, Rfile) => "FILE" + | (Rrelease, Rmemory mk) => "FREED" ^ mk_name mk + | (Rrelease, Rfile) => "CLOSED" + | (_, Rignore) => "IGNORE" + | (Racquire, Rlock) => "LOCKED" + | (Rrelease, Rlock) => "UNLOCKED" + }; + let str_vpath = + if Config.trace_error { + pp_to_string (pp_vpath pe) ra.ra_vpath + } else { + "" + }; + name ^ + str_binop pe Lt ^ + Procname.to_string ra.ra_pname ^ + ":" ^ + string_of_int ra.ra_loc.Location.line ^ + str_binop pe Gt ^ + str_vpath + } + | Aautorelease => "AUTORELEASE" + | Adangling dk => { + let dks = + switch dk { + | DAuninit => "UNINIT" + | DAaddr_stack_var => "ADDR_STACK" + | DAminusone => "MINUS1" + }; + "DANGL" ^ str_binop pe Lt ^ dks ^ str_binop pe Gt + } + | Aundef pn _ loc _ => + "UND" ^ + str_binop pe Lt ^ + Procname.to_string pn ^ + str_binop pe Gt ^ + ":" ^ + string_of_int loc.Location.line + | Ataint {taint_source} => "TAINTED[" ^ Procname.to_string taint_source ^ "]" + | Auntaint => "UNTAINTED" + | Alocked => "LOCKED" + | Aunlocked => "UNLOCKED" + | Adiv0 (_, _) => "DIV0" + | Aobjc_null exp => { + let info_s = + switch exp { + | Lvar var => "FORMAL " ^ Pvar.to_string var + | Lfield _ => "FIELD " ^ exp_to_string exp + | _ => "" + }; + "OBJC_NULL[" ^ info_s ^ "]" + } + | Aretval pn _ => "RET" ^ str_binop pe Lt ^ Procname.to_string pn ^ str_binop pe Gt + | Aobserver => "OBSERVER" + | Aunsubscribed_observer => "UNSUBSCRIBED_OBSERVER" +and pp_const pe f => + fun + | Cint i => Int.pp f i + | Cfun fn => + switch pe.pe_kind { + | PP_HTML => F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn)) + | _ => F.fprintf f "_fun_%s" (Procname.to_string fn) + } + | Cstr s => F.fprintf f "\"%s\"" (String.escaped s) + | Cfloat v => F.fprintf f "%f" v + | Cattribute att => F.fprintf f "%s" (attribute_to_string pe att) + | Cexn e => F.fprintf f "EXN %a" (pp_exp pe) e + | Cclass c => F.fprintf f "%a" Ident.pp_name c + | Cptr_to_fld fn _ => F.fprintf f "__fld_%a" Ident.pp_fieldname fn + | Cclosure {name, captured_vars} => { + let id_exps = IList.map (fun (id_exp, _, _) => id_exp) captured_vars; + F.fprintf f "(%a)" (pp_comma_seq (pp_exp pe)) [Const (Cfun name), ...id_exps] + } +/** Pretty print a type. Do nothing by default. */ +and pp_typ pe f te => + if Config.print_types { + pp_typ_full pe f te + } else { + () + } +and pp_struct_typ pe pp_base f struct_typ => + switch struct_typ.struct_name { + | Some name when false => + /* remove "when false" to print the details of struct */ + F.fprintf + f + "%s %a {%a} %a" + (Csu.name struct_typ.csu) + Mangled.pp + name + (pp_seq (fun f (fld, t, _) => F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) + struct_typ.instance_fields + pp_base + () + | Some name => F.fprintf f "%s %a %a" (Csu.name struct_typ.csu) Mangled.pp name pp_base () + | None => + F.fprintf + f + "%s {%a} %a" + (Csu.name struct_typ.csu) + (pp_seq (fun f (fld, t, _) => F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) + struct_typ.instance_fields + pp_base + () + } +/** Pretty print a type declaration. + pp_base prints the variable for a declaration, or can be skip to print only the type + pp_size prints the expression for the array size */ +and pp_type_decl pe pp_base pp_size f => + fun + | Tvar tname => F.fprintf f "%s %a" (Typename.to_string tname) pp_base () + | Tint ik => F.fprintf f "%s %a" (ikind_to_string ik) pp_base () + | Tfloat fk => F.fprintf f "%s %a" (fkind_to_string fk) pp_base () + | Tvoid => F.fprintf f "void %a" pp_base () + | Tfun false => F.fprintf f "_fn_ %a" pp_base () + | Tfun true => F.fprintf f "_fn_noreturn_ %a" pp_base () + | Tptr ((Tarray _ | Tfun _) as typ) pk => { + let pp_base' fmt () => F.fprintf fmt "(%s%a)" (ptr_kind_string pk) pp_base (); + pp_type_decl pe pp_base' pp_size f typ + } + | Tptr typ pk => { + let pp_base' fmt () => F.fprintf fmt "%s%a" (ptr_kind_string pk) pp_base (); + pp_type_decl pe pp_base' pp_size f typ + } + | Tstruct struct_typ => pp_struct_typ pe pp_base f struct_typ + | Tarray typ size => { + let pp_base' fmt () => F.fprintf fmt "%a[%a]" pp_base () (pp_size pe) size; + pp_type_decl pe pp_base' pp_size f typ + } +/** Pretty print a type with all the details, using the C syntax. */ +and pp_typ_full pe => pp_type_decl pe (fun _ () => ()) pp_exp_full +/** Pretty print an expression. */ +and _pp_exp pe0 pp_t f e0 => { + let (pe, changed) = color_pre_wrapper pe0 f e0; + let e = + switch pe.pe_obj_sub { + | Some sub => Obj.obj (sub (Obj.repr e0)) /* apply object substitution to expression */ + | None => e0 + }; + if (not (exp_equal e0 e)) { + switch e { + | Lvar pvar => Pvar.pp_value pe f pvar + | _ => assert false + } + } else { + let pp_exp = _pp_exp pe pp_t; + let print_binop_stm_output e1 op e2 => + switch op { + | Eq + | Ne + | PlusA + | Mult => F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1 + | Lt => F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1 + | Gt => F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1 + | Le => F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1 + | Ge => F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1 + | _ => F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 + }; + switch e { + | Var id => (Ident.pp pe) f id + | Const c => F.fprintf f "%a" (pp_const pe) c + | Cast typ e => F.fprintf f "(%a)%a" pp_t typ pp_exp e + | UnOp op e _ => F.fprintf f "%s%a" (str_unop op) pp_exp e + | BinOp op (Const c) e2 when Config.smt_output => print_binop_stm_output (Const c) op e2 + | BinOp op e1 e2 => F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 + | Lvar pv => Pvar.pp pe f pv + | Lfield e fld _ => F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld + | Lindex e1 e2 => F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 + | Sizeof t s => F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s + } + }; + color_post_wrapper changed pe0 f +} +and pp_exp pe f e => _pp_exp pe (pp_typ pe) f e +and pp_exp_full pe f e => _pp_exp pe (pp_typ_full pe) f e +/** Convert an expression to a string */ +and exp_to_string e => pp_to_string (pp_exp pe_text) e; + +let typ_to_string typ => { + let pp fmt () => pp_typ_full pe_text fmt typ; + pp_to_string pp () +}; + + +/** dump a type with all the details. */ +let d_typ_full (t: typ) => L.add_print_action (L.PTtyp_full, Obj.repr t); + + +/** dump a list of types. */ +let d_typ_list (tl: list typ) => L.add_print_action (L.PTtyp_list, Obj.repr tl); + + +/** dump an expression. */ +let d_exp (e: exp) => L.add_print_action (L.PTexp, Obj.repr e); + + +/** Pretty print a list of expressions. */ +let pp_exp_list pe f expl => (pp_seq (pp_exp pe)) f expl; + + +/** dump a list of expressions. */ +let d_exp_list (el: list exp) => L.add_print_action (L.PTexp_list, Obj.repr el); + +let pp_texp pe f => + fun + | Sizeof t s => F.fprintf f "%a%a" (pp_typ pe) t Subtype.pp s + | e => (pp_exp pe) f e; + + +/** Pretty print a type with all the details. */ +let pp_texp_full pe f => + fun + | Sizeof t s => F.fprintf f "%a%a" (pp_typ_full pe) t Subtype.pp s + | e => (_pp_exp pe) (pp_typ_full pe) f e; + + +/** Dump a type expression with all the details. */ +let d_texp_full (te: exp) => L.add_print_action (L.PTtexp_full, Obj.repr te); + + +/** Pretty print an offset */ +let pp_offset pe f => + fun + | Off_fld fld _ => F.fprintf f "%a" Ident.pp_fieldname fld + | Off_index exp => F.fprintf f "%a" (pp_exp pe) exp; + + +/** dump an offset. */ +let d_offset (off: offset) => L.add_print_action (L.PToff, Obj.repr off); + + +/** Pretty print a list of offsets */ +let rec pp_offset_list pe f => + fun + | [] => () + | [off1, off2] => F.fprintf f "%a.%a" (pp_offset pe) off1 (pp_offset pe) off2 + | [off, ...off_list] => F.fprintf f "%a.%a" (pp_offset pe) off (pp_offset_list pe) off_list; + + +/** Dump a list of offsets */ +let d_offset_list (offl: list offset) => L.add_print_action (L.PToff_list, Obj.repr offl); + +let pp_exp_typ pe f (e, t) => F.fprintf f "%a:%a" (pp_exp pe) e (pp_typ pe) t; + + +/** Get the location of the instruction */ +let instr_get_loc = + fun + | Letderef _ _ _ loc + | Set _ _ _ loc + | Prune _ loc _ _ + | Call _ _ _ loc _ + | Nullify _ loc + | Abstract loc + | Remove_temps _ loc + | Stackop _ loc + | Declare_locals _ loc => loc; + + +/** get the expressions occurring in the instruction */ +let instr_get_exps = + fun + | Letderef id e _ _ => [Var id, e] + | Set e1 _ e2 _ => [e1, e2] + | Prune cond _ _ _ => [cond] + | Call ret_ids e _ _ _ => [e, ...(IList.map (fun id => Var id)) ret_ids] + | Nullify pvar _ => [Lvar pvar] + | Abstract _ => [] + | Remove_temps temps _ => IList.map (fun id => Var id) temps + | Stackop _ => [] + | Declare_locals _ => []; + + +/** Pretty print call flags */ +let pp_call_flags f cf => { + if cf.cf_virtual { + F.fprintf f " virtual" + }; + if cf.cf_noreturn { + F.fprintf f " noreturn" + } +}; + + +/** Pretty print an instruction. */ +let pp_instr pe0 f instr => { + let (pe, changed) = color_pre_wrapper pe0 f instr; + switch instr { + | Letderef id e t loc => + F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t Location.pp loc + | Set e1 t e2 loc => + F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 Location.pp loc + | Prune cond loc true_branch _ => + F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch Location.pp loc + | Call ret_ids e arg_ts loc cf => + switch ret_ids { + | [] => () + | _ => F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids + }; + F.fprintf + f + "%a(%a)%a %a" + (pp_exp pe) + e + (pp_comma_seq (pp_exp_typ pe)) + arg_ts + pp_call_flags + cf + Location.pp + loc + | Nullify pvar loc => F.fprintf f "NULLIFY(%a); %a" (Pvar.pp pe) pvar Location.pp loc + | Abstract loc => F.fprintf f "APPLY_ABSTRACTION; %a" Location.pp loc + | Remove_temps temps loc => + F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps Location.pp loc + | Stackop stackop loc => + let s = + switch stackop { + | Push => "Push" + | Swap => "Swap" + | Pop => "Pop" + }; + F.fprintf f "STACKOP.%s; %a" s Location.pp loc + | Declare_locals ptl loc => + let pp_typ fmt (pvar, _) => F.fprintf fmt "%a" (Pvar.pp pe) pvar; + F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_typ) ptl Location.pp loc + }; + color_post_wrapper changed pe0 f +}; + +let has_block_prefix s => + switch (Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) s) { + | [_, _, ..._] => true + | _ => false + }; + + +/** Check if type is a type for a block in objc */ +let is_block_type typ => has_block_prefix (typ_to_string typ); + + +/** Check if a pvar is a local pointing to a block in objc */ +let is_block_pvar pvar => has_block_prefix (Mangled.to_string (Pvar.get_name pvar)); + +/* A block pvar used to explain retain cycles */ +let block_pvar = Pvar.mk (Mangled.from_string "block") (Procname.from_string_c_fun ""); + + +/** Iterate over all the subtypes in the type (including the type itself) */ +let rec typ_iter_types (f: typ => unit) typ => { + f typ; + switch typ { + | Tvar _ + | Tint _ + | Tfloat _ + | Tvoid + | Tfun _ => () + | Tptr t' _ => typ_iter_types f t' + | Tstruct struct_typ => + IList.iter (fun (_, t, _) => typ_iter_types f t) struct_typ.instance_fields + | Tarray t e => + typ_iter_types f t; + exp_iter_types f e + } +} +/** Iterate over all the subtypes in the type (including the type itself) */ +and exp_iter_types f e => + switch e { + | Var _ => () + | Const (Cexn e1) => exp_iter_types f e1 + | Const (Cclosure {captured_vars}) => IList.iter (fun (_, _, typ) => f typ) captured_vars + | Const _ => () + | Cast t e1 => + typ_iter_types f t; + exp_iter_types f e1 + | UnOp _ e1 typo => + exp_iter_types f e1; + switch typo { + | Some t => typ_iter_types f t + | None => () + } + | BinOp _ e1 e2 => + exp_iter_types f e1; + exp_iter_types f e2 + | Lvar _ => () + | Lfield e1 _ typ => + exp_iter_types f e1; + typ_iter_types f typ + | Lindex e1 e2 => + exp_iter_types f e1; + exp_iter_types f e2 + | Sizeof t _ => typ_iter_types f t + }; + + +/** Iterate over all the types (and subtypes) in the instruction */ +let instr_iter_types f instr => + switch instr { + | Letderef _ e t _ => + exp_iter_types f e; + typ_iter_types f t + | Set e1 t e2 _ => + exp_iter_types f e1; + typ_iter_types f t; + exp_iter_types f e2 + | Prune cond _ _ _ => exp_iter_types f cond + | Call _ e arg_ts _ _ => + exp_iter_types f e; + IList.iter + ( + fun (e, t) => { + exp_iter_types f e; + typ_iter_types f t + } + ) + arg_ts + | Nullify _ _ => () + | Abstract _ => () + | Remove_temps _ _ => () + | Stackop _ _ => () + | Declare_locals ptl _ => IList.iter (fun (_, t) => typ_iter_types f t) ptl + }; + + +/** Dump an instruction. */ +let d_instr (i: instr) => L.add_print_action (L.PTinstr, Obj.repr i); + +let rec pp_instr_list pe f => + fun + | [] => F.fprintf f "" + | [i, ...is] => F.fprintf f "%a;@\n%a" (pp_instr pe) i (pp_instr_list pe) is; + + +/** Dump a list of instructions. */ +let d_instr_list (il: list instr) => L.add_print_action (L.PTinstr_list, Obj.repr il); + +let pp_atom pe0 f a => { + let (pe, changed) = color_pre_wrapper pe0 f a; + switch a { + | Aeq (BinOp op e1 e2) (Const (Cint i)) when Int.isone i => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => F.fprintf f "%a" (pp_exp pe) (BinOp op e1 e2) + | PP_LATEX => F.fprintf f "%a" (pp_exp pe) (BinOp op e1 e2) + } + | Aeq e1 e2 => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2 + | PP_LATEX => F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2 + } + | Aneq (Const (Cattribute _) as ea) e + | Aneq e (Const (Cattribute _) as ea) => F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e + | Aneq e1 e2 => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2 + | PP_LATEX => F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2 + } + }; + color_post_wrapper changed pe0 f +}; + + +/** dump an atom */ +let d_atom (a: atom) => L.add_print_action (L.PTatom, Obj.repr a); + +let pp_lseg_kind f => + fun + | Lseg_NE => F.fprintf f "ne" + | Lseg_PE => F.fprintf f ""; + + +/** Print a *-separated sequence. */ +let rec pp_star_seq pp f => + fun + | [] => () + | [x] => F.fprintf f "%a" pp x + | [x, ...l] => F.fprintf f "%a * %a" pp x (pp_star_seq pp) l; + + +/********* START OF MODULE Predicates **********/ +/** Module Predicates records the occurrences of predicates as parameters + of (doubly -)linked lists and Epara. Provides unique numbering + for predicates and an iterator. */ +let module Predicates: { + /** predicate environment */ + type env; + + /** create an empty predicate environment */ + let empty_env: unit => env; + + /** return true if the environment is empty */ + let is_empty: env => bool; + + /** return the id of the hpara */ + let get_hpara_id: env => hpara => int; + + /** return the id of the hpara_dll */ + let get_hpara_dll_id: env => hpara_dll => int; + + /** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, + passing the unique id to the functions. The iterator can only be used once. */ + let iter: env => (int => hpara => unit) => (int => hpara_dll => unit) => unit; + + /** Process one hpred, updating the predicate environment */ + let process_hpred: env => hpred => unit; +} = { + /** hash tables for hpara */ + let module HparaHash = Hashtbl.Make { + type t = hpara; + let equal = hpara_equal; + let hash = Hashtbl.hash; + }; + + /** hash tables for hpara_dll */ + let module HparaDllHash = Hashtbl.Make { + type t = hpara_dll; + let equal = hpara_dll_equal; + let hash = Hashtbl.hash; + }; + + /** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted, + also keep a list of hparas still to be emitted. Same for hpara_dll. */ + type env = { + mutable num: int, + hash: HparaHash.t (int, bool), + mutable todo: list hpara, + hash_dll: HparaDllHash.t (int, bool), + mutable todo_dll: list hpara_dll + }; + + /** return true if the environment is empty */ + let is_empty env => env.num == 0; + + /** return the id of the hpara */ + let get_hpara_id env hpara => fst (HparaHash.find env.hash hpara); + + /** return the id of the hpara_dll */ + let get_hpara_dll_id env hpara_dll => fst (HparaDllHash.find env.hash_dll hpara_dll); + + /** Process one hpara, updating the map from hparas to numbers, and the todo list */ + let process_hpara env hpara => + if (not (HparaHash.mem env.hash hpara)) { + HparaHash.add env.hash hpara (env.num, false); + env.num = env.num + 1; + env.todo = env.todo @ [hpara] + }; + + /** Process one hpara_dll, updating the map from hparas to numbers, and the todo list */ + let process_hpara_dll env hpara_dll => + if (not (HparaDllHash.mem env.hash_dll hpara_dll)) { + HparaDllHash.add env.hash_dll hpara_dll (env.num, false); + env.num = env.num + 1; + env.todo_dll = env.todo_dll @ [hpara_dll] + }; + + /** Process a sexp, updating env */ + let rec process_sexp env => + fun + | Eexp _ => () + | Earray _ esel _ => IList.iter (fun (_, se) => process_sexp env se) esel + | Estruct fsel _ => IList.iter (fun (_, se) => process_sexp env se) fsel; + + /** Process one hpred, updating env */ + let rec process_hpred env => + fun + | Hpointsto _ se _ => process_sexp env se + | Hlseg _ hpara _ _ _ => { + IList.iter (process_hpred env) hpara.body; + process_hpara env hpara + } + | Hdllseg _ hpara_dll _ _ _ _ _ => { + IList.iter (process_hpred env) hpara_dll.body_dll; + process_hpara_dll env hpara_dll + }; + + /** create an empty predicate environment */ + let empty_env () => { + num: 0, + hash: HparaHash.create 3, + todo: [], + hash_dll: HparaDllHash.create 3, + todo_dll: [] + }; + + /** iterator for predicates which are marked as todo in env, + unless they have been visited already. + This can in turn extend the todo list for the nested predicates, + which are then visited as well. + Can be applied only once, as it destroys the todo list */ + let iter (env: env) f f_dll => + while (env.todo !== [] || env.todo_dll !== []) { + if (env.todo !== []) { + let hpara = IList.hd env.todo; + let () = env.todo = IList.tl env.todo; + let (n, emitted) = HparaHash.find env.hash hpara; + if (not emitted) { + f n hpara + } + } else if ( + env.todo_dll !== [] + ) { + let hpara_dll = IList.hd env.todo_dll; + let () = env.todo_dll = IList.tl env.todo_dll; + let (n, emitted) = HparaDllHash.find env.hash_dll hpara_dll; + if (not emitted) { + f_dll n hpara_dll + } + } + }; +}; + + +/********* END OF MODULE Predicates **********/ +let pp_texp_simple pe => + switch pe.pe_opt { + | PP_SIM_DEFAULT => pp_texp pe + | PP_SIM_WITH_TYP => pp_texp_full pe + }; + +let inst_abstraction = Iabstraction; + +let inst_actual_precondition = Iactual_precondition; + +let inst_alloc = Ialloc; + +let inst_formal = Iformal None false; /** for formal parameters */ + +let inst_initial = Iinitial; /** for initial values */ + +let inst_lookup = Ilookup; + +let inst_none = Inone; + +let inst_nullify = Inullify; + +let inst_rearrange b loc pos => Irearrange (Some b) false loc.Location.line pos; + +let inst_taint = Itaint; + +let inst_update loc pos => Iupdate None false loc.Location.line pos; + + +/** update the location of the instrumentation */ +let inst_new_loc loc inst => + switch inst { + | Iabstraction => inst + | Iactual_precondition => inst + | Ialloc => inst + | Iformal _ => inst + | Iinitial => inst + | Ilookup => inst + | Inone => inst + | Inullify => inst + | Irearrange zf ncf _ pos => Irearrange zf ncf loc.Location.line pos + | Itaint => inst + | Iupdate zf ncf _ pos => Iupdate zf ncf loc.Location.line pos + | Ireturn_from_call _ => Ireturn_from_call loc.Location.line + | Ireturn_from_pointer_wrapper_call _ => Ireturn_from_pointer_wrapper_call loc.Location.line + }; + + +/** return a string representing the inst */ +let inst_to_string inst => { + let zero_flag_to_string = + fun + | Some true => "(z)" + | _ => ""; + let null_case_flag_to_string ncf => + if ncf { + "(ncf)" + } else { + "" + }; + switch inst { + | Iabstraction => "abstraction" + | Iactual_precondition => "actual_precondition" + | Ialloc => "alloc" + | Iformal zf ncf => "formal" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf + | Iinitial => "initial" + | Ilookup => "lookup" + | Inone => "none" + | Inullify => "nullify" + | Irearrange zf ncf n _ => + "rearrange:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n + | Itaint => "taint" + | Iupdate zf ncf n _ => + "update:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n + | Ireturn_from_call n => "return_from_call: " ^ string_of_int n + | Ireturn_from_pointer_wrapper_call n => "Ireturn_from_pointer_wrapper_call: " ^ string_of_int n + } +}; + + +/** join of instrumentations */ +let inst_partial_join inst1 inst2 => { + let fail () => { + L.d_strln ("inst_partial_join failed on " ^ inst_to_string inst1 ^ " " ^ inst_to_string inst2); + raise IList.Fail + }; + if (inst1 == inst2) { + inst1 + } else { + switch (inst1, inst2) { + | (_, Inone) + | (Inone, _) => inst_none + | (_, Ialloc) + | (Ialloc, _) => fail () + | (_, Iinitial) + | (Iinitial, _) => fail () + | (_, Iupdate _) + | (Iupdate _, _) => fail () + | _ => inst_none + } + } +}; + + +/** meet of instrumentations */ +let inst_partial_meet inst1 inst2 => + if (inst1 == inst2) { + inst1 + } else { + inst_none + }; + + +/** Return the zero flag of the inst */ +let inst_zero_flag = + fun + | Iabstraction => None + | Iactual_precondition => None + | Ialloc => None + | Iformal zf _ => zf + | Iinitial => None + | Ilookup => None + | Inone => None + | Inullify => None + | Irearrange zf _ _ _ => zf + | Itaint => None + | Iupdate zf _ _ _ => zf + | Ireturn_from_call _ + | Ireturn_from_pointer_wrapper_call _ => None; + + +/** Set the null case flag of the inst. */ +let inst_set_null_case_flag = + fun + | Iformal zf false => Iformal zf true + | Irearrange zf false n pos => Irearrange zf true n pos + | Iupdate zf false n pos => Iupdate zf true n pos + | inst => inst; + + +/** Get the null case flag of the inst. */ +let inst_get_null_case_flag = + fun + | Iupdate _ ncf _ _ => Some ncf + | _ => None; + + +/** Update [inst_old] to [inst_new] preserving the zero flag */ +let update_inst inst_old inst_new => { + let combine_zero_flags z1 z2 => + switch (z1, z2) { + | (Some b1, Some b2) => Some (b1 || b2) + | (Some b, None) => Some b + | (None, Some b) => Some b + | (None, None) => None + }; + switch inst_new { + | Iabstraction => inst_new + | Iactual_precondition => inst_new + | Ialloc => inst_new + | Iformal zf ncf => + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf; + Iformal zf' ncf + | Iinitial => inst_new + | Ilookup => inst_new + | Inone => inst_new + | Inullify => inst_new + | Irearrange zf ncf n pos => + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf; + Irearrange zf' ncf n pos + | Itaint => inst_new + | Iupdate zf ncf n pos => + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf; + Iupdate zf' ncf n pos + | Ireturn_from_call _ => inst_new + | Ireturn_from_pointer_wrapper_call _ => inst_new + } +}; + + +/** describe an instrumentation with a string */ +let pp_inst pe f inst => { + let str = inst_to_string inst; + if (pe.pe_kind === PP_HTML) { + F.fprintf f " %a%s%a" Io_infer.Html.pp_start_color Orange str Io_infer.Html.pp_end_color () + } else { + F.fprintf f "%s%s%s" (str_binop pe Lt) str (str_binop pe Gt) + } +}; + +let pp_inst_if_trace pe f inst => + if Config.trace_error { + pp_inst pe f inst + }; + + +/** pretty print a strexp with an optional predicate env */ +let rec pp_sexp_env pe0 envo f se => { + let (pe, changed) = color_pre_wrapper pe0 f se; + switch se { + | Eexp e inst => F.fprintf f "%a%a" (pp_exp pe) e (pp_inst_if_trace pe) inst + | Estruct fel inst => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => + let pp_diff f (n, se) => F.fprintf f "%a:%a" Ident.pp_fieldname n (pp_sexp_env pe envo) se; + F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst + | PP_LATEX => + let pp_diff f (n, se) => + F.fprintf f "%a:%a" (Ident.pp_fieldname_latex Latex.Boldface) n (pp_sexp_env pe envo) se; + F.fprintf f "\\{%a\\}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst + } + | Earray size nel inst => + let pp_diff f (i, se) => F.fprintf f "%a:%a" (pp_exp pe) i (pp_sexp_env pe envo) se; + F.fprintf + f "[%a|%a]%a" (pp_exp pe) size (pp_seq_diff pp_diff pe) nel (pp_inst_if_trace pe) inst + }; + color_post_wrapper changed pe0 f +} +/** Pretty print an hpred with an optional predicate env */ +and pp_hpred_env pe0 envo f hpred => { + let (pe, changed) = color_pre_wrapper pe0 f hpred; + switch hpred { + | Hpointsto e se te => + let pe' = + switch (e, se) { + | (Lvar pvar, Eexp (Var _) _) when not (Pvar.is_global pvar) => + {...pe, pe_obj_sub: None} /* dont use obj sub on the var defining it */ + | _ => pe + }; + switch pe'.pe_kind { + | PP_TEXT + | PP_HTML => + F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te + | PP_LATEX => F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se + } + | Hlseg k hpara e1 e2 elist => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => + F.fprintf + f + "lseg%a(%a,%a,[%a],%a)" + pp_lseg_kind + k + (pp_exp pe) + e1 + (pp_exp pe) + e2 + (pp_comma_seq (pp_exp pe)) + elist + (pp_hpara_env pe envo) + hpara + | PP_LATEX => + F.fprintf + f + "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" + pp_lseg_kind + k + (pp_exp pe) + e1 + (pp_exp pe) + e2 + (pp_comma_seq (pp_exp pe)) + elist + (pp_hpara_env pe envo) + hpara + } + | Hdllseg k hpara_dll iF oB oF iB elist => + switch pe.pe_kind { + | PP_TEXT + | PP_HTML => + F.fprintf + f + "dllseg%a(%a,%a,%a,%a,[%a],%a)" + pp_lseg_kind + k + (pp_exp pe) + iF + (pp_exp pe) + oB + (pp_exp pe) + oF + (pp_exp pe) + iB + (pp_comma_seq (pp_exp pe)) + elist + (pp_hpara_dll_env pe envo) + hpara_dll + | PP_LATEX => + F.fprintf + f + "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" + pp_lseg_kind + k + (pp_exp pe) + iF + (pp_exp pe) + oB + (pp_exp pe) + oF + (pp_exp pe) + iB + (pp_comma_seq (pp_exp pe)) + elist + (pp_hpara_dll_env pe envo) + hpara_dll + } + }; + color_post_wrapper changed pe0 f +} +and pp_hpara_env pe envo f hpara => + switch envo { + | None => + let (r, n, svars, evars, b) = (hpara.root, hpara.next, hpara.svars, hpara.evars, hpara.body); + F.fprintf + f + "lam [%a,%a,%a]. exists [%a]. %a" + (Ident.pp pe) + r + (Ident.pp pe) + n + (pp_seq (Ident.pp pe)) + svars + (pp_seq (Ident.pp pe)) + evars + (pp_star_seq (pp_hpred_env pe envo)) + b + | Some env => F.fprintf f "P%d" (Predicates.get_hpara_id env hpara) + } +and pp_hpara_dll_env pe envo f hpara_dll => + switch envo { + | None => + let (iF, oB, oF, svars, evars, b) = ( + hpara_dll.cell, + hpara_dll.blink, + hpara_dll.flink, + hpara_dll.svars_dll, + hpara_dll.evars_dll, + hpara_dll.body_dll + ); + F.fprintf + f + "lam [%a,%a,%a,%a]. exists [%a]. %a" + (Ident.pp pe) + iF + (Ident.pp pe) + oB + (Ident.pp pe) + oF + (pp_seq (Ident.pp pe)) + svars + (pp_seq (Ident.pp pe)) + evars + (pp_star_seq (pp_hpred_env pe envo)) + b + | Some env => F.fprintf f "P%d" (Predicates.get_hpara_dll_id env hpara_dll) + }; + + +/** pretty print a strexp */ +let pp_sexp pe f => pp_sexp_env pe None f; + + +/** pretty print a hpara */ +let pp_hpara pe f => pp_hpara_env pe None f; + + +/** pretty print a hpara_dll */ +let pp_hpara_dll pe f => pp_hpara_dll_env pe None f; + + +/** pretty print a hpred */ +let pp_hpred pe f => pp_hpred_env pe None f; + + +/** dump a strexp. */ +let d_sexp (se: strexp) => L.add_print_action (L.PTsexp, Obj.repr se); + + +/** Pretty print a list of expressions. */ +let pp_sexp_list pe f sel => + F.fprintf f "%a" (pp_seq (fun f se => F.fprintf f "%a" (pp_sexp pe) se)) sel; + + +/** dump a list of expressions. */ +let d_sexp_list (sel: list strexp) => L.add_print_action (L.PTsexp_list, Obj.repr sel); + +let rec pp_hpara_list pe f => + fun + | [] => () + | [para] => F.fprintf f "PRED: %a" (pp_hpara pe) para + | [para, ...paras] => F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara pe) para (pp_hpara_list pe) paras; + +let rec pp_hpara_dll_list pe f => + fun + | [] => () + | [para] => F.fprintf f "PRED: %a" (pp_hpara_dll pe) para + | [para, ...paras] => + F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara_dll pe) para (pp_hpara_dll_list pe) paras; + + +/** dump a hpred. */ +let d_hpred (hpred: hpred) => L.add_print_action (L.PThpred, Obj.repr hpred); + + +/** {2 Functions for traversing SIL data types} */ +let rec strexp_expmap (f: (exp, option inst) => (exp, option inst)) => { + let fe e => fst (f (e, None)); + let fei (e, inst) => + switch (f (e, Some inst)) { + | (e', None) => (e', inst) + | (e', Some inst') => (e', inst') + }; + fun + | Eexp e inst => { + let (e', inst') = fei (e, inst); + Eexp e' inst' + } + | Estruct fld_se_list inst => { + let f_fld_se (fld, se) => (fld, strexp_expmap f se); + Estruct (IList.map f_fld_se fld_se_list) inst + } + | Earray size idx_se_list inst => { + let size' = fe size; + let f_idx_se (idx, se) => { + let idx' = fe idx; + (idx', strexp_expmap f se) + }; + Earray size' (IList.map f_idx_se idx_se_list) inst + } +}; + +let hpred_expmap (f: (exp, option inst) => (exp, option inst)) => { + let fe e => fst (f (e, None)); + fun + | Hpointsto e se te => { + let e' = fe e; + let se' = strexp_expmap f se; + let te' = fe te; + Hpointsto e' se' te' + } + | Hlseg k hpara root next shared => { + let root' = fe root; + let next' = fe next; + let shared' = IList.map fe shared; + Hlseg k hpara root' next' shared' + } + | Hdllseg k hpara iF oB oF iB shared => { + let iF' = fe iF; + let oB' = fe oB; + let oF' = fe oF; + let iB' = fe iB; + let shared' = IList.map fe shared; + Hdllseg k hpara iF' oB' oF' iB' shared' + } +}; + +let rec strexp_instmap (f: inst => inst) strexp => + switch strexp { + | Eexp e inst => Eexp e (f inst) + | Estruct fld_se_list inst => + let f_fld_se (fld, se) => (fld, strexp_instmap f se); + Estruct (IList.map f_fld_se fld_se_list) (f inst) + | Earray size idx_se_list inst => + let f_idx_se (idx, se) => (idx, strexp_instmap f se); + Earray size (IList.map f_idx_se idx_se_list) (f inst) + } +and hpara_instmap (f: inst => inst) hpara => { + ...hpara, + body: IList.map (hpred_instmap f) hpara.body +} +and hpara_dll_instmap (f: inst => inst) hpara_dll => { + ...hpara_dll, + body_dll: IList.map (hpred_instmap f) hpara_dll.body_dll +} +and hpred_instmap (fn: inst => inst) (hpred: hpred) :hpred => + switch hpred { + | Hpointsto e se te => + let se' = strexp_instmap fn se; + Hpointsto e se' te + | Hlseg k hpara e f el => Hlseg k (hpara_instmap fn hpara) e f el + | Hdllseg k hpar_dll e f g h el => Hdllseg k (hpara_dll_instmap fn hpar_dll) e f g h el + }; + +let hpred_list_expmap (f: (exp, option inst) => (exp, option inst)) (hlist: list hpred) => + IList.map (hpred_expmap f) hlist; + +let atom_expmap (f: exp => exp) => + fun + | Aeq e1 e2 => Aeq (f e1) (f e2) + | Aneq e1 e2 => Aneq (f e1) (f e2); + +let atom_list_expmap (f: exp => exp) (alist: list atom) => IList.map (atom_expmap f) alist; + + +/** {2 Function for computing lexps in sigma} */ +let hpred_get_lexp acc => + fun + | Hpointsto e _ _ => [e, ...acc] + | Hlseg _ _ e _ _ => [e, ...acc] + | Hdllseg _ _ e1 _ _ e2 _ => [e1, e2, ...acc]; + +let hpred_list_get_lexps (filter: exp => bool) (hlist: list hpred) :list exp => { + let lexps = IList.fold_left hpred_get_lexp [] hlist; + IList.filter filter lexps +}; + + +/** {2 Utility Functions for Expressions} */ +let unsome_typ s => + fun + | Some default_typ => default_typ + | None => { + L.err "No default typ in %s@." s; + assert false + }; + + +/** Turn an expression representing a type into the type it represents + If not a sizeof, return the default type if given, otherwise raise an exception */ +let texp_to_typ default_opt => + fun + | Sizeof t _ => t + | _ => unsome_typ "texp_to_typ" default_opt; + + +/** If a struct type with field f, return the type of f. + If not, return the default type if given, otherwise raise an exception */ +let struct_typ_fld default_opt f => { + let def () => unsome_typ "struct_typ_fld" default_opt; + fun + | Tstruct struct_typ => + try ( + (fun (_, y, _) => y) ( + IList.find (fun (_f, _, _) => Ident.fieldname_equal _f f) struct_typ.instance_fields + ) + ) { + | Not_found => def () + } + | _ => def () +}; + + +/** If an array type, return the type of the element. + If not, return the default type if given, otherwise raise an exception */ +let array_typ_elem default_opt => + fun + | Tarray t_el _ => t_el + | _ => unsome_typ "array_typ_elem" default_opt; + + +/** Return the root of [lexp]. */ +let rec root_of_lexp lexp => + switch lexp { + | Var _ => lexp + | Const _ => lexp + | Cast _ e => root_of_lexp e + | UnOp _ + | BinOp _ => lexp + | Lvar _ => lexp + | Lfield e _ _ => root_of_lexp e + | Lindex e _ => root_of_lexp e + | Sizeof _ => lexp + }; + + +/** Checks whether an expression denotes a location by pointer arithmetic. + Currently, catches array - indexing expressions such as a[i] only. */ +let rec exp_pointer_arith = + fun + | Lfield e _ _ => exp_pointer_arith e + | Lindex _ => true + | _ => false; + +let exp_get_undefined footprint => + Var ( + Ident.create_fresh ( + if footprint { + Ident.kfootprint + } else { + Ident.kprimed + } + ) + ); + + +/** Create integer constant */ +let exp_int i => Const (Cint i); + + +/** Create float constant */ +let exp_float v => Const (Cfloat v); + + +/** Integer constant 0 */ +let exp_zero = exp_int Int.zero; + + +/** Null constant */ +let exp_null = exp_int Int.null; + + +/** Integer constant 1 */ +let exp_one = exp_int Int.one; + + +/** Integer constant -1 */ +let exp_minus_one = exp_int Int.minus_one; + + +/** Create integer constant corresponding to the boolean value */ +let exp_bool b => + if b { + exp_one + } else { + exp_zero + }; + + +/** Create expresstion [e1 == e2] */ +let exp_eq e1 e2 => BinOp Eq e1 e2; + + +/** Create expresstion [e1 != e2] */ +let exp_ne e1 e2 => BinOp Ne e1 e2; + + +/** Create expression [e1 <= e2] */ +let exp_le e1 e2 => BinOp Le e1 e2; + + +/** Create expression [e1 < e2] */ +let exp_lt e1 e2 => BinOp Lt e1 e2; + + +/** {2 Functions for computing program variables} */ +let rec exp_fpv = + fun + | Var _ => [] + | Const (Cexn e) => exp_fpv e + | Const (Cclosure {captured_vars}) => IList.map (fun (_, pvar, _) => pvar) captured_vars + | Const _ => [] + | Cast _ e + | UnOp _ e _ => exp_fpv e + | BinOp _ e1 e2 => exp_fpv e1 @ exp_fpv e2 + | Lvar name => [name] + | Lfield e _ _ => exp_fpv e + | Lindex e1 e2 => exp_fpv e1 @ exp_fpv e2 + | Sizeof _ => [] +and exp_list_fpv el => IList.flatten (IList.map exp_fpv el); + +let atom_fpv = + fun + | Aeq e1 e2 => exp_fpv e1 @ exp_fpv e2 + | Aneq e1 e2 => exp_fpv e1 @ exp_fpv e2; + +let rec strexp_fpv = + fun + | Eexp e _ => exp_fpv e + | Estruct fld_se_list _ => { + let f (_, se) => strexp_fpv se; + IList.flatten (IList.map f fld_se_list) + } + | Earray size idx_se_list _ => { + let fpv_in_size = exp_fpv size; + let f (idx, se) => exp_fpv idx @ strexp_fpv se; + fpv_in_size @ IList.flatten (IList.map f idx_se_list) + } +and hpred_fpv = + fun + | Hpointsto base se te => exp_fpv base @ strexp_fpv se @ exp_fpv te + | Hlseg _ para e1 e2 elist => { + let fpvars_in_elist = exp_list_fpv elist; + hpara_fpv para @ /* This set has to be empty. */ exp_fpv e1 @ exp_fpv e2 @ fpvars_in_elist + } + | Hdllseg _ para e1 e2 e3 e4 elist => { + let fpvars_in_elist = exp_list_fpv elist; + hpara_dll_fpv para @ + /* This set has to be empty. */ + exp_fpv e1 @ + exp_fpv e2 @ + exp_fpv e3 @ + exp_fpv e4 @ + fpvars_in_elist + } +/** hpara should not contain any program variables. + This is because it might cause problems when we do interprocedural + analysis. In interprocedural analysis, we should consider the issue + of scopes of program variables. */ +and hpara_fpv para => { + let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body); + switch fpvars_in_body { + | [] => [] + | _ => assert false + } +} +/** hpara_dll should not contain any program variables. + This is because it might cause problems when we do interprocedural + analysis. In interprocedural analysis, we should consider the issue + of scopes of program variables. */ +and hpara_dll_fpv para => { + let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body_dll); + switch fpvars_in_body { + | [] => [] + | _ => assert false + } +}; + + +/** {2 Functions for computing free non-program variables} */ +/** Type of free variables. These include primed, normal and footprint variables. + We keep a count of how many types the variables appear. */ +type fav = ref (list Ident.t); + +let fav_new () => ref []; + + +/** Emptyness check. */ +let fav_is_empty fav => + switch !fav { + | [] => true + | _ => false + }; + + +/** Check whether a predicate holds for all elements. */ +let fav_for_all fav predicate => IList.for_all predicate !fav; + + +/** Check whether a predicate holds for some elements. */ +let fav_exists fav predicate => IList.exists predicate !fav; + + +/** flag to indicate whether fav's are stored in duplicate form. + Only to be used with fav_to_list */ +let fav_duplicates = ref false; + + +/** extend [fav] with a [id] */ +let (++) fav id => + if (!fav_duplicates || not (IList.exists (Ident.equal id) !fav)) { + fav := [id, ...!fav] + }; + + +/** extend [fav] with ident list [idl] */ +let (+++) fav idl => IList.iter (fun id => fav ++ id) idl; + + +/** add identity lists to fav */ +let ident_list_fav_add idl fav => fav +++ idl; + + +/** Convert a list to a fav. */ +let fav_from_list l => { + let fav = fav_new (); + let _ = IList.iter (fun id => fav ++ id) l; + fav +}; + +let rec remove_duplicates_from_sorted special_equal => + fun + | [] => [] + | [x] => [x] + | [x, y, ...l] => + if (special_equal x y) { + remove_duplicates_from_sorted special_equal [y, ...l] + } else { + [x, ...remove_duplicates_from_sorted special_equal [y, ...l]] + }; + + +/** Convert a [fav] to a list of identifiers while preserving the order + that the identifiers were added to [fav]. */ +let fav_to_list fav => IList.rev !fav; + + +/** Pretty print a fav. */ +let pp_fav pe f fav => (pp_seq (Ident.pp pe)) f (fav_to_list fav); + + +/** Copy a [fav]. */ +let fav_copy fav => ref (IList.map (fun x => x) !fav); + + +/** Turn a xxx_fav_add function into a xxx_fav function */ +let fav_imperative_to_functional f x => { + let fav = fav_new (); + let _ = f fav x; + fav +}; + + +/** [fav_filter_ident fav f] only keeps [id] if [f id] is true. */ +let fav_filter_ident fav filter => fav := IList.filter filter !fav; + + +/** Like [fav_filter_ident] but return a copy. */ +let fav_copy_filter_ident fav filter => ref (IList.filter filter !fav); + + +/** checks whether every element in l1 appears l2 **/ +let rec ident_sorted_list_subset l1 l2 => + switch (l1, l2) { + | ([], _) => true + | ([_, ..._], []) => false + | ([id1, ...l1], [id2, ...l2]) => + let n = Ident.compare id1 id2; + if (n == 0) { + ident_sorted_list_subset l1 [id2, ...l2] + } else if (n > 0) { + ident_sorted_list_subset [id1, ...l1] l2 + } else { + false + } + }; + + +/** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] + is in [fav2].*/ +let fav_subset_ident fav1 fav2 => ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2); + +let fav_mem fav id => IList.exists (Ident.equal id) !fav; + +let rec exp_fav_add fav => + fun + | Var id => fav ++ id + | Const (Cexn e) => exp_fav_add fav e + | Const (Cclosure {captured_vars}) => + IList.iter (fun (e, _, _) => exp_fav_add fav e) captured_vars + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cattribute _ | Cclass _ | Cptr_to_fld _) => () + | Cast _ e + | UnOp _ e _ => exp_fav_add fav e + | BinOp _ e1 e2 => { + exp_fav_add fav e1; + exp_fav_add fav e2 + } + | Lvar _ => () /* do nothing since we only count non-program variables */ + | Lfield e _ _ => exp_fav_add fav e + | Lindex e1 e2 => { + exp_fav_add fav e1; + exp_fav_add fav e2 + } + | Sizeof _ => (); + +let exp_fav = fav_imperative_to_functional exp_fav_add; + +let exp_fav_list e => fav_to_list (exp_fav e); + +let ident_in_exp id e => { + let fav = fav_new (); + exp_fav_add fav e; + fav_mem fav id +}; + +let atom_fav_add fav => + fun + | Aeq e1 e2 + | Aneq e1 e2 => { + exp_fav_add fav e1; + exp_fav_add fav e2 + }; + +let atom_fav = fav_imperative_to_functional atom_fav_add; + + +/** Atoms do not contain binders */ +let atom_av_add = atom_fav_add; + +let rec strexp_fav_add fav => + fun + | Eexp e _ => exp_fav_add fav e + | Estruct fld_se_list _ => IList.iter (fun (_, se) => strexp_fav_add fav se) fld_se_list + | Earray size idx_se_list _ => { + exp_fav_add fav size; + IList.iter + ( + fun (e, se) => { + exp_fav_add fav e; + strexp_fav_add fav se + } + ) + idx_se_list + }; + +let hpred_fav_add fav => + fun + | Hpointsto base sexp te => { + exp_fav_add fav base; + strexp_fav_add fav sexp; + exp_fav_add fav te + } + | Hlseg _ _ e1 e2 elist => { + exp_fav_add fav e1; + exp_fav_add fav e2; + IList.iter (exp_fav_add fav) elist + } + | Hdllseg _ _ e1 e2 e3 e4 elist => { + exp_fav_add fav e1; + exp_fav_add fav e2; + exp_fav_add fav e3; + exp_fav_add fav e4; + IList.iter (exp_fav_add fav) elist + }; + +let hpred_fav = fav_imperative_to_functional hpred_fav_add; + + +/** This function should be used before adding a new + index to Earray. The [exp] is the newly created + index. This function "cleans" [exp] according to whether it is + the footprint or current part of the prop. + The function faults in the re - execution mode, as an internal check of the tool. */ +let array_clean_new_index footprint_part new_idx => { + if (footprint_part && not !Config.footprint) { + assert false + }; + let fav = exp_fav new_idx; + if (footprint_part && fav_exists fav (fun id => not (Ident.is_footprint id))) { + L.d_warning ( + "Array index " ^ + exp_to_string new_idx ^ " has non-footprint vars: replaced by fresh footprint var" + ); + L.d_ln (); + let id = Ident.create_fresh Ident.kfootprint; + Var id + } else { + new_idx + } +}; + + +/** {2 Functions for computing all free or bound non-program variables} */ +let exp_av_add = exp_fav_add; /** Expressions do not bind variables */ + +let strexp_av_add = strexp_fav_add; /** Structured expressions do not bind variables */ + +let rec hpara_av_add fav para => { + IList.iter (hpred_av_add fav) para.body; + fav ++ para.root; + fav ++ para.next; + fav +++ para.svars; + fav +++ para.evars +} +and hpara_dll_av_add fav para => { + IList.iter (hpred_av_add fav) para.body_dll; + fav ++ para.cell; + fav ++ para.blink; + fav ++ para.flink; + fav +++ para.svars_dll; + fav +++ para.evars_dll +} +and hpred_av_add fav => + fun + | Hpointsto base se te => { + exp_av_add fav base; + strexp_av_add fav se; + exp_av_add fav te + } + | Hlseg _ para e1 e2 elist => { + hpara_av_add fav para; + exp_av_add fav e1; + exp_av_add fav e2; + IList.iter (exp_av_add fav) elist + } + | Hdllseg _ para e1 e2 e3 e4 elist => { + hpara_dll_av_add fav para; + exp_av_add fav e1; + exp_av_add fav e2; + exp_av_add fav e3; + exp_av_add fav e4; + IList.iter (exp_av_add fav) elist + }; + +let hpara_shallow_av_add fav para => { + IList.iter (hpred_fav_add fav) para.body; + fav ++ para.root; + fav ++ para.next; + fav +++ para.svars; + fav +++ para.evars +}; + +let hpara_dll_shallow_av_add fav para => { + IList.iter (hpred_fav_add fav) para.body_dll; + fav ++ para.cell; + fav ++ para.blink; + fav ++ para.flink; + fav +++ para.svars_dll; + fav +++ para.evars_dll +}; + + +/** Variables in hpara, excluding bound vars in the body */ +let hpara_shallow_av = fav_imperative_to_functional hpara_shallow_av_add; + + +/** Variables in hpara_dll, excluding bound vars in the body */ +let hpara_dll_shallow_av = fav_imperative_to_functional hpara_dll_shallow_av_add; + + +/** {2 Functions for Substitution} */ +let rec reverse_with_base base => + fun + | [] => base + | [x, ...l] => reverse_with_base [x, ...base] l; + +let sorted_list_merge compare l1_in l2_in => { + let rec merge acc l1 l2 => + switch (l1, l2) { + | ([], l2) => reverse_with_base l2 acc + | (l1, []) => reverse_with_base l1 acc + | ([x1, ...l1'], [x2, ...l2']) => + if (compare x1 x2 <= 0) { + merge [x1, ...acc] l1' l2 + } else { + merge [x2, ...acc] l1 l2' + } + }; + merge [] l1_in l2_in +}; + +let rec sorted_list_check_consecutives f => + fun + | [] + | [_] => false + | [x1, ...[x2, ..._] as l] => + if (f x1 x2) { + true + } else { + sorted_list_check_consecutives f l + }; + + +/** substitution */ +type subst = list (Ident.t, exp); + + +/** Comparison between substitutions. */ +let rec sub_compare (sub1: subst) (sub2: subst) => + if (sub1 === sub2) { + 0 + } else { + switch (sub1, sub2) { + | ([], []) => 0 + | ([], [_, ..._]) => (-1) + | ([(i1, e1), ...sub1'], [(i2, e2), ...sub2']) => + let n = Ident.compare i1 i2; + if (n != 0) { + n + } else { + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + sub_compare sub1' sub2' + } + } + | ([_, ..._], []) => 1 + } + }; + + +/** Equality for substitutions. */ +let sub_equal sub1 sub2 => sub_compare sub1 sub2 == 0; + +let sub_check_duplicated_ids sub => { + let f (id1, _) (id2, _) => Ident.equal id1 id2; + sorted_list_check_consecutives f sub +}; + + +/** Create a substitution from a list of pairs. + For all (id1, e1), (id2, e2) in the input list, + if id1 = id2, then e1 = e2. */ +let sub_of_list sub => { + let sub' = IList.sort ident_exp_compare sub; + let sub'' = remove_duplicates_from_sorted ident_exp_equal sub'; + if (sub_check_duplicated_ids sub'') { + assert false + }; + sub' +}; + + +/** like sub_of_list, but allow duplicate ids and only keep the first occurrence */ +let sub_of_list_duplicates sub => { + let sub' = IList.sort ident_exp_compare sub; + let rec remove_duplicate_ids = + fun + | [(id1, e1), (id2, e2), ...l] => + if (Ident.equal id1 id2) { + remove_duplicate_ids [(id1, e1), ...l] + } else { + [(id1, e1), ...remove_duplicate_ids [(id2, e2), ...l]] + } + | l => l; + remove_duplicate_ids sub' +}; + + +/** Convert a subst to a list of pairs. */ +let sub_to_list sub => sub; + + +/** The empty substitution. */ +let sub_empty = sub_of_list []; + + +/** Join two substitutions into one. + For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). */ +let sub_join sub1 sub2 => { + let sub = sorted_list_merge ident_exp_compare sub1 sub2; + let sub' = remove_duplicates_from_sorted ident_exp_equal sub; + if (sub_check_duplicated_ids sub') { + assert false + }; + sub +}; + + +/** Compute the common id-exp part of two inputs [subst1] and [subst2]. + The first component of the output is this common part. + The second and third components are the remainder of [subst1] + and [subst2], respectively. */ +let sub_symmetric_difference sub1_in sub2_in => { + let rec diff sub_common sub1_only sub2_only sub1 sub2 => + switch (sub1, sub2) { + | ([], _) + | (_, []) => + let sub1_only' = reverse_with_base sub1 sub1_only; + let sub2_only' = reverse_with_base sub2 sub2_only; + let sub_common = reverse_with_base [] sub_common; + (sub_common, sub1_only', sub2_only') + | ([id_e1, ...sub1'], [id_e2, ...sub2']) => + let n = ident_exp_compare id_e1 id_e2; + if (n == 0) { + diff [id_e1, ...sub_common] sub1_only sub2_only sub1' sub2' + } else if (n < 0) { + diff sub_common [id_e1, ...sub1_only] sub2_only sub1' sub2 + } else { + diff sub_common sub1_only [id_e2, ...sub2_only] sub1 sub2' + } + }; + diff [] [] [] sub1_in sub2_in +}; + +let module Typtbl = Hashtbl.Make { + type t = typ; + let equal = typ_equal; + let hash = Hashtbl.hash; +}; + + +/** [sub_find filter sub] returns the expression associated to the first identifier + that satisfies [filter]. Raise [Not_found] if there isn't one. */ +let sub_find filter (sub: subst) => snd (IList.find (fun (i, _) => filter i) sub); + + +/** [sub_filter filter sub] restricts the domain of [sub] to the + identifiers satisfying [filter]. */ +let sub_filter filter (sub: subst) => IList.filter (fun (i, _) => filter i) sub; + + +/** [sub_filter_pair filter sub] restricts the domain of [sub] to the + identifiers satisfying [filter(id, sub(id))]. */ +let sub_filter_pair = IList.filter; + + +/** [sub_range_partition filter sub] partitions [sub] according to + whether range expressions satisfy [filter]. */ +let sub_range_partition filter (sub: subst) => IList.partition (fun (_, e) => filter e) sub; + + +/** [sub_domain_partition filter sub] partitions [sub] according to + whether domain identifiers satisfy [filter]. */ +let sub_domain_partition filter (sub: subst) => IList.partition (fun (i, _) => filter i) sub; + + +/** Return the list of identifiers in the domain of the substitution. */ +let sub_domain sub => IList.map fst sub; + + +/** Return the list of expressions in the range of the substitution. */ +let sub_range sub => IList.map snd sub; + + +/** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. */ +let sub_range_map f sub => sub_of_list (IList.map (fun (i, e) => (i, f e)) sub); + + +/** [sub_map f g sub] applies the renaming [f] to identifiers in the domain + of [sub] and the substitution [g] to the expressions in the range of [sub]. */ +let sub_map f g sub => sub_of_list (IList.map (fun (i, e) => (f i, g e)) sub); + +let mem_sub id sub => IList.exists (fun (id1, _) => Ident.equal id id1) sub; + + +/** Extend substitution and return [None] if not possible. */ +let extend_sub sub id exp :option subst => { + let compare (id1, _) (id2, _) => Ident.compare id1 id2; + if (mem_sub id sub) { + None + } else { + Some (sorted_list_merge compare sub [(id, exp)]) + } +}; + + +/** Free auxilary variables in the domain and range of the + substitution. */ +let sub_fav_add fav (sub: subst) => + IList.iter + ( + fun (id, e) => { + fav ++ id; + exp_fav_add fav e + } + ) + sub; + +let sub_fpv (sub: subst) => IList.flatten (IList.map (fun (_, e) => exp_fpv e) sub); + + +/** Substitutions do not contain binders */ +let sub_av_add = sub_fav_add; + +let rec typ_sub (subst: subst) typ => + switch typ { + | Tvar _ + | Tint _ + | Tfloat _ + | Tvoid + | Tstruct _ + | Tfun _ => typ + | Tptr t' pk => Tptr (typ_sub subst t') pk + | Tarray t e => Tarray (typ_sub subst t) (exp_sub subst e) + } +and exp_sub (subst: subst) e => + switch e { + | Var id => + let rec apply_sub = ( + fun + | [] => e + | [(i, e), ...l] => + if (Ident.equal i id) { + e + } else { + apply_sub l + } + ); + apply_sub subst + | Const (Cexn e1) => + let e1' = exp_sub subst e1; + Const (Cexn e1') + | Const (Cclosure c) => + let captured_vars = + IList.map (fun (exp, pvar, typ) => (exp_sub subst exp, pvar, typ)) c.captured_vars; + Const (Cclosure {...c, captured_vars}) + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cattribute _ | Cclass _ | Cptr_to_fld _) => e + | Cast t e1 => + let e1' = exp_sub subst e1; + Cast t e1' + | UnOp op e1 typo => + let e1' = exp_sub subst e1; + let typo' = + switch typo { + | None => None + | Some typ => Some (typ_sub subst typ) + }; + UnOp op e1' typo' + | BinOp op e1 e2 => + let e1' = exp_sub subst e1; + let e2' = exp_sub subst e2; + BinOp op e1' e2' + | Lvar _ => e + | Lfield e1 fld typ => + let e1' = exp_sub subst e1; + let typ' = typ_sub subst typ; + Lfield e1' fld typ' + | Lindex e1 e2 => + let e1' = exp_sub subst e1; + let e2' = exp_sub subst e2; + Lindex e1' e2' + | Sizeof t s => Sizeof (typ_sub subst t) s + }; + +let instr_sub (subst: subst) instr => { + let id_s id => + switch (exp_sub subst (Var id)) { + | Var id' => id' + | _ => id + }; + let exp_s = exp_sub subst; + let typ_s = typ_sub subst; + switch instr { + | Letderef id e t loc => Letderef (id_s id) (exp_s e) (typ_s t) loc + | Set e1 t e2 loc => Set (exp_s e1) (typ_s t) (exp_s e2) loc + | Prune cond loc true_branch ik => Prune (exp_s cond) loc true_branch ik + | Call ret_ids e arg_ts loc cf => + let arg_s (e, t) => (exp_s e, typ_s t); + Call (IList.map id_s ret_ids) (exp_s e) (IList.map arg_s arg_ts) loc cf + | Nullify _ => instr + | Abstract _ => instr + | Remove_temps temps loc => Remove_temps (IList.map id_s temps) loc + | Stackop _ => instr + | Declare_locals ptl loc => + let pt_s (pv, t) => (pv, typ_s t); + Declare_locals (IList.map pt_s ptl) loc + } +}; + +let call_flags_compare cflag1 cflag2 => + bool_compare cflag1.cf_virtual cflag2.cf_virtual |> + next bool_compare cflag1.cf_interface cflag2.cf_interface |> + next bool_compare cflag1.cf_noreturn cflag2.cf_noreturn |> + next bool_compare cflag1.cf_is_objc_block cflag2.cf_is_objc_block; + +let exp_typ_compare (exp1, typ1) (exp2, typ2) => { + let n = exp_compare exp1 exp2; + if (n != 0) { + n + } else { + typ_compare typ1 typ2 + } +}; + +let instr_compare instr1 instr2 => + switch (instr1, instr2) { + | (Letderef id1 e1 t1 loc1, Letderef id2 e2 t2 loc2) => + let n = Ident.compare id1 id2; + if (n != 0) { + n + } else { + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + let n = typ_compare t1 t2; + if (n != 0) { + n + } else { + Location.compare loc1 loc2 + } + } + } + | (Letderef _, _) => (-1) + | (_, Letderef _) => 1 + | (Set e11 t1 e21 loc1, Set e12 t2 e22 loc2) => + let n = exp_compare e11 e12; + if (n != 0) { + n + } else { + let n = typ_compare t1 t2; + if (n != 0) { + n + } else { + let n = exp_compare e21 e22; + if (n != 0) { + n + } else { + Location.compare loc1 loc2 + } + } + } + | (Set _, _) => (-1) + | (_, Set _) => 1 + | (Prune cond1 loc1 true_branch1 ik1, Prune cond2 loc2 true_branch2 ik2) => + let n = exp_compare cond1 cond2; + if (n != 0) { + n + } else { + let n = Location.compare loc1 loc2; + if (n != 0) { + n + } else { + let n = bool_compare true_branch1 true_branch2; + if (n != 0) { + n + } else { + Pervasives.compare ik1 ik2 + } + } + } + | (Prune _, _) => (-1) + | (_, Prune _) => 1 + | (Call ret_ids1 e1 arg_ts1 loc1 cf1, Call ret_ids2 e2 arg_ts2 loc2 cf2) => + let n = IList.compare Ident.compare ret_ids1 ret_ids2; + if (n != 0) { + n + } else { + let n = exp_compare e1 e2; + if (n != 0) { + n + } else { + let n = IList.compare exp_typ_compare arg_ts1 arg_ts2; + if (n != 0) { + n + } else { + let n = Location.compare loc1 loc2; + if (n != 0) { + n + } else { + call_flags_compare cf1 cf2 + } + } + } + } + | (Call _, _) => (-1) + | (_, Call _) => 1 + | (Nullify pvar1 loc1, Nullify pvar2 loc2) => + let n = Pvar.compare pvar1 pvar2; + if (n != 0) { + n + } else { + Location.compare loc1 loc2 + } + | (Nullify _, _) => (-1) + | (_, Nullify _) => 1 + | (Abstract loc1, Abstract loc2) => Location.compare loc1 loc2 + | (Abstract _, _) => (-1) + | (_, Abstract _) => 1 + | (Remove_temps temps1 loc1, Remove_temps temps2 loc2) => + let n = IList.compare Ident.compare temps1 temps2; + if (n != 0) { + n + } else { + Location.compare loc1 loc2 + } + | (Remove_temps _, _) => (-1) + | (_, Remove_temps _) => 1 + | (Stackop stackop1 loc1, Stackop stackop2 loc2) => + let n = Pervasives.compare stackop1 stackop2; + if (n != 0) { + n + } else { + Location.compare loc1 loc2 + } + | (Stackop _, _) => (-1) + | (_, Stackop _) => 1 + | (Declare_locals ptl1 loc1, Declare_locals ptl2 loc2) => + let pt_compare (pv1, t1) (pv2, t2) => { + let n = Pvar.compare pv1 pv2; + if (n != 0) { + n + } else { + typ_compare t1 t2 + } + }; + let n = IList.compare pt_compare ptl1 ptl2; + if (n != 0) { + n + } else { + Location.compare loc1 loc2 + } + }; + + +/** compare expressions from different procedures without considering loc's, ident's, and pvar's. + the [exp_map] param gives a mapping of names used in the procedure of [e1] to names used in the + procedure of [e2] */ +let rec exp_compare_structural e1 e2 exp_map => { + let compare_exps_with_map e1 e2 exp_map => + try { + let e1_mapping = ExpMap.find e1 exp_map; + (exp_compare e1_mapping e2, exp_map) + } { + | Not_found => + /* assume e1 and e2 equal, enforce by adding to [exp_map] */ + (0, ExpMap.add e1 e2 exp_map) + }; + switch (e1, e2) { + | (Var _, Var _) => compare_exps_with_map e1 e2 exp_map + | (UnOp o1 e1 to1, UnOp o2 e2 to2) => + let n = unop_compare o1 o2; + if (n != 0) { + (n, exp_map) + } else { + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + ( + if (n != 0) { + n + } else { + typ_opt_compare to1 to2 + }, + exp_map + ) + } + | (BinOp o1 e1 f1, BinOp o2 e2 f2) => + let n = binop_compare o1 o2; + if (n != 0) { + (n, exp_map) + } else { + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + if (n != 0) { + (n, exp_map) + } else { + exp_compare_structural f1 f2 exp_map + } + } + | (Cast t1 e1, Cast t2 e2) => + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + ( + if (n != 0) { + n + } else { + typ_compare t1 t2 + }, + exp_map + ) + | (Lvar _, Lvar _) => compare_exps_with_map e1 e2 exp_map + | (Lfield e1 f1 t1, Lfield e2 f2 t2) => + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + ( + if (n != 0) { + n + } else { + let n = fld_compare f1 f2; + if (n != 0) { + n + } else { + typ_compare t1 t2 + } + }, + exp_map + ) + | (Lindex e1 f1, Lindex e2 f2) => + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + if (n != 0) { + (n, exp_map) + } else { + exp_compare_structural f1 f2 exp_map + } + | _ => (exp_compare e1 e2, exp_map) + } +}; + +let exp_typ_compare_structural (e1, t1) (e2, t2) exp_map => { + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + ( + if (n != 0) { + n + } else { + typ_compare t1 t2 + }, + exp_map + ) +}; + + +/** compare instructions from different procedures without considering loc's, ident's, and pvar's. + the [exp_map] param gives a mapping of names used in the procedure of [instr1] to identifiers + used in the procedure of [instr2] */ +let instr_compare_structural instr1 instr2 exp_map => { + let id_list_compare_structural ids1 ids2 exp_map => { + let n = Pervasives.compare (IList.length ids1) (IList.length ids2); + if (n != 0) { + (n, exp_map) + } else { + IList.fold_left2 + ( + fun (n, exp_map) id1 id2 => + if (n != 0) { + (n, exp_map) + } else { + exp_compare_structural (Var id1) (Var id2) exp_map + } + ) + (0, exp_map) + ids1 + ids2 + } + }; + switch (instr1, instr2) { + | (Letderef id1 e1 t1 _, Letderef id2 e2 t2 _) => + let (n, exp_map) = exp_compare_structural (Var id1) (Var id2) exp_map; + if (n != 0) { + (n, exp_map) + } else { + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + ( + if (n != 0) { + n + } else { + typ_compare t1 t2 + }, + exp_map + ) + } + | (Set e11 t1 e21 _, Set e12 t2 e22 _) => + let (n, exp_map) = exp_compare_structural e11 e12 exp_map; + if (n != 0) { + (n, exp_map) + } else { + let n = typ_compare t1 t2; + if (n != 0) { + (n, exp_map) + } else { + exp_compare_structural e21 e22 exp_map + } + } + | (Prune cond1 _ true_branch1 ik1, Prune cond2 _ true_branch2 ik2) => + let (n, exp_map) = exp_compare_structural cond1 cond2 exp_map; + ( + if (n != 0) { + n + } else { + let n = bool_compare true_branch1 true_branch2; + if (n != 0) { + n + } else { + Pervasives.compare ik1 ik2 + } + }, + exp_map + ) + | (Call ret_ids1 e1 arg_ts1 _ cf1, Call ret_ids2 e2 arg_ts2 _ cf2) => + let args_compare_structural args1 args2 exp_map => { + let n = Pervasives.compare (IList.length args1) (IList.length args2); + if (n != 0) { + (n, exp_map) + } else { + IList.fold_left2 + ( + fun (n, exp_map) arg1 arg2 => + if (n != 0) { + (n, exp_map) + } else { + exp_typ_compare_structural arg1 arg2 exp_map + } + ) + (0, exp_map) + args1 + args2 + } + }; + let (n, exp_map) = id_list_compare_structural ret_ids1 ret_ids2 exp_map; + if (n != 0) { + (n, exp_map) + } else { + let (n, exp_map) = exp_compare_structural e1 e2 exp_map; + if (n != 0) { + (n, exp_map) + } else { + let (n, exp_map) = args_compare_structural arg_ts1 arg_ts2 exp_map; + ( + if (n != 0) { + n + } else { + call_flags_compare cf1 cf2 + }, + exp_map + ) + } + } + | (Nullify pvar1 _, Nullify pvar2 _) => exp_compare_structural (Lvar pvar1) (Lvar pvar2) exp_map + | (Abstract _, Abstract _) => (0, exp_map) + | (Remove_temps temps1 _, Remove_temps temps2 _) => + id_list_compare_structural temps1 temps2 exp_map + | (Stackop stackop1 _, Stackop stackop2 _) => (Pervasives.compare stackop1 stackop2, exp_map) + | (Declare_locals ptl1 _, Declare_locals ptl2 _) => + let n = Pervasives.compare (IList.length ptl1) (IList.length ptl2); + if (n != 0) { + (n, exp_map) + } else { + IList.fold_left2 + ( + fun (n, exp_map) (pv1, t1) (pv2, t2) => + if (n != 0) { + (n, exp_map) + } else { + let (n, exp_map) = exp_compare_structural (Lvar pv1) (Lvar pv2) exp_map; + if (n != 0) { + (n, exp_map) + } else { + (typ_compare t1 t2, exp_map) + } + } + ) + (0, exp_map) + ptl1 + ptl2 + } + | _ => (instr_compare instr1 instr2, exp_map) + } +}; + +let atom_sub subst => atom_expmap (exp_sub subst); + +let hpred_sub subst => { + let f (e, inst_opt) => (exp_sub subst e, inst_opt); + hpred_expmap f +}; + + +/** {2 Functions for replacing occurrences of expressions.} */ +let exp_replace_exp epairs e => + try { + let (_, e') = IList.find (fun (e1, _) => exp_equal e e1) epairs; + e' + } { + | Not_found => e + }; + +let atom_replace_exp epairs => + fun + | Aeq e1 e2 => { + let e1' = exp_replace_exp epairs e1; + let e2' = exp_replace_exp epairs e2; + Aeq e1' e2' + } + | Aneq e1 e2 => { + let e1' = exp_replace_exp epairs e1; + let e2' = exp_replace_exp epairs e2; + Aneq e1' e2' + }; + +let rec strexp_replace_exp epairs => + fun + | Eexp e inst => Eexp (exp_replace_exp epairs e) inst + | Estruct fsel inst => { + let f (fld, se) => (fld, strexp_replace_exp epairs se); + Estruct (IList.map f fsel) inst + } + | Earray size isel inst => { + let size' = exp_replace_exp epairs size; + let f (idx, se) => { + let idx' = exp_replace_exp epairs idx; + (idx', strexp_replace_exp epairs se) + }; + Earray size' (IList.map f isel) inst + }; + +let hpred_replace_exp epairs => + fun + | Hpointsto root se te => { + let root_repl = exp_replace_exp epairs root; + let strexp_repl = strexp_replace_exp epairs se; + let te_repl = exp_replace_exp epairs te; + Hpointsto root_repl strexp_repl te_repl + } + | Hlseg k para root next shared => { + let root_repl = exp_replace_exp epairs root; + let next_repl = exp_replace_exp epairs next; + let shared_repl = IList.map (exp_replace_exp epairs) shared; + Hlseg k para root_repl next_repl shared_repl + } + | Hdllseg k para e1 e2 e3 e4 shared => { + let e1' = exp_replace_exp epairs e1; + let e2' = exp_replace_exp epairs e2; + let e3' = exp_replace_exp epairs e3; + let e4' = exp_replace_exp epairs e4; + let shared_repl = IList.map (exp_replace_exp epairs) shared; + Hdllseg k para e1' e2' e3' e4' shared_repl + }; + + +/** {2 Compaction} */ +let module ExpHash = Hashtbl.Make { + type t = exp; + let equal = exp_equal; + let hash = Hashtbl.hash; +}; + +let module HpredHash = Hashtbl.Make { + type t = hpred; + let equal = hpred_equal; + let hash = Hashtbl.hash; +}; + +type sharing_env = {exph: ExpHash.t exp, hpredh: HpredHash.t hpred}; + + +/** Create a sharing env to store canonical representations */ +let create_sharing_env () => {exph: ExpHash.create 3, hpredh: HpredHash.create 3}; + + +/** Return a canonical representation of the exp */ +let exp_compact sh e => + try (ExpHash.find sh.exph e) { + | Not_found => + ExpHash.add sh.exph e e; + e + }; + +let rec sexp_compact sh se => + switch se { + | Eexp e inst => Eexp (exp_compact sh e) inst + | Estruct fsel inst => Estruct (IList.map (fun (f, se) => (f, sexp_compact sh se)) fsel) inst + | Earray _ => se + }; + + +/** Return a compact representation of the hpred */ +let _hpred_compact sh hpred => + switch hpred { + | Hpointsto e1 se e2 => + let e1' = exp_compact sh e1; + let e2' = exp_compact sh e2; + let se' = sexp_compact sh se; + Hpointsto e1' se' e2' + | Hlseg _ => hpred + | Hdllseg _ => hpred + }; + +let hpred_compact sh hpred => + try (HpredHash.find sh.hpredh hpred) { + | Not_found => + let hpred' = _hpred_compact sh hpred; + HpredHash.add sh.hpredh hpred' hpred'; + hpred' + }; + + +/** {2 Functions for constructing or destructing entities in this module} */ +/** Extract the ids and pvars from an expression */ +let exp_get_vars exp => { + let rec exp_get_vars_ exp vars => + switch exp { + | Lvar pvar => (fst vars, [pvar, ...snd vars]) + | Var id => ([id, ...fst vars], snd vars) + | Cast _ e + | UnOp _ e _ + | Lfield e _ _ + | Const (Cexn e) => exp_get_vars_ e vars + | BinOp _ e1 e2 + | Lindex e1 e2 => exp_get_vars_ e1 vars |> exp_get_vars_ e2 + | Const (Cclosure {captured_vars}) => + IList.fold_left + (fun vars_acc (captured_exp, _, _) => exp_get_vars_ captured_exp vars_acc) + vars + captured_vars + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cattribute _ | Cclass _ | Cptr_to_fld _) + | Sizeof _ => vars + }; + exp_get_vars_ exp ([], []) +}; + + +/** Compute the offset list of an expression */ +let exp_get_offsets exp => { + let rec f offlist_past e => + switch e { + | Var _ + | Const _ + | UnOp _ + | BinOp _ + | Lvar _ + | Sizeof _ => offlist_past + | Cast _ sub_exp => f offlist_past sub_exp + | Lfield sub_exp fldname typ => f [Off_fld fldname typ, ...offlist_past] sub_exp + | Lindex sub_exp e => f [Off_index e, ...offlist_past] sub_exp + }; + f [] exp +}; + +let exp_add_offsets exp offsets => { + let rec f acc => + fun + | [] => acc + | [Off_fld fld typ, ...offs'] => f (Lfield acc fld typ) offs' + | [Off_index e, ...offs'] => f (Lindex acc e) offs'; + f exp offsets +}; + + +/** Convert all the lseg's in sigma to nonempty lsegs. */ +let sigma_to_sigma_ne sigma :list (list atom, list hpred) => + if Config.nelseg { + let f eqs_sigma_list hpred => + switch hpred { + | Hpointsto _ + | Hlseg Lseg_NE _ _ _ _ + | Hdllseg Lseg_NE _ _ _ _ _ _ => + let g (eqs, sigma) => (eqs, [hpred, ...sigma]); + IList.map g eqs_sigma_list + | Hlseg Lseg_PE para e1 e2 el => + let g (eqs, sigma) => [ + ([Aeq e1 e2, ...eqs], sigma), + (eqs, [Hlseg Lseg_NE para e1 e2 el, ...sigma]) + ]; + IList.flatten (IList.map g eqs_sigma_list) + | Hdllseg Lseg_PE para_dll e1 e2 e3 e4 el => + let g (eqs, sigma) => [ + ([Aeq e1 e3, Aeq e2 e4, ...eqs], sigma), + (eqs, [Hdllseg Lseg_NE para_dll e1 e2 e3 e4 el, ...sigma]) + ]; + IList.flatten (IList.map g eqs_sigma_list) + }; + IList.fold_left f [([], [])] sigma + } else { + [([], sigma)] + }; + + +/** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], + [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], + then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] + for some fresh [_zs'].*/ +let hpara_instantiate para e1 e2 elist => { + let subst_for_svars = { + let g id e => (id, e); + try (IList.map2 g para.svars elist) { + | Invalid_argument _ => assert false + } + }; + let ids_evars = { + let g _ => Ident.create_fresh Ident.kprimed; + IList.map g para.evars + }; + let subst_for_evars = { + let g id id' => (id, Var id'); + try (IList.map2 g para.evars ids_evars) { + | Invalid_argument _ => assert false + } + }; + let subst = sub_of_list ( + [(para.root, e1), (para.next, e2), ...subst_for_svars] @ subst_for_evars + ); + (ids_evars, IList.map (hpred_sub subst) para.body) +}; + + +/** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], + [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], + then the result of the instantiation is + [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] + for some fresh [_zs'].*/ +let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist => { + let subst_for_svars = { + let g id e => (id, e); + try (IList.map2 g para.svars_dll elist) { + | Invalid_argument _ => assert false + } + }; + let ids_evars = { + let g _ => Ident.create_fresh Ident.kprimed; + IList.map g para.evars_dll + }; + let subst_for_evars = { + let g id id' => (id, Var id'); + try (IList.map2 g para.evars_dll ids_evars) { + | Invalid_argument _ => assert false + } + }; + let subst = sub_of_list ( + [(para.cell, cell), (para.blink, blink), (para.flink, flink), ...subst_for_svars] @ subst_for_evars + ); + (ids_evars, IList.map (hpred_sub subst) para.body_dll) +}; + +let custom_error = Pvar.mk_global (Mangled.from_string "INFER_CUSTOM_ERROR"); diff --git a/infer/src/IR/Sil.rei b/infer/src/IR/Sil.rei new file mode 100644 index 000000000..5883532d7 --- /dev/null +++ b/infer/src/IR/Sil.rei @@ -0,0 +1,1478 @@ +/* + * 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; + + +/** The Smallfoot Intermediate Language */ +let module F = Format; + + +/** {2 Programs and Types} */ +/** Type to represent one @Annotation. */ +type annotation = { + class_name: string, /* name of the annotation */ + parameters: list string + /* currently only one string parameter */ +}; + + +/** Annotation for one item: a list of annotations with visibility. */ +type item_annotation = list (annotation, bool); + + +/** Annotation for a method: return value and list of parameters. */ +type method_annotation = (item_annotation, list item_annotation); + +type func_attribute = | FA_sentinel of int int; + + +/** Visibility modifiers. */ +type access = | Default | Public | Private | Protected; + + +/** Unary operations */ +type unop = + | Neg /** Unary minus */ + | BNot /** Bitwise complement (~) */ + | LNot /** Logical Not (!) */; + + +/** Binary operations */ +type binop = + | PlusA /** arithmetic + */ + | PlusPI /** pointer + integer */ + | MinusA /** arithmetic - */ + | MinusPI /** pointer - integer */ + | MinusPP /** pointer - pointer */ + | Mult /** * */ + | Div /** / */ + | Mod /** % */ + | Shiftlt /** shift left */ + | Shiftrt /** shift right */ + | Lt /** < (arithmetic comparison) */ + | Gt /** > (arithmetic comparison) */ + | Le /** <= (arithmetic comparison) */ + | Ge /** >= (arithmetic comparison) */ + | Eq /** == (arithmetic comparison) */ + | Ne /** != (arithmetic comparison) */ + | BAnd /** bitwise and */ + | BXor /** exclusive-or */ + | BOr /** inclusive-or */ + | LAnd /** logical and. Does not always evaluate both operands. */ + | LOr /** logical or. Does not always evaluate both operands. */ + | PtrFld /** field offset via pointer to field: takes the address of a + Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) */; + + +/** Kinds of integers */ +type ikind = + | IChar /** [char] */ + | ISChar /** [signed char] */ + | IUChar /** [unsigned char] */ + | IBool /** [bool] */ + | IInt /** [int] */ + | IUInt /** [unsigned int] */ + | IShort /** [short] */ + | IUShort /** [unsigned short] */ + | ILong /** [long] */ + | IULong /** [unsigned long] */ + | ILongLong /** [long long] (or [_int64] on Microsoft Visual C) */ + | IULongLong /** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) */ + | I128 /** [__int128_t] */ + | IU128 /** [__uint128_t] */; + + +/** Kinds of floating-point numbers*/ +type fkind = + | FFloat /** [float] */ + | FDouble /** [double] */ + | FLongDouble /** [long double] */; + +type mem_kind = + | Mmalloc /** memory allocated with malloc */ + | Mnew /** memory allocated with new */ + | Mnew_array /** memory allocated with new[] */ + | Mobjc /** memory allocated with objective-c alloc */; + + +/** resource that can be allocated */ +type resource = | Rmemory of mem_kind | Rfile | Rignore | Rlock; + + +/** kind of resource action */ +type res_act_kind = | Racquire | Rrelease; + + +/** kind of dangling pointers */ +type dangling_kind = + /** pointer is dangling because it is uninitialized */ + | DAuninit + /** pointer is dangling because it is the address of a stack variable which went out of scope */ + | DAaddr_stack_var + /** pointer is -1 */ + | DAminusone; + + +/** kind of pointer */ +type ptr_kind = + | Pk_pointer /* C/C++, Java, Objc standard/__strong pointer*/ + | Pk_reference /* C++ reference */ + | Pk_objc_weak /* Obj-C __weak pointer*/ + | Pk_objc_unsafe_unretained /* Obj-C __unsafe_unretained pointer */ + | Pk_objc_autoreleasing /* Obj-C __autoreleasing pointer */; + + +/** position in a path: proc name, node id */ +type path_pos = (Procname.t, int); + + +/** module for subtypes, to be used with Sizeof info */ +let module Subtype: { + type t; + let exact: t; /** denotes the current type only */ + let subtypes: t; /** denotes the current type and any subtypes */ + let subtypes_cast: t; + let subtypes_instof: t; + let join: t => t => t; + + /** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according + to [st1] and [st2] where f c1 c2 is true if c1 is a subtype of c2. + get_subtypes returning a pair: + - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] + - whether [st1] and [st2] admit [not(c1 <: c2)], and in case return + the updated subtype [st1] */ + let case_analysis: + (Typename.t, t) => + (Typename.t, t) => + (Typename.t => Typename.t => bool) => + (Typename.t => bool) => + (option t, option t); + let check_subtype: (Typename.t => Typename.t => bool) => Typename.t => Typename.t => bool; + let subtypes_to_string: t => string; + let is_cast: t => bool; + let is_instof: t => bool; + + /** equality ignoring flags in the subtype */ + let equal_modulo_flag: t => t => bool; +}; + + +/** module for signed and unsigned integers */ +let module Int: { + type t; + let add: t => t => t; + + /** compare the value of the integers, notice this is different from const compare, + which distinguished between signed and unsigned +1 */ + let compare_value: t => t => int; + let div: t => t => t; + let eq: t => t => bool; + let of_int: int => t; + let of_int32: int32 => t; + let of_int64: int64 => t; + let geq: t => t => bool; + let gt: t => t => bool; + let isminusone: t => bool; + let isnegative: t => bool; + let isnull: t => bool; + let isone: t => bool; + let iszero: t => bool; + let leq: t => t => bool; + let logand: t => t => t; + let lognot: t => t; + let logor: t => t => t; + let logxor: t => t => t; + let lt: t => t => bool; + let minus_one: t; + let mul: t => t => t; + let neg: t => t; + let neq: t => t => bool; + let null: t; /** null behaves like zero except for the function isnull */ + let one: t; + let pp: F.formatter => t => unit; + let rem: t => t => t; + let sub: t => t => t; + let to_int: t => int; + let to_signed: t => option t; /** convert to signed if the value is representable */ + let to_string: t => string; + let two: t; + let zero: t; +}; + + +/** Flags for a procedure call */ +type call_flags = { + cf_virtual: bool, + cf_interface: bool, + cf_noreturn: bool, + cf_is_objc_block: bool, + cf_targets: list Procname.t +}; + + +/** Default value for call_flags where all fields are set to false */ +let cf_default: call_flags; + + +/** expression representing the result of decompilation */ +type dexp = + | Darray of dexp dexp + | Dbinop of binop dexp dexp + | Dconst of const + | Dsizeof of typ Subtype.t + | Dderef of dexp + | Dfcall of dexp (list dexp) Location.t call_flags + | Darrow of dexp Ident.fieldname + | Ddot of dexp Ident.fieldname + | Dpvar of Pvar.t + | Dpvaraddr of Pvar.t + | Dunop of unop dexp + | Dunknown + | Dretcall of dexp (list dexp) Location.t call_flags +/** Value paths: identify an occurrence of a value in a symbolic heap + each expression represents a path, with Dpvar being the simplest one */ +and vpath = option dexp +/** acquire/release action on a resource */ +and res_action = { + ra_kind: res_act_kind, /** kind of action */ + ra_res: resource, /** kind of resource */ + ra_pname: Procname.t, /** name of the procedure used to acquire/release the resource */ + ra_loc: Location.t, /** location of the acquire/release */ + ra_vpath: vpath /** vpath of the resource value */ +} +and taint_kind = + | Tk_unverified_SSL_socket + | Tk_shared_preferences_data + | Tk_privacy_annotation + | Tk_integrity_annotation + | Tk_unknown +and taint_info = {taint_source: Procname.t, taint_kind: taint_kind} +/** Attributes */ +and attribute = + | Aresource of res_action /** resource acquire/release */ + | Aautorelease + | Adangling of dangling_kind /** dangling pointer */ + /** undefined value obtained by calling the given procedure */ + | Aundef of Procname.t item_annotation Location.t path_pos + | Ataint of taint_info + | Auntaint + | Alocked + | Aunlocked + /** value appeared in second argument of division at given path position */ + | Adiv0 of path_pos + /** the exp. is null because of a call to a method with exp as a null receiver */ + | Aobjc_null of exp + /** value was returned from a call to the given procedure */ + | Aretval of Procname.t item_annotation + /** denotes an object registered as an observers to a notification center */ + | Aobserver + /** denotes an object unsubscribed from observers of a notification center */ + | Aunsubscribed_observer +/** Categories of attributes */ +and attribute_category = + | ACresource + | ACautorelease + | ACtaint + | AClock + | ACdiv0 + | ACobjc_null + | ACundef + | ACretval + | ACobserver +and closure = {name: Procname.t, captured_vars: list (exp, Pvar.t, typ)} +/** Constants */ +and const = + | Cint of Int.t /** integer constants */ + | Cfun of Procname.t /** function names */ + | Cstr of string /** string constants */ + | Cfloat of float /** float constants */ + | Cattribute of attribute /** attribute used in disequalities to annotate a value */ + | Cexn of exp /** exception */ + | Cclass of Ident.name /** class constant */ + | Cptr_to_fld of Ident.fieldname typ /** pointer to field constant, + and type of the surrounding Csu.t type */ + | Cclosure of closure /** anonymous function */ +and struct_fields = list (Ident.fieldname, typ, item_annotation) +/** Type for a structured value. */ +and struct_typ = { + instance_fields: struct_fields, /** non-static fields */ + static_fields: struct_fields, /** static fields */ + csu: Csu.t, /** class/struct/union */ + struct_name: option Mangled.t, /** name */ + superclasses: list Typename.t, /** list of superclasses */ + def_methods: list Procname.t, /** methods defined */ + struct_annotations: item_annotation /** annotations */ +} +/** Types for sil (structured) expressions. */ +and typ = + | Tvar of Typename.t /** named type */ + | Tint of ikind /** integer type */ + | Tfloat of fkind /** float type */ + | Tvoid /** void type */ + | Tfun of bool /** function type with noreturn attribute */ + | Tptr of typ ptr_kind /** pointer type */ + | Tstruct of struct_typ /** Type for a structured value */ + | Tarray of typ exp /** array type with fixed size */ +/** Program expressions. */ +and exp = + /** Pure variable: it is not an lvalue */ + | Var of Ident.t + /** Unary operator with type of the result if known */ + | UnOp of unop exp (option typ) + /** Binary operator */ + | BinOp of binop exp exp + /** Constants */ + | Const of const + /** Type cast */ + | Cast of typ exp + /** The address of a program variable */ + | Lvar of Pvar.t + /** A field offset, the type is the surrounding struct type */ + | Lfield of exp Ident.fieldname typ + /** An array index offset: [exp1\[exp2\]] */ + | Lindex of exp exp + /** A sizeof expression */ + | Sizeof of typ Subtype.t; + +let struct_typ_equal: struct_typ => struct_typ => bool; + + +/** Sets of types. */ +let module StructTypSet: Set.S with type elt = struct_typ; + +let module TypSet: Set.S with type elt = typ; + + +/** Maps with type keys. */ +let module TypMap: Map.S with type key = typ; + + +/** Sets of expressions. */ +let module ExpSet: Set.S with type elt = exp; + + +/** Maps with expression keys. */ +let module ExpMap: Map.S with type key = exp; + + +/** Hashtable with expressions as keys. */ +let module ExpHash: Hashtbl.S with type key = exp; + + +/** Convert expression lists to expression sets. */ +let elist_to_eset: list exp => ExpSet.t; + + +/** Kind of prune instruction */ +type if_kind = + | Ik_bexp /* boolean expressions, and exp ? exp : exp */ + | Ik_dowhile + | Ik_for + | Ik_if + | Ik_land_lor /* obtained from translation of && or || */ + | Ik_while + | Ik_switch; + + +/** Stack operation for symbolic execution on propsets */ +type stackop = + | Push /* copy the curreny propset to the stack */ + | Swap /* swap the current propset and the top of the stack */ + | Pop /* pop the stack and combine with the current propset */; + + +/** An instruction. */ +type instr = + /** declaration [let x = *lexp:typ] where [typ] is the root type of [lexp] */ + | Letderef of Ident.t exp typ Location.t + /** assignment [*lexp1:typ = exp2] where [typ] is the root type of [lexp1] */ + | Set of exp typ exp Location.t + /** prune the state based on [exp=1], the boolean indicates whether true branch */ + | Prune of exp Location.t bool if_kind + /** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions + [ret_id1..ret_idn = e_fun(arg_ts);] + where n = 0 for void return and n > 1 for struct return */ + | Call of (list Ident.t) exp (list (exp, typ)) Location.t call_flags + /** nullify stack variable */ + | Nullify of Pvar.t Location.t + | Abstract of Location.t /** apply abstraction */ + | Remove_temps of (list Ident.t) Location.t /** remove temporaries */ + | Stackop of stackop Location.t /** operation on the stack of propsets */ + | Declare_locals of (list (Pvar.t, typ)) Location.t /** declare local variables */; + + +/** Check if an instruction is auxiliary, or if it comes from source instructions. */ +let instr_is_auxiliary: instr => bool; + + +/** Offset for an lvalue. */ +type offset = | Off_fld of Ident.fieldname typ | Off_index of exp; + + +/** {2 Components of Propositions} */ +/** an atom is a pure atomic formula */ +type atom = + | Aeq of exp exp /** equality */ + | Aneq of exp exp /** disequality*/; + + +/** kind of lseg or dllseg predicates */ +type lseg_kind = + | Lseg_NE /** nonempty (possibly circular) listseg */ + | Lseg_PE /** possibly empty (possibly circular) listseg */; + + +/** The boolean is true when the pointer was dereferenced without testing for zero. */ +type zero_flag = option bool; + + +/** True when the value was obtained by doing case analysis on null in a procedure call. */ +type null_case_flag = bool; + + +/** instrumentation of heap values */ +type inst = + | Iabstraction + | Iactual_precondition + | Ialloc + | Iformal of zero_flag null_case_flag + | Iinitial + | Ilookup + | Inone + | Inullify + | Irearrange of zero_flag null_case_flag int path_pos + | Itaint + | Iupdate of zero_flag null_case_flag int path_pos + | Ireturn_from_call of int + | Ireturn_from_pointer_wrapper_call of int; + +let inst_abstraction: inst; + +let inst_actual_precondition: inst; + +let inst_alloc: inst; + +let inst_formal: inst; /** for formal parameters and heap values at the beginning of the function */ + +let inst_initial: inst; /** for initial values */ + +let inst_lookup: inst; + +let inst_none: inst; + +let inst_nullify: inst; + + +/** the boolean indicates whether the pointer is known nonzero */ +let inst_rearrange: bool => Location.t => path_pos => inst; + +let inst_taint: inst; + +let inst_update: Location.t => path_pos => inst; + + +/** Get the null case flag of the inst. */ +let inst_get_null_case_flag: inst => option bool; + + +/** Set the null case flag of the inst. */ +let inst_set_null_case_flag: inst => inst; + + +/** update the location of the instrumentation */ +let inst_new_loc: Location.t => inst => inst; + + +/** Update [inst_old] to [inst_new] preserving the zero flag */ +let update_inst: inst => inst => inst; + + +/** join of instrumentations */ +let inst_partial_join: inst => inst => inst; + + +/** meet of instrumentations */ +let inst_partial_meet: inst => inst => inst; + + +/** structured expressions represent a value of structured type, such as an array or a struct. */ +type strexp = + | Eexp of exp inst /** Base case: expression with instrumentation */ + | Estruct of (list (Ident.fieldname, strexp)) inst /** C structure */ + | Earray of exp (list (exp, strexp)) inst /** Array of given size. */ +/** There are two conditions imposed / used in the array case. + First, if some index and value pair appears inside an array + in a strexp, then the index is less than the size of the array. + For instance, x |->[10 | e1: v1] implies that e1 <= 9. + Second, if two indices appear in an array, they should be different. + For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. */ +/** an atomic heap predicate */ +and hpred = + | Hpointsto of exp strexp exp + /** represents [exp|->strexp:typexp] where [typexp] + is an expression representing a type, e.h. [sizeof(t)]. */ + | Hlseg of lseg_kind hpara exp exp (list exp) + /** higher - order predicate for singly - linked lists. + Should ensure that exp1!= exp2 implies that exp1 is allocated. + This assumption is used in the rearrangement. The last [exp list] parameter + is used to denote the shared links by all the nodes in the list.*/ + | Hdllseg of lseg_kind hpara_dll exp exp exp exp (list exp) +/** higher-order predicate for doubly-linked lists. */ +/** parameter for the higher-order singly-linked list predicate. + Means "lambda (root,next,svars). Exists evars. body". + Assume that root, next, svars, evars are disjoint sets of + primed identifiers, and include all the free primed identifiers in body. + body should not contain any non - primed identifiers or program + variables (i.e. pvars). */ +and hpara = { + root: Ident.t, + next: Ident.t, + svars: list Ident.t, + evars: list Ident.t, + body: list hpred +} +/** parameter for the higher-order doubly-linked list predicates. + Assume that all the free identifiers in body_dll should belong to + cell, blink, flink, svars_dll, evars_dll. */ +and hpara_dll = { + cell: Ident.t, /** address cell */ + blink: Ident.t, /** backward link */ + flink: Ident.t, /** forward link */ + svars_dll: list Ident.t, + evars_dll: list Ident.t, + body_dll: list hpred +}; + + +/** Sets of heap predicates */ +let module HpredSet: Set.S with type elt = hpred; + + +/** {2 Compaction} */ +type sharing_env; + + +/** Create a sharing env to store canonical representations */ +let create_sharing_env: unit => sharing_env; + + +/** Return a canonical representation of the exp */ +let exp_compact: sharing_env => exp => exp; + + +/** Return a compact representation of the exp */ +let hpred_compact: sharing_env => hpred => hpred; + + +/** {2 Comparision And Inspection Functions} */ +let is_objc_ref_counter_field: (Ident.fieldname, typ, item_annotation) => bool; + +let has_objc_ref_counter: hpred => bool; + +let objc_class_annotation: list (annotation, bool); + +let cpp_class_annotation: list (annotation, bool); + +let is_objc_class: typ => bool; + +let is_cpp_class: typ => bool; + +let is_java_class: typ => bool; + +let is_array_of_cpp_class: typ => bool; + +let is_pointer_to_cpp_class: typ => bool; + +let exp_is_zero: exp => bool; + +let exp_is_null_literal: exp => bool; + + +/** return true if [exp] is the special this/self expression */ +let exp_is_this: exp => bool; + +let path_pos_equal: path_pos => path_pos => bool; + + +/** turn a *T into a T. fails if [typ] is not a pointer type */ +let typ_strip_ptr: typ => typ; + +let zero_value_of_numerical_type: typ => exp; + + +/** Make a static local name in objc */ +let mk_static_local_name: string => string => string; + + +/** Check if a pvar is a local static in objc */ +let is_static_local_name: string => Pvar.t => bool; + +/* A block pvar used to explain retain cycles */ +let block_pvar: Pvar.t; + + +/** Check if a pvar is a local pointing to a block in objc */ +let is_block_pvar: Pvar.t => bool; + + +/** Check if type is a type for a block in objc */ +let is_block_type: typ => bool; + + +/** Comparision for fieldnames. */ +let fld_compare: Ident.fieldname => Ident.fieldname => int; + + +/** Equality for fieldnames. */ +let fld_equal: Ident.fieldname => Ident.fieldname => bool; + + +/** Check wheter the integer kind is a char */ +let ikind_is_char: ikind => bool; + + +/** Check wheter the integer kind is unsigned */ +let ikind_is_unsigned: ikind => bool; + + +/** Convert an int64 into an Int.t given the kind: + the int64 is interpreted as unsigned according to the kind */ +let int_of_int64_kind: int64 => ikind => Int.t; + + +/** Comparision for ptr_kind */ +let ptr_kind_compare: ptr_kind => ptr_kind => int; + + +/** Comparision for types. */ +let typ_compare: typ => typ => int; + + +/** Equality for types. */ +let typ_equal: typ => typ => bool; + + +/** Comparision for fieldnames * types * item annotations. */ +let fld_typ_ann_compare: + (Ident.fieldname, typ, item_annotation) => (Ident.fieldname, typ, item_annotation) => int; + +let unop_equal: unop => unop => bool; + +let binop_equal: binop => binop => bool; + + +/** This function returns true if the operation is injective + wrt. each argument: op(e,-) and op(-, e) is injective for all e. + The return value false means "don't know". */ +let binop_injective: binop => bool; + + +/** This function returns true if the operation can be inverted. */ +let binop_invertible: binop => bool; + + +/** This function inverts an injective binary operator + with respect to the first argument. It returns an expression [e'] such that + BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, + the function raises an exception by calling "assert false". */ +let binop_invert: binop => exp => exp => exp; + + +/** This function returns true if 0 is the right unit of [binop]. + The return value false means "don't know". */ +let binop_is_zero_runit: binop => bool; + +let mem_kind_compare: mem_kind => mem_kind => int; + +let attribute_compare: attribute => attribute => int; + +let attribute_equal: attribute => attribute => bool; + +let attribute_category_compare: attribute_category => attribute_category => int; + +let attribute_category_equal: attribute_category => attribute_category => bool; + + +/** Return the category to which the attribute belongs. */ +let attribute_to_category: attribute => attribute_category; + +let attr_is_undef: attribute => bool; + +let const_compare: const => const => int; + +let const_equal: const => const => bool; + + +/** Return true if the constants have the same kind (both integers, ...) */ +let const_kind_equal: const => const => bool; + +let exp_compare: exp => exp => int; + +let exp_equal: exp => exp => bool; + + +/** exp_is_array_index_of index arr returns true is index is an array index of arr. */ +let exp_is_array_index_of: exp => exp => bool; + +let call_flags_compare: call_flags => call_flags => int; + +let exp_typ_compare: (exp, typ) => (exp, typ) => int; + +let instr_compare: instr => instr => int; + + +/** compare instructions from different procedures without considering loc's, ident's, and pvar's. + the [exp_map] param gives a mapping of names used in the procedure of [instr1] to identifiers + used in the procedure of [instr2] */ +let instr_compare_structural: instr => instr => ExpMap.t exp => (int, ExpMap.t exp); + +let exp_list_compare: list exp => list exp => int; + +let exp_list_equal: list exp => list exp => bool; + +let atom_compare: atom => atom => int; + +let atom_equal: atom => atom => bool; + +let strexp_compare: strexp => strexp => int; + +let strexp_equal: strexp => strexp => bool; + +let hpara_compare: hpara => hpara => int; + +let hpara_equal: hpara => hpara => bool; + +let hpara_dll_compare: hpara_dll => hpara_dll => int; + +let hpara_dll_equal: hpara_dll => hpara_dll => bool; + +let lseg_kind_compare: lseg_kind => lseg_kind => int; + +let lseg_kind_equal: lseg_kind => lseg_kind => bool; + +let hpred_compare: hpred => hpred => int; + +let hpred_equal: hpred => hpred => bool; + +let fld_strexp_compare: (Ident.fieldname, strexp) => (Ident.fieldname, strexp) => int; + +let fld_strexp_list_compare: + list (Ident.fieldname, strexp) => list (Ident.fieldname, strexp) => int; + +let exp_strexp_compare: (exp, strexp) => (exp, strexp) => int; + + +/** Return the lhs expression of a hpred */ +let hpred_get_lhs: hpred => exp; + + +/** Field used for objective-c reference counting */ +let objc_ref_counter_field: (Ident.fieldname, typ, item_annotation); + + +/** Compare function for annotations. */ +let annotation_compare: annotation => annotation => int; + + +/** Compare function for annotation items. */ +let item_annotation_compare: item_annotation => item_annotation => int; + + +/** Compare function for Method annotations. */ +let method_annotation_compare: method_annotation => method_annotation => int; + + +/** Empty item annotation. */ +let item_annotation_empty: item_annotation; + + +/** Empty method annotation. */ +let method_annotation_empty: method_annotation; + + +/** Check if the item annodation is empty. */ +let item_annotation_is_empty: item_annotation => bool; + + +/** Check if the method annodation is empty. */ +let method_annotation_is_empty: method_annotation => bool; + + +/** Return the value of the FA_sentinel attribute in [attr_list] if it is found */ +let get_sentinel_func_attribute_value: list func_attribute => option (int, int); + + +/** {2 Pretty Printing} */ +/** Begin change color if using diff printing, return updated printenv and change status */ +let color_pre_wrapper: printenv => F.formatter => 'a => (printenv, bool); + + +/** Close color annotation if changed */ +let color_post_wrapper: bool => printenv => F.formatter => unit; + + +/** String representation of a unary operator. */ +let str_unop: unop => string; + + +/** String representation of a binary operator. */ +let str_binop: printenv => binop => string; + + +/** name of the allocation function for the given memory kind */ +let mem_alloc_pname: mem_kind => Procname.t; + + +/** name of the deallocation function for the given memory kind */ +let mem_dealloc_pname: mem_kind => Procname.t; + + +/** Pretty print an annotation. */ +let pp_annotation: F.formatter => annotation => unit; + + +/** Pretty print a const. */ +let pp_const: printenv => F.formatter => const => unit; + + +/** Pretty print an item annotation. */ +let pp_item_annotation: F.formatter => item_annotation => unit; + +let item_annotation_to_string: item_annotation => string; + + +/** Pretty print a method annotation. */ +let pp_method_annotation: string => F.formatter => method_annotation => unit; + + +/** Pretty print a type. */ +let pp_typ: printenv => F.formatter => typ => unit; + +let pp_struct_typ: printenv => (F.formatter => unit => unit) => F.formatter => struct_typ => unit; + + +/** Pretty print a type with all the details. */ +let pp_typ_full: printenv => F.formatter => typ => unit; + +let typ_to_string: typ => string; + + +/** [pp_type_decl pe pp_base pp_size f typ] pretty prints a type declaration. + pp_base prints the variable for a declaration, or can be skip to print only the type + pp_size prints the expression for the array size */ +let pp_type_decl: + printenv => + (F.formatter => unit => unit) => + (printenv => F.formatter => exp => unit) => + F.formatter => + typ => + unit; + + +/** Dump a type with all the details. */ +let d_typ_full: typ => unit; + + +/** Dump a list of types. */ +let d_typ_list: list typ => unit; + + +/** convert the attribute to a string */ +let attribute_to_string: printenv => attribute => string; + + +/** convert a dexp to a string */ +let dexp_to_string: dexp => string; + + +/** Pretty print a dexp. */ +let pp_dexp: F.formatter => dexp => unit; + + +/** Pretty print an expression. */ +let pp_exp: printenv => F.formatter => exp => unit; + + +/** Pretty print an expression with type. */ +let pp_exp_typ: printenv => F.formatter => (exp, typ) => unit; + + +/** Convert an expression to a string */ +let exp_to_string: exp => string; + + +/** dump an expression. */ +let d_exp: exp => unit; + + +/** Pretty print a type. */ +let pp_texp: printenv => F.formatter => exp => unit; + + +/** Pretty print a type with all the details. */ +let pp_texp_full: printenv => F.formatter => exp => unit; + + +/** Dump a type expression with all the details. */ +let d_texp_full: exp => unit; + + +/** Pretty print a list of expressions. */ +let pp_exp_list: printenv => F.formatter => list exp => unit; + + +/** Dump a list of expressions. */ +let d_exp_list: list exp => unit; + + +/** Pretty print an offset */ +let pp_offset: printenv => F.formatter => offset => unit; + + +/** Dump an offset */ +let d_offset: offset => unit; + + +/** Pretty print a list of offsets */ +let pp_offset_list: printenv => F.formatter => list offset => unit; + + +/** Dump a list of offsets */ +let d_offset_list: list offset => unit; + + +/** Get the location of the instruction */ +let instr_get_loc: instr => Location.t; + + +/** get the expressions occurring in the instruction */ +let instr_get_exps: instr => list exp; + + +/** Pretty print an instruction. */ +let pp_instr: printenv => F.formatter => instr => unit; + + +/** Dump an instruction. */ +let d_instr: instr => unit; + + +/** Pretty print a list of instructions. */ +let pp_instr_list: printenv => F.formatter => list instr => unit; + + +/** Dump a list of instructions. */ +let d_instr_list: list instr => unit; + + +/** Pretty print a value path */ +let pp_vpath: printenv => F.formatter => vpath => unit; + + +/** Pretty print an atom. */ +let pp_atom: printenv => F.formatter => atom => unit; + + +/** Dump an atom. */ +let d_atom: atom => unit; + + +/** return a string representing the inst */ +let inst_to_string: inst => string; + + +/** Pretty print a strexp. */ +let pp_sexp: printenv => F.formatter => strexp => unit; + + +/** Dump a strexp. */ +let d_sexp: strexp => unit; + + +/** Pretty print a strexp list. */ +let pp_sexp_list: printenv => F.formatter => list strexp => unit; + + +/** Dump a strexp. */ +let d_sexp_list: list strexp => unit; + + +/** Pretty print a hpred. */ +let pp_hpred: printenv => F.formatter => hpred => unit; + + +/** Dump a hpred. */ +let d_hpred: hpred => unit; + + +/** Pretty print a hpara. */ +let pp_hpara: printenv => F.formatter => hpara => unit; + + +/** Pretty print a list of hparas. */ +let pp_hpara_list: printenv => F.formatter => list hpara => unit; + + +/** Pretty print a hpara_dll. */ +let pp_hpara_dll: printenv => F.formatter => hpara_dll => unit; + + +/** Pretty print a list of hpara_dlls. */ +let pp_hpara_dll_list: printenv => F.formatter => list hpara_dll => unit; + + +/** Module Predicates records the occurrences of predicates as parameters + of (doubly -)linked lists and Epara. + Provides unique numbering for predicates and an iterator. */ +let module Predicates: { + /** predicate environment */ + type env; + + /** create an empty predicate environment */ + let empty_env: unit => env; + + /** return true if the environment is empty */ + let is_empty: env => bool; + + /** return the id of the hpara */ + let get_hpara_id: env => hpara => int; + + /** return the id of the hpara_dll */ + let get_hpara_dll_id: env => hpara_dll => int; + + /** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, + passing the unique id to the functions. The iterator can only be used once. */ + let iter: env => (int => hpara => unit) => (int => hpara_dll => unit) => unit; + + /** Process one hpred, updating the predicate environment */ + let process_hpred: env => hpred => unit; +}; + + +/** Pretty print a hpred with optional predicate env */ +let pp_hpred_env: printenv => option Predicates.env => F.formatter => hpred => unit; + + +/** {2 Functions for traversing SIL data types} */ +/** This function should be used before adding a new + index to Earray. The [exp] is the newly created + index. This function "cleans" [exp] according to whether it is the + footprint or current part of the prop. + The function faults in the re - execution mode, as an internal check of the tool. */ +let array_clean_new_index: bool => exp => exp; + + +/** Change exps in strexp using [f]. */ +/** WARNING: the result might not be normalized. */ +let strexp_expmap: ((exp, option inst) => (exp, option inst)) => strexp => strexp; + + +/** Change exps in hpred by [f]. */ +/** WARNING: the result might not be normalized. */ +let hpred_expmap: ((exp, option inst) => (exp, option inst)) => hpred => hpred; + + +/** Change instrumentations in hpred using [f]. */ +let hpred_instmap: (inst => inst) => hpred => hpred; + + +/** Change exps in hpred list by [f]. */ +/** WARNING: the result might not be normalized. */ +let hpred_list_expmap: ((exp, option inst) => (exp, option inst)) => list hpred => list hpred; + + +/** Change exps in atom by [f]. */ +/** WARNING: the result might not be normalized. */ +let atom_expmap: (exp => exp) => atom => atom; + + +/** Change exps in atom list by [f]. */ +/** WARNING: the result might not be normalized. */ +let atom_list_expmap: (exp => exp) => list atom => list atom; + + +/** {2 Function for computing lexps in sigma} */ +let hpred_list_get_lexps: (exp => bool) => list hpred => list exp; + + +/** {2 Utility Functions for Expressions} */ +/** Turn an expression representing a type into the type it represents + If not a sizeof, return the default type if given, otherwise raise an exception */ +let texp_to_typ: option typ => exp => typ; + + +/** If a struct type with field f, return the type of f. + If not, return the default type if given, otherwise raise an exception */ +let struct_typ_fld: option typ => Ident.fieldname => typ => typ; + + +/** If an array type, return the type of the element. + If not, return the default type if given, otherwise raise an exception */ +let array_typ_elem: option typ => typ => typ; + + +/** Return the root of [lexp]. */ +let root_of_lexp: exp => exp; + + +/** Get an expression "undefined", the boolean indicates + whether the undefined value goest into the footprint */ +let exp_get_undefined: bool => exp; + + +/** Checks whether an expression denotes a location using pointer arithmetic. + Currently, catches array - indexing expressions such as a[i] only. */ +let exp_pointer_arith: exp => bool; + + +/** Integer constant 0 */ +let exp_zero: exp; + + +/** Null constant */ +let exp_null: exp; + + +/** Integer constant 1 */ +let exp_one: exp; + + +/** Integer constant -1 */ +let exp_minus_one: exp; + + +/** Create integer constant */ +let exp_int: Int.t => exp; + + +/** Create float constant */ +let exp_float: float => exp; + + +/** Create integer constant corresponding to the boolean value */ +let exp_bool: bool => exp; + + +/** Create expresstion [e1 == e2] */ +let exp_eq: exp => exp => exp; + + +/** Create expresstion [e1 != e2] */ +let exp_ne: exp => exp => exp; + + +/** Create expresstion [e1 <= e2] */ +let exp_le: exp => exp => exp; + + +/** Create expression [e1 < e2] */ +let exp_lt: exp => exp => exp; + + +/** {2 Functions for computing program variables} */ +let exp_fpv: exp => list Pvar.t; + +let strexp_fpv: strexp => list Pvar.t; + +let atom_fpv: atom => list Pvar.t; + +let hpred_fpv: hpred => list Pvar.t; + +let hpara_fpv: hpara => list Pvar.t; + + +/** {2 Functions for computing free non-program variables} */ +/** Type of free variables. These include primed, normal and footprint variables. + We remember the order in which variables are added. */ +type fav; + + +/** flag to indicate whether fav's are stored in duplicate form. + Only to be used with fav_to_list */ +let fav_duplicates: ref bool; + + +/** Pretty print a fav. */ +let pp_fav: printenv => F.formatter => fav => unit; + + +/** Create a new [fav]. */ +let fav_new: unit => fav; + + +/** Emptyness check. */ +let fav_is_empty: fav => bool; + + +/** Check whether a predicate holds for all elements. */ +let fav_for_all: fav => (Ident.t => bool) => bool; + + +/** Check whether a predicate holds for some elements. */ +let fav_exists: fav => (Ident.t => bool) => bool; + + +/** Membership test fot [fav] */ +let fav_mem: fav => Ident.t => bool; + + +/** Convert a list to a fav. */ +let fav_from_list: list Ident.t => fav; + + +/** Convert a [fav] to a list of identifiers while preserving the order + that identifiers were added to [fav]. */ +let fav_to_list: fav => list Ident.t; + + +/** Copy a [fav]. */ +let fav_copy: fav => fav; + + +/** Turn a xxx_fav_add function into a xxx_fav function */ +let fav_imperative_to_functional: (fav => 'a => unit) => 'a => fav; + + +/** [fav_filter_ident fav f] only keeps [id] if [f id] is true. */ +let fav_filter_ident: fav => (Ident.t => bool) => unit; + + +/** Like [fav_filter_ident] but return a copy. */ +let fav_copy_filter_ident: fav => (Ident.t => bool) => fav; + + +/** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] + is in [fav2].*/ +let fav_subset_ident: fav => fav => bool; + + +/** add identifier list to fav */ +let ident_list_fav_add: list Ident.t => fav => unit; + + +/** [exp_fav_add fav exp] extends [fav] with the free variables of [exp] */ +let exp_fav_add: fav => exp => unit; + +let exp_fav: exp => fav; + +let exp_fav_list: exp => list Ident.t; + +let ident_in_exp: Ident.t => exp => bool; + +let strexp_fav_add: fav => strexp => unit; + +let atom_fav_add: fav => atom => unit; + +let atom_fav: atom => fav; + +let hpred_fav_add: fav => hpred => unit; + +let hpred_fav: hpred => fav; + + +/** Variables in hpara, excluding bound vars in the body */ +let hpara_shallow_av: hpara => fav; + + +/** Variables in hpara_dll, excluding bound vars in the body */ +let hpara_dll_shallow_av: hpara_dll => fav; + + +/** {2 Functions for computing all free or bound non-program variables} */ +/** Non-program variables include all of primed, normal and footprint + variables. Thus, the functions essentially compute all the + identifiers occuring in a parameter. Some variables can appear more + than once in the result. */ +let exp_av_add: fav => exp => unit; + +let strexp_av_add: fav => strexp => unit; + +let atom_av_add: fav => atom => unit; + +let hpred_av_add: fav => hpred => unit; + +let hpara_av_add: fav => hpara => unit; + + +/** {2 Substitution} */ +type subst; + + +/** Create a substitution from a list of pairs. + For all (id1, e1), (id2, e2) in the input list, + if id1 = id2, then e1 = e2. */ +let sub_of_list: list (Ident.t, exp) => subst; + + +/** like sub_of_list, but allow duplicate ids and only keep the first occurrence */ +let sub_of_list_duplicates: list (Ident.t, exp) => subst; + + +/** Convert a subst to a list of pairs. */ +let sub_to_list: subst => list (Ident.t, exp); + + +/** The empty substitution. */ +let sub_empty: subst; + + +/** Comparison for substitutions. */ +let sub_compare: subst => subst => int; + + +/** Equality for substitutions. */ +let sub_equal: subst => subst => bool; + + +/** Compute the common id-exp part of two inputs [subst1] and [subst2]. + The first component of the output is this common part. + The second and third components are the remainder of [subst1] + and [subst2], respectively. */ +let sub_join: subst => subst => subst; + + +/** Compute the common id-exp part of two inputs [subst1] and [subst2]. + The first component of the output is this common part. + The second and third components are the remainder of [subst1] + and [subst2], respectively. */ +let sub_symmetric_difference: subst => subst => (subst, subst, subst); + + +/** [sub_find filter sub] returns the expression associated to the first identifier + that satisfies [filter]. + Raise [Not_found] if there isn't one. */ +let sub_find: (Ident.t => bool) => subst => exp; + + +/** [sub_filter filter sub] restricts the domain of [sub] to the + identifiers satisfying [filter]. */ +let sub_filter: (Ident.t => bool) => subst => subst; + + +/** [sub_filter_exp filter sub] restricts the domain of [sub] to the + identifiers satisfying [filter(id, sub(id))]. */ +let sub_filter_pair: ((Ident.t, exp) => bool) => subst => subst; + + +/** [sub_range_partition filter sub] partitions [sub] according to + whether range expressions satisfy [filter]. */ +let sub_range_partition: (exp => bool) => subst => (subst, subst); + + +/** [sub_domain_partition filter sub] partitions [sub] according to + whether domain identifiers satisfy [filter]. */ +let sub_domain_partition: (Ident.t => bool) => subst => (subst, subst); + + +/** Return the list of identifiers in the domain of the substitution. */ +let sub_domain: subst => list Ident.t; + + +/** Return the list of expressions in the range of the substitution. */ +let sub_range: subst => list exp; + + +/** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. */ +let sub_range_map: (exp => exp) => subst => subst; + + +/** [sub_map f g sub] applies the renaming [f] to identifiers in the domain + of [sub] and the substitution [g] to the expressions in the range of [sub]. */ +let sub_map: (Ident.t => Ident.t) => (exp => exp) => subst => subst; + + +/** Checks whether [id] belongs to the domain of [subst]. */ +let mem_sub: Ident.t => subst => bool; + + +/** Extend substitution and return [None] if not possible. */ +let extend_sub: subst => Ident.t => exp => option subst; + + +/** Free auxilary variables in the domain and range of the + substitution. */ +let sub_fav_add: fav => subst => unit; + + +/** Free or bound auxilary variables in the domain and range of the + substitution. */ +let sub_av_add: fav => subst => unit; + + +/** Compute free pvars in a sub */ +let sub_fpv: subst => list Pvar.t; + + +/** substitution functions */ +/** WARNING: these functions do not ensure that the results are normalized. */ +let exp_sub: subst => exp => exp; + +let atom_sub: subst => atom => atom; + +let instr_sub: subst => instr => instr; + +let hpred_sub: subst => hpred => hpred; + + +/** {2 Functions for replacing occurrences of expressions.} */ +/** The first parameter should define a partial function. + No parts of hpara are replaced by these functions. */ +let exp_replace_exp: list (exp, exp) => exp => exp; + +let strexp_replace_exp: list (exp, exp) => strexp => strexp; + +let atom_replace_exp: list (exp, exp) => atom => atom; + +let hpred_replace_exp: list (exp, exp) => hpred => hpred; + + +/** {2 Functions for constructing or destructing entities in this module} */ +/** Extract the ids and pvars from an expression */ +let exp_get_vars: exp => (list Ident.t, list Pvar.t); + + +/** Compute the offset list of an expression */ +let exp_get_offsets: exp => list offset; + + +/** Add the offset list to an expression */ +let exp_add_offsets: exp => list offset => exp; + +let sigma_to_sigma_ne: list hpred => list (list atom, list hpred); + + +/** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], + [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], + then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] + for some fresh [_zs'].*/ +let hpara_instantiate: hpara => exp => exp => list exp => (list Ident.t, list hpred); + + +/** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], + [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], + then the result of the instantiation is + [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] + for some fresh [_zs'].*/ +let hpara_dll_instantiate: hpara_dll => exp => exp => exp => list exp => (list Ident.t, list hpred); + + +/** Iterate over all the subtypes in the type (including the type itself) */ +let typ_iter_types: (typ => unit) => typ => unit; + + +/** Iterate over all the types (and subtypes) in the expression */ +let exp_iter_types: (typ => unit) => exp => unit; + + +/** Iterate over all the types (and subtypes) in the instruction */ +let instr_iter_types: (typ => unit) => instr => unit; + +let custom_error: Pvar.t; diff --git a/infer/src/IR/Tenv.re b/infer/src/IR/Tenv.re new file mode 100644 index 000000000..baf189dd8 --- /dev/null +++ b/infer/src/IR/Tenv.re @@ -0,0 +1,172 @@ +/* + * 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! Utils; + + +/** Module for Type Environments. */ +/** Hash tables on strings. */ +let module TypenameHash = Hashtbl.Make { + type t = Typename.t; + let equal tn1 tn2 => Typename.equal tn1 tn2; + let hash = Hashtbl.hash; +}; + + +/** Type for type environment. */ +type t = TypenameHash.t Sil.struct_typ; + + +/** Create a new type environment. */ +let create () => TypenameHash.create 1000; + + +/** 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 => + try (Some (TypenameHash.find tenv name)) { + | Not_found => None + }; + + +/** Lookup Java types by name */ +let lookup_java_typ_from_string tenv typ_str => { + let rec loop = + fun + | "" + | "void" => Some Sil.Tvoid + | "int" => Some (Sil.Tint Sil.IInt) + | "byte" => Some (Sil.Tint Sil.IShort) + | "short" => Some (Sil.Tint Sil.IShort) + | "boolean" => Some (Sil.Tint Sil.IBool) + | "char" => Some (Sil.Tint Sil.IChar) + | "long" => Some (Sil.Tint Sil.ILong) + | "float" => Some (Sil.Tfloat Sil.FFloat) + | "double" => Some (Sil.Tfloat Sil.FDouble) + | typ_str when String.contains typ_str '[' => { + let stripped_typ = String.sub typ_str 0 (String.length typ_str - 2); + let array_typ_size = Sil.exp_get_undefined false; + switch (loop stripped_typ) { + | Some typ => Some (Sil.Tptr (Sil.Tarray typ array_typ_size) Sil.Pk_pointer) + | None => None + } + } + | typ_str => + /* non-primitive/non-array type--resolve it in the tenv */ + { + let typename = Typename.Java.from_string typ_str; + switch (lookup tenv typename) { + | Some struct_typ => Some (Sil.Tstruct struct_typ) + | None => None + } + }; + loop typ_str +}; + + +/** resolve a type string to a Java *class* type. For strings that may represent primitive or array + typs, use [lookup_java_typ_from_string] */ +let lookup_java_class_from_string tenv typ_str => + switch (lookup_java_typ_from_string tenv typ_str) { + | Some (Sil.Tstruct struct_typ) => Some struct_typ + | _ => None + }; + + +/** Add a (name,type) pair to the global type environment. */ +let add tenv name struct_typ => TypenameHash.replace tenv name struct_typ; + + +/** Return the declaring class type of [pname_java] */ +let proc_extract_declaring_class_typ tenv pname_java => + lookup_java_class_from_string tenv (Procname.java_get_class_name pname_java); + + +/** Return the return type of [pname_java]. */ +let proc_extract_return_typ tenv pname_java => + lookup_java_typ_from_string tenv (Procname.java_get_return_type pname_java); + + +/** Get method that is being overriden by java_pname (if any) **/ +let get_overriden_method tenv pname_java => { + let struct_typ_get_def_method_by_name struct_typ method_name => + IList.find + (fun def_method => method_name == Procname.get_method def_method) struct_typ.Sil.def_methods; + let rec get_overriden_method_in_superclasses pname_java superclasses => + switch superclasses { + | [superclass, ...superclasses_tail] => + switch (lookup tenv superclass) { + | Some struct_typ => + try ( + Some (struct_typ_get_def_method_by_name struct_typ (Procname.java_get_method pname_java)) + ) { + | Not_found => + get_overriden_method_in_superclasses + pname_java (superclasses_tail @ struct_typ.Sil.superclasses) + } + | None => get_overriden_method_in_superclasses pname_java superclasses_tail + } + | [] => None + }; + switch (proc_extract_declaring_class_typ tenv pname_java) { + | Some proc_struct_typ => + get_overriden_method_in_superclasses pname_java proc_struct_typ.superclasses + | _ => None + } +}; + + +/** expand a type if it is a typename by looking it up in the type environment */ +let expand_type tenv typ => + switch typ { + | Sil.Tvar tname => + switch (lookup tenv tname) { + | None => assert false + | Some struct_typ => Sil.Tstruct struct_typ + } + | _ => typ + }; + + +/** Serializer for type environments */ +let tenv_serializer: Serialization.serializer t = Serialization.create_serializer Serialization.tenv_key; + +let global_tenv: Lazy.t (option t) = + lazy (Serialization.from_file tenv_serializer (DB.global_tenv_fname ())); + + +/** Load a type environment from a file */ +let load_from_file (filename: DB.filename) :option t => + if (filename == DB.global_tenv_fname ()) { + Lazy.force global_tenv + } else { + Serialization.from_file tenv_serializer filename + }; + + +/** Save a type environment into a file */ +let store_to_file (filename: DB.filename) (tenv: t) => + Serialization.to_file tenv_serializer filename tenv; + +let iter f tenv => TypenameHash.iter f tenv; + +let fold f tenv => TypenameHash.fold f tenv; + +let pp fmt (tenv: t) => + TypenameHash.iter + ( + fun name typ => { + Format.fprintf fmt "@[<6>NAME: %s@." (Typename.to_string name); + Format.fprintf fmt "@[<6>TYPE: %a@." (Sil.pp_struct_typ pe_text (fun _ () => ())) typ + } + ) + tenv; diff --git a/infer/src/IR/Tenv.rei b/infer/src/IR/Tenv.rei new file mode 100644 index 000000000..d55b23231 --- /dev/null +++ b/infer/src/IR/Tenv.rei @@ -0,0 +1,75 @@ +/* + * 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! Utils; + + +/** Module for Type Environments. */ +type t; /** Type for type environment. */ + + +/** Add a (name,typename) pair to the global type environment. */ +let add: t => Typename.t => Sil.struct_typ => unit; + + +/** Create a new type environment. */ +let create: unit => t; + + +/** Expand a type if it is a typename by looking it up in the type environment. */ +let expand_type: t => Sil.typ => Sil.typ; + + +/** Fold a function over the elements of the type environment. */ +let fold: (Typename.t => Sil.struct_typ => 'a => 'a) => t => 'a => 'a; + + +/** iterate over a type environment */ +let iter: (Typename.t => Sil.struct_typ => unit) => t => unit; + + +/** Load a type environment from a file */ +let load_from_file: DB.filename => option t; + + +/** Look up a name in the global type environment. */ +let lookup: t => Typename.t => option Sil.struct_typ; + + +/** Lookup Java types by name. */ +let lookup_java_typ_from_string: t => string => option Sil.typ; + + +/** resolve a type string to a Java *class* type. For strings that may represent primitive or array + typs, use [lookup_java_typ_from_string]. */ +let lookup_java_class_from_string: t => string => option Sil.struct_typ; + + +/** Return the declaring class type of [pname_java] */ +let proc_extract_declaring_class_typ: t => Procname.java => option Sil.struct_typ; + + +/** Return the return type of [pname_java]. */ +let proc_extract_return_typ: t => Procname.java => option Sil.typ; + + +/** Check if typename is found in t */ +let mem: t => Typename.t => bool; + + +/** print a type environment */ +let pp: Format.formatter => t => unit; + + +/** Save a type environment into a file */ +let store_to_file: DB.filename => t => unit; + + +/** Get method that is being overriden by java_pname (if any) **/ +let get_overriden_method: t => Procname.java => option Procname.t; diff --git a/infer/src/IR/Typename.re b/infer/src/IR/Typename.re new file mode 100644 index 000000000..05f7415ad --- /dev/null +++ b/infer/src/IR/Typename.re @@ -0,0 +1,61 @@ +/* + * Copyright (c) 2015 - 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; + +let module F = Format; + + +/** Named types. */ +type t = | TN_typedef of Mangled.t | TN_enum of Mangled.t | TN_csu of Csu.t Mangled.t; + +let to_string = + fun + | TN_enum name + | TN_typedef name => Mangled.to_string name + | TN_csu csu name => Csu.name csu ^ " " ^ Mangled.to_string name; + +let pp f typename => F.fprintf f "%s" (to_string typename); + +let name = + fun + | TN_enum name + | TN_typedef name + | TN_csu _ name => Mangled.to_string name; + +let compare tn1 tn2 => + switch (tn1, tn2) { + | (TN_typedef n1, TN_typedef n2) => Mangled.compare n1 n2 + | (TN_typedef _, _) => (-1) + | (_, TN_typedef _) => 1 + | (TN_enum n1, TN_enum n2) => Mangled.compare n1 n2 + | (TN_enum _, _) => (-1) + | (_, TN_enum _) => 1 + | (TN_csu csu1 n1, TN_csu csu2 n2) => + let n = Csu.compare csu1 csu2; + if (n != 0) { + n + } else { + Mangled.compare n1 n2 + } + }; + +let equal tn1 tn2 => compare tn1 tn2 == 0; + +let module Java = { + let from_string class_name_str => + TN_csu (Csu.Class Csu.Java) (Mangled.from_string class_name_str); +}; + +type typename_t = t; + +let module Set = Set.Make { + type t = typename_t; + let compare = compare; +}; diff --git a/infer/src/IR/Typename.rei b/infer/src/IR/Typename.rei new file mode 100644 index 000000000..182d21aa1 --- /dev/null +++ b/infer/src/IR/Typename.rei @@ -0,0 +1,39 @@ +/* + * Copyright (c) 2015 - 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; + + +/** Named types. */ +type t = | TN_typedef of Mangled.t | TN_enum of Mangled.t | TN_csu of Csu.t Mangled.t; + + +/** convert the typename to a string */ +let to_string: t => string; + +let pp: Format.formatter => t => unit; + + +/** name of the typename without qualifier */ +let name: t => string; + + +/** Comparison for typenames */ +let compare: t => t => int; + + +/** Equality for typenames */ +let equal: t => t => bool; + +let module Java: { + /** Create a typename from a Java classname in the form "package.class" */ + let from_string: string => t; +}; + +let module Set: Set.S with type elt = t; diff --git a/infer/src/IR/attributesTable.ml b/infer/src/IR/attributesTable.ml deleted file mode 100644 index e5edacb5f..000000000 --- a/infer/src/IR/attributesTable.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -module F = Format -module L = Logging - -(** Module to manage the table of attributes. *) - -let serializer : ProcAttributes.t Serialization.serializer = - Serialization.create_serializer Serialization.attributes_key - -let attributes_filename pname = - let pname_file = Procname.to_filename pname in - pname_file ^ ".attr" - -(** path to the .attr file for the given procedure in the current results directory *) -let res_dir_attr_filename pname = - let attr_fname = attributes_filename pname in - let bucket_dir = - let base = Filename.chop_extension attr_fname in - let len = String.length base in - if len < 2 - then Filename.current_dir_name - else String.sub base (len - 2) 2 in - let filename = - DB.Results_dir.path_to_filename - DB.Results_dir.Abs_root - [Config.attributes_dir_name; bucket_dir; attr_fname] in - DB.filename_create_dir filename; - filename - -let store_attributes proc_attributes = - let proc_name = proc_attributes.ProcAttributes.proc_name in - let attributes_file = res_dir_attr_filename proc_name in - let should_write = (* only overwrite defined procedures *) - proc_attributes.ProcAttributes.is_defined || - not (DB.file_exists attributes_file) in - if should_write then - Serialization.to_file serializer attributes_file proc_attributes - -let load_attributes proc_name = - let attributes_file = res_dir_attr_filename proc_name in - Serialization.from_file serializer attributes_file - -(** Given a procdesure name, find the file where it is defined and *) -(** its corresponding type environment *) -let find_tenv_from_class_of_proc procname = - match load_attributes procname with - | None -> None - | Some attrs -> - let source_file = attrs.ProcAttributes.loc.Location.file in - let source_dir = DB.source_dir_from_source_file source_file in - let tenv_fname = DB.source_dir_get_internal_file source_dir ".tenv" in - Tenv.load_from_file tenv_fname - -(** Given an ObjC class c, extract the type from the tenv where the class was *) -(** defined. We do this by adding a method that is unique to each class, and then *) -(** finding the tenv that corresponds to the class definition. *) -let get_correct_type_from_objc_class_name c = - let class_method = Procname.get_default_objc_class_method (Mangled.to_string c) in - match find_tenv_from_class_of_proc class_method with - | None -> None - | Some tenv -> - let type_name = Typename.TN_csu (Csu.Class Csu.Objc, c) in - Option.map (fun st -> Sil.Tstruct st) (Tenv.lookup tenv type_name) diff --git a/infer/src/IR/attributesTable.mli b/infer/src/IR/attributesTable.mli deleted file mode 100644 index eed79607f..000000000 --- a/infer/src/IR/attributesTable.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -(** Module to manage the table of attributes. *) - - -(** Save .attr file for the procedure into the attributes database. *) -val store_attributes : ProcAttributes.t -> unit - -(** Load the attributes for the procedure from the attributes database. *) -val load_attributes : Procname.t -> ProcAttributes.t option - -(** Given a procdesure name, find the file where it is defined and *) -(** its corresponding type environment *) -val find_tenv_from_class_of_proc : Procname.t -> Tenv.t option - -(** Given an ObjC class c, extract the type from the tenv where the class was *) -(** defined. We do this by adding a method that is unique to each class, and then *) -(** finding the tenv that corresponds to the class definition. *) -val get_correct_type_from_objc_class_name : Mangled.t -> Sil.typ option diff --git a/infer/src/IR/cfg.ml b/infer/src/IR/cfg.ml deleted file mode 100644 index 503fb76e5..000000000 --- a/infer/src/IR/cfg.ml +++ /dev/null @@ -1,1194 +0,0 @@ -(* - * 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 - -module L = Logging -module F = Format - -(* ============== START of ADT node and proc_desc ============== *) - -(* =============== START of module Node =============== *) -module Node = struct - type id = int - - type nodekind = - | Start_node of proc_desc - | Exit_node of proc_desc - | Stmt_node of string - | Join_node - | Prune_node of bool * Sil.if_kind * string (** (true/false branch, if_kind, comment) *) - | Skip_node of string - - (** a node *) - and t = { - (** unique id of the node *) - nd_id : id; - - (** distance to the exit node *) - mutable nd_dist_exit : int option; - - (** dead program variables after executing the instructions *) - mutable nd_dead_pvars_after : Pvar.t list; - - (** dead program variables before executing the instructions *) - mutable nd_deads_before : Pvar.t list; - - (** exception nodes in the cfg *) - mutable nd_exn : t list; - - (** instructions for symbolic execution *) - mutable nd_instrs : Sil.instr list; - - (** kind of node *) - mutable nd_kind : nodekind; - - (** location in the source code *) - mutable nd_loc : Location.t; - - (** predecessor nodes in the cfg *) - mutable nd_preds : t list; - - (** proc desc from cil *) - mutable nd_proc : proc_desc option; - - (** successor nodes in the cfg *) - mutable nd_succs : t list; - } - - (** procedure description *) - and proc_desc = { - pd_attributes : ProcAttributes.t; (** attributes of the procedure *) - pd_id : int; (** unique proc_desc identifier *) - mutable pd_nodes : t list; (** list of nodes of this procedure *) - mutable pd_start_node : t; (** start node of this procedure *) - mutable pd_exit_node : t; (** exit node of ths procedure *) - } - - let exn_handler_kind = Stmt_node "exception handler" - let exn_sink_kind = Stmt_node "exceptions sink" - let throw_kind = Stmt_node "throw" - - (** data type for the control flow graph *) - type cfg = - { node_id : int ref; - node_list : t list ref; - name_pdesc_tbl : proc_desc Procname.Hash.t; (** Map proc name to procdesc *) - mutable priority_set : Procname.Set.t (** set of function names to be analyzed first *) } - - let create_cfg () = (** create a new empty cfg *) - { node_id = ref 0; - node_list = ref []; - name_pdesc_tbl = Procname.Hash.create 1000; - priority_set = Procname.Set.empty } - - (** compute the list of procedures added or changed in [cfg_new] over [cfg_old] *) - let mark_unchanged_pdescs cfg_new cfg_old = - let pdescs_eq pd1 pd2 = - (* map of exp names in pd1 -> exp names in pd2 *) - let exp_map = ref Sil.ExpMap.empty in - (* map of node id's in pd1 -> node id's in pd2 *) - let id_map = ref IntMap.empty in - (* formals are the same if their types are the same *) - let formals_eq formals1 formals2 = - IList.equal (fun (_, typ1) (_, typ2) -> Sil.typ_compare typ1 typ2) formals1 formals2 in - let nodes_eq n1s n2s = - (* nodes are the same if they have the same id, instructions, and succs/preds up to renaming - with [exp_map] and [id_map] *) - let node_eq n1 n2 = - let id_compare n1 n2 = - let id1, id2 = n1.nd_id, n2.nd_id in - try - let id1_mapping = IntMap.find id1 !id_map in - Pervasives.compare id1_mapping id2 - with - Not_found -> - (* assume id's are equal and enforce by adding to [id_map] *) - id_map := IntMap.add id1 id2 !id_map; - 0 in - let instrs_eq instrs1 instrs2 = - IList.equal - (fun i1 i2 -> - let n, exp_map' = Sil.instr_compare_structural i1 i2 !exp_map in - exp_map := exp_map'; - n) - instrs1 - instrs2 in - id_compare n1 n2 = 0 && - IList.equal id_compare n1.nd_succs n2.nd_succs && - IList.equal id_compare n1.nd_preds n2.nd_preds && - instrs_eq n1.nd_instrs n2.nd_instrs in - try - IList.for_all2 node_eq n1s n2s - with Invalid_argument _ -> false in - let att1 = pd1.pd_attributes and att2 = pd2.pd_attributes in - att1.ProcAttributes.is_defined = att2.ProcAttributes.is_defined && - Sil.typ_equal att1.ProcAttributes.ret_type att2.ProcAttributes.ret_type && - formals_eq att1.ProcAttributes.formals att2.ProcAttributes.formals && - nodes_eq pd1.pd_nodes pd2.pd_nodes in - let old_procs = cfg_old.name_pdesc_tbl in - let new_procs = cfg_new.name_pdesc_tbl in - let mark_pdesc_if_unchanged pname new_pdesc = - try - let old_pdesc = Procname.Hash.find old_procs pname in - let changed = - (* in continue_capture mode keep the old changed bit *) - (Config.continue_capture && old_pdesc.pd_attributes.ProcAttributes.changed) || - not (pdescs_eq old_pdesc new_pdesc) in - new_pdesc.pd_attributes.changed <- changed - with Not_found -> () in - Procname.Hash.iter mark_pdesc_if_unchanged new_procs - - let node_id_gen cfg = - incr cfg.node_id; - !(cfg.node_id) - - let pdesc_tbl_add cfg proc_name proc_desc = - Procname.Hash.add cfg.name_pdesc_tbl proc_name proc_desc - - let pdesc_tbl_remove cfg proc_name = - Procname.Hash.remove cfg.name_pdesc_tbl proc_name - - let pdesc_tbl_find cfg proc_name = - Procname.Hash.find cfg.name_pdesc_tbl proc_name - - let iter_proc_desc cfg f = - Procname.Hash.iter f cfg.name_pdesc_tbl - - let dummy () = { - nd_id = 0; - nd_dist_exit = None; - nd_dead_pvars_after = []; - nd_deads_before = []; - nd_instrs = []; - nd_kind = Skip_node "dummy"; - nd_loc = Location.dummy; - nd_proc = None; - nd_succs = []; nd_preds = []; nd_exn = []; - } - - let compare node1 node2 = - int_compare node1.nd_id node2.nd_id - - let hash node = - Hashtbl.hash node.nd_id - - let equal node1 node2 = - (compare node1 node2 = 0) - - let get_all_nodes cfg = !(cfg.node_list) - - let create cfg loc kind instrs pdesc = - let node_id = node_id_gen cfg in - let node = - { nd_id = node_id; - nd_dist_exit = None; - nd_dead_pvars_after = []; - nd_deads_before = []; - nd_instrs = instrs; - nd_kind = kind; - nd_loc = loc; - nd_preds = []; - nd_proc = Some pdesc; - nd_succs = []; - nd_exn = [] - } in - cfg.node_list := node :: !(cfg.node_list); - pdesc.pd_nodes <- node :: pdesc.pd_nodes; - node - - (** Get the unique id of the node *) - let get_id node = node.nd_id - - (** compare node ids *) - let id_compare = int_compare - - let get_succs node = node.nd_succs - - type node = t - - module NodeSet = Set.Make(struct - type t = node - let compare = compare - end) - - module NodeMap = Map.Make(struct - type t = node - let compare = compare - end) - - module IdMap = Map.Make(struct - type t = id - let compare = id_compare - end) - - let get_sliced_succs node f = - let visited = ref NodeSet.empty in - let rec slice_nodes nodes : NodeSet.t = - let do_node acc n = - visited := NodeSet.add n !visited; - if f n then NodeSet.singleton n - else - NodeSet.union acc - (slice_nodes (IList.filter (fun s -> not (NodeSet.mem s !visited)) n.nd_succs)) in - IList.fold_left do_node NodeSet.empty nodes in - NodeSet.elements (slice_nodes node.nd_succs) - - let get_sliced_preds node f = - let visited = ref NodeSet.empty in - let rec slice_nodes nodes : NodeSet.t = - let do_node acc n = - visited := NodeSet.add n !visited; - if f n then NodeSet.singleton n - else - NodeSet.union acc - (slice_nodes (IList.filter (fun s -> not (NodeSet.mem s !visited)) n.nd_preds)) in - IList.fold_left do_node NodeSet.empty nodes in - NodeSet.elements (slice_nodes node.nd_preds) - - let get_exn node = node.nd_exn - - let set_proc_desc node proc = node.nd_proc <- Some proc - - (** Get the proc desc of the node *) - let get_proc_desc node = - match node.nd_proc with - | None -> - L.out "node_get_proc_desc: at node %d@\n" node.nd_id; - assert false - | Some proc_desc -> proc_desc - - (** Set the successor nodes and exception nodes, and build predecessor links *) - let set_succs_exn_base node succs exn = - node.nd_succs <- succs; - node.nd_exn <- exn; - IList.iter (fun n -> n.nd_preds <- (node :: n.nd_preds)) succs - - (** Set the successor and exception nodes. - If this is a join node right before the exit node, add an extra node in the middle, - otherwise nullify and abstract instructions cannot be added after a conditional. *) - let set_succs_exn cfg node succs exn = - match node.nd_kind, succs with - | Join_node, [({nd_kind = (Exit_node _)} as exit_node)] -> - let kind = Stmt_node "between_join_and_exit" in - let pdesc = get_proc_desc node in - let node' = create cfg node.nd_loc kind node.nd_instrs pdesc in - set_succs_exn_base node [node'] exn; - set_succs_exn_base node' [exit_node] exn - | _ -> - set_succs_exn_base node succs exn - - (** Get the predecessors of the node *) - let get_preds node = node.nd_preds - - (** Generates a list of nodes starting at a given node - and recursively adding the results of the generator *) - let get_generated_slope start_node generator = - let visited = ref NodeSet.empty in - let rec nodes n = - visited := NodeSet.add n !visited; - let succs = IList.filter (fun n -> not (NodeSet.mem n !visited)) (generator n) in - match IList.length succs with - | 1 -> n:: (nodes (IList.hd succs)) - | _ -> [n] in - nodes start_node - - (** Get the node kind *) - let get_kind node = node.nd_kind - - (** Set the node kind *) - let set_kind node kind = node.nd_kind <- kind - - (** Comparison for node kind *) - let kind_compare k1 k2 = match k1, k2 with - | Start_node pd1, Start_node pd2 -> - int_compare pd1.pd_id pd2.pd_id - | Start_node _, _ -> -1 - | _, Start_node _ -> 1 - | Exit_node pd1, Exit_node pd2 -> - int_compare pd1.pd_id pd2.pd_id - | Exit_node _, _ -> -1 - | _, Exit_node _ -> 1 - | Stmt_node s1, Stmt_node s2 -> - string_compare s1 s2 - | Stmt_node _, _ -> -1 - | _, Stmt_node _ -> 1 - | Join_node, Join_node -> 0 - | Join_node, _ -> -1 - | _, Join_node -> 1 - | Prune_node (is_true_branch1, if_kind1, descr1), - Prune_node (is_true_branch2, if_kind2, descr2) -> - let n = bool_compare is_true_branch1 is_true_branch2 in - if n <> 0 then n else let n = Pervasives.compare if_kind1 if_kind2 in - if n <> 0 then n else string_compare descr1 descr2 - | Prune_node _, _ -> -1 - | _, Prune_node _ -> 1 - | Skip_node s1, Skip_node s2 -> - string_compare s1 s2 - - (** Get the instructions to be executed *) - let get_instrs node = - node.nd_instrs - - (** Get the list of callee procnames from the node *) - let get_callees node = - let collect callees instr = - match instr with - | Sil.Call (_, exp, _, _, _) -> - begin - match exp with - | Sil.Const (Sil.Cfun procname) -> procname:: callees - | _ -> callees - end - | _ -> callees in - IList.fold_left collect [] (get_instrs node) - - (** Get the location of the node *) - let get_loc n = n.nd_loc - - (** Get the source location of the last instruction in the node *) - let get_last_loc n = - match IList.rev (get_instrs n) with - | instr :: _ -> Sil.instr_get_loc instr - | [] -> n.nd_loc - - (** Set the location of the node *) - let set_loc n loc = n.nd_loc <- loc - - let pp_id f id = - F.fprintf f "%d" id - - let pp f node = - pp_id f (get_id node) - - let proc_desc_from_name cfg proc_name = - try Some (pdesc_tbl_find cfg proc_name) - with Not_found -> None - - let set_dead_pvars node after dead = - if after then node.nd_dead_pvars_after <- dead - else node.nd_deads_before <- dead - - let get_dead_pvars node after = - if after then node.nd_dead_pvars_after - else node.nd_deads_before - - let get_distance_to_exit node = - node.nd_dist_exit - - (** Append the instructions to the list of instructions to execute *) - let append_instrs node instrs = - node.nd_instrs <- node.nd_instrs @ instrs - - (** Add the instructions at the beginning of the list of instructions to execute *) - let prepend_instrs node instrs = - node.nd_instrs <- instrs @ node.nd_instrs - - (** Replace the instructions to be executed. *) - let replace_instrs node instrs = - node.nd_instrs <- instrs - - let proc_desc_get_ret_var pdesc = - Pvar.get_ret_pvar pdesc.pd_attributes.ProcAttributes.proc_name - - (** Add declarations for local variables and return variable to the node *) - let add_locals_ret_declaration node locals = - let loc = get_loc node in - let pdesc = get_proc_desc node in - let proc_name = pdesc.pd_attributes.ProcAttributes.proc_name in - let ret_var = - let ret_type = pdesc.pd_attributes.ProcAttributes.ret_type in - (proc_desc_get_ret_var pdesc, ret_type) in - let construct_decl (x, typ) = - (Pvar.mk x proc_name, typ) in - let ptl = ret_var :: IList.map construct_decl locals in - let instr = Sil.Declare_locals (ptl, loc) in - prepend_instrs node [instr] - - (** Counter for identifiers of procdescs *) - let proc_desc_id_counter = ref 0 - - let proc_desc_create cfg proc_attributes = - incr proc_desc_id_counter; - let pdesc = - { - pd_attributes = proc_attributes; - pd_id = !proc_desc_id_counter; - pd_nodes = []; - pd_start_node = dummy (); - pd_exit_node = dummy (); - } in - pdesc_tbl_add cfg proc_attributes.ProcAttributes.proc_name pdesc; - pdesc - - let remove_node' filter_out_fun cfg = - let remove_node_in_cfg nodes = - IList.filter filter_out_fun nodes in - cfg.node_list := remove_node_in_cfg !(cfg.node_list) - - let remove_node_set cfg nodes = - remove_node' (fun node' -> not (NodeSet.mem node' nodes)) cfg - - let proc_desc_remove cfg name remove_nodes = - (if remove_nodes then - let pdesc = pdesc_tbl_find cfg name in - let proc_nodes = - IList.fold_right (fun node set -> NodeSet.add node set) - pdesc.pd_nodes NodeSet.empty in - remove_node_set cfg proc_nodes); - pdesc_tbl_remove cfg name - - let proc_desc_get_start_node proc_desc = - proc_desc.pd_start_node - - let proc_desc_get_err_log proc_desc = - proc_desc.pd_attributes.ProcAttributes.err_log - - let proc_desc_get_attributes proc_desc = - proc_desc.pd_attributes - - let proc_desc_get_exit_node proc_desc = - proc_desc.pd_exit_node - - (** Compute the distance of each node to the exit node, if not computed already *) - let proc_desc_compute_distance_to_exit_node proc_desc = - let exit_node = proc_desc.pd_exit_node in - let rec mark_distance dist nodes = - let next_nodes = ref [] in - let do_node node = - match node.nd_dist_exit with - | Some _ -> () - | None -> - node.nd_dist_exit <- Some dist; - next_nodes := node.nd_preds @ !next_nodes in - IList.iter do_node nodes; - if !next_nodes != [] then mark_distance (dist + 1) !next_nodes in - mark_distance 0 [exit_node] - - (** Set the start node of the proc desc *) - let proc_desc_set_start_node pdesc node = - pdesc.pd_start_node <- node - - (** Set the exit node of the proc desc *) - let proc_desc_set_exit_node pdesc node = - pdesc.pd_exit_node <- node - - (** Set a flag for the proc desc *) - let proc_desc_set_flag pdesc key value = - proc_flags_add pdesc.pd_attributes.ProcAttributes.proc_flags key value - - (** Return the return type of the procedure *) - let proc_desc_get_ret_type proc_desc = - proc_desc.pd_attributes.ProcAttributes.ret_type - - let proc_desc_get_proc_name proc_desc = - proc_desc.pd_attributes.ProcAttributes.proc_name - - (** Return [true] iff the procedure is defined, and not just declared *) - let proc_desc_is_defined proc_desc = - proc_desc.pd_attributes.ProcAttributes.is_defined - - let proc_desc_get_loc proc_desc = - proc_desc.pd_attributes.ProcAttributes.loc - - (** Return name and type of formal parameters *) - let proc_desc_get_formals proc_desc = - proc_desc.pd_attributes.ProcAttributes.formals - - (** Return name and type of local variables *) - let proc_desc_get_locals proc_desc = - proc_desc.pd_attributes.ProcAttributes.locals - - (** Return name and type of captured variables *) - let proc_desc_get_captured proc_desc = - proc_desc.pd_attributes.ProcAttributes.captured - - (** Return the visibility attribute *) - let proc_desc_get_access proc_desc = - proc_desc.pd_attributes.ProcAttributes.access - - let proc_desc_get_nodes proc_desc = - proc_desc.pd_nodes - - (** List of nodes in the procedure up to the first branching *) - let proc_desc_get_slope proc_desc = - get_generated_slope (proc_desc_get_start_node proc_desc) get_succs - - (** List of nodes in the procedure sliced by a predicate up to the first branching *) - let proc_desc_get_sliced_slope proc_desc f = - get_generated_slope (proc_desc_get_start_node proc_desc) (fun n -> get_sliced_succs n f) - - (** Get flags for the proc desc *) - let proc_desc_get_flags proc_desc = - proc_desc.pd_attributes.ProcAttributes.proc_flags - - (** Append the locals to the list of local variables *) - let proc_desc_append_locals proc_desc new_locals = - proc_desc.pd_attributes.ProcAttributes.locals <- - proc_desc.pd_attributes.ProcAttributes.locals @ new_locals - - (** Print extended instructions for the node, - highlighting the given subinstruction if present *) - let pp_instrs pe0 ~sub_instrs instro fmt node = - let pe = match instro with - | None -> pe0 - | Some instr -> pe_extend_colormap pe0 (Obj.repr instr) Red in - let instrs = get_instrs node in - let pp_loc fmt () = - F.fprintf fmt " %a " Location.pp (get_loc node) in - let print_sub_instrs () = - F.fprintf fmt "%a" (Sil.pp_instr_list pe) instrs in - match get_kind node with - | Stmt_node s -> - if sub_instrs then print_sub_instrs () - else F.fprintf fmt "statements (%s) %a" s pp_loc () - | Prune_node (_, _, descr) -> - if sub_instrs then print_sub_instrs () - else F.fprintf fmt "assume %s %a" descr pp_loc () - | Exit_node _ -> - if sub_instrs then print_sub_instrs () - else F.fprintf fmt "exit %a" pp_loc () - | Skip_node s -> - if sub_instrs then print_sub_instrs () - else F.fprintf fmt "skip (%s) %a" s pp_loc () - | Start_node _ -> - if sub_instrs then print_sub_instrs () - else F.fprintf fmt "start %a" pp_loc () - | Join_node -> - if sub_instrs then print_sub_instrs () - else F.fprintf fmt "join %a" pp_loc () - - (** Dump extended instructions for the node *) - let d_instrs ~(sub_instrs: bool) (curr_instr: Sil.instr option) (node: t) = - L.add_print_action (L.PTnode_instrs, Obj.repr (sub_instrs, curr_instr, node)) - - (** Return a description of the cfg node *) - let get_description pe node = - let str = - match get_kind node with - | Stmt_node _ -> - "Instructions" - | Prune_node (_, _, descr) -> - "Conditional" ^ " " ^ descr - | Exit_node _ -> - "Exit" - | Skip_node _ -> - "Skip" - | Start_node _ -> - "Start" - | Join_node -> - "Join" in - let pp fmt () = - F.fprintf fmt "%s\n%a@?" - str - (pp_instrs pe None ~sub_instrs: true) node in - pp_to_string pp () - - let proc_desc_iter_nodes f proc_desc = - IList.iter f (IList.rev (proc_desc_get_nodes proc_desc)) - - let proc_desc_fold_nodes f acc proc_desc = - IList.fold_left f acc (IList.rev (proc_desc_get_nodes proc_desc)) - - let proc_desc_fold_calls f acc pdesc = - let do_node a node = - IList.fold_left - (fun b callee_pname -> f b (callee_pname, get_loc node)) - a (get_callees node) in - IList.fold_left do_node acc (proc_desc_get_nodes pdesc) - - (** iterate over the calls from the procedure: (callee,location) pairs *) - let proc_desc_iter_calls f pdesc = - proc_desc_fold_calls (fun _ call -> f call) () pdesc - - let proc_desc_iter_slope f proc_desc = - let visited = ref NodeSet.empty in - let rec do_node node = begin - visited := NodeSet.add node !visited; - f node; - match get_succs node with - | [n] -> if not (NodeSet.mem n !visited) then do_node n - | _ -> () - end in - do_node (proc_desc_get_start_node proc_desc) - - (** iterate between two nodes or until we reach a branching structure *) - let proc_desc_iter_slope_range f src_node dst_node = - let visited = ref NodeSet.empty in - let rec do_node node = begin - visited := NodeSet.add node !visited; - f node; - match get_succs node with - | [n] -> - if not (NodeSet.mem n !visited) - && not (equal node dst_node) - then do_node n - | _ -> () - end in - do_node src_node - - let proc_desc_iter_slope_calls f proc_desc = - let do_node node = - IList.iter - (fun callee_pname -> f callee_pname) - (get_callees node) in - proc_desc_iter_slope do_node proc_desc - - let proc_desc_iter_instrs f proc_desc = - let do_node node = - IList.iter (fun i -> f node i) (get_instrs node) in - proc_desc_iter_nodes do_node proc_desc - - let proc_desc_fold_instrs f acc proc_desc = - let fold_node acc node = - IList.fold_left (fun acc instr -> f acc node instr) acc (get_instrs node) in - proc_desc_fold_nodes fold_node acc proc_desc - -(* - let remove_node cfg node = - remove_node' (fun node' -> not (equal node node')) - cfg node -*) - - (* clone a procedure description and apply the type substitutions where - the parameters are used *) - let proc_desc_specialize_types callee_proc_desc resolved_attributes substitutions = - let cfg = create_cfg () in - let resolved_proc_desc = proc_desc_create cfg resolved_attributes in - let resolved_proc_name = proc_desc_get_proc_name resolved_proc_desc - and callee_start_node = proc_desc_get_start_node callee_proc_desc - and callee_exit_node = proc_desc_get_exit_node callee_proc_desc in - let convert_pvar pvar = - Pvar.mk (Pvar.get_name pvar) resolved_proc_name in - let convert_exp = function - | Sil.Lvar origin_pvar -> - Sil.Lvar (convert_pvar origin_pvar) - | exp -> exp in - let extract_class_name = function - | Sil.Tptr (Sil.Tstruct { Sil.struct_name }, _) when struct_name <> None -> - Mangled.to_string (Option.get struct_name) - | _ -> failwith "Expecting classname for Java types" in - let subst_map = ref Ident.IdentMap.empty in - let redirected_class_name origin_id = - try - Some (Ident.IdentMap.find origin_id !subst_map) - with Not_found -> None in - let convert_instr instrs = function - | Sil.Letderef (id, (Sil.Lvar origin_pvar as origin_exp), origin_typ, loc) -> - let (_, specialized_typ) = - let pvar_name = Pvar.get_name origin_pvar in - try - IList.find - (fun (n, _) -> Mangled.equal n pvar_name) - substitutions - with Not_found -> - (pvar_name, origin_typ) in - subst_map := Ident.IdentMap.add id specialized_typ !subst_map; - Sil.Letderef (id, convert_exp origin_exp, specialized_typ, loc) :: instrs - | Sil.Letderef (id, (Sil.Var origin_id as origin_exp), origin_typ, loc) -> - let updated_typ = - match Ident.IdentMap.find origin_id !subst_map with - | Sil.Tptr (typ, _) -> typ - | _ -> failwith "Expecting a pointer type" - | exception Not_found -> origin_typ in - Sil.Letderef (id, convert_exp origin_exp, updated_typ, loc) :: instrs - | Sil.Letderef (id, origin_exp, origin_typ, loc) -> - Sil.Letderef (id, convert_exp origin_exp, origin_typ, loc) :: instrs - | Sil.Set (assignee_exp, origin_typ, origin_exp, loc) -> - let set_instr = - Sil.Set (convert_exp assignee_exp, origin_typ, convert_exp origin_exp, loc) in - set_instr :: instrs - | Sil.Call (return_ids, Sil.Const (Sil.Cfun (Procname.Java callee_pname_java)), - (Sil.Var id, _) :: origin_args, loc, call_flags) - when call_flags.Sil.cf_virtual && redirected_class_name id <> None -> - let redirected_typ = Option.get (redirected_class_name id) in - let redirected_pname = - Procname.replace_class - (Procname.Java callee_pname_java) (extract_class_name redirected_typ) - and args = - let other_args = (IList.map (fun (exp, typ) -> (convert_exp exp, typ)) origin_args) in - (Sil.Var id, redirected_typ) :: other_args in - let call_instr = - Sil.Call (return_ids, Sil.Const (Sil.Cfun redirected_pname), args, loc, call_flags) in - call_instr :: instrs - | Sil.Call (return_ids, origin_call_exp, origin_args, loc, call_flags) -> - let converted_args = IList.map (fun (exp, typ) -> (convert_exp exp, typ)) origin_args in - let call_instr = - Sil.Call (return_ids, convert_exp origin_call_exp, converted_args, loc, call_flags) in - call_instr :: instrs - | Sil.Prune (origin_exp, loc, is_true_branch, if_kind) -> - Sil.Prune (convert_exp origin_exp, loc, is_true_branch, if_kind):: instrs - | Sil.Nullify (origin_pvar, loc) -> - Sil.Nullify (convert_pvar origin_pvar, loc) :: instrs - | Sil.Declare_locals (typed_vars, loc) -> - let new_typed_vars = IList.map (fun (pvar, typ) -> (convert_pvar pvar, typ)) typed_vars in - (Sil.Declare_locals (new_typed_vars, loc)) :: instrs - | instr -> instr :: instrs in - let convert_node_kind = function - | Start_node _ -> Start_node resolved_proc_desc - | Exit_node _ -> Exit_node resolved_proc_desc - | node_kind -> node_kind in - let node_map = ref NodeMap.empty in - let rec convert_node node = - let loc = get_loc node - and kind = convert_node_kind (get_kind node) - and instrs = - IList.fold_left convert_instr [] (get_instrs node) |> IList.rev in - create cfg loc kind instrs resolved_proc_desc - and loop callee_nodes = - match callee_nodes with - | [] -> [] - | node :: other_node -> - let converted_node = - try - NodeMap.find node !node_map - with Not_found -> - let new_node = convert_node node - and successors = get_succs node - and exn_nodes = get_exn node in - node_map := NodeMap.add node new_node !node_map; - if equal node callee_start_node then - proc_desc_set_start_node resolved_proc_desc new_node; - if equal node callee_exit_node then - proc_desc_set_exit_node resolved_proc_desc new_node; - set_succs_exn cfg new_node (loop successors) (loop exn_nodes); - new_node in - converted_node :: (loop other_node) in - ignore (loop [callee_start_node]); - resolved_proc_desc - -end -(* =============== END of module Node =============== *) - -type node = Node.t -type cfg = Node.cfg - - -(* =============== START of module Procdesc =============== *) -module Procdesc = struct - type t = Node.proc_desc - let compute_distance_to_exit_node = Node.proc_desc_compute_distance_to_exit_node - - let create = Node.proc_desc_create - let remove = Node.proc_desc_remove - let find_from_name = Node.proc_desc_from_name - let get_attributes = Node.proc_desc_get_attributes - let get_err_log = Node.proc_desc_get_err_log - let get_exit_node = Node.proc_desc_get_exit_node - let get_flags = Node.proc_desc_get_flags - let get_formals = Node.proc_desc_get_formals - let get_loc = Node.proc_desc_get_loc - let get_locals = Node.proc_desc_get_locals - let get_captured = Node.proc_desc_get_captured - let get_access = Node.proc_desc_get_access - let get_nodes = Node.proc_desc_get_nodes - let get_slope = Node.proc_desc_get_slope - let get_sliced_slope = Node.proc_desc_get_sliced_slope - let get_proc_name = Node.proc_desc_get_proc_name - let get_ret_type = Node.proc_desc_get_ret_type - let get_ret_var pdesc = Pvar.mk Ident.name_return (get_proc_name pdesc) - let get_start_node = Node.proc_desc_get_start_node - let is_defined = Node.proc_desc_is_defined - let iter_nodes = Node.proc_desc_iter_nodes - let fold_calls = Node.proc_desc_fold_calls - let iter_calls = Node.proc_desc_iter_calls - let iter_instrs = Node.proc_desc_iter_instrs - let fold_instrs = Node.proc_desc_fold_instrs - let iter_slope = Node.proc_desc_iter_slope - let iter_slope_calls = Node.proc_desc_iter_slope_calls - let iter_slope_range = Node.proc_desc_iter_slope_range - let set_exit_node = Node.proc_desc_set_exit_node - let set_flag = Node.proc_desc_set_flag - let set_start_node = Node.proc_desc_set_start_node - let append_locals = Node.proc_desc_append_locals - let specialize_types = Node.proc_desc_specialize_types -end - -(* =============== END of module Procdesc =============== *) - -(** Hash table with nodes as keys. *) -module NodeHash = Hashtbl.Make(Node) - -(** Set of nodes. *) -module NodeSet = Node.NodeSet - -(** Map with node id keys. *) -module IdMap = Node.IdMap - -let iter_proc_desc = Node.iter_proc_desc - -let rec pp_node_list f = function - | [] -> () - | [node] -> Node.pp f node - | node:: nodes -> - F.fprintf f "%a, %a" Node.pp node pp_node_list nodes - -(** Get all the procdescs (defined and declared) *) -let get_all_procs cfg = - let procs = ref [] in - let f _ pdesc = procs := pdesc :: !procs in - iter_proc_desc cfg f; !procs - -(** Get the procedures whose body is defined in this cfg *) -let get_defined_procs cfg = - IList.filter Procdesc.is_defined (get_all_procs cfg) - -(** get the function names which should be analyzed before the other ones *) -let get_priority_procnames cfg = - cfg.Node.priority_set - -(** set the function names whose address has been taken in this file *) -let set_procname_priority cfg pname = - cfg.Node.priority_set <- Procname.Set.add pname cfg.Node.priority_set - -let get_name_of_local (curr_f : Procdesc.t) (x, _) = - Pvar.mk x (Procdesc.get_proc_name curr_f) - -(* returns a list of local static variables (ie local variables defined static) in a proposition *) -let get_name_of_objc_static_locals (curr_f : Procdesc.t) p = - let pname = Procname.to_string (Procdesc.get_proc_name curr_f) in - let local_static e = - match e with (* is a local static if it's a global and it has a static local name *) - | Sil.Lvar pvar - when (Pvar.is_global pvar) && (Sil.is_static_local_name pname pvar) -> [pvar] - | _ -> [] in - let hpred_local_static hpred = - match hpred with - | Sil.Hpointsto(e, _, _) -> [local_static e] - | _ -> [] in - let vars_sigma = IList.map hpred_local_static (Prop.get_sigma p) in - IList.flatten (IList.flatten vars_sigma) - -(* returns a list of local variables that points to an objc block in a proposition *) -let get_name_of_objc_block_locals p = - let local_blocks e = - match e with - | Sil.Lvar pvar when (Sil.is_block_pvar pvar) -> - [pvar] - | _ -> [] in - let hpred_local_blocks hpred = - match hpred with - | Sil.Hpointsto(e, _, _) -> [local_blocks e] - | _ -> [] in - let vars_sigma = IList.map hpred_local_blocks (Prop.get_sigma p) in - IList.flatten (IList.flatten vars_sigma) - -let remove_abducted_retvars p = - (* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *) - let compute_reachable p seed_exps = - let sigma, pi = Prop.get_sigma p, Prop.get_pi p in - let rec collect_exps exps = function - | Sil.Eexp (Sil.Const (Sil.Cexn e), _) -> Sil.ExpSet.add e exps - | Sil.Eexp (e, _) -> Sil.ExpSet.add e exps - | Sil.Estruct (flds, _) -> - IList.fold_left (fun exps (_, strexp) -> collect_exps exps strexp) exps flds - - | Sil.Earray (_, elems, _) -> - IList.fold_left (fun exps (_, strexp) -> collect_exps exps strexp) exps elems in - let rec compute_reachable_hpreds_rec sigma (reach, exps) = - let add_hpred_if_reachable (reach, exps) = function - | Sil.Hpointsto (lhs, rhs, _) as hpred when Sil.ExpSet.mem lhs exps -> - let reach' = Sil.HpredSet.add hpred reach in - let exps' = collect_exps exps rhs in - (reach', exps') - | _ -> reach, exps in - let reach', exps' = IList.fold_left add_hpred_if_reachable (reach, exps) sigma in - if (Sil.HpredSet.cardinal reach) = (Sil.HpredSet.cardinal reach') then (reach, exps) - else compute_reachable_hpreds_rec sigma (reach', exps') in - let reach_hpreds, reach_exps = - compute_reachable_hpreds_rec sigma (Sil.HpredSet.empty, seed_exps) in - (* filter away the pure atoms without reachable exps *) - let reach_pi = - let rec exp_contains = function - | exp when Sil.ExpSet.mem exp reach_exps -> true - | Sil.UnOp (_, e, _) | Sil.Cast (_, e) | Sil.Lfield (e, _, _) -> exp_contains e - | Sil.BinOp (_, e0, e1) | Sil.Lindex (e0, e1) -> exp_contains e0 || exp_contains e1 - | _ -> false in - IList.filter - (function - | Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> exp_contains lhs || exp_contains rhs) - pi in - Sil.HpredSet.elements reach_hpreds, reach_pi in - (* separate the abducted pvars from the normal ones, deallocate the abducted ones*) - let abducteds, normal_pvars = - IList.fold_left - (fun pvars hpred -> - match hpred with - | Sil.Hpointsto (Sil.Lvar pvar, _, _) -> - let abducteds, normal_pvars = pvars in - if Pvar.is_abducted pvar then pvar :: abducteds, normal_pvars - else abducteds, pvar :: normal_pvars - | _ -> pvars) - ([], []) - (Prop.get_sigma p) in - let _, p' = Prop.deallocate_stack_vars p abducteds in - let normal_pvar_set = - IList.fold_left - (fun normal_pvar_set pvar -> Sil.ExpSet.add (Sil.Lvar pvar) normal_pvar_set) - Sil.ExpSet.empty - normal_pvars in - (* walk forward from non-abducted pvars, keep everything reachable. remove everything else *) - let sigma_reach, pi_reach = compute_reachable p' normal_pvar_set in - Prop.normalize (Prop.replace_pi pi_reach (Prop.replace_sigma sigma_reach p')) - -let remove_locals (curr_f : Procdesc.t) p = - let names_of_locals = IList.map (get_name_of_local curr_f) (Procdesc.get_locals curr_f) in - let names_of_locals' = match !Config.curr_language with - | Config.Clang -> (* in ObjC to deal with block we need to remove static locals *) - let names_of_static_locals = get_name_of_objc_static_locals curr_f p in - let names_of_block_locals = get_name_of_objc_block_locals p in - names_of_block_locals @ names_of_locals @ names_of_static_locals - | _ -> names_of_locals in - let removed, p' = Prop.deallocate_stack_vars p names_of_locals' in - (removed, if Config.angelic_execution then remove_abducted_retvars p' else p') - -let remove_formals (curr_f : Procdesc.t) p = - let pname = Procdesc.get_proc_name curr_f in - let formal_vars = IList.map (fun (n, _) -> Pvar.mk n pname) (Procdesc.get_formals curr_f) in - Prop.deallocate_stack_vars p formal_vars - -(** remove the return variable from the prop *) -let remove_ret (curr_f : Procdesc.t) (p: Prop.normal Prop.t) = - let pname = Procdesc.get_proc_name curr_f in - let name_of_ret = Procdesc.get_ret_var curr_f in - let _, p' = Prop.deallocate_stack_vars p [(Pvar.to_callee pname name_of_ret)] in - p' - -(** remove locals and return variable from the prop *) -let remove_locals_ret (curr_f : Procdesc.t) p = - snd (remove_locals curr_f (remove_ret curr_f p)) - -(** Remove locals and formal parameters from the prop. - Return the list of stack variables whose address was still present after deallocation. *) -let remove_locals_formals (curr_f : Procdesc.t) p = - let pvars1, p1 = remove_formals curr_f p in - let pvars2, p2 = remove_locals curr_f p1 in - pvars1 @ pvars2, p2 - -(** remove seed vars from a prop *) -let remove_seed_vars (prop: 'a Prop.t) : Prop.normal Prop.t = - let hpred_not_seed = function - | Sil.Hpointsto(Sil.Lvar pv, _, _) -> not (Pvar.is_seed pv) - | _ -> true in - let sigma = Prop.get_sigma prop in - let sigma' = IList.filter hpred_not_seed sigma in - Prop.normalize (Prop.replace_sigma sigma' prop) - -(** checks whether a cfg is connected or not *) -let check_cfg_connectedness cfg = - let is_exit_node n = - match Node.get_kind n with - | Node.Exit_node _ -> true - | _ -> false in - let broken_node n = - let succs = Node.get_succs n in - let preds = Node.get_preds n in - match Node.get_kind n with - | Node.Start_node _ -> (IList.length succs = 0) || (IList.length preds > 0) - | Node.Exit_node _ -> (IList.length succs > 0) || (IList.length preds = 0) - | Node.Stmt_node _ | Node.Prune_node _ - | Node.Skip_node _ -> (IList.length succs = 0) || (IList.length preds = 0) - | Node.Join_node -> - (* Join node has the exception that it may be without predecessors - and pointing to an exit node *) - (* if the if brances end with a return *) - (match succs with - | [n'] when is_exit_node n' -> false - | _ -> (IList.length preds = 0)) in - let do_pdesc pd = - let pname = Procname.to_string (Procdesc.get_proc_name pd) in - let nodes = Procdesc.get_nodes pd in - let broken = IList.exists broken_node nodes in - if broken then - L.out "\n ***BROKEN CFG: '%s'\n" pname - else - L.out "\n ***CONNECTED CFG: '%s'\n" pname in - let pdescs = get_all_procs cfg in - IList.iter do_pdesc pdescs - -(** Removes seeds variables from a prop corresponding to captured variables in an objc block *) -let remove_seed_captured_vars_block captured_vars prop = - let is_captured pname vn = Mangled.equal pname vn in - let hpred_seed_captured = function - | Sil.Hpointsto(Sil.Lvar pv, _, _) -> - let pname = Pvar.get_name pv in - (Pvar.is_seed pv) && (IList.mem is_captured pname captured_vars) - | _ -> false in - let sigma = Prop.get_sigma prop in - let sigma' = IList.filter (fun hpred -> not (hpred_seed_captured hpred)) sigma in - Prop.normalize (Prop.replace_sigma sigma' prop) - -(** Serializer for control flow graphs *) -let cfg_serializer : cfg Serialization.serializer = - Serialization.create_serializer Serialization.cfg_key - -(** Load a cfg from a file *) -let load_cfg_from_file (filename : DB.filename) : cfg option = - Serialization.from_file cfg_serializer filename - -(** save a copy in the results dir of the source files of procedures defined in the cfg, - unless an updated copy already exists *) -let save_source_files cfg = - let process_proc _ pdesc = - let loc = Node.proc_desc_get_loc pdesc in - let source_file = loc.Location.file in - let source_file_str = DB.source_file_to_abs_path source_file in - let dest_file = DB.source_file_in_resdir source_file in - let dest_file_str = DB.filename_to_string dest_file in - let needs_copy = - Node.proc_desc_is_defined pdesc && - Sys.file_exists source_file_str && - (not (Sys.file_exists dest_file_str) || - DB.file_modified_time (DB.filename_from_string source_file_str) - > - DB.file_modified_time dest_file) in - if needs_copy then - match copy_file source_file_str dest_file_str with - | Some _ -> () - | None -> L.err "Error cannot create copy of source file %s@." source_file_str in - Node.iter_proc_desc cfg process_proc - -(** Save the .attr files for the procedures in the cfg. *) -let save_attributes cfg = - let save_proc proc_desc = - let attributes = Procdesc.get_attributes proc_desc in - let loc = attributes.ProcAttributes.loc in - let attributes' = - if Location.equal loc Location.dummy then - let loc' = {loc with Location.file = !DB.current_source } in - {attributes with ProcAttributes.loc = loc'} - else - attributes in - (* - L.stderr "save_proc@. proc_name:%a@. filename:%s@. current_source:%s@. loc:%s@." - Procname.pp (Procdesc.get_proc_name proc_desc) - (DB.filename_to_string filename) - (DB.source_file_to_string !DB.current_source) - (Location.to_string loc); - *) - AttributesTable.store_attributes attributes' in - IList.iter save_proc (get_all_procs cfg) - -(** Inline a synthetic (access or bridge) method. *) -let inline_synthetic_method ret_ids etl proc_desc loc_call : Sil.instr option = - let modified = ref None in - let debug = false in - let found instr instr' = - modified := Some instr'; - if debug then - begin - L.stderr "XX inline_synthetic_method found instr: %a@." (Sil.pp_instr pe_text) instr; - L.stderr "XX inline_synthetic_method instr': %a@." (Sil.pp_instr pe_text) instr' - end in - let do_instr _ instr = - match instr, ret_ids, etl with - | Sil.Letderef (_, Sil.Lfield (Sil.Var _, fn, ft), bt, _), - [ret_id], - [(e1, _)] -> (* getter for fields *) - let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in - found instr instr' - | Sil.Letderef (_, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, _), [ret_id], [] - when Pvar.is_global pvar -> (* getter for static fields *) - let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in - found instr instr' - | Sil.Set (Sil.Lfield (_, fn, ft), bt , _, _), - _, - [(e1, _); (e2, _)] -> (* setter for fields *) - let instr' = Sil.Set (Sil.Lfield (e1, fn, ft), bt , e2, loc_call) in - found instr instr' - | Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , _, _), _, [(e1, _)] - when Pvar.is_global pvar -> (* setter for static fields *) - let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in - found instr instr' - | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', _, cf), _, _ - when IList.length ret_ids = IList.length ret_ids' - && IList.length etl' = IList.length etl -> - let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in - found instr instr' - | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', _, cf), _, _ - when IList.length ret_ids = IList.length ret_ids' - && IList.length etl' + 1 = IList.length etl -> - let etl1 = match IList.rev etl with (* remove last element *) - | _ :: l -> IList.rev l - | [] -> assert false in - let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl1, loc_call, cf) in - found instr instr' - | _ -> () in - Procdesc.iter_instrs do_instr proc_desc; - !modified - -(** Find synthetic (access or bridge) Java methods in the procedure and inline them in the cfg. *) -let proc_inline_synthetic_methods cfg proc_desc : unit = - let instr_inline_synthetic_method = function - | Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc, _) -> - (match Procdesc.find_from_name cfg pn with - | Some pd -> - let is_access = Procname.java_is_access_method pn in - let attributes = Procdesc.get_attributes pd in - let is_synthetic = attributes.ProcAttributes.is_synthetic_method in - let is_bridge = attributes.ProcAttributes.is_bridge_method in - if is_access || is_bridge || is_synthetic - then inline_synthetic_method ret_ids etl pd loc - else None - | None -> None) - | _ -> None in - let node_inline_synthetic_methods node = - let modified = ref false in - let do_instr instr = match instr_inline_synthetic_method instr with - | None -> instr - | Some instr' -> - modified := true; - instr' in - let instrs = Node.get_instrs node in - let instrs' = IList.map do_instr instrs in - if !modified then Node.replace_instrs node instrs' in - Procdesc.iter_nodes node_inline_synthetic_methods proc_desc - -(** Inline the java synthetic methods in the cfg *) -let inline_java_synthetic_methods cfg = - let f proc_name proc_desc = - if Procname.is_java proc_name - then proc_inline_synthetic_methods cfg proc_desc in - iter_proc_desc cfg f - -(** Save a cfg into a file *) -let store_cfg_to_file (filename : DB.filename) (save_sources : bool) (cfg : cfg) = - inline_java_synthetic_methods cfg; - if save_sources then save_source_files cfg; - if Config.incremental_procs then - begin - match load_cfg_from_file filename with - | Some old_cfg -> Node.mark_unchanged_pdescs cfg old_cfg - | None -> () - end; - save_attributes cfg; - Serialization.to_file cfg_serializer filename cfg - - -(** Creates a copy of a procedure description and a list of type substitutions of the form - (name, typ) where name is a parameter. The resulting proc desc is isomorphic but - all the type of the parameters are replaced in the instructions according to the list. - The virtual calls are also replaced to match the parameter types *) -let specialize_types callee_proc_desc resolved_proc_name args = - (** TODO (#9333890): This currently only works when the callee is defined in the same file. - Add support to search for the callee procedure description in the execution environment *) - let callee_attributes = Procdesc.get_attributes callee_proc_desc in - let resolved_formals = - IList.fold_left2 - (fun accu (name, _) (_, arg_typ) -> (name, arg_typ) :: accu) - [] callee_attributes.ProcAttributes.formals args |> IList.rev in - let resolved_attributes = - { callee_attributes with - ProcAttributes.formals = resolved_formals; - proc_name = resolved_proc_name; - } in - AttributesTable.store_attributes resolved_attributes; - Procdesc.specialize_types - callee_proc_desc resolved_attributes resolved_formals diff --git a/infer/src/IR/cfg.mli b/infer/src/IR/cfg.mli deleted file mode 100644 index 9d34d83ea..000000000 --- a/infer/src/IR/cfg.mli +++ /dev/null @@ -1,323 +0,0 @@ -(* - * 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 - -(** Control Flow Graph for Interprocedural Analysis *) - -(** {2 ADT node and proc_desc} *) - -type node -type cfg - -(** Load a cfg from a file *) -val load_cfg_from_file: DB.filename -> cfg option - -(** Save a cfg into a file, and save a copy of the source files if the boolean is true *) -val store_cfg_to_file: DB.filename -> bool -> cfg -> unit - -(** proc description *) -module Procdesc : sig - (** proc description *) - type t - - (** Compute the distance of each node to the exit node, if not computed already *) - val compute_distance_to_exit_node : t -> unit - - (** Create a procdesc *) - val create : cfg -> ProcAttributes.t -> t - - (** [remove cfg name remove_nodes] remove the procdesc [name] - from the control flow graph [cfg]. *) - (** It also removes all the nodes from the procedure from the cfg if remove_nodes is true *) - val remove: cfg -> Procname.t -> bool -> unit - - (** Find the procdesc given the proc name. Return None if not found. *) - val find_from_name : cfg -> Procname.t -> t option - - (** Get the attributes of the procedure. *) - val get_attributes : t -> ProcAttributes.t - - val get_err_log : t -> Errlog.t - - val get_exit_node : t -> node - - (** Get flags for the proc desc *) - val get_flags : t -> proc_flags - - (** Return name and type of formal parameters *) - val get_formals : t -> (Mangled.t * Sil.typ) list - - (** Return loc information for the procedure *) - val get_loc : t -> Location.t - - (** Return name and type of local variables *) - val get_locals : t -> (Mangled.t * Sil.typ) list - - (** Return name and type of block's captured variables *) - val get_captured : t -> (Mangled.t * Sil.typ) list - - (** Return the visibility attribute *) - val get_access : t -> Sil.access - - val get_nodes : t -> node list - - (** Get the procedure's nodes up until the first branching *) - val get_slope : t -> node list - - (** Get the sliced procedure's nodes up until the first branching *) - val get_sliced_slope : t -> (node -> bool) -> node list - - val get_proc_name : t -> Procname.t - - (** Return the return type of the procedure and type string *) - val get_ret_type : t -> Sil.typ - - val get_ret_var : t -> Pvar.t - - val get_start_node : t -> node - - (** Return [true] iff the procedure is defined, and not just declared *) - val is_defined : t -> bool - - (** iterate over all the nodes of a procedure *) - val iter_nodes : (node -> unit) -> t -> unit - - (** fold over the calls from the procedure: (callee, location) pairs *) - val fold_calls : ('a -> Procname.t * Location.t -> 'a) -> 'a -> t -> 'a - - (** iterate over the calls from the procedure: (callee, location) pairs *) - val iter_calls : (Procname.t * Location.t -> unit) -> t -> unit - - (** iterate over all nodes and their instructions *) - val iter_instrs : (node -> Sil.instr -> unit) -> t -> unit - - (** fold over all nodes and their instructions *) - val fold_instrs : ('a -> node -> Sil.instr -> 'a) -> 'a -> t -> 'a - - (** iterate over all nodes until we reach a branching structure *) - val iter_slope : (node -> unit) -> t -> unit - - (** iterate over all calls until we reach a branching structure *) - val iter_slope_calls : (Procname.t -> unit) -> t -> unit - - (** iterate between two nodes or until we reach a branching structure *) - val iter_slope_range : (node -> unit) -> node -> node -> unit - - val set_exit_node : t -> node -> unit - - (** Set a flag for the proc desc *) - val set_flag : t -> string -> string -> unit - - val set_start_node : t -> node -> unit - - (** append a list of new local variables to the existing list of local variables *) - val append_locals : t -> (Mangled.t * Sil.typ) list -> unit - -end - -(** node of the control flow graph *) -module Node : sig - type t = node (** type of nodes *) - - type id = private int - - (** kind of cfg node *) - type nodekind = - | Start_node of Procdesc.t - | Exit_node of Procdesc.t - | Stmt_node of string - | Join_node - | Prune_node of bool * Sil.if_kind * string (** (true/false branch, if_kind, comment) *) - | Skip_node of string - - (** kind of Stmt_node for an exception handler. *) - val exn_handler_kind : nodekind - - (** kind of Stmt_node for an exceptions sink. *) - val exn_sink_kind : nodekind - - (** kind of Stmt_node for a throw instruction. *) - val throw_kind : nodekind - - (** Append the instructions to the list of instructions to execute *) - val append_instrs : t -> Sil.instr list -> unit - - (** Add the instructions at the beginning of the list of instructions to execute *) - val prepend_instrs : t -> Sil.instr list -> unit - - (** Add declarations for local variables and return variable to the node *) - val add_locals_ret_declaration : t -> (Mangled.t * Sil.typ) list -> unit - - (** Compare two nodes *) - val compare : t -> t -> int - - (** [create cfg loc kind instrs proc_desc] create a new cfg node - with the given location, kind, list of instructions, - procdesc *) - val create : cfg -> Location.t -> nodekind -> Sil.instr list -> Procdesc.t -> t - - (** create a new empty cfg *) - val create_cfg : unit -> cfg - - (** Dump extended instructions for the node *) - val d_instrs : sub_instrs: bool -> Sil.instr option -> t -> unit - - (** Create a dummy node *) - val dummy : unit -> t - - (** Check if two nodes are equal *) - val equal : t -> t -> bool - - (** Get all the nodes *) - val get_all_nodes : cfg -> t list - - (** Get the (after/before) dead program variables. - After/before indicated with the true/false flag. *) - val get_dead_pvars: t -> bool -> Pvar.t list - - (** Get the distance to the exit node, if it has been computed *) - val get_distance_to_exit: t -> int option - - (** Return a description of the node *) - val get_description : printenv -> t -> string - - (** Get the exception nodes from the current node *) - val get_exn : t -> t list - - (** Get the unique id of the node *) - val get_id : t -> id - - (** compare node ids *) - val id_compare : id -> id -> int - - (** Get the source location of the node *) - val get_loc : t -> Location.t - - (** Get the source location of the last instruction in the node *) - val get_last_loc : t -> Location.t - - (** Get the kind of the current node *) - val get_kind : t -> nodekind - - (** Get the predecessor nodes of the current node *) - val get_preds : t -> t list - - (** Get a list of unique nodes until the first branch starting - from a node with subsequent applications of a generator function *) - val get_generated_slope : t -> (t -> t list) -> t list - - (** Get the proc desc associated to the node *) - val get_proc_desc : t -> Procdesc.t - - (** Get the instructions to be executed *) - val get_instrs : t -> Sil.instr list - - (** Get the list of callee procnames from the node *) - val get_callees : t -> Procname.t list - - (** Get the successor nodes of the current node *) - val get_succs : t -> t list - - (** Get the successor nodes of a node where the given predicate evaluates to true *) - val get_sliced_succs : t -> (t -> bool) -> t list - - (** Get the predecessor nodes of a node where the given predicate evaluates to true *) - val get_sliced_preds : t -> (t -> bool) -> t list - - (** Hash function for nodes *) - val hash : t -> int - - (** Comparison for node kind *) - val kind_compare : nodekind -> nodekind -> int - - (** Pretty print the node *) - val pp : Format.formatter -> t -> unit - - val pp_id : Format.formatter -> id -> unit - - (** Print extended instructions for the node, - highlighting the given subinstruction if present *) - val pp_instrs : - printenv -> sub_instrs: bool -> Sil.instr option -> Format.formatter -> t -> unit - - (** Replace the instructions to be executed. *) - val replace_instrs : t -> Sil.instr list -> unit - - (** Set the (after/before) dead program variables. - After/before indicated with the true/false flag. *) - val set_dead_pvars : t -> bool -> Pvar.t list -> unit - - (** Set the node kind *) - val set_kind : t -> nodekind -> unit - - (** Set the source location of the node *) - val set_loc : t -> Location.t -> unit - - (** Set the proc desc associated to the node *) - val set_proc_desc : t -> Procdesc.t -> unit - - (** Set the successor nodes and exception nodes, and build predecessor links *) - val set_succs_exn : cfg -> t -> t list -> t list -> unit -end - -(** Hash table with nodes as keys. *) -module NodeHash : Hashtbl.S with type key = Node.t - -(** Set of nodes. *) -module NodeSet : Set.S with type elt = Node.t - -(** Map with node id keys. *) -module IdMap : Map.S with type key = Node.id - -val pp_node_list : Format.formatter -> Node.t list -> unit - -(** {2 Functions for manipulating an interprocedural CFG} *) - -(** Iterate over all the procdesc's *) -val iter_proc_desc : cfg -> (Procname.t -> Procdesc.t -> unit) -> unit - -(** Get all the procedures (defined and declared) *) -val get_all_procs : cfg -> Procdesc.t list - -(** Get the procedures whose body is defined in this cfg *) -val get_defined_procs : cfg -> Procdesc.t list - -(** get the function names which should be analyzed before the other ones *) -val get_priority_procnames : cfg -> Procname.Set.t - -(** set the function names whose address has been taken in this file *) -val set_procname_priority : cfg -> Procname.t -> unit - -(** remove the return variable from the prop *) -val remove_ret : Procdesc.t -> Prop.normal Prop.t -> Prop.normal Prop.t - -(** remove locals and return variable from the prop *) -val remove_locals_ret : Procdesc.t -> Prop.normal Prop.t -> Prop.normal Prop.t - -(** Deallocate the stack variables in [pvars], and replace them by normal variables. - Return the list of stack variables whose address was still present after deallocation. *) -val remove_locals_formals : Procdesc.t -> Prop.normal Prop.t -> Pvar.t list * Prop.normal Prop.t - -(** remove seed vars from a prop *) -val remove_seed_vars : 'a Prop.t -> Prop.normal Prop.t - -(** checks whether a cfg is connected or not *) -val check_cfg_connectedness : cfg -> unit - -(** Removes seeds variables from a prop corresponding to captured variables in an objc block *) -val remove_seed_captured_vars_block : Mangled.t list -> Prop.normal Prop.t -> Prop.normal Prop.t - -(** Creates a copy of a procedure description and a list of type substitutions of the form - (name, typ) where name is a parameter. The resulting procdesc is isomorphic but - all the type of the parameters are replaced in the instructions according to the list. - The virtual calls are also replaced to match the parameter types *) -val specialize_types : - Procdesc.t -> Procname.t -> (Sil.exp * Sil.typ) list -> Procdesc.t diff --git a/infer/src/IR/cg.ml b/infer/src/IR/cg.ml deleted file mode 100644 index b68d0ec20..000000000 --- a/infer/src/IR/cg.ml +++ /dev/null @@ -1,363 +0,0 @@ -(* - * 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 - -(** Module for call graphs *) - -module L = Logging -module F = Format - -type node = Procname.t - -type in_out_calls = - { in_calls: int; (** total number of in calls transitively *) - out_calls: int (** total number of out calls transitively *) - } - -type node_info = - { - (** defined procedure as opposed to just declared *) - mutable defined : bool; - - mutable parents: Procname.Set.t; - - mutable children: Procname.Set.t; - - (** ancestors are computed lazily *) - mutable ancestors : Procname.Set.t option; - - (** heirs are computed lazily *) - mutable heirs : Procname.Set.t option; - - (** recursive dependents are computed lazily *) - mutable recursive_dependents : Procname.Set.t option; - - (** calls are computed lazily *) - mutable in_out_calls : in_out_calls option; - } - -(** Type for call graph *) -type t = - { - mutable source : DB.source_file; (** path for the source file *) - mutable nLOC : int; (** number of LOC *) - node_map : node_info Procname.Hash.t (** map from node to node_info *) - } - -let create () = - { source = !DB.current_source; - nLOC = !Config.nLOC; - node_map = Procname.Hash.create 3 } - -let add_node g n ~defined = - try - let info = Procname.Hash.find g.node_map n in - (* defined and disabled only go from false to true - to avoid accidental overwrite to false by calling add_edge *) - if defined then info.defined <- true; - with Not_found -> - let info = - { defined = defined; - parents = Procname.Set.empty; - children = Procname.Set.empty; - ancestors = None; - heirs = None; - recursive_dependents = None; - in_out_calls = None } in - Procname.Hash.add g.node_map n info - -let add_defined_node g n = - add_node g n ~defined:true - - -(** Compute the ancestors of the node, if not already computed *) -let compute_ancestors g node = - let todo = ref (Procname.Set.singleton node) in - let seen = ref Procname.Set.empty in - let result = ref Procname.Set.empty in - while not (Procname.Set.is_empty !todo) do - let current = Procname.Set.choose !todo in - todo := Procname.Set.remove current !todo; - if not (Procname.Set.mem current !seen) then - begin - seen := Procname.Set.add current !seen; - let info = Procname.Hash.find g current in - match info.ancestors with - | Some ancestors -> - result := Procname.Set.union !result ancestors - | None -> - result := Procname.Set.union !result info.parents; - todo := Procname.Set.union !todo info.parents - end - done; - !result - -(** Compute the heirs of the node, if not already computed *) -let compute_heirs g node = - let todo = ref (Procname.Set.singleton node) in - let seen = ref Procname.Set.empty in - let result = ref Procname.Set.empty in - while not (Procname.Set.is_empty !todo) do - let current = Procname.Set.choose !todo in - todo := Procname.Set.remove current !todo; - if not (Procname.Set.mem current !seen) then - begin - seen := Procname.Set.add current !seen; - let info = Procname.Hash.find g current in - match info.heirs with - | Some heirs -> - result := Procname.Set.union !result heirs - | None -> - result := Procname.Set.union !result info.children; - todo := Procname.Set.union !todo info.children - end - done; - !result - -(** Compute the ancestors of the node, if not pre-computed already *) -let get_ancestors (g: t) node = - let info = Procname.Hash.find g.node_map node in - match info.ancestors with - | None -> - let ancestors = compute_ancestors g.node_map node in - info.ancestors <- Some ancestors; - let size = Procname.Set.cardinal ancestors in - if size > 1000 then L.err "%a has %d ancestors@." Procname.pp node size; - ancestors - | Some ancestors -> ancestors - -(** Compute the heirs of the node, if not pre-computed already *) -let get_heirs (g: t) node = - let info = Procname.Hash.find g.node_map node in - match info.heirs with - | None -> - let heirs = compute_heirs g.node_map node in - info.heirs <- Some heirs; - let size = Procname.Set.cardinal heirs in - if size > 1000 then L.err "%a has %d heirs@." Procname.pp node size; - heirs - | Some heirs -> heirs - -let node_defined (g: t) n = - try - let info = Procname.Hash.find g.node_map n in - info.defined - with Not_found -> false - -let add_edge g nfrom nto = - add_node g nfrom ~defined:false; - add_node g nto ~defined:false; - let info_from = Procname.Hash.find g.node_map nfrom in - let info_to = Procname.Hash.find g.node_map nto in - info_from.children <- Procname.Set.add nto info_from.children; - info_to.parents <- Procname.Set.add nfrom info_to.parents - -(** iterate over the elements of a node_map in node order *) -let node_map_iter f g = - let table = ref [] in - Procname.Hash.iter (fun node info -> table := (node, info) :: !table) g.node_map; - let cmp ((n1: Procname.t), _) ((n2: Procname.t), _) = Procname.compare n1 n2 in - IList.iter (fun (n, info) -> f n info) (IList.sort cmp !table) - -let get_nodes (g: t) = - let nodes = ref Procname.Set.empty in - let f node _ = - nodes := Procname.Set.add node !nodes in - node_map_iter f g; - !nodes - -let compute_calls g node = - { in_calls = Procname.Set.cardinal (get_ancestors g node); - out_calls = Procname.Set.cardinal (get_heirs g node) } - -(** Compute the calls of the node, if not pre-computed already *) -let get_calls (g: t) node = - let info = Procname.Hash.find g.node_map node in - match info.in_out_calls with - | None -> - let calls = compute_calls g node in - info.in_out_calls <- Some calls; - calls - | Some calls -> calls - -let get_all_nodes (g: t) = - let nodes = Procname.Set.elements (get_nodes g) in - IList.map (fun node -> (node, get_calls g node)) nodes - -let get_nodes_and_calls (g: t) = - IList.filter (fun (n, _) -> node_defined g n) (get_all_nodes g) - -let node_get_num_ancestors g n = - (n, Procname.Set.cardinal (get_ancestors g n)) - -let get_edges (g: t) : ((node * int) * (node * int)) list = - let edges = ref [] in - let f node info = - Procname.Set.iter - (fun nto -> - edges := - (node_get_num_ancestors g node, node_get_num_ancestors g nto) :: !edges) - info.children in - node_map_iter f g; - !edges - -(** Return all the children of [n], whether defined or not *) -let get_all_children (g: t) n = - (Procname.Hash.find g.node_map n).children - -(** Return the children of [n] which are defined *) -let get_defined_children (g: t) n = - Procname.Set.filter (node_defined g) (get_all_children g n) - -(** Return the parents of [n] *) -let get_parents (g: t) n = - (Procname.Hash.find g.node_map n).parents - -(** Check if [source] recursively calls [dest] *) -let calls_recursively (g: t) source dest = - Procname.Set.mem source (get_ancestors g dest) - -(** Return the children of [n] which are not heirs of [n] *) -let get_nonrecursive_dependents (g: t) n = - let is_not_recursive pn = not (Procname.Set.mem pn (get_ancestors g n)) in - let res0 = Procname.Set.filter is_not_recursive (get_all_children g n) in - let res = Procname.Set.filter (node_defined g) res0 in - res - -(** Return the ancestors of [n] which are also heirs of [n] *) -let compute_recursive_dependents (g: t) n = - let reached_from_n pn = Procname.Set.mem n (get_ancestors g pn) in - let res0 = Procname.Set.filter reached_from_n (get_ancestors g n) in - let res = Procname.Set.filter (node_defined g) res0 in - res - -(** Compute the ancestors of [n] which are also heirs of [n], if not pre-computed already *) -let get_recursive_dependents (g: t) n = - let info = Procname.Hash.find g.node_map n in - match info.recursive_dependents with - | None -> - let recursive_dependents = compute_recursive_dependents g n in - info.recursive_dependents <- Some recursive_dependents; - recursive_dependents - | Some recursive_dependents -> recursive_dependents - -(** Return the nodes dependent on [n] *) -let get_dependents (g: t) n = - Procname.Set.union (get_nonrecursive_dependents g n) (get_recursive_dependents g n) - -(** Return all the nodes with their defined children *) -let get_nodes_and_defined_children (g: t) = - let nodes = ref Procname.Set.empty in - node_map_iter (fun n info -> if info.defined then nodes := Procname.Set.add n !nodes) g; - let nodes_list = Procname.Set.elements !nodes in - IList.map (fun n -> (n, get_defined_children g n)) nodes_list - -(** nodes with defined flag, and edges *) -type nodes_and_edges = - (node * bool) list * - (node * node) list - -(** Return the list of nodes, with defined+disabled flags, and the list of edges *) -let get_nodes_and_edges (g: t) : nodes_and_edges = - let nodes = ref [] in - let edges = ref [] in - let do_children node nto = - edges := (node, nto) :: !edges in - let f node info = - nodes := (node, info.defined) :: !nodes; - Procname.Set.iter (do_children node) info.children in - node_map_iter f g; - (!nodes, !edges) - -(** Return the list of nodes which are defined *) -let get_defined_nodes (g: t) = - let (nodes, _) = get_nodes_and_edges g in - let get_node (node, _) = node in - IList.map get_node - (IList.filter (fun (_, defined) -> defined) - nodes) - -(** Return the path of the source file *) -let get_source (g: t) = - g.source - -(** Return the number of LOC of the source file *) -let get_nLOC (g: t) = - g.nLOC - -(** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2]; - undefined nodes become defined if at least one side is. *) -let extend cg_old cg_new = - let nodes, edges = get_nodes_and_edges cg_new in - IList.iter (fun (node, defined) -> add_node cg_old node ~defined) nodes; - IList.iter (fun (nfrom, nto) -> add_edge cg_old nfrom nto) edges - -(** Begin support for serialization *) - -let callgraph_serializer : (DB.source_file * int * nodes_and_edges) Serialization.serializer = - Serialization.create_serializer Serialization.cg_key - -(** Load a call graph from a file *) -let load_from_file (filename : DB.filename) : t option = - let g = create () in - match Serialization.from_file callgraph_serializer filename with - | None -> None - | Some (source, nLOC, (nodes, edges)) -> - IList.iter - (fun (node, defined) -> - if defined then add_defined_node g node) - nodes; - IList.iter (fun (nfrom, nto) -> add_edge g nfrom nto) edges; - g.source <- source; - g.nLOC <- nLOC; - Some g - -(** Save a call graph into a file *) -let store_to_file (filename : DB.filename) (call_graph : t) = - Serialization.to_file - callgraph_serializer - filename - (call_graph.source, call_graph.nLOC, (get_nodes_and_edges call_graph)) - -let pp_graph_dotty get_specs (g: t) fmt = - let nodes_with_calls = get_all_nodes g in - let num_specs n = try IList.length (get_specs n) with exn when SymOp.exn_not_failure exn -> - 1 in - let get_color (n, _) = - if num_specs n != 0 then "green" else "red" in - let get_shape (n, _) = - if node_defined g n then "box" else "diamond" in - let pp_node fmt (n, _) = - F.fprintf fmt "\"%s\"" (Procname.to_filename n) in - let pp_node_label fmt (n, calls) = - F.fprintf fmt "\"%a | calls=%d %d | specs=%d)\"" - Procname.pp n calls.in_calls calls.out_calls (num_specs n) in - F.fprintf fmt "digraph {@\n"; - IList.iter - (fun nc -> - F.fprintf fmt "%a [shape=box,label=%a,color=%s,shape=%s]@\n" - pp_node nc pp_node_label nc (get_color nc) (get_shape nc)) - nodes_with_calls; - IList.iter - (fun (s, d) -> - F.fprintf fmt "%a -> %a@\n" pp_node s pp_node d) - (get_edges g); - F.fprintf fmt "}@." - -(** Print the current call graph as a dotty file. - If the filename is [None], use the current file dir inside the DB dir. *) -let save_call_graph_dotty fname_opt get_specs (g: t) = - let fname_dot = match fname_opt with - | None -> DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir ["call_graph.dot"] - | Some fname -> fname in - let outc = open_out (DB.filename_to_string fname_dot) in - let fmt = F.formatter_of_out_channel outc in - pp_graph_dotty get_specs g fmt; - close_out outc diff --git a/infer/src/IR/cg.mli b/infer/src/IR/cg.mli deleted file mode 100644 index a6ee313f5..000000000 --- a/infer/src/IR/cg.mli +++ /dev/null @@ -1,102 +0,0 @@ -(* - * 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 - -(** Module for call graphs *) - -type in_out_calls = - { in_calls: int; (** total number of in calls transitively *) - out_calls: int (** total number of out calls transitively *) - } - -type t (** the type of a call graph *) - -(** A call graph consists of a set of nodes (Procname.t), and edges between them. - A node can be defined or undefined (to represent whether we have code for it). - In an edge from [n1] to [n2], indicating that [n1] calls [n2], - [n1] is the parent and [n2] is the child. - Node [n1] is dependent on [n2] if there is a path from [n1] to [n2] - using the child relationship. *) - -(** [add_edge cg f t] adds an edge from [f] to [t] in the call graph [cg]. - The nodes are also added as undefined, unless already present. *) -val add_edge : t -> Procname.t -> Procname.t -> unit - -(** Add a node to the call graph as defined *) -val add_defined_node : t -> Procname.t -> unit - -(** Check if [source] recursively calls [dest] *) -val calls_recursively: t -> Procname.t -> Procname.t -> bool - -(** Create an empty call graph *) -val create : unit -> t - -(** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2]; - undefined nodes become defined if at least one side is. *) -val extend : t -> t -> unit - -(** Return all the children of [n], whether defined or not *) -val get_all_children : t -> Procname.t -> Procname.Set.t - -(** Compute the ancestors of the node, if not pre-computed already *) -val get_ancestors : t -> Procname.t -> Procname.Set.t - -(** Compute the heirs of the node, if not pre-computed already *) -val get_heirs : t -> Procname.t -> Procname.Set.t - -(** Return the in/out calls of the node *) -val get_calls : t -> Procname.t -> in_out_calls - -(** Return the list of nodes which are defined *) -val get_defined_nodes : t -> Procname.t list - -(** Return the children of [n] which are defined *) -val get_defined_children: t -> Procname.t -> Procname.Set.t - -(** Return the nodes dependent on [n] *) -val get_dependents: t -> Procname.t -> Procname.Set.t - -(** Return the number of LOC of the source file *) -val get_nLOC: t -> int - -(** Return the list of nodes with calls *) -val get_nodes_and_calls : t -> (Procname.t * in_out_calls) list - -(** Return all the nodes with their defined children *) -val get_nodes_and_defined_children : t -> (Procname.t * Procname.Set.t) list - -(** Return the list of nodes, with defined flag, and the list of edges *) -val get_nodes_and_edges : t -> (Procname.t * bool) list * (Procname.t * Procname.t) list - -(** Return the children of [n] which are not heirs of [n] and are defined *) -val get_nonrecursive_dependents : t -> Procname.t -> Procname.Set.t - -(** Return the parents of [n] *) -val get_parents : t -> Procname.t -> Procname.Set.t - -(** Return the ancestors of [n] which are also heirs of [n] *) -val get_recursive_dependents: t -> Procname.t -> Procname.Set.t - -(** Return the path of the source file *) -val get_source : t -> DB.source_file - -(** Load a call graph from a file *) -val load_from_file : DB.filename -> t option - -(** Returns true if the node is defined *) -val node_defined : t -> Procname.t -> bool - -(** Print the current call graph as a dotty file. If the filename is [None], - use the current file dir inside the DB dir. *) -val save_call_graph_dotty : DB.filename option -> (Procname.t -> 'a list) -> t -> unit - -(** Save a call graph into a file *) -val store_to_file : DB.filename -> t -> unit diff --git a/infer/src/IR/csu.ml b/infer/src/IR/csu.ml deleted file mode 100644 index 9e1b43ec9..000000000 --- a/infer/src/IR/csu.ml +++ /dev/null @@ -1,55 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -(** Internal representation of data structure for Java, Objective-C and C++ classes, - C-style structs struct and union, - And Objective C protocol *) - -type class_kind = - | CPP - | Java - | Objc - -type t = - | Class of class_kind - | Struct - | Union - | Protocol - -let name = function - | Class _ -> "class" - | Struct -> "struct" - | Union -> "union" - | Protocol -> "protocol" - -let class_kind_num = function - | CPP -> 1 - | Java -> 2 - | Objc -> 3 - -let class_kind_compare ck1 ck2 = - (class_kind_num ck1) - (class_kind_num ck2) - -let compare dstruct1 dstruct2 = - match dstruct1, dstruct2 with - | Class ck1, Class ck2 -> class_kind_compare ck1 ck2 - | Class _, _ -> -1 - | _, Class _ -> 1 - | Struct, Struct -> 0 - | Struct, _ -> -1 - | _, Struct -> 1 - | Union, Union -> 0 - | Union, _ -> -1 - | _, Union -> 1 - | Protocol, Protocol -> 0 - -let equal tn1 tn2 = - compare tn1 tn2 = 0 diff --git a/infer/src/IR/ident.ml b/infer/src/IR/ident.ml deleted file mode 100644 index bc055233f..000000000 --- a/infer/src/IR/ident.ml +++ /dev/null @@ -1,371 +0,0 @@ -(* - * 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 - -(** Module for Names and Identifiers *) - -module L = Logging -module F = Format - -type name = string - -type fieldname = - { fpos : int; - fname : Mangled.t } - -type kind = int - -let kprimed = - 1 -let knormal = 0 -let kfootprint = 1 - -type t = - { kind: int; - name: name; - stamp: int } - -type _ident = t - -(** {2 Comparison Functions} *) - -let name_compare = string_compare - -let fieldname_compare fn1 fn2 = - let n = int_compare fn1.fpos fn2.fpos in - if n <> 0 then n else Mangled.compare fn1.fname fn2.fname - -let name_equal = string_equal - -let kind_equal k1 k2 = k1 == k2 - -let compare i1 i2 = - let n = i2.kind - i1.kind - in if n <> 0 then n - else - let n = name_compare i1.name i2.name - in if n <> 0 then n - else int_compare i1.stamp i2.stamp - -let equal i1 i2 = - i1.stamp == i2.stamp && i1.kind == i2.kind && name_equal i1.name i2.name (* most unlikely first *) - -let fieldname_equal fn1 fn2 = - fieldname_compare fn1 fn2 = 0 - -let rec ident_list_compare il1 il2 = match il1, il2 with - | [],[] -> 0 - | [], _ -> - 1 - | _,[] -> 1 - | i1:: l1, i2:: l2 -> - let n = compare i1 i2 - in if n <> 0 then n - else ident_list_compare l1 l2 - -let ident_list_equal ids1 ids2 = (ident_list_compare ids1 ids2 = 0) - -(** {2 Set for identifiers} *) - -module IdentSet = Set.Make - (struct - type t = _ident - let compare = compare - end) - -module IdentMap = Map.Make - (struct - type t = _ident - let compare = compare - end) - -module IdentHash = - Hashtbl.Make(struct - type t = _ident - let equal = equal - let hash (id: t) = Hashtbl.hash id - end) - -module FieldSet = Set.Make(struct - type t = fieldname - let compare = fieldname_compare - end) - -module FieldMap = Map.Make(struct - type t = fieldname - let compare = fieldname_compare - end) - -let idlist_to_idset ids = - IList.fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids - -(** {2 Conversion between Names and Strings} *) - -module StringHash = - Hashtbl.Make(struct - type t = string - let equal (s1: string) (s2: string) = s1 = s2 - let hash = Hashtbl.hash - end) - -module NameHash = - Hashtbl.Make(struct - type t = name - let equal = name_equal - let hash = Hashtbl.hash - end) - -(** Convert a string to a name *) -let string_to_name (s: string) = - s - -(** Create a field name with the given position (field number in the CSU) *) -let create_fieldname (n: Mangled.t) (position: int) = - { fpos = position; - fname = n } - -(** Convert a name to a string. *) -let name_to_string (name: name) = - name - -(** Convert a fieldname to a string. *) -let fieldname_to_string fn = Mangled.to_string fn.fname - -(** Convert a fieldname to a simplified string with at most one-level path. *) -let fieldname_to_simplified_string fn = - let s = Mangled.to_string fn.fname in - match string_split_character s '.' with - | Some s1, s2 -> - (match string_split_character s1 '.' with - | Some _, s4 -> s4 ^ "." ^ s2 - | _ -> s) - | _ -> s - -(** Convert a fieldname to a flat string without path. *) -let fieldname_to_flat_string fn = - let s = Mangled.to_string fn.fname in - match string_split_character s '.' with - | Some _, s2 -> s2 - | _ -> s - -(** Returns the class part of the fieldname *) -let java_fieldname_get_class fn = - let fn = fieldname_to_string fn in - let ri = String.rindex fn '.' in - String.sub fn 0 ri - -(** Returns the last component of the fieldname *) -let java_fieldname_get_field fn = - let fn = fieldname_to_string fn in - let ri = 1 + String.rindex fn '.' in - String.sub fn ri (String.length fn - ri) - -(** Check if the field is the synthetic this$n of a nested class, used to access the n-th outher instance. *) -let java_fieldname_is_outer_instance fn = - let fn = fieldname_to_string fn in - let fn_len = String.length fn in - let this = ".this$" in - let this_len = String.length this in - let zero_to_nine s = s >= "0" && s <= "9" in - fn_len > this_len && - String.sub fn (fn_len - this_len - 1) this_len = this && - zero_to_nine (String.sub fn (fn_len - 1) 1) - -let fieldname_offset fn = fn.fpos - -(** hidded fieldname constant *) -let fieldname_hidden = create_fieldname (Mangled.from_string ".hidden") 0 - -(** hidded fieldname constant *) -let fieldname_is_hidden fn = - fieldname_equal fn fieldname_hidden - -(** {2 Functions and Hash Tables for Managing Stamps} *) - -(** Set the stamp of the identifier *) -let set_stamp i stamp = - { i with stamp = stamp } - -(** Get the stamp of the identifier *) -let get_stamp i = - i.stamp - -module NameGenerator = struct - type t = int NameHash.t - - let create () : t = NameHash.create 17 - - (** Map from names to stamps. *) - let name_map = ref (create ()) - - let get_current () = - !name_map - - let set_current map = - name_map := map - - (** Reset the name generator *) - let reset () = - name_map := create () - - (** Create a fresh identifier with the given kind and name. *) - let create_fresh_ident kind name = - let stamp = - try - let stamp = NameHash.find !name_map name in - NameHash.replace !name_map name (stamp + 1); - stamp + 1 - with Not_found -> - NameHash.add !name_map name 0; - 0 in - { kind = kind; name = name; stamp = stamp } - - (** Make sure that fresh ids after whis one will be with different stamps *) - let update_name_hash name stamp = - try - let curr_stamp = NameHash.find !name_map name in - let new_stamp = max curr_stamp stamp in - NameHash.replace !name_map name new_stamp - with Not_found -> - NameHash.add !name_map name stamp -end - -(** Name used for primed tmp variables *) -let name_primed = string_to_name "t" - -(** Name used for normal tmp variables *) -let name_normal = string_to_name "n" - -(** Name used for footprint tmp variables *) -let name_footprint = string_to_name "f" - -(** Name used for spec variables *) -let name_spec = string_to_name "val" - -(** Name used for the return variable *) -let name_return = Mangled.from_string "return" - -(** Return the standard name for the given kind *) -let standard_name kind = - if kind == knormal then name_normal - else if kind == kfootprint then name_footprint - else name_primed - -(** Every identifier with a given stamp should unltimately be created using this function *) -let create_with_stamp kind name stamp = - NameGenerator.update_name_hash name stamp; - { kind = kind; name = name; stamp = stamp; } - -(** Create an identifier with default name for the given kind *) -let create kind stamp = - create_with_stamp kind (standard_name kind) stamp - -(** Generate a normal identifier with the given name and stamp *) -let create_normal name stamp = - create_with_stamp knormal name stamp - -(** Generate a primed identifier with the given name and stamp *) -let create_primed name stamp = - create_with_stamp kprimed name stamp - -(** Generate a footprint identifier with the given name and stamp *) -let create_footprint name stamp = - create_with_stamp kfootprint name stamp - -(** {2 Functions for Identifiers} *) - -(** Get a name of an identifier *) -let get_name id = - id.name - -let get_kind id = - id.kind - -let is_primed (id: t) = - id.kind == kprimed - -let is_normal (id: t) = - id.kind == knormal - -let is_footprint (id: t) = - id.kind == kfootprint - -(* timestamp for a path identifier *) -let path_ident_stamp = - 3 - -let is_path (id: t) = - id.kind == knormal && id.stamp = path_ident_stamp - -let make_unprimed id = - if id.kind <> kprimed then assert false - else { id with kind = knormal } - -(** Update the name generator so that the given id's are not generated again *) -let update_name_generator ids = - let upd id = ignore (create_with_stamp id.kind id.name id.stamp) in - IList.iter upd ids - -(** Create a fresh identifier with default name for the given kind. *) -let create_fresh kind = - NameGenerator.create_fresh_ident kind (standard_name kind) - -(** Generate a normal identifier whose name encodes a path given as a string. *) -let create_path pathstring = - create_normal (string_to_name ("%path%" ^ pathstring)) path_ident_stamp - -(** {2 Pretty Printing} *) - -(** Convert an identifier to a string. *) -let to_string id = - let base_name = name_to_string id.name in - let prefix = - if id.kind == kfootprint then "@" - else if id.kind == knormal then "" - else "_" in - let suffix = "$" ^ (string_of_int id.stamp) - in prefix ^ base_name ^ suffix - -(** Pretty print a name. *) -let pp_name f name = - F.fprintf f "%s" (name_to_string name) - -let pp_fieldname f fn = - (* only use for debug F.fprintf f "%a#%d" pp_name fn.fname fn.fpos *) - Mangled.pp f fn.fname - -(** Pretty print a name in latex. *) -let pp_name_latex style f (name: name) = - Latex.pp_string style f (name_to_string name) - -let pp_fieldname_latex style f fn = - Latex.pp_string style f (Mangled.to_string fn.fname) - -(** Pretty print an identifier. *) -let pp pe f id = match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%s" (to_string id) - | PP_LATEX -> - let base_name = name_to_string id.name in - let style = - if id.kind = kfootprint then Latex.Boldface - else if id.kind = knormal then Latex.Roman - else Latex.Roman in - F.fprintf f "%a_{%s}" (Latex.pp_string style) base_name (string_of_int id.stamp) - -(** pretty printer for lists of identifiers *) -let pp_list pe = pp_comma_seq (pp pe) - -(** pretty printer for lists of names *) -let pp_name_list = pp_comma_seq pp_name - -(* -let make_ident_primed id = - if id.kind == kprimed then assert false - else { id with kind = kprimed } -*) diff --git a/infer/src/IR/ident.mli b/infer/src/IR/ident.mli deleted file mode 100644 index 8013eeb70..000000000 --- a/infer/src/IR/ident.mli +++ /dev/null @@ -1,211 +0,0 @@ -(* - * 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 - -(** Identifiers: program variables and logical variables *) - -(** Program and logical variables. *) -type t - -(** Names used to replace strings. *) -type name - -(** Names for fields of class/struct/union *) -type fieldname - -(** Kind of identifiers. *) -type kind - -(** Set for identifiers. *) -module IdentSet : Set.S with type elt = t - -(** Hash table with ident as key. *) -module IdentHash : Hashtbl.S with type key = t - -(** Map with ident as key. *) -module IdentMap : Map.S with type key = t - -(** Set for fieldnames *) -module FieldSet : Set.S with type elt = fieldname - -(** Map for fieldnames *) -module FieldMap : Map.S with type key = fieldname - -module NameGenerator : sig - type t - - (** Get the current name generator. *) - val get_current : unit -> t - - (** Reset the name generator. *) - val reset : unit -> unit - - (** Set the current name generator. *) - val set_current : t -> unit -end - -(** Convert an identfier list to an identifier set *) -val idlist_to_idset : t list -> IdentSet.t - -val kprimed : kind -val knormal : kind -val kfootprint : kind - -(** hash table with names as keys *) -module NameHash : Hashtbl.S with type key = name - -(** Name used for primed tmp variables *) -val name_primed : name - -(** Name used for spec variables *) -val name_spec : name - -(** Name used for the return variable *) -val name_return : Mangled.t - -(** Convert a string to a name. *) -val string_to_name : string -> name - -(** Create a field name at the given position *) -val create_fieldname : Mangled.t -> int -> fieldname - -(** Convert a name to a string. *) -val name_to_string : name -> string - -(** Convert a field name to a string. *) -val fieldname_to_string : fieldname -> string - -(** Convert a fieldname to a simplified string with at most one-level path. *) -val fieldname_to_simplified_string : fieldname -> string - -(** Convert a fieldname to a flat string without path. *) -val fieldname_to_flat_string : fieldname -> string - -(** The class part of the fieldname *) -val java_fieldname_get_class : fieldname -> string - -(** The last component of the fieldname *) -val java_fieldname_get_field : fieldname -> string - -(** Check if the field is the synthetic this$n of a nested class, used to access the n-th outher instance. *) -val java_fieldname_is_outer_instance : fieldname -> bool - -(** get the offset of a fieldname *) -val fieldname_offset : fieldname -> int - -(** hidded fieldname constant *) -val fieldname_hidden : fieldname - -(** hidded fieldname constant *) -val fieldname_is_hidden : fieldname -> bool - -(** Name of the identifier. *) -val get_name : t -> name - -(** Kind of the identifier. *) -val get_kind : t -> kind - -(** Create an identifier with default name for the given kind *) -val create : kind -> int -> t - -(** Generate a normal identifier with the given name and stamp. *) -val create_normal : name -> int -> t - -(** Generate a primed identifier with the given name and stamp. *) -val create_primed : name -> int -> t - -(** Generate a footprint identifier with the given name and stamp. *) -val create_footprint : name -> int -> t - -(** Update the name generator so that the given id's are not generated again *) -val update_name_generator : t list -> unit - -(** Create a fresh identifier with default name for the given kind. *) -val create_fresh : kind -> t - -(** Generate a normal identifier whose name encodes a path given as a string. *) -val create_path : string -> t - -(** Check whether an identifier is primed or not. *) -val is_primed : t -> bool - -(** Check whether an identifier is normal or not. *) -val is_normal : t -> bool - -(** Check whether an identifier is footprint or not. *) -val is_footprint : t -> bool - -(** Check whether an identifier represents a path or not. *) -val is_path : t -> bool - -(** Convert a primed ident into a nonprimed one, keeping the stamp. *) -val make_unprimed : t -> t - -(** Get the stamp of the identifier *) -val get_stamp: t -> int - -(** Set the stamp of the identifier *) -val set_stamp: t -> int -> t - -(** {2 Comparision Functions} *) - -(** Comparison for names. *) -val name_compare : name -> name -> int - -(** Comparison for field names. *) -val fieldname_compare : fieldname -> fieldname -> int - -(** Equality for names. *) -val name_equal : name -> name -> bool - -(** Equality for field names. *) -val fieldname_equal : fieldname -> fieldname -> bool - -(** Equality for kind. *) -val kind_equal : kind -> kind -> bool - -(** Comparison for identifiers. *) -val compare : t -> t -> int - -(** Equality for identifiers. *) -val equal : t -> t -> bool - -(** Comparison for lists of identities *) -val ident_list_compare : t list -> t list -> int - -(** Equality for lists of identities *) -val ident_list_equal : t list -> t list -> bool - -(** {2 Pretty Printing} *) - -(** Pretty print a name. *) -val pp_name : Format.formatter -> name -> unit - -(** Pretty print a field name. *) -val pp_fieldname : Format.formatter -> fieldname -> unit - -(** Pretty print a name in latex. *) -val pp_name_latex : Latex.style -> Format.formatter -> name -> unit - -(** Pretty print a field name in latex. *) -val pp_fieldname_latex : Latex.style -> Format.formatter -> fieldname -> unit - -(** Pretty print an identifier. *) -val pp : printenv -> Format.formatter -> t -> unit - -(** Convert an identifier to a string. *) -val to_string : t -> string - -(** Pretty print a list of identifiers. *) -val pp_list : printenv -> Format.formatter -> t list -> unit - -(** Pretty print a list of names. *) -val pp_name_list : Format.formatter -> name list -> unit diff --git a/infer/src/IR/location.ml b/infer/src/IR/location.ml deleted file mode 100644 index 458fcf143..000000000 --- a/infer/src/IR/location.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -module F = Format -module L = Logging - -(** Location in the original source file *) -type t = { - line: int; (** The line number. -1 means "do not know" *) - col: int; (** The column number. -1 means "do not know" *) - file: DB.source_file; (** The name of the source file *) - nLOC : int; (** Lines of code in the source file *) -} - -let compare loc1 loc2 = - let n = int_compare loc1.line loc2.line in - if n <> 0 then n else DB.source_file_compare loc1.file loc2.file - -(** Dump a location *) -let d (loc: t) = L.add_print_action (L.PTloc, Obj.repr loc) - -(** Dummy location *) -let dummy = { - line = -1; - col = -1; - file = DB.source_file_empty; - nLOC = -1; -} - -let equal loc1 loc2 = - compare loc1 loc2 = 0 - -(** Pretty print a location *) -let pp f (loc: t) = - F.fprintf f "[line %d]" loc.line - -let to_string loc = - let s = (string_of_int loc.line) in - if (loc.col != -1) then - s ^":"^(string_of_int loc.col) - else s diff --git a/infer/src/IR/location.mli b/infer/src/IR/location.mli deleted file mode 100644 index a260acc17..000000000 --- a/infer/src/IR/location.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -(** Location in the original source file *) -type t = { - line: int; (** The line number. -1 means "do not know" *) - col: int; (** The column number. -1 means "do not know" *) - file: DB.source_file; (** The name of the source file *) - nLOC : int; (** Lines of code in the source file *) -} - -val compare : t -> t -> int - -(** Dump a location. *) -val d : t -> unit - -(** Dummy location *) -val dummy : t - -val equal : t -> t -> bool - -(** Pretty print a location. *) -val pp : Format.formatter -> t -> unit - -(** String representation of a location. *) -val to_string : t -> string diff --git a/infer/src/IR/mangled.ml b/infer/src/IR/mangled.ml deleted file mode 100644 index c60bfe913..000000000 --- a/infer/src/IR/mangled.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* - * 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 - -(** Module for Mangled Names *) - -module F = Format - -type t = - { plain: string; - mangled: string option } - -let mangled_compare so1 so2 = match so1, so2 with - | None, None -> 0 - | None, Some _ -> -1 - | Some _, None -> 1 - | Some s1, Some s2 -> string_compare s1 s2 - -let compare pn1 pn2 = - let n = string_compare pn1.plain pn2.plain in - if n <> 0 then n else mangled_compare pn1.mangled pn2.mangled - -let equal pn1 pn2 = - compare pn1 pn2 = 0 - -(** Convert a string to a mangled name *) -let from_string (s: string) = - { plain = s; - mangled = None } - -(** Create a mangled name from a plain and mangled string *) -let mangled (plain: string) (mangled: string) = - { plain = plain; - mangled = Some (plain ^ "{" ^ mangled ^ "}") } - -(** Convert a mangled name to a string *) -let to_string (pn: t) = - pn.plain - -(** Convert a full mangled name to a string *) -let to_string_full (pn: t) = - match pn.mangled with - | Some mangled -> pn.plain ^ "{" ^ mangled ^ "}" - | None -> pn.plain - -(** Get mangled string if given *) -let get_mangled pn = match pn.mangled with - | Some s -> s - | None -> pn.plain - -(** Create a mangled type name from a package name and a class name *) -let from_package_class package_name class_name = - if package_name = "" then from_string class_name - else from_string (package_name ^ "." ^ class_name) - -(** Pretty print a mangled name *) -let pp f pn = - F.fprintf f "%s" (to_string pn) - - -type mangled_t = t -module MangledSet = Set.Make - (struct - type t = mangled_t - let compare = compare - end) diff --git a/infer/src/IR/mangled.mli b/infer/src/IR/mangled.mli deleted file mode 100644 index f2eff480a..000000000 --- a/infer/src/IR/mangled.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* - * 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 - -(** Module for Mangled Names *) - -(** Type of mangled names *) -type t - -(** Comparison for mangled names *) -val compare : t -> t -> int - -(** Equality for mangled names *) -val equal : t -> t -> bool - -(** Convert a string to a mangled name *) -val from_string : string -> t - -(** Create a mangled type name from a package name and a class name *) -val from_package_class : string -> string -> t - -(** Create a mangled name from a plain and mangled string *) -val mangled : string -> string -> t - -(** Convert a mangled name to a string *) -val to_string : t -> string - -(** Convert a full mangled name to a string *) -val to_string_full : t -> string - -(** Get mangled string if given *) -val get_mangled : t -> string - -(** Pretty print a mangled name *) -val pp : Format.formatter -> t -> unit - -(** Set of Mangled. *) -module MangledSet : Set.S with type elt = t diff --git a/infer/src/IR/procAttributes.ml b/infer/src/IR/procAttributes.ml deleted file mode 100644 index 3d4726391..000000000 --- a/infer/src/IR/procAttributes.ml +++ /dev/null @@ -1,69 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -(** Attributes of a procedure. *) - -module L = Logging -module F = Format - -(** Type for ObjC accessors *) -type objc_accessor_type = - | Objc_getter of Ident.fieldname - | Objc_setter of Ident.fieldname - -type t = - { - access : Sil.access; (** visibility access *) - captured : (Mangled.t * Sil.typ) list; (** name and type of variables captured in blocks *) - mutable changed : bool; (** true if proc has changed since last analysis *) - err_log: Errlog.t; (** Error log for the procedure *) - exceptions : string list; (** exceptions thrown by the procedure *) - formals : (Mangled.t * Sil.typ) list; (** name and type of formal parameters *) - func_attributes : Sil.func_attribute list; - is_abstract : bool; (** the procedure is abstract *) - mutable is_bridge_method : bool; (** the procedure is a bridge method *) - is_defined : bool; (** true if the procedure is defined, and not just declared *) - is_objc_instance_method : bool; (** the procedure is an objective-C instance method *) - is_cpp_instance_method : bool; (** the procedure is an C++ instance method *) - mutable is_synthetic_method : bool; (** the procedure is a synthetic method *) - language : Config.language; (** language of the procedure *) - loc : Location.t; (** location of this procedure in the source code *) - mutable locals : (Mangled.t * Sil.typ) list; (** name and type of local variables *) - method_annotation : Sil.method_annotation; (** annotations for java methods *) - objc_accessor : objc_accessor_type option; (** type of ObjC accessor, if any *) - proc_flags : proc_flags; (** flags of the procedure *) - proc_name : Procname.t; (** name of the procedure *) - ret_type : Sil.typ; (** return type *) - } - -let default proc_name language = { - access = Sil.Default; - captured = []; - changed = true; - err_log = Errlog.empty (); - exceptions = []; - formals = []; - func_attributes = []; - is_abstract = false; - is_bridge_method = false; - is_cpp_instance_method = false; - is_defined = false; - is_objc_instance_method = false; - is_synthetic_method = false; - language; - loc = Location.dummy; - locals = []; - method_annotation = Sil.method_annotation_empty; - objc_accessor = None; - proc_flags = proc_flags_empty (); - proc_name; - ret_type = Sil.Tvoid; -} diff --git a/infer/src/IR/procAttributes.mli b/infer/src/IR/procAttributes.mli deleted file mode 100644 index b379d31fb..000000000 --- a/infer/src/IR/procAttributes.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -(** Attributes of a procedure. *) - -type objc_accessor_type = - | Objc_getter of Ident.fieldname - | Objc_setter of Ident.fieldname - -type t = - { - access : Sil.access; (** visibility access *) - captured : (Mangled.t * Sil.typ) list; (** name and type of variables captured in blocks *) - mutable changed : bool; (** true if proc has changed since last analysis *) - err_log: Errlog.t; (** Error log for the procedure *) - exceptions : string list; (** exceptions thrown by the procedure *) - formals : (Mangled.t * Sil.typ) list; (** name and type of formal parameters *) - func_attributes : Sil.func_attribute list; - is_abstract : bool; (** the procedure is abstract *) - mutable is_bridge_method : bool; (** the procedure is a bridge method *) - is_defined : bool; (** true if the procedure is defined, and not just declared *) - is_objc_instance_method : bool; (** the procedure is an objective-C instance method *) - is_cpp_instance_method : bool; (** the procedure is an C++ instance method *) - mutable is_synthetic_method : bool; (** the procedure is a synthetic method *) - language : Config.language; (** language of the procedure *) - loc : Location.t; (** location of this procedure in the source code *) - mutable locals : (Mangled.t * Sil.typ) list; (** name and type of local variables *) - method_annotation : Sil.method_annotation; (** annotations for java methods *) - objc_accessor : objc_accessor_type option; (** type of ObjC accessor, if any *) - proc_flags : proc_flags; (** flags of the procedure *) - proc_name : Procname.t; (** name of the procedure *) - ret_type : Sil.typ; (** return type *) - } - -(** Create a proc_attributes with default values. *) -val default : Procname.t -> Config.language -> t diff --git a/infer/src/IR/procname.ml b/infer/src/IR/procname.ml deleted file mode 100644 index 2e2dc2c14..000000000 --- a/infer/src/IR/procname.ml +++ /dev/null @@ -1,515 +0,0 @@ -(* - * 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 - -(** Module for Procedure Names *) - -module L = Logging -module F = Format - -type java_type = string option * string (* e.g. ("", "int") for primitive types or ("java.io", "PrintWriter") for objects *) - -type method_kind = - | Static (* in Java, procedures called with invokestatic *) - | Non_Static (* in Java, procedures called with invokevirtual, invokespecial, and invokeinterface *) - -(** Type of java procedure names. *) -type java = { - class_name: java_type; - return_type: java_type option; (* option because constructors have no return type *) - method_name: string; - parameters: java_type list; - kind: method_kind -} - -(** Type of c procedure names. *) -type c = string * (string option) - -(** Type of Objective C and C++ procedure names: method signatures. *) -type objc_cpp = { - class_name: string; - method_name: string; - mangled: string option; -} - -(** Type of Objective C block names. *) -type block = string - -(** Type of procedure names. *) -type t = - | Java of java - | C of c - | ObjC_Cpp of objc_cpp - | Block of block - -(** Level of verbosity of some to_string functions. *) -type detail_level = - | Verbose - | Non_verbose - | Simple - -type objc_method_kind = - | Instance_objc_method - | Class_objc_method - -let mangled_of_objc_method_kind kind = - match kind with - | Instance_objc_method -> Some "instance" - | Class_objc_method -> Some "class" - -let objc_method_kind_of_bool is_instance = - if is_instance then Instance_objc_method - else Class_objc_method - -let empty_block = Block "" - -let is_verbose v = - match v with - | Verbose -> true - | _ -> false - -type proc_name = t - -let mangled_compare so1 so2 = match so1, so2 with - | None, None -> 0 - | None, Some _ -> -1 - | Some _, None -> 1 - | Some s1, Some s2 -> string_compare s1 s2 - -let method_kind_compare k0 k1 = - match k0, k1 with - | _ when k0 = k1 -> 0 - | Static, _ -> 1 - | Non_Static, _ -> -1 - -(** A type is a pair (package, type_name) that is translated in a string package.type_name *) -let java_type_to_string_verbosity p verbosity = - match p with - | (None, typ) -> typ - | (Some p, cls) -> - if is_verbose verbosity then p ^ "." ^ cls - else cls - -let java_type_to_string p = - java_type_to_string_verbosity p Verbose - -(** Given a list of types, it creates a unique string of types separated by commas *) -let rec java_param_list_to_string inputList verbosity = - match inputList with - | [] -> "" - | [head] -> java_type_to_string_verbosity head verbosity - | head :: rest -> - (java_type_to_string_verbosity head verbosity) ^ "," ^ (java_param_list_to_string rest verbosity) - -(** It is the same as java_type_to_string, but Java return types are optional because of constructors without type *) -let java_return_type_to_string j verbosity = - match j.return_type with - | None -> "" - | Some typ -> - java_type_to_string_verbosity typ verbosity - -let java_type_compare (p1, c1) (p2, c2) = - string_compare c1 c2 |> next mangled_compare p1 p2 - -let rec java_type_list_compare jt1 jt2 = - match jt1, jt2 with - | [], [] -> 0 - | [], _ -> -1 - | _, [] -> 1 - | (x1:: rest1), (x2:: rest2) -> - java_type_compare x1 x2 |> next java_type_list_compare rest1 rest2 - -let java_return_type_compare jr1 jr2 = - match jr1, jr2 with - | None, None -> 0 - | None, Some _ -> -1 - | Some _, None -> 1 - | Some jt1 , Some jt2 -> java_type_compare jt1 jt2 - -(** Compare java procedure names. *) -let java_compare (j1: java) (j2 : java) = - string_compare j1.method_name j2.method_name - |> next java_type_list_compare j1.parameters j2.parameters - |> next java_type_compare j1.class_name j2.class_name - |> next java_return_type_compare j1.return_type j2.return_type - |> next method_kind_compare j1.kind j2.kind - -let c_function_mangled_compare mangled1 mangled2 = - match mangled1, mangled2 with - | Some _, None -> 1 - | None, Some _ -> -1 - | None, None -> 0 - | Some mangled1, Some mangled2 -> - string_compare mangled1 mangled2 - -(** Compare c_method signatures. *) -let c_meth_sig_compare osig1 osig2 = - string_compare osig1.method_name osig2.method_name - |> next string_compare osig1.class_name osig2.class_name - |> next c_function_mangled_compare osig1.mangled osig2.mangled - -(** Given a package.class_name string, it looks for the latest dot and split the string - in two (package, class_name) *) -let split_classname package_classname = - string_split_character package_classname '.' - -let from_string_c_fun (s: string) = C (s, None) - -let c (plain: string) (mangled: string) = (plain, Some mangled) - -let java class_name return_type method_name parameters kind = - { - class_name; - return_type; - method_name; - parameters; - kind; - } - -(** Create an objc procedure name from a class_name and method_name. *) -let objc_cpp class_name method_name mangled = - { - class_name = class_name; - method_name = method_name; - mangled = mangled; - } - -let get_default_objc_class_method objc_class = - let objc_cpp = objc_cpp objc_class "__find_class_" (Some "internal") in - ObjC_Cpp objc_cpp - -(** Create an objc procedure name from a class_name and method_name. *) -let mangled_objc_block name = - Block name - -let is_java = function - | Java _ -> true - | _ -> false - -let is_c_method = function - | ObjC_Cpp _ -> true - | _ -> false - -(** Replace the class name component of a procedure name. - In case of Java, replace package and class name. *) -let replace_class t new_class = match t with - | Java j -> - Java { j with class_name = (split_classname new_class) } - | ObjC_Cpp osig -> - ObjC_Cpp { osig with class_name = new_class } - | C _ - | Block _ -> - t - -(** Get the class name of a Objective-C/C++ procedure name. *) -let objc_cpp_get_class_name objc_cpp = - objc_cpp.class_name - -(** Return the package.classname of a java procname. *) -let java_get_class_name (j : java) = - java_type_to_string j.class_name - -(** Return the class name of a java procedure name. *) -let java_get_simple_class_name (j : java) = - snd j.class_name - -(** Return the package of a java procname. *) -let java_get_package (j : java) = - fst j.class_name - -(** Return the method of a java procname. *) -let java_get_method (j : java) = - j.method_name - -(** Replace the method of a java procname. *) -let java_replace_method (j : java) mname = - { j with method_name = mname } - -(** Replace the return type of a java procname. *) -let java_replace_return_type j ret_type = - { j with return_type = Some ret_type } - -(** Replace the parameters of a java procname. *) -let java_replace_parameters j parameters = - { j with parameters } - -(** Return the method/function of a procname. *) -let get_method = function - | ObjC_Cpp name -> - name.method_name - | C (name, _) -> - name - | Block name -> - name - | Java j -> - j.method_name - -(** Return the language of the procedure. *) -let get_language = function - | ObjC_Cpp _ -> - Config.Clang - | C _ -> - Config.Clang - | Block _ -> - Config.Clang - | Java _ -> - Config.Java - - -(** Return the return type of a java procname. *) -let java_get_return_type (j : java) = - java_return_type_to_string j Verbose - -(** Return the parameters of a java procname. *) -let java_get_parameters j = - j.parameters - -(** Return the parameters of a java procname as strings. *) -let java_get_parameters_as_strings j = - IList.map (fun param -> java_type_to_string param) j.parameters - -(** Return true if the java procedure is static *) -let java_is_static = function - | Java j -> - j.kind = Static - | _ -> - false - -(** Prints a string of a java procname with the given level of verbosity *) -let java_to_string ?(withclass = false) (j : java) verbosity = - match verbosity with - | Verbose | Non_verbose -> - (* if verbose, then package.class.method(params): rtype, - else rtype package.class.method(params) - verbose is used for example to create unique filenames, non_verbose to create reports *) - let return_type = java_return_type_to_string j verbosity in - let params = java_param_list_to_string j.parameters verbosity in - let class_name = java_type_to_string_verbosity j.class_name verbosity in - let separator = - match j.return_type, verbosity with - | (None, _) -> "" - | (Some _, Verbose) -> ":" - | _ -> " " in - let output = class_name ^ "." ^ j.method_name ^ "(" ^ params ^ ")" in - if verbosity = Verbose then output ^ separator ^ return_type - else return_type ^ separator ^ output - | Simple -> (* methodname(...) or without ... if there are no parameters *) - let cls_prefix = - if withclass then - java_type_to_string_verbosity j.class_name verbosity ^ "." - else "" in - let params = - match j.parameters with - | [] -> "" - | _ -> "..." in - let method_name = - if j.method_name = "" then - java_get_simple_class_name j - else - cls_prefix ^ j.method_name in - method_name ^ "(" ^ params ^ ")" - -(** Check if the class name is for an anonymous inner class. *) -let is_anonymous_inner_class_name class_name = - match string_split_character class_name '$' with - | Some _, s -> - let is_int = - try ignore (int_of_string (String.trim s)); true with Failure _ -> false in - is_int - | None, _ -> false - -(** Check if the procedure belongs to an anonymous inner class. *) -let java_is_anonymous_inner_class = function - | Java j -> is_anonymous_inner_class_name (snd j.class_name) - | _ -> false - -(** Check if the last parameter is a hidden inner class, and remove it if present. - This is used in private constructors, where a proxy constructor is generated - with an extra parameter and calls the normal constructor. *) -let java_remove_hidden_inner_class_parameter = function - | Java js -> - (match IList.rev js.parameters with - | (_, s) :: par' -> - if is_anonymous_inner_class_name s - then Some (Java { js with parameters = IList.rev par'}) - else None - | [] -> None) - | _ -> None - -(** Check if the procedure name is an anonymous inner class constructor. *) -let java_is_anonymous_inner_class_constructor = function - | Java js -> - let _, name = js.class_name in - is_anonymous_inner_class_name name - | _ -> false - -(** Check if the procedure name is an acess method (e.g. access$100 used to - access private members from a nested class. *) -let java_is_access_method = function - | Java js -> - (match string_split_character js.method_name '$' with - | Some "access", s -> - let is_int = - try ignore (int_of_string s); true with Failure _ -> false in - is_int - | _ -> false) - | _ -> false - -(** Check if the proc name has the type of a java vararg. - Note: currently only checks that the last argument has type Object[]. *) -let java_is_vararg = function - | Java js -> - begin - match (IList.rev js.parameters) with - | (_,"java.lang.Object[]") :: _ -> true - | _ -> false - end - | _ -> false - -(** [is_constructor pname] returns true if [pname] is a constructor *) -let is_constructor = function - | Java js -> js.method_name = "" - | ObjC_Cpp name -> - (name.method_name = "new") || - string_is_prefix "init" name.method_name - | _ -> false - -(** [is_objc_dealloc pname] returns true if [pname] is the dealloc method in Objective-C *) -let is_objc_dealloc = function - | ObjC_Cpp name -> name.method_name = "dealloc" - | _ -> false - -let java_is_close = function - | Java js -> js.method_name = "close" - | _ -> false - -(** [is_class_initializer pname] returns true if [pname] is a class initializer *) -let is_class_initializer = function - | Java js -> js.method_name = "" - | _ -> false - -(** [is_infer_undefined pn] returns true if [pn] is a special Infer undefined proc *) -let is_infer_undefined pn = match pn with - | Java j -> - let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in - Str.string_match regexp (java_get_class_name j) 0 - | _ -> - (* TODO: add cases for obj-c, c, c++ *) - false - -(** to_string for C_function type *) -let to_readable_string (c1, c2) verbose = - let plain = c1 in - if verbose then - match c2 with - | None -> plain - | Some s -> plain ^ "{" ^ s ^ "}" - else - plain - -let c_method_to_string osig detail_level = - match detail_level with - | Simple -> osig.method_name - | Non_verbose -> osig.class_name ^ "_" ^ osig.method_name - | Verbose -> - let m_str = match osig.mangled with - | None -> "" - | Some s -> "{" ^ s ^ "}" in - osig.class_name ^ "_" ^ osig.method_name ^ m_str - -(** Very verbose representation of an existing Procname.t *) -let to_unique_id pn = - match pn with - | Java j -> java_to_string j Verbose - | C (c1, c2) -> to_readable_string (c1, c2) true - | ObjC_Cpp osig -> c_method_to_string osig Verbose - | Block name -> name - -(** Convert a proc name to a string for the user to see *) -let to_string p = - match p with - | Java j -> (java_to_string j Non_verbose) - | C (c1, c2) -> - to_readable_string (c1, c2) false - | ObjC_Cpp osig -> c_method_to_string osig Non_verbose - | Block name -> name - -(** Convenient representation of a procname for external tools (e.g. eclipse plugin) *) -let to_simplified_string ?(withclass = false) p = - match p with - | Java j -> - (java_to_string ~withclass j Simple) - | C (c1, c2) -> - to_readable_string (c1, c2) false ^ "()" - | ObjC_Cpp osig -> - c_method_to_string osig Simple - | Block _ -> - "block" - -(** Convert a proc name to a filename *) -let to_filename proc_name = - Escape.escape_filename @@ string_append_crc_cutoff @@ to_unique_id proc_name - -(** Pretty print a proc name *) -let pp f pn = - F.fprintf f "%s" (to_string pn) - -(** Compare function for Procname.t types. - These rules create an ordered set of procnames grouped with the following - priority (lowest to highest): *) -let compare pn1 pn2 = match pn1, pn2 with - | Java j1, Java j2 -> - java_compare j1 j2 - | Java _, _ -> - -1 - | _, Java _ -> - 1 - | C (c1, c2), C (c3, c4) -> (* Compare C_function types *) - string_compare c1 c3 - |> next mangled_compare c2 c4 - | C _, _ -> - -1 - | _, C _ -> - 1 - | Block s1, Block s2 -> (* Compare ObjC_block types *) - string_compare s1 s2 - | Block _, _ -> - -1 - | _, Block _ -> - 1 - | ObjC_Cpp osig1, ObjC_Cpp osig2 -> - c_meth_sig_compare osig1 osig2 - -let equal pn1 pn2 = - compare pn1 pn2 = 0 - -(** hash function for procname *) -let hash_pname = Hashtbl.hash - -module Hash = - Hashtbl.Make(struct - type t = proc_name - let equal = equal - let hash = hash_pname - end) - -module Map = Map.Make (struct - type t = proc_name - let compare = compare end) - -module Set = Set.Make(struct - type t = proc_name - let compare = compare - end) - -(** Pretty print a set of proc names *) -let pp_set fmt set = - Set.iter (fun pname -> F.fprintf fmt "%a " pp pname) set diff --git a/infer/src/IR/procname.mli b/infer/src/IR/procname.mli deleted file mode 100644 index 2e6682479..000000000 --- a/infer/src/IR/procname.mli +++ /dev/null @@ -1,201 +0,0 @@ -(* - * 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 - -(** Module for Procedure Names. *) - -(** Type of java procedure names. *) -type java - -(** Type of c procedure names. *) -type c - -(** Type of Objective C and C++ procedure names. *) -type objc_cpp - -(** Type of Objective C block names. *) -type block - -(** Type of procedure names. *) -type t = - | Java of java - | C of c - | ObjC_Cpp of objc_cpp - | Block of block - -type java_type = string option * string - -type method_kind = - | Static (* in Java, procedures called with invokestatic *) - | Non_Static (* in Java, procedures called with invokevirtual, invokespecial, and invokeinterface *) - -type objc_method_kind = - | Instance_objc_method (* for instance methods in ObjC *) - | Class_objc_method (* for class methods in ObjC *) - -(** Hash tables with proc names as keys. *) -module Hash : Hashtbl.S with type key = t - -(** Maps from proc names. *) -module Map : Map.S with type key = t - -(** Sets of proc names. *) -module Set : Set.S with type elt = t - -(** Create a C procedure name from plain and mangled name. *) -val c : string -> string -> c - -(** Comparison for proc names. *) -val compare : t -> t -> int - -(** Empty block name. *) -val empty_block : t - -(** Equality for proc names. *) -val equal : t -> t -> bool - -(** Convert a string to a proc name. *) -val from_string_c_fun : string -> t - -(** Return the language of the procedure. *) -val get_language : t -> Config.language - -(** Return the method/function of a procname. *) -val get_method : t -> string - -(** Hash function for procname. *) -val hash_pname : t -> int - -(** Check if a class string is an anoynmous inner class name. *) -val is_anonymous_inner_class_name : string -> bool - -(** Check if this is an Objective-C/C++ method name. *) -val is_c_method : t -> bool - -(** Check if this is a constructor. *) -val is_constructor : t -> bool - -(** Check if this is a Java procedure name. *) -val is_java : t -> bool - -(** Check if this is a dealloc method in Objective-C. *) -val is_objc_dealloc : t -> bool - -(** Create a Java procedure name from its - class_name method_name args_type_name return_type_name method_kind. *) -val java : java_type -> java_type option -> string -> java_type list -> method_kind -> java - -(** Replace the parameters of a java procname. *) -val java_replace_parameters : java -> java_type list -> java - -(** Replace the method of a java procname. *) -val java_replace_return_type : java -> java_type -> java - -(** Create an objc block name. *) -val mangled_objc_block : string -> t - -(** Mangled string for method types. *) -val mangled_of_objc_method_kind : objc_method_kind -> string option - -(** Create an objc procedure name from a class_name and method_name. *) -val objc_cpp : string -> string -> string option -> objc_cpp - -val get_default_objc_class_method : string -> t - -(** Get the class name of a Objective-C/C++ procedure name. *) -val objc_cpp_get_class_name : objc_cpp -> string - -(** Create ObjC method type from a bool is_instance. *) -val objc_method_kind_of_bool : bool -> objc_method_kind - -(** Return the class name of a java procedure name. *) -val java_get_class_name : java -> string - -(** Return the simple class name of a java procedure name. *) -val java_get_simple_class_name : java -> string - -(** Return the package name of a java procedure name. *) -val java_get_package : java -> string option - -(** Return the method name of a java procedure name. *) -val java_get_method : java -> string - -(** Return the return type of a java procedure name. *) -val java_get_return_type : java -> string - -(** Return the parameters of a java procedure name. *) -val java_get_parameters : java -> java_type list - -(** Return the parameters of a java procname as strings. *) -val java_get_parameters_as_strings : java -> string list - -(** Check if the procedure name is an acess method (e.g. access$100 used to - access private members from a nested class. *) -val java_is_access_method : t -> bool - -(** Check if the procedure belongs to an anonymous inner class. *) -val java_is_anonymous_inner_class : t -> bool - -(** Check if the procedure name is an anonymous inner class constructor. *) -val java_is_anonymous_inner_class_constructor : t -> bool - -(** Check if the method name is "close". *) -val java_is_close : t -> bool - -(** Check if the java procedure is static. *) -val java_is_static : t -> bool - -(** Check if the proc name has the type of a java vararg. - Note: currently only checks that the last argument has type Object[]. *) -val java_is_vararg : t -> bool - -(** Check if the last parameter is a hidden inner class, and remove it if present. - This is used in private constructors, where a proxy constructor is generated - with an extra parameter and calls the normal constructor. *) -val java_remove_hidden_inner_class_parameter : t -> t option - -(** Replace the method name of an existing java procname. *) -val java_replace_method : java -> string -> java - -(** Convert a java type to a string. *) -val java_type_to_string : java_type -> string - -(** Check if this is a class initializer. *) -val is_class_initializer : t -> bool - -(** Check if this is a special Infer undefined procedure. *) -val is_infer_undefined : t -> bool - -(** Pretty print a proc name. *) -val pp : Format.formatter -> t -> unit - -(** Pretty print a set of proc names. *) -val pp_set : Format.formatter -> Set.t -> unit - -(** Replace the class name component of a procedure name. - In case of Java, replace package and class name. *) -val replace_class : t -> string -> t - -(** Given a package.class_name string, look for the latest dot and split the string - in two (package, class_name). *) -val split_classname : string -> string option * string - -(** Convert a proc name to a string for the user to see. *) -val to_string : t -> string - -(** Convert a proc name into a easy string for the user to see in an IDE. *) -val to_simplified_string : ?withclass: bool -> t -> string - -(** Convert a proc name into a unique identifier. *) -val to_unique_id : t -> string - -(** Convert a proc name to a filename. *) -val to_filename : t -> string diff --git a/infer/src/IR/pvar.ml b/infer/src/IR/pvar.ml deleted file mode 100644 index 0f444137e..000000000 --- a/infer/src/IR/pvar.ml +++ /dev/null @@ -1,215 +0,0 @@ -(* - * 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 - -(** The Smallfoot Intermediate Language *) - -module L = Logging -module F = Format - -(** Kind of global variables *) -type pvar_kind = - | Local_var of Procname.t (** local variable belonging to a function *) - | Callee_var of Procname.t (** local variable belonging to a callee *) - | Abducted_retvar of Procname.t * Location.t (** synthetic variable to represent return value *) - | Abducted_ref_param of Procname.t * t * Location.t - (** synthetic variable to represent param passed by reference *) - | Global_var (** gloval variable *) - | Seed_var (** variable used to store the initial value of formal parameters *) - -(** Names for program variables. *) -and t = - { pv_name: Mangled.t; - pv_kind: pvar_kind } - -let rec pvar_kind_compare k1 k2 = match k1, k2 with - | Local_var n1, Local_var n2 -> Procname.compare n1 n2 - | Local_var _, _ -> - 1 - | _, Local_var _ -> 1 - | Callee_var n1, Callee_var n2 -> Procname.compare n1 n2 - | Callee_var _, _ -> - 1 - | _, Callee_var _ -> 1 - | Abducted_retvar (p1, l1), Abducted_retvar (p2, l2) -> - let n = Procname.compare p1 p2 in - if n <> 0 then n else Location.compare l1 l2 - | Abducted_retvar _, _ -> - 1 - | _, Abducted_retvar _ -> 1 - | Abducted_ref_param (p1, pv1, l1), Abducted_ref_param (p2, pv2, l2) -> - let n = Procname.compare p1 p2 in - if n <> 0 then n else - let n = compare pv1 pv2 in - if n <> 0 then n else Location.compare l1 l2 - | Abducted_ref_param _, _ -> - 1 - | _, Abducted_ref_param _ -> 1 - | Global_var, Global_var -> 0 - | Global_var, _ -> - 1 - | _, Global_var -> 1 - | Seed_var, Seed_var -> 0 - -and compare pv1 pv2 = - let n = Mangled.compare pv1.pv_name pv2.pv_name in - if n <> 0 then n else pvar_kind_compare pv1.pv_kind pv2.pv_kind - -let equal pvar1 pvar2 = - compare pvar1 pvar2 = 0 - - -let rec _pp f pv = - let name = pv.pv_name in - match pv.pv_kind with - | Local_var n -> - if !Config.pp_simple then F.fprintf f "%a" Mangled.pp name - else F.fprintf f "%a$%a" Procname.pp n Mangled.pp name - | Callee_var n -> - if !Config.pp_simple then F.fprintf f "%a|callee" Mangled.pp name - else F.fprintf f "%a$%a|callee" Procname.pp n Mangled.pp name - | Abducted_retvar (n, l) -> - if !Config.pp_simple then F.fprintf f "%a|abductedRetvar" Mangled.pp name - else F.fprintf f "%a$%a%a|abductedRetvar" Procname.pp n Location.pp l Mangled.pp name - | Abducted_ref_param (n, pv, l) -> - if !Config.pp_simple then F.fprintf f "%a|%a|abductedRefParam" _pp pv Mangled.pp name - else F.fprintf f "%a$%a%a|abductedRefParam" Procname.pp n Location.pp l Mangled.pp name - | Global_var -> F.fprintf f "#GB$%a" Mangled.pp name - | Seed_var -> F.fprintf f "old_%a" Mangled.pp name - -(** Pretty print a program variable in latex. *) -let pp_latex f pv = - let name = pv.pv_name in - match pv.pv_kind with - | Local_var _ -> - Latex.pp_string Latex.Roman f (Mangled.to_string name) - | Callee_var _ -> - F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) - (Latex.pp_string Latex.Roman) "callee" - | Abducted_retvar _ -> - F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) - (Latex.pp_string Latex.Roman) "abductedRetvar" - | Abducted_ref_param _ -> - F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) - (Latex.pp_string Latex.Roman) "abductedRefParam" - | Global_var -> - Latex.pp_string Latex.Boldface f (Mangled.to_string name) - | Seed_var -> - F.fprintf f "%a^{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) - (Latex.pp_string Latex.Roman) "old" - -(** Pretty print a pvar which denotes a value, not an address *) -let pp_value pe f pv = - match pe.pe_kind with - | PP_TEXT -> _pp f pv - | PP_HTML -> _pp f pv - | PP_LATEX -> pp_latex f pv - -(** Pretty print a program variable. *) -let pp pe f pv = - let ampersand = match pe.pe_kind with - | PP_TEXT -> "&" - | PP_HTML -> "&" - | PP_LATEX -> "\\&" in - F.fprintf f "%s%a" ampersand (pp_value pe) pv - -(** Dump a program variable. *) -let d (pvar: t) = L.add_print_action (L.PTpvar, Obj.repr pvar) - -(** Pretty print a list of program variables. *) -let pp_list pe f pvl = - F.fprintf f "%a" (pp_seq (fun f e -> F.fprintf f "%a" (pp pe) e)) pvl - -(** Dump a list of program variables. *) -let d_list pvl = - IList.iter (fun pv -> d pv; L.d_str " ") pvl - -let get_name pv = pv.pv_name - -let to_string pv = Mangled.to_string pv.pv_name - -let get_simplified_name pv = - let s = Mangled.to_string pv.pv_name in - match string_split_character s '.' with - | Some s1, s2 -> - (match string_split_character s1 '.' with - | Some _, s4 -> s4 ^ "." ^ s2 - | _ -> s) - | _ -> s - -(** Check if the pvar is an abucted return var or param passed by ref *) -let is_abducted pv = - match pv.pv_kind with - | Abducted_retvar _ | Abducted_ref_param _ -> true - | _ -> false - -(** Turn a pvar into a seed pvar (which stored the initial value) *) -let to_seed pv = { pv with pv_kind = Seed_var } - -(** Check if the pvar is a local var *) -let is_local pv = - match pv.pv_kind with - | Local_var _ -> true - | _ -> false - -(** Check if the pvar is a callee var *) -let is_callee pv = - match pv.pv_kind with - | Callee_var _ -> true - | _ -> false - -(** Check if the pvar is a seed var *) -let is_seed pv = - match pv.pv_kind with - | Seed_var -> true - | _ -> false - -(** Check if the pvar is a global var *) -let is_global pv = - pv.pv_kind = Global_var - -(** Check if a pvar is the special "this" var *) -let is_this pvar = - Mangled.equal (get_name pvar) (Mangled.from_string "this") - -(** Check if the pvar is a return var *) -let is_return pv = - get_name pv = Ident.name_return - -(** Turn an ordinary program variable into a callee program variable *) -let to_callee pname pvar = match pvar.pv_kind with - | Local_var _ -> - { pvar with pv_kind = Callee_var pname } - | Global_var -> - pvar - | Callee_var _ | Abducted_retvar _ | Abducted_ref_param _ | Seed_var -> - L.d_str "Cannot convert pvar to callee: "; - d pvar; L.d_ln (); - assert false -(** [mk name proc_name] creates a program var with the given function name *) -let mk (name: Mangled.t) (proc_name: Procname.t) : t = - { pv_name = name; pv_kind = Local_var proc_name } - -let get_ret_pvar pname = - mk Ident.name_return pname - -(** [mk_callee name proc_name] creates a program var - for a callee function with the given function name *) -let mk_callee (name: Mangled.t) (proc_name: Procname.t) : t = - { pv_name = name; pv_kind = Callee_var proc_name } - -(** create a global variable with the given name *) -let mk_global (name: Mangled.t) : t = - { pv_name = name; pv_kind = Global_var } - -(** create an abducted return variable for a call to [proc_name] at [loc] *) -let mk_abducted_ret (proc_name : Procname.t) (loc : Location.t) : t = - let name = Mangled.from_string ("$RET_" ^ (Procname.to_unique_id proc_name)) in - { pv_name = name; pv_kind = Abducted_retvar (proc_name, loc) } - -let mk_abducted_ref_param (proc_name : Procname.t) (pv : t) (loc : Location.t) : t = - let name = Mangled.from_string ("$REF_PARAM_" ^ (Procname.to_unique_id proc_name)) in - { pv_name = name; pv_kind = Abducted_ref_param (proc_name, pv, loc) } diff --git a/infer/src/IR/pvar.mli b/infer/src/IR/pvar.mli deleted file mode 100644 index e5ad0555b..000000000 --- a/infer/src/IR/pvar.mli +++ /dev/null @@ -1,99 +0,0 @@ -(* - * 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 - -(** Program variables. *) - -module F = Format - -(** Type for program variables. There are 4 kinds of variables: - 1) local variables, used for local variables and formal parameters - 2) callee program variables, used to handle recursion ([x | callee] is distinguished from [x]) - 3) global variables - 4) seed variables, used to store the initial value of formal parameters -*) -type t - -(** Compare two pvar's *) -val compare : t -> t -> int - -(** Dump a program variable. *) -val d : t -> unit - -(** Dump a list of program variables. *) -val d_list : t list -> unit - -(** Equality for pvar's *) -val equal : t -> t -> bool - -(** Get the name component of a program variable. *) -val get_name : t -> Mangled.t - -(** [get_ret_pvar proc_name] retuns the return pvar associated with the procedure name *) -val get_ret_pvar : Procname.t -> t - -(** Get a simplified version of the name component of a program variable. *) -val get_simplified_name : t -> string - -(** Check if the pvar is an abducted return var or param passed by ref *) -val is_abducted : t -> bool - -(** Check if the pvar is a callee var *) -val is_callee : t -> bool - -(** Check if the pvar is a global var *) -val is_global : t -> bool - -(** Check if the pvar is a local var *) -val is_local : t -> bool - -(** Check if the pvar is a seed var *) -val is_seed : t -> bool - -(** Check if the pvar is a return var *) -val is_return : t -> bool - -(** Check if a pvar is the special "this" var *) -val is_this : t -> bool - -(** [mk name proc_name suffix] creates a program var with the given function name and suffix *) -val mk : Mangled.t -> Procname.t -> t - -(** create an abducted variable for a parameter passed by reference *) -val mk_abducted_ref_param : Procname.t -> t -> Location.t -> t - -(** create an abducted return variable for a call to [proc_name] at [loc] *) -val mk_abducted_ret : Procname.t -> Location.t -> t - -(** [mk_callee name proc_name] creates a program var - for a callee function with the given function name *) -val mk_callee : Mangled.t -> Procname.t -> t - -(** create a global variable with the given name *) -val mk_global : Mangled.t -> t - -(** Pretty print a program variable. *) -val pp : printenv -> F.formatter -> t -> unit - -(** Pretty print a list of program variables. *) -val pp_list : printenv -> F.formatter -> t list -> unit - -(** Pretty print a pvar which denotes a value, not an address *) -val pp_value : printenv -> F.formatter -> t -> unit - -(** Turn an ordinary program variable into a callee program variable *) -val to_callee : Procname.t -> t -> t - -(** Turn a pvar into a seed pvar (which stores the initial value of a stack var) *) -val to_seed : t -> t - -(** Convert a pvar to string. *) -val to_string : t -> string diff --git a/infer/src/IR/sil.ml b/infer/src/IR/sil.ml deleted file mode 100644 index a90962756..000000000 --- a/infer/src/IR/sil.ml +++ /dev/null @@ -1,3854 +0,0 @@ -(* - * 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 - -(** The Smallfoot Intermediate Language *) - -module L = Logging -module F = Format - -(** {2 Programs and Types} *) - -(** Type to represent one @Annotation. *) -type annotation = - { class_name: string; (* name of the annotation *) - parameters: string list; (* currently only one string parameter *) } - -(** Annotation for one item: a list of annotations with visibility. *) -type item_annotation = (annotation * bool) list - -(** Annotation for a method: return value and list of parameters. *) -type method_annotation = - item_annotation * item_annotation list - -type func_attribute = - | FA_sentinel of int * int (** __attribute__((sentinel(int, int))) *) - -(** Visibility modifiers. *) -type access = Default | Public | Private | Protected - -(** Compare function for annotations. *) -let annotation_compare a1 a2 = - let n = string_compare a1.class_name a2.class_name in - if n <> 0 then n else IList.compare string_compare a1.parameters a2.parameters - -(** Compare function for annotation items. *) -let item_annotation_compare ia1 ia2 = - let cmp (a1, b1) (a2, b2) = - let n = annotation_compare a1 a2 in - if n <> 0 then n else bool_compare b1 b2 in - IList.compare cmp ia1 ia2 - -(** Compare function for Method annotations. *) -let method_annotation_compare (ia1, ial1) (ia2, ial2) = - IList.compare item_annotation_compare (ia1 :: ial1) (ia2 :: ial2) - -(** Empty item annotation. *) -let item_annotation_empty = [] - -(** Empty method annotation. *) -let method_annotation_empty = [], [] - -(** Check if the item annodation is empty. *) -let item_annotation_is_empty ia = ia = [] - -(** Check if the method annodation is empty. *) -let method_annotation_is_empty (ia, ial) = - IList.for_all item_annotation_is_empty (ia :: ial) - -(** Pretty print an annotation. *) -let pp_annotation fmt annotation = F.fprintf fmt "@@%s" annotation.class_name - -(** Pretty print an item annotation. *) -let pp_item_annotation fmt item_annotation = - let pp fmt (a, _) = pp_annotation fmt a in - F.fprintf fmt "<%a>" (pp_seq pp) item_annotation - -let item_annotation_to_string ann = - let pp fmt () = pp_item_annotation fmt ann in - pp_to_string pp () - -(** Pretty print a method annotation. *) -let pp_method_annotation s fmt (ia, ial) = - F.fprintf fmt "%a %s(%a)" pp_item_annotation ia s (pp_seq pp_item_annotation) ial - -(** Return the value of the FA_sentinel attribute in [attr_list] if it is found *) -let get_sentinel_func_attribute_value attr_list = - match attr_list with - | FA_sentinel (sentinel, null_pos) :: _ -> Some (sentinel, null_pos) - | [] -> None - -(** Unary operations *) -type unop = - | Neg (** Unary minus *) - | BNot (** Bitwise complement (~) *) - | LNot (** Logical Not (!) *) - -(** Binary operations *) -type binop = - | PlusA (** arithmetic + *) - | PlusPI (** pointer + integer *) - | MinusA (** arithmetic - *) - | MinusPI (** pointer - integer *) - | MinusPP (** pointer - pointer *) - | Mult (** * *) - | Div (** / *) - | Mod (** % *) - | Shiftlt (** shift left *) - | Shiftrt (** shift right *) - - | Lt (** < (arithmetic comparison) *) - | Gt (** > (arithmetic comparison) *) - | Le (** <= (arithmetic comparison) *) - | Ge (** > (arithmetic comparison) *) - | Eq (** == (arithmetic comparison) *) - | Ne (** != (arithmetic comparison) *) - | BAnd (** bitwise and *) - | BXor (** exclusive-or *) - | BOr (** inclusive-or *) - - | LAnd (** logical and. Does not always evaluate both operands. *) - | LOr (** logical or. Does not always evaluate both operands. *) - | PtrFld (** field offset via pointer to field: takes the address of a - Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) *) - -(** Kinds of integers *) -type ikind = - IChar (** [char] *) - | ISChar (** [signed char] *) - | IUChar (** [unsigned char] *) - | IBool (** [bool] *) - | IInt (** [int] *) - | IUInt (** [unsigned int] *) - | IShort (** [short] *) - | IUShort (** [unsigned short] *) - | ILong (** [long] *) - | IULong (** [unsigned long] *) - | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) - | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) *) - | I128 (** [__int128_t] *) - | IU128 (** [__uint128_t] *) - -(** Kinds of floating-point numbers*) -type fkind = - | FFloat (** [float] *) - | FDouble (** [double] *) - | FLongDouble (** [long double] *) - -type mem_kind = - | Mmalloc (** memory allocated with malloc *) - | Mnew (** memory allocated with new *) - | Mnew_array (** memory allocated with new[] *) - | Mobjc (** memory allocated with objective-c alloc *) - -(** resource that can be allocated *) -type resource = - | Rmemory of mem_kind - | Rfile - | Rignore - | Rlock - -(** kind of resource action *) -type res_act_kind = - | Racquire - | Rrelease - -(** kind of dangling pointers *) -type dangling_kind = - (** pointer is dangling because it is uninitialized *) - | DAuninit - - (** pointer is dangling because it is the address - of a stack variable which went out of scope *) - | DAaddr_stack_var - - (** pointer is -1 *) - | DAminusone - -(** kind of pointer *) -type ptr_kind = - | Pk_pointer (* C/C++, Java, Objc standard/__strong pointer*) - | Pk_reference (* C++ reference *) - | Pk_objc_weak (* Obj-C __weak pointer*) - | Pk_objc_unsafe_unretained (* Obj-C __unsafe_unretained pointer *) - | Pk_objc_autoreleasing (* Obj-C __autoreleasing pointer *) - -(** position in a path: proc name, node id *) -type path_pos = Procname.t * int - -(** module for subtypes, to be used with Sizeof info *) -module Subtype = struct - - let list_to_string list = - let rec aux list = - match list with - | [] -> "" - | el:: rest -> - let s = (aux rest) in - if (s = "") then (Typename.name el) - else (Typename.name el)^", "^s in - if (IList.length list = 0) then "( sub )" - else ("- {"^(aux list)^"}") - - type t' = - | Exact (** denotes the current type only *) - | Subtypes of Typename.t list - (** denotes the current type and a list of types that are not their subtypes *) - - type kind = - | CAST - | INSTOF - | NORMAL - - type t = t' * kind - - module SubtypesPair = struct - type t = (Typename.t * Typename.t) - - let compare (e1 : t)(e2 : t) : int = - pair_compare Typename.compare Typename.compare e1 e2 - end - - module SubtypesMap = Map.Make (SubtypesPair) - - type subtMap = bool SubtypesMap.t - - let subtMap : subtMap ref = ref SubtypesMap.empty - - let check_subtype f c1 c2 = - try - SubtypesMap.find (c1, c2) !subtMap - with Not_found -> - let is_subt = f c1 c2 in - subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap); - is_subt - - let flag_to_string flag = - match flag with - | CAST -> "(cast)" - | INSTOF -> "(instof)" - | NORMAL -> "" - - let pp f (t, flag) = - if Config.print_types then - match t with - | Exact -> - F.fprintf f "%s" (flag_to_string flag) - | Subtypes list -> - F.fprintf f "%s" ((list_to_string list)^(flag_to_string flag)) - - let exact = Exact, NORMAL - let all_subtypes = Subtypes [] - let subtypes = all_subtypes, NORMAL - let subtypes_cast = all_subtypes, CAST - let subtypes_instof = all_subtypes, INSTOF - - let is_cast t = snd t = CAST - - let is_instof t = snd t = INSTOF - - let list_intersect equal l1 l2 = - let in_l2 a = IList.mem equal a l2 in - IList.filter in_l2 l1 - - let join_flag flag1 flag2 = - match flag1, flag2 with - | CAST, _ -> CAST - | _, CAST -> CAST - | _, _ -> NORMAL - - let join (s1, flag1) (s2, flag2) = - let s = - match s1, s2 with - | Exact, _ -> s2 - | _, Exact -> s1 - | Subtypes l1, Subtypes l2 -> Subtypes (list_intersect Typename.equal l1 l2) in - let flag = join_flag flag1 flag2 in - s, flag - - let subtypes_compare l1 l2 = - IList.compare Typename.compare l1 l2 - - let compare_flag flag1 flag2 = - match flag1, flag2 with - | CAST, CAST -> 0 - | INSTOF, INSTOF -> 0 - | NORMAL, NORMAL -> 0 - | CAST, _ -> -1 - | _, CAST -> 1 - | INSTOF, NORMAL -> -1 - | NORMAL, INSTOF -> 1 - - let compare_subt s1 s2 = - match s1, s2 with - | Exact, Exact -> 0 - | Exact, _ -> -1 - | _, Exact -> 1 - | Subtypes l1, Subtypes l2 -> - subtypes_compare l1 l2 - - let compare t1 t2 = - pair_compare compare_subt compare_flag t1 t2 - - let equal_modulo_flag (st1, _) (st2, _) = - compare_subt st1 st2 = 0 - - let update_flag c1 c2 flag flag' = - match flag with - | INSTOF -> - if (Typename.equal c1 c2) then flag else flag' - | _ -> flag' - - let change_flag st_opt c1 c2 flag' = - match st_opt with - | Some st -> - (match st with - | Exact, flag -> - let new_flag = update_flag c1 c2 flag flag' in - Some (Exact, new_flag) - | Subtypes t, flag -> - let new_flag = update_flag c1 c2 flag flag' in - Some (Subtypes t, new_flag)) - | None -> None - - let normalize_subtypes t_opt c1 c2 flag1 flag2 = - let new_flag = update_flag c1 c2 flag1 flag2 in - match t_opt with - | Some t -> - (match t with - | Exact -> Some (t, new_flag) - | Subtypes l -> - Some (Subtypes (IList.sort Typename.compare l), new_flag)) - | None -> None - - let subtypes_to_string t = - match fst t with - | Exact -> "ex"^(flag_to_string (snd t)) - | Subtypes l -> (list_to_string l)^(flag_to_string (snd t)) - - (* c is a subtype when it does not appear in the list l of no-subtypes *) - let is_subtype f c l = - try ignore( IList.find (f c) l); false - with Not_found -> true - - let is_strict_subtype f c1 c2 = - f c1 c2 && not (Typename.equal c1 c2) - - (* checks for redundancies when adding c to l - Xi in A - { X1,..., Xn } is redundant in two cases: - 1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A - 2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *) - let check_redundancies f c l = - let aux (l, add) ci = - let l, should_add = - if (f ci c) then (l, true) - else if (f c ci) then (ci:: l, false) - else (ci:: l, true) in - l, (add && should_add) in - (IList.fold_left aux ([], true) l) - - let rec updates_head f c l = - match l with - | [] -> [] - | ci:: rest -> - if (is_strict_subtype f ci c) then ci:: (updates_head f c rest) - else (updates_head f c rest) - - (* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur - A - { X1,..., Xn } is inconsistent if A <: Xi for some i *) - let rec add_not_subtype f c1 l1 l2 = - match l2 with - | [] -> l1 - | c:: rest -> - if (f c1 c) then (add_not_subtype f c1 l1 rest) (* checks for inconsistencies *) - else - let l1', should_add = (check_redundancies f c l1) in (* checks for redundancies *) - let rest' = (add_not_subtype f c1 l1' rest) in - if (should_add) then c:: rest' else rest' - - let get_subtypes (c1, (st1, flag1)) (c2, (st2, flag2)) f is_interface = - let is_sub = f c1 c2 in - let pos_st, neg_st = match st1, st2 with - | Exact, Exact -> - if (is_sub) then (Some st1, None) - else (None, Some st1) - | Exact, Subtypes l2 -> - if is_sub && (is_subtype f c1 l2) then (Some st1, None) - else (None, Some st1) - | Subtypes l1, Exact -> - if (is_sub) then (Some st1, None) - else - let l1' = updates_head f c2 l1 in - if (is_subtype f c2 l1) - then (Some (Subtypes l1'), Some (Subtypes (add_not_subtype f c1 l1 [c2]))) - else (None, Some st1) - | Subtypes l1, Subtypes l2 -> - if (is_interface c2) || (is_sub) then - if (is_subtype f c1 l2) then - let l2' = updates_head f c1 l2 in - (Some (Subtypes (add_not_subtype f c1 l1 l2')), None) - else (None, Some st1) - else if ((is_interface c1) || (f c2 c1)) && (is_subtype f c2 l1) then - let l1' = updates_head f c2 l1 in - (Some (Subtypes (add_not_subtype f c2 l1' l2)), - Some (Subtypes (add_not_subtype f c1 l1 [c2]))) - else (None, Some st1) in - (normalize_subtypes pos_st c1 c2 flag1 flag2), (normalize_subtypes neg_st c1 c2 flag1 flag2) - - let case_analysis_basic (c1, st) (c2, (_, flag2)) f = - let (pos_st, neg_st) = - if f c1 c2 then (Some st, None) - else if f c2 c1 then - match st with - | Exact, _ -> - if Typename.equal c1 c2 - then (Some st, None) - else (None, Some st) - | Subtypes _ , _ -> - if Typename.equal c1 c2 - then (Some st, None) - else (Some st, Some st) - else (None, Some st) in - (change_flag pos_st c1 c2 flag2), (change_flag neg_st c1 c2 flag2) - - (** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] - according to [st1] and [st2] - where f c1 c2 is true if c1 is a subtype of c2. - get_subtypes returning a pair: - - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] - - whether [st1] and [st2] admit [not(c1 <: c2)], - and in case return the updated subtype [st1] *) - let case_analysis (c1, st1) (c2, st2) f is_interface = - let f = check_subtype f in - if Config.subtype_multirange then - get_subtypes (c1, st1) (c2, st2) f is_interface - else case_analysis_basic (c1, st1) (c2, st2) f - -end - -(** module for signed and unsigned integers *) -module Int : sig - type t - val add : t -> t -> t - val compare : t -> t -> int - val compare_value : t -> t -> int - val div : t -> t -> t - val eq : t -> t -> bool - val of_int : int -> t - val of_int32 : int32 -> t - val of_int64 : int64 -> t - val of_int64_unsigned : int64 -> bool -> t - val geq : t -> t -> bool - val gt : t -> t -> bool - val isminusone : t -> bool - val isone : t -> bool - val isnegative : t -> bool - val isnull : t -> bool - val iszero : t -> bool - val leq : t -> t -> bool - val logand : t -> t -> t - val lognot : t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - val lt : t -> t -> bool - val minus_one : t - val mul : t -> t -> t - val neg : t -> t - val neq : t -> t -> bool - val null : t - val one : t - val pp : Format.formatter -> t -> unit - val rem : t -> t -> t - val sub : t -> t -> t - val to_int : t -> int - val to_signed : t -> t option - val to_string : t -> string - val two : t - val zero : t -end = struct - (* the first bool indicates whether this is an unsigned value, - and the second whether it is a pointer *) - type t = bool * Int64.t * bool - - let area u i = match i < 0L, u with - | true, false -> 1 (* only representable as signed *) - | false, _ -> 2 (* in the intersection between signed and unsigned *) - | true, true -> 3 (* only representable as unsigned *) - - let to_signed (unsigned, i, ptr) = - if area unsigned i = 3 then None (* not representable as signed *) - else Some (false, i, ptr) - - let compare (unsigned1, i1, _) (unsigned2, i2, _) = - let n = bool_compare unsigned1 unsigned2 in - if n <> 0 then n else Int64.compare i1 i2 - - let compare_value (unsigned1, i1, _) (unsigned2, i2, _) = - let area1 = area unsigned1 i1 in - let area2 = area unsigned2 i2 in - let n = int_compare area1 area2 in - if n <> 0 then n else Int64.compare i1 i2 - - let eq i1 i2 = compare_value i1 i2 = 0 - let neq i1 i2 = compare_value i1 i2 <> 0 - let leq i1 i2 = compare_value i1 i2 <= 0 - let lt i1 i2 = compare_value i1 i2 < 0 - let geq i1 i2 = compare_value i1 i2 >= 0 - let gt i1 i2 = compare_value i1 i2 > 0 - - let of_int64 i = (false, i, false) - let of_int32 i = of_int64 (Int64.of_int32 i) - let of_int64_unsigned i unsigned = (unsigned, i, false) - let of_int i = of_int64 (Int64.of_int i) - let to_int (_, i, _) = Int64.to_int i - let null = (false, 0L, true) - let zero = of_int 0 - let one = of_int 1 - let two = of_int 2 - let minus_one = of_int (-1) - - let isone (_, i, _) = i = 1L - let iszero (_, i, _) = i = 0L - let isnull (_, i, ptr) = i = 0L && ptr - let isminusone (unsigned, i, _) = not unsigned && i = -1L - let isnegative (unsigned, i, _) = not unsigned && i < 0L - - let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr) - - let lift binop (unsigned1, i1, ptr1) (unsigned2, i2, ptr2) = - (unsigned1 || unsigned2, binop i1 i2, ptr1 || ptr2) - - let lift1 unop (unsigned, i, ptr) = (unsigned, unop i, ptr) - - let add i1 i2 = lift Int64.add i1 i2 - - let mul i1 i2 = lift Int64.mul i1 i2 - - let div i1 i2 = lift Int64.div i1 i2 - - let rem i1 i2 = lift Int64.rem i1 i2 - - let logand i1 i2 = lift Int64.logand i1 i2 - - let logor i1 i2 = lift Int64.logor i1 i2 - - let logxor i1 i2 = lift Int64.logxor i1 i2 - - let lognot i = lift1 Int64.lognot i - - let sub i1 i2 = add i1 (neg i2) - - let pp f (unsigned, n, ptr) = - if ptr && n = 0L then F.fprintf f "null" else - if unsigned then F.fprintf f "%Lu" n - else F.fprintf f "%Ld" n - - let to_string i = - pp_to_string pp i -end - -(** Flags for a procedure call *) -type call_flags = { - cf_virtual : bool; - cf_interface : bool; - cf_noreturn : bool; - cf_is_objc_block : bool; - cf_targets : Procname.t list; -} - -let cf_default = - { cf_virtual = false; - cf_interface = false; - cf_noreturn = false; - cf_is_objc_block = false; - cf_targets = []; - } - -(** expression representing the result of decompilation *) -type dexp = - | Darray of dexp * dexp - | Dbinop of binop * dexp * dexp - | Dconst of const - | Dsizeof of typ * Subtype.t - | Dderef of dexp - | Dfcall of dexp * dexp list * Location.t * call_flags - | Darrow of dexp * Ident.fieldname - | Ddot of dexp * Ident.fieldname - | Dpvar of Pvar.t - | Dpvaraddr of Pvar.t - | Dunop of unop * dexp - | Dunknown - | Dretcall of dexp * dexp list * Location.t * call_flags - -(** Value paths: identify an occurrence of a value in a symbolic heap - each expression represents a path, with Dpvar being the simplest one *) -and vpath = - dexp option - -(** acquire/release action on a resource *) -and res_action = - { ra_kind : res_act_kind; (** kind of action *) - ra_res : resource; (** kind of resource *) - ra_pname : Procname.t; (** name of the procedure used to acquire/release the resource *) - ra_loc : Location.t; (** location of the acquire/release *) - ra_vpath: vpath; (** vpath of the resource value *) - } - -and taint_kind = - | Tk_unverified_SSL_socket - | Tk_shared_preferences_data - | Tk_privacy_annotation - | Tk_integrity_annotation - | Tk_unknown - -and taint_info = { - taint_source : Procname.t; - taint_kind : taint_kind; -} - -(** Attributes *) -and attribute = - | Aresource of res_action (** resource acquire/release *) - | Aautorelease - | Adangling of dangling_kind (** dangling pointer *) - (** undefined value obtained by calling the given procedure, plus its return value annots *) - | Aundef of Procname.t * item_annotation * Location.t * path_pos - | Ataint of taint_info - | Auntaint - | Alocked - | Aunlocked - (** value appeared in second argument of division at given path position *) - | Adiv0 of path_pos - (** the exp. is null because of a call to a method with exp as a null receiver *) - | Aobjc_null of exp - (** value was returned from a call to the given procedure, plus the annots of the return value *) - | Aretval of Procname.t * item_annotation - (** denotes an object registered as an observers to a notification center *) - | Aobserver - (** denotes an object unsubscribed from observers of a notification center *) - | Aunsubscribed_observer - -(** Categories of attributes *) -and attribute_category = - | ACresource - | ACautorelease - | ACtaint - | AClock - | ACdiv0 - | ACobjc_null - | ACundef - | ACretval - | ACobserver - -and closure = { - name : Procname.t; - captured_vars : (exp * Pvar.t * typ) list; -} - -(** Constants *) -and const = - | Cint of Int.t (** integer constants *) - | Cfun of Procname.t (** function names *) - | Cstr of string (** string constants *) - | Cfloat of float (** float constants *) - | Cattribute of attribute (** attribute used in disequalities to annotate a value *) - | Cexn of exp (** exception *) - | Cclass of Ident.name (** class constant *) - | Cptr_to_fld of Ident.fieldname * typ (** pointer to field constant, - and type of the surrounding Csu.t type *) - | Cclosure of closure (** anonymous function *) - -and struct_fields = (Ident.fieldname * typ * item_annotation) list - -(** Type for a structured value. *) -and struct_typ = { - instance_fields : struct_fields; (** non-static fields *) - static_fields : struct_fields; (** static fields *) - csu : Csu.t; (** class/struct/union *) - struct_name : Mangled.t option; (** name *) - superclasses : Typename.t list; (** list of superclasses *) - def_methods : Procname.t list; (** methods defined *) - struct_annotations : item_annotation; (** annotations *) -} - -(** types for sil (structured) expressions *) -and typ = - | Tvar of Typename.t (** named type *) - | Tint of ikind (** integer type *) - | Tfloat of fkind (** float type *) - | Tvoid (** void type *) - | Tfun of bool (** function type with noreturn attribute *) - | Tptr of typ * ptr_kind (** pointer type *) - | Tstruct of struct_typ (** Type for a structured value *) - | Tarray of typ * exp (** array type with fixed size *) - - -(** Program expressions. *) -and exp = - (** Pure variable: it is not an lvalue *) - | Var of Ident.t - - (** Unary operator with type of the result if known *) - | UnOp of unop * exp * typ option - - (** Binary operator *) - | BinOp of binop * exp * exp - - (** Constants *) - | Const of const - - (** Type cast *) - | Cast of typ * exp - - (** The address of a program variable *) - | Lvar of Pvar.t - - (** A field offset, the type is the surrounding struct type *) - | Lfield of exp * Ident.fieldname * typ - - (** An array index offset: [exp1\[exp2\]] *) - | Lindex of exp * exp - - (** A sizeof expression *) - | Sizeof of typ * Subtype.t - -(** Kind of prune instruction *) -type if_kind = - | Ik_bexp (* boolean expressions, and exp ? exp : exp *) - | Ik_dowhile - | Ik_for - | Ik_if - | Ik_land_lor (* obtained from translation of && or || *) - | Ik_while - | Ik_switch - -(** Stack operation for symbolic execution on propsets *) -type stackop = - | Push (* copy the curreny propset to the stack *) - | Swap (* swap the current propset and the top of the stack *) - | Pop (* pop the stack and combine with the current propset *) - -(** An instruction. *) -type instr = - (** declaration [let x = *lexp:typ] where [typ] is the root type of [lexp] *) - | Letderef of Ident.t * exp * typ * Location.t - (** assignment [*lexp1:typ = exp2] where [typ] is the root type of [lexp1] *) - | Set of exp * typ * exp * Location.t - (** prune the state based on [exp=1], the boolean indicates whether true branch *) - | Prune of exp * Location.t * bool * if_kind - (** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions - [ret_id1..ret_idn = e_fun(arg_ts);] - where n = 0 for void return and n > 1 for struct return *) - | Call of Ident.t list * exp * (exp * typ) list * Location.t * call_flags - (** nullify stack variable *) - | Nullify of Pvar.t * Location.t - | Abstract of Location.t (** apply abstraction *) - | Remove_temps of Ident.t list * Location.t (** remove temporaries *) - | Stackop of stackop * Location.t (** operation on the stack of propsets *) - | Declare_locals of (Pvar.t * typ) list * Location.t (** declare local variables *) - -(** Check if an instruction is auxiliary, or if it comes from source instructions. *) -let instr_is_auxiliary = function - | Letderef _ | Set _ | Prune _ | Call _ -> - false - | Nullify _ | Abstract _ | Remove_temps _ | Stackop _ | Declare_locals _ -> - true - -(** offset for an lvalue *) -type offset = Off_fld of Ident.fieldname * typ | Off_index of exp - -(** {2 Components of Propositions} *) - -(** an atom is a pure atomic formula *) -type atom = - | Aeq of exp * exp (** equality *) - | Aneq of exp * exp (** disequality*) - -(** kind of lseg or dllseg predicates *) -type lseg_kind = - | Lseg_NE (** nonempty (possibly circular) listseg *) - | Lseg_PE (** possibly empty (possibly circular) listseg *) - -(** The boolean is true when the pointer was dereferenced without testing for zero. *) -type zero_flag = bool option - -(** True when the value was obtained by doing case analysis on null in a procedure call. *) -type null_case_flag = bool - -(** instrumentation of heap values *) -type inst = - | Iabstraction - | Iactual_precondition - | Ialloc - | Iformal of zero_flag * null_case_flag - | Iinitial - | Ilookup - | Inone - | Inullify - | Irearrange of zero_flag * null_case_flag * int * path_pos - | Itaint - | Iupdate of zero_flag * null_case_flag * int * path_pos - | Ireturn_from_call of int - | Ireturn_from_pointer_wrapper_call of int - -(** structured expressions represent a value of structured type, such as an array or a struct. *) -type strexp = - | Eexp of exp * inst (** Base case: expression with instrumentation *) - | Estruct of (Ident.fieldname * strexp) list * inst (** C structure *) - | Earray of exp * (exp * strexp) list * inst (** Array of given size. *) -(** There are two conditions imposed / used in the array case. - First, if some index and value pair appears inside an array - in a strexp, then the index is less than the size of the array. - For instance, x |->[10 | e1: v1] implies that e1 <= 9. - Second, if two indices appear in an array, they should be different. - For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) - -(** an atomic heap predicate *) -and hpred = - | Hpointsto of exp * strexp * exp - (** represents [exp|->strexp:typexp] where [typexp] - is an expression representing a type, e.h. [sizeof(t)]. *) - | Hlseg of lseg_kind * hpara * exp * exp * exp list - (** higher - order predicate for singly - linked lists. - Should ensure that exp1!= exp2 implies that exp1 is allocated. - This assumption is used in the rearrangement. The last [exp list] parameter - is used to denote the shared links by all the nodes in the list. *) - | Hdllseg of lseg_kind * hpara_dll * exp * exp * exp * exp * exp list - (** higher-order predicate for doubly-linked lists. *) - -(** parameter for the higher-order singly-linked list predicate. - Means "lambda (root,next,svars). Exists evars. body". - Assume that root, next, svars, evars are disjoint sets of - primed identifiers, and include all the free primed identifiers in body. - body should not contain any non - primed identifiers or program - variables (i.e. pvars). *) -and hpara = - { root: Ident.t; - next: Ident.t; - svars: Ident.t list; - evars: Ident.t list; - body: hpred list } - -(** parameter for the higher-order doubly-linked list predicates. - Assume that all the free identifiers in body_dll should belong to - cell, blink, flink, svars_dll, evars_dll. *) -and hpara_dll = - { cell: Ident.t; (** address cell *) - blink: Ident.t; (** backward link *) - flink: Ident.t; (** forward link *) - svars_dll: Ident.t list; - evars_dll: Ident.t list; - body_dll: hpred list } - -(** Return the lhs expression of a hpred *) -let hpred_get_lhs h = - match h with - | Hpointsto (e, _, _) - | Hlseg(_, _, e, _, _) - | Hdllseg(_, _, e, _, _, _, _) -> e - -let objc_ref_counter_annot = - [({ class_name = "ref_counter"; parameters = []}, false)] - -(** Field used for objective-c reference counting *) -let objc_ref_counter_field = - (Ident.fieldname_hidden, Tint IInt, objc_ref_counter_annot) - -(** {2 Comparision and Inspection Functions} *) - -let is_objc_ref_counter_field (fld, _, a) = - Ident.fieldname_is_hidden fld && (item_annotation_compare a objc_ref_counter_annot = 0) - -let has_objc_ref_counter hpred = - match hpred with - | Hpointsto(_, _, Sizeof(Tstruct struct_typ, _)) -> - IList.exists is_objc_ref_counter_field struct_typ.instance_fields - | _ -> false - -let objc_class_str = "ObjC-Class" - -let cpp_class_str = "Cpp-Class" - -let class_annotation class_string = - [({ class_name = class_string; parameters =[]}, true)] - -let objc_class_annotation = - class_annotation objc_class_str - -let cpp_class_annotation = - class_annotation cpp_class_str - -let is_class_of_kind typ ck = - match typ with - | Tstruct { csu = Csu.Class ck' } -> - ck = ck' - | _ -> - false - -let is_objc_class typ = - is_class_of_kind typ Csu.Objc - -let is_cpp_class typ = - is_class_of_kind typ Csu.CPP - -let is_java_class typ = - is_class_of_kind typ Csu.Java - -let rec is_array_of_cpp_class typ = - match typ with - | Tarray (typ, _) -> - is_array_of_cpp_class typ - | _ -> is_cpp_class typ - -let is_pointer_to_cpp_class typ = - match typ with - | Tptr (t, _) -> is_cpp_class t - | _ -> false - -(** turn a *T into a T. fails if [typ] is not a pointer type *) -let typ_strip_ptr = function - | Tptr (t, _) -> t - | _ -> assert false - -let zero_value_of_numerical_type typ = - match typ with - | Tint _ -> Const (Cint Int.zero) - | Tfloat _ -> Const (Cfloat 0.0) - | Tptr _ -> Const (Cint Int.null) - | _ -> assert false - -(** Make a static local name in objc *) -let mk_static_local_name pname vname = - pname^"_"^vname - -(** Check if a pvar is a local static in objc *) -let is_static_local_name pname pvar = (* local static name is of the form procname_varname *) - let var_name = Mangled.to_string (Pvar.get_name pvar) in - match Str.split_delim (Str.regexp_string pname) var_name with - | [_; _] -> true - | _ -> false - -let fld_compare (fld1 : Ident.fieldname) fld2 = Ident.fieldname_compare fld1 fld2 - -let fld_equal fld1 fld2 = fld_compare fld1 fld2 = 0 - -let exp_is_zero = function - | Const (Cint n) -> Int.iszero n - | _ -> false - -let exp_is_null_literal = function - | Const (Cint n) -> Int.isnull n - | _ -> false - -let exp_is_this = function - | Lvar pvar -> Pvar.is_this pvar - | _ -> false - -let ikind_is_char = function - | IChar | ISChar | IUChar -> true - | _ -> false - -let ikind_is_unsigned = function - | IUChar | IUInt | IUShort | IULong | IULongLong -> true - | _ -> false - -let int_of_int64_kind i ik = - Int.of_int64_unsigned i (ikind_is_unsigned ik) - -let unop_compare o1 o2 = match o1, o2 with - | Neg, Neg -> 0 - | Neg, _ -> - 1 - | _, Neg -> 1 - | BNot, BNot -> 0 - | BNot, _ -> - 1 - | _, BNot -> 1 - | LNot, LNot -> 0 - -let unop_equal o1 o2 = unop_compare o1 o2 = 0 - -let binop_compare o1 o2 = match o1, o2 with - | PlusA, PlusA -> 0 - | PlusA, _ -> - 1 - | _, PlusA -> 1 - | PlusPI, PlusPI -> 0 - | PlusPI, _ -> - 1 - | _, PlusPI -> 1 - | MinusA, MinusA -> 0 - | MinusA, _ -> - 1 - | _, MinusA -> 1 - | MinusPI, MinusPI -> 0 - | MinusPI, _ -> - 1 - | _, MinusPI -> 1 - | MinusPP, MinusPP -> 0 - | MinusPP, _ -> - 1 - | _, MinusPP -> 1 - | Mult, Mult -> 0 - | Mult, _ -> - 1 - | _, Mult -> 1 - | Div, Div -> 0 - | Div, _ -> - 1 - | _, Div -> 1 - | Mod, Mod -> 0 - | Mod, _ -> - 1 - | _, Mod -> 1 - | Shiftlt, Shiftlt -> 0 - | Shiftlt, _ -> - 1 - | _, Shiftlt -> 1 - | Shiftrt, Shiftrt -> 0 - | Shiftrt, _ -> - 1 - | _, Shiftrt -> 1 - | Lt, Lt -> 0 - | Lt, _ -> - 1 - | _, Lt -> 1 - | Gt, Gt -> 0 - | Gt, _ -> - 1 - | _, Gt -> 1 - | Le, Le -> 0 - | Le, _ -> - 1 - | _, Le -> 1 - | Ge, Ge -> 0 - | Ge, _ -> - 1 - | _, Ge -> 1 - | Eq, Eq -> 0 - | Eq, _ -> - 1 - | _, Eq -> 1 - | Ne, Ne -> 0 - | Ne, _ -> - 1 - | _, Ne -> 1 - | BAnd, BAnd -> 0 - | BAnd, _ -> - 1 - | _, BAnd -> 1 - | BXor, BXor -> 0 - | BXor, _ -> - 1 - | _, BXor -> 1 - | BOr, BOr -> 0 - | BOr, _ -> - 1 - | _, BOr -> 1 - | LAnd, LAnd -> 0 - | LAnd, _ -> - 1 - | _, LAnd -> 1 - | LOr, LOr -> 0 - | LOr, _ -> -1 - | _, LOr -> 1 - | PtrFld, PtrFld -> 0 - -let binop_equal o1 o2 = binop_compare o1 o2 = 0 - -(** This function returns true if the operation is injective - wrt. each argument: op(e,-) and op(-, e) is injective for all e. - The return value false means "don't know". *) -let binop_injective = function - | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true - | _ -> false - -(** This function returns true if the operation can be inverted. *) -let binop_invertible = function - | PlusA | PlusPI | MinusA | MinusPI -> true - | _ -> false - -(** This function inverts an injective binary operator - with respect to the first argument. It returns an expression [e'] such that - BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, - the function raises an exception by calling "assert false". *) -let binop_invert bop e1 e2 = - let inverted_bop = match bop with - | PlusA -> MinusA - | PlusPI -> MinusPI - | MinusA -> PlusA - | MinusPI -> PlusPI - | _ -> assert false in - BinOp(inverted_bop, e2, e1) - -(** This function returns true if 0 is the right unit of [binop]. - The return value false means "don't know". *) -let binop_is_zero_runit = function - | PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true - | _ -> false - -let path_pos_compare (pn1, nid1) (pn2, nid2) = - let n = Procname.compare pn1 pn2 in - if n <> 0 then n else int_compare nid1 nid2 - -let path_pos_equal pp1 pp2 = - path_pos_compare pp1 pp2 = 0 - -let mem_kind_to_num = function - | Mmalloc -> 0 - | Mnew -> 1 - | Mnew_array -> 2 - | Mobjc -> 3 - -(** name of the allocation function for the given memory kind *) -let mem_alloc_pname = function - | Mmalloc -> Procname.from_string_c_fun "malloc" - | Mnew -> Procname.from_string_c_fun "new" - | Mnew_array -> Procname.from_string_c_fun "new[]" - | Mobjc -> Procname.from_string_c_fun "alloc" - -(** name of the deallocation function for the given memory kind *) -let mem_dealloc_pname = function - | Mmalloc -> Procname.from_string_c_fun "free" - | Mnew -> Procname.from_string_c_fun "delete" - | Mnew_array -> Procname.from_string_c_fun "delete[]" - | Mobjc -> Procname.from_string_c_fun "dealloc" - -let mem_kind_compare mk1 mk2 = - int_compare (mem_kind_to_num mk1) (mem_kind_to_num mk2) - -let resource_compare r1 r2 = - let res_to_num = function - | Rmemory mk -> mem_kind_to_num mk - | Rfile -> 100 - | Rignore -> 200 - | Rlock -> 300 in - int_compare (res_to_num r1) (res_to_num r2) - -let res_act_kind_compare rak1 rak2 = match rak1, rak2 with - | Racquire, Racquire -> 0 - | Racquire, Rrelease -> - 1 - | Rrelease, Racquire -> 1 - | Rrelease, Rrelease -> 0 - -let dangling_kind_compare dk1 dk2 = match dk1, dk2 with - | DAuninit, DAuninit -> 0 - | DAuninit, _ -> - 1 - | _, DAuninit -> 1 - | DAaddr_stack_var, DAaddr_stack_var -> 0 - | DAaddr_stack_var, _ -> - 1 - | _, DAaddr_stack_var -> 1 - | DAminusone, DAminusone -> 0 - -let taint_kind_compare tk1 tk2 = match tk1, tk2 with - | Tk_unverified_SSL_socket, Tk_unverified_SSL_socket -> 0 - | Tk_unverified_SSL_socket, _ -> - 1 - | _, Tk_unverified_SSL_socket -> 1 - | Tk_shared_preferences_data, Tk_shared_preferences_data -> 0 - | Tk_shared_preferences_data, _ -> 1 - | _, Tk_shared_preferences_data -> - 1 - | Tk_privacy_annotation, Tk_privacy_annotation -> 0 - | Tk_privacy_annotation, _ -> 1 - | _, Tk_privacy_annotation -> - 1 - | Tk_integrity_annotation, Tk_integrity_annotation -> 0 - | Tk_integrity_annotation, _ -> 1 - | _, Tk_integrity_annotation -> - 1 - | Tk_unknown, Tk_unknown -> 0 - -let taint_info_compare { taint_source=ts1; taint_kind=tk1; } { taint_source=ts2; taint_kind=tk2; } = - taint_kind_compare tk1 tk2 - |> next Procname.compare ts1 ts2 - -let attribute_category_compare (ac1 : attribute_category) (ac2 : attribute_category) : int = - Pervasives.compare ac1 ac2 - -let attribute_category_equal att1 att2 = - attribute_category_compare att1 att2 = 0 - -let attribute_to_category att = - match att with - | Aresource _ - | Adangling _ -> ACresource - | Ataint _ - | Auntaint -> ACtaint - | Alocked - | Aunlocked -> AClock - | Aautorelease -> ACautorelease - | Adiv0 _ -> ACdiv0 - | Aobjc_null _ -> ACobjc_null - | Aretval _ -> ACretval - | Aundef _ -> ACundef - | Aobserver - | Aunsubscribed_observer -> ACobserver - -let attr_is_undef = function - | Aundef _ -> true - | _ -> false - -let cname_opt_compare nameo1 nameo2 = match nameo1, nameo2 with - | None, None -> 0 - | None, _ -> - 1 - | _, None -> 1 - | Some n1, Some n2 -> Mangled.compare n1 n2 - -(** comparison for ikind *) -let ikind_compare k1 k2 = match k1, k2 with - | IChar, IChar -> 0 - | IChar, _ -> - 1 - | _, IChar -> 1 - | ISChar, ISChar -> 0 - | ISChar, _ -> - 1 - | _, ISChar -> 1 - | IUChar, IUChar -> 0 - | IUChar, _ -> - 1 - | _, IUChar -> 1 - | IBool, IBool -> 0 - | IBool, _ -> - 1 - | _, IBool -> 1 - | IInt, IInt -> 0 - | IInt, _ -> - 1 - | _, IInt -> 1 - | IUInt, IUInt -> 0 - | IUInt, _ -> - 1 - | _, IUInt -> 1 - | IShort, IShort -> 0 - | IShort, _ -> - 1 - | _, IShort -> 1 - | IUShort, IUShort -> 0 - | IUShort, _ -> - 1 - | _, IUShort -> 1 - | ILong, ILong -> 0 - | ILong, _ -> - 1 - | _, ILong -> 1 - | IULong, IULong -> 0 - | IULong, _ -> - 1 - | _, IULong -> 1 - | ILongLong, ILongLong -> 0 - | ILongLong, _ -> - 1 - | _, ILongLong -> 1 - | IULongLong, IULongLong -> 0 - | IULongLong, _ -> -1 - | _, IULongLong -> 1 - | I128, I128 -> 0 - | I128, _ -> -1 - | _, I128 -> 1 - | IU128, IU128 -> 0 - -(** comparison for fkind *) -let fkind_compare k1 k2 = match k1, k2 with - | FFloat, FFloat -> 0 - | FFloat, _ -> - 1 - | _, FFloat -> 1 - | FDouble, FDouble -> 0 - | FDouble, _ -> - 1 - | _, FDouble -> 1 - | FLongDouble, FLongDouble -> 0 - -let ptr_kind_compare pk1 pk2 = match pk1, pk2 with - | Pk_pointer, Pk_pointer -> 0 - | Pk_pointer, _ -> -1 - | _, Pk_pointer -> 1 - | Pk_reference, Pk_reference -> 0 - | _ , Pk_reference -> -1 - | Pk_reference, _ -> 1 - | Pk_objc_weak, Pk_objc_weak -> 0 - | Pk_objc_weak, _ -> -1 - | _, Pk_objc_weak -> 1 - | Pk_objc_unsafe_unretained, Pk_objc_unsafe_unretained -> 0 - | Pk_objc_unsafe_unretained, _ -> -1 - | _, Pk_objc_unsafe_unretained -> 1 - | Pk_objc_autoreleasing, Pk_objc_autoreleasing -> 0 - -let const_kind_equal c1 c2 = - let const_kind_number = function - | Cint _ -> 1 - | Cfun _ -> 2 - | Cstr _ -> 3 - | Cfloat _ -> 4 - | Cattribute _ -> 5 - | Cexn _ -> 6 - | Cclass _ -> 7 - | Cptr_to_fld _ -> 8 - | Cclosure _ -> 9 in - const_kind_number c1 = const_kind_number c2 - -let rec const_compare (c1 : const) (c2 : const) : int = - match (c1, c2) with - | Cint i1, Cint i2 -> Int.compare i1 i2 - | Cint _, _ -> - 1 - | _, Cint _ -> 1 - | Cfun fn1, Cfun fn2 -> Procname.compare fn1 fn2 - | Cfun _, _ -> - 1 - | _, Cfun _ -> 1 - | Cstr s1, Cstr s2 -> string_compare s1 s2 - | Cstr _, _ -> - 1 - | _, Cstr _ -> 1 - | Cfloat f1, Cfloat f2 -> float_compare f1 f2 - | Cfloat _, _ -> - 1 - | _, Cfloat _ -> 1 - | Cattribute att1, Cattribute att2 -> attribute_compare att1 att2 - | Cattribute _, _ -> -1 - | _, Cattribute _ -> 1 - | Cexn e1, Cexn e2 -> exp_compare e1 e2 - | Cexn _, _ -> -1 - | _, Cexn _ -> 1 - | Cclass c1, Cclass c2 -> Ident.name_compare c1 c2 - | Cclass _, _ -> -1 - | _, Cclass _ -> 1 - | Cptr_to_fld (fn1, t1), Cptr_to_fld (fn2, t2) -> - let n = fld_compare fn1 fn2 in - if n <> 0 then n else typ_compare t1 t2 - | Cptr_to_fld _, _ -> -1 - | _, Cptr_to_fld _ -> 1 - | Cclosure { name=n1; captured_vars=c1; }, Cclosure { name=n2; captured_vars=c2; } -> - let captured_var_compare acc (e1, pvar1, typ1) (e2, pvar2, typ2) = - if acc <> 0 then acc - else - let n = exp_compare e1 e2 in - if n <> 0 then n - else - let n = Pvar.compare pvar1 pvar2 in - if n <> 0 then n - else typ_compare typ1 typ2 in - let n = Procname.compare n1 n2 in - if n <> 0 then n else IList.fold_left2 captured_var_compare 0 c1 c2 - -and struct_typ_compare struct_typ1 struct_typ2 = - if struct_typ1.csu = Csu.Class Csu.Java && struct_typ2.csu = Csu.Class Csu.Java then - cname_opt_compare struct_typ1.struct_name struct_typ2.struct_name - else - let n = fld_typ_ann_list_compare struct_typ1.instance_fields struct_typ2.instance_fields in - if n <> 0 then n else - let n = fld_typ_ann_list_compare struct_typ1.static_fields struct_typ2.static_fields in - if n <> 0 then n else let n = Csu.compare struct_typ1.csu struct_typ2.csu in - if n <> 0 then n else cname_opt_compare struct_typ1.struct_name struct_typ2.struct_name - -and struct_typ_equal struct_typ1 struct_typ2 = - struct_typ_compare struct_typ1 struct_typ2 = 0 - -(** Comparision for types. *) -and typ_compare t1 t2 = - if t1 == t2 then 0 else match t1, t2 with - | Tvar tn1, Tvar tn2 -> Typename.compare tn1 tn2 - | Tvar _, _ -> - 1 - | _, Tvar _ -> 1 - | Tint ik1, Tint ik2 -> ikind_compare ik1 ik2 - | Tint _, _ -> - 1 - | _, Tint _ -> 1 - | Tfloat fk1, Tfloat fk2 -> fkind_compare fk1 fk2 - | Tfloat _, _ -> - 1 - | _, Tfloat _ -> 1 - | Tvoid, Tvoid -> 0 - | Tvoid, _ -> - 1 - | _, Tvoid -> 1 - | Tfun noreturn1, Tfun noreturn2 -> bool_compare noreturn1 noreturn2 - | Tfun _, _ -> - 1 - | _, Tfun _ -> 1 - | Tptr (t1', pk1), Tptr (t2', pk2) -> - let n = typ_compare t1' t2' in - if n <> 0 then n else ptr_kind_compare pk1 pk2 - | Tptr _, _ -> - 1 - | _, Tptr _ -> 1 - | Tstruct struct_typ1, Tstruct struct_typ2 -> - struct_typ_compare struct_typ1 struct_typ2 - | Tstruct _, _ -> - 1 - | _, Tstruct _ -> 1 - | Tarray (t1, _), Tarray (t2, _) -> typ_compare t1 t2 - -and typ_opt_compare to1 to2 = match to1, to2 with - | None, None -> 0 - | None, Some _ -> - 1 - | Some _, None -> 1 - | Some t1, Some t2 -> typ_compare t1 t2 - -and fld_typ_ann_compare fta1 fta2 = - triple_compare fld_compare typ_compare item_annotation_compare fta1 fta2 - -and fld_typ_ann_list_compare ftal1 ftal2 = - IList.compare fld_typ_ann_compare ftal1 ftal2 - -and attribute_compare (att1 : attribute) (att2 : attribute) : int = - match att1, att2 with - | Aresource ra1, Aresource ra2 -> - let n = res_act_kind_compare ra1.ra_kind ra2.ra_kind in - if n <> 0 - then n - (* ignore other values beside resources: arbitrary merging into one *) - else resource_compare ra1.ra_res ra2.ra_res - | Aresource _, _ -> - 1 - | _, Aresource _ -> 1 - | Aautorelease, Aautorelease -> 0 - | Aautorelease, _ -> -1 - | _, Aautorelease -> 1 - | Adangling dk1, Adangling dk2 -> dangling_kind_compare dk1 dk2 - | Adangling _, _ -> - 1 - | _, Adangling _ -> 1 - | Aundef (pn1, _, _, _), Aundef (pn2, _, _, _) -> Procname.compare pn1 pn2 - | Ataint ti1, Ataint ti2 -> taint_info_compare ti1 ti2 - | Ataint _, _ -> -1 - | _, Ataint _ -> 1 - | Auntaint, Auntaint -> 0 - | Auntaint, _ -> -1 - | _, Auntaint -> 1 - | Alocked, Alocked -> 0 - | Alocked, _ -> -1 - | _, Alocked -> 1 - | Aunlocked, Aunlocked -> 0 - | Aunlocked, _ -> -1 - | _, Aunlocked -> 1 - | Adiv0 pp1, Adiv0 pp2 -> - path_pos_compare pp1 pp2 - | Adiv0 _, _ -> -1 - | _, Adiv0 _ -> 1 - | Aobjc_null exp1, Aobjc_null exp2 -> - exp_compare exp1 exp2 - | Aobjc_null _, _ -> -1 - | _, Aobjc_null _ -> 1 - | Aretval (pn1, annots1), Aretval (pn2, annots2) -> - let n = Procname.compare pn1 pn2 in - if n <> 0 - then n - else item_annotation_compare annots1 annots2 - | Aretval _, _ -> -1 - | _, Aretval _ -> 1 - | Aobserver, Aobserver -> 0 - | Aobserver, _ -> -1 - | _, Aobserver -> 1 - | Aunsubscribed_observer, Aunsubscribed_observer -> 0 - | Aunsubscribed_observer, _ -> -1 - | _, Aunsubscribed_observer -> 1 - -(** Compare epressions. Variables come before other expressions. *) -and exp_compare (e1 : exp) (e2 : exp) : int = - match (e1, e2) with - | Var id1, Var id2 -> - Ident.compare id2 id1 - | Var _, _ -> - 1 - | _, Var _ -> 1 - | UnOp (o1, e1, to1), UnOp (o2, e2, to2) -> - let n = unop_compare o1 o2 in - if n <> 0 then n else - let n = exp_compare e1 e2 in - if n <> 0 then n else typ_opt_compare to1 to2 - | UnOp _, _ -> - 1 - | _, UnOp _ -> 1 - | BinOp (o1, e1, f1), BinOp (o2, e2, f2) -> - let n = binop_compare o1 o2 in - if n <> 0 then n - else - let n = exp_compare e1 e2 in - if n <> 0 then n else exp_compare f1 f2 - | BinOp _, _ -> - 1 - | _, BinOp _ -> 1 - | Const c1, Const c2 -> - const_compare c1 c2 - | Const _, _ -> - 1 - | _, Const _ -> 1 - | Cast (t1, e1), Cast(t2, e2) -> - let n = exp_compare e1 e2 in - if n <> 0 then n else typ_compare t1 t2 - | Cast _, _ -> - 1 - | _, Cast _ -> 1 - | Lvar i1, Lvar i2 -> - Pvar.compare i1 i2 - | Lvar _, _ -> - 1 - | _, Lvar _ -> 1 - | Lfield (e1, f1, t1), Lfield (e2, f2, t2) -> - let n = exp_compare e1 e2 in - if n <> 0 then n else - let n = fld_compare f1 f2 in - if n <> 0 then n else typ_compare t1 t2 - | Lfield _, _ -> - 1 - | _, Lfield _ -> 1 - | Lindex (e1, f1), Lindex (e2, f2) -> - let n = exp_compare e1 e2 in - if n <> 0 then n else exp_compare f1 f2 - | Lindex _, _ -> - 1 - | _, Lindex _ -> 1 - | Sizeof (t1, s1), Sizeof (t2, s2) -> - let n = typ_compare t1 t2 in - if n <> 0 then n else Subtype.compare s1 s2 - -let const_equal c1 c2 = - const_compare c1 c2 = 0 - -let typ_equal t1 t2 = - (typ_compare t1 t2 = 0) - -let exp_equal e1 e2 = - exp_compare e1 e2 = 0 - -let rec exp_is_array_index_of exp1 exp2 = - match exp1 with - | Lindex (exp, _) -> - exp_is_array_index_of exp exp2 - | _ -> exp_equal exp1 exp2 - -let ident_exp_compare = - pair_compare Ident.compare exp_compare - -let ident_exp_equal ide1 ide2 = - ident_exp_compare ide1 ide2 = 0 - -let exp_list_compare = - IList.compare exp_compare - -let exp_list_equal el1 el2 = - exp_list_compare el1 el2 = 0 - -let attribute_equal att1 att2 = - attribute_compare att1 att2 = 0 - -(** Compare atoms. Equalities come before disequalities *) -let atom_compare a b = - if a == b then 0 else - match (a, b) with - | Aeq (e1, e2), Aeq(f1, f2) -> - let n = exp_compare e1 f1 in - if n <> 0 then n else exp_compare e2 f2 - | Aeq _, Aneq _ -> - 1 - | Aneq _, Aeq _ -> 1 - | Aneq (e1, e2), Aneq (f1, f2) -> - let n = exp_compare e1 f1 in - if n <> 0 then n else exp_compare e2 f2 - -let atom_equal x y = - atom_compare x y = 0 - -let lseg_kind_compare k1 k2 = match k1, k2 with - | Lseg_NE, Lseg_NE -> 0 - | Lseg_NE, Lseg_PE -> - 1 - | Lseg_PE, Lseg_NE -> 1 - | Lseg_PE, Lseg_PE -> 0 - -let lseg_kind_equal k1 k2 = - lseg_kind_compare k1 k2 = 0 - -(* Comparison for strexps *) -let rec strexp_compare se1 se2 = - if se1 == se2 then 0 - else match se1, se2 with - | Eexp (e1, _), Eexp (e2, _) -> exp_compare e1 e2 - | Eexp _, _ -> - 1 - | _, Eexp _ -> 1 - | Estruct (fel1, _), Estruct (fel2, _) -> fld_strexp_list_compare fel1 fel2 - | Estruct _, _ -> - 1 - | _, Estruct _ -> 1 - | Earray (e1, esel1, _), Earray (e2, esel2, _) -> - let n = exp_compare e1 e2 in - if n <> 0 then n else exp_strexp_list_compare esel1 esel2 - -and fld_strexp_compare fse1 fse2 = - pair_compare fld_compare strexp_compare fse1 fse2 - -and fld_strexp_list_compare fsel1 fsel2 = - IList.compare fld_strexp_compare fsel1 fsel2 - -and exp_strexp_compare ese1 ese2 = - pair_compare exp_compare strexp_compare ese1 ese2 - -and exp_strexp_list_compare esel1 esel2 = - IList.compare exp_strexp_compare esel1 esel2 - -(** Comparsion between heap predicates. Hpointsto comes before others. *) -and hpred_compare hpred1 hpred2 = - if hpred1 == hpred2 then 0 else - match (hpred1, hpred2) with - | Hpointsto (e1, _, _), Hlseg(_, _, e2, _, _) when exp_compare e2 e1 <> 0 -> - exp_compare e2 e1 - | Hpointsto (e1, _, _), Hdllseg(_, _, e2, _, _, _, _) when exp_compare e2 e1 <> 0 -> - exp_compare e2 e1 - | Hlseg(_, _, e1, _, _), Hpointsto (e2, _, _) when exp_compare e2 e1 <> 0 -> - exp_compare e2 e1 - | Hlseg(_, _, e1, _, _), Hdllseg(_, _, e2, _, _, _, _) when exp_compare e2 e1 <> 0 -> - exp_compare e2 e1 - | Hdllseg(_, _, e1, _, _, _, _), Hpointsto (e2, _, _) when exp_compare e2 e1 <> 0 -> - exp_compare e2 e1 - | Hdllseg(_, _, e1, _, _, _, _), Hlseg(_, _, e2, _, _) when exp_compare e2 e1 <> 0 -> - exp_compare e2 e1 - | Hpointsto (e1, se1, te1), Hpointsto (e2, se2, te2) -> - let n = exp_compare e2 e1 in - if n <> 0 then n else - let n = strexp_compare se2 se1 in - if n <> 0 then n else exp_compare te2 te1 - | Hpointsto _, _ -> - 1 - | _, Hpointsto _ -> 1 - | Hlseg (k1, hpar1, e1, f1, el1), Hlseg (k2, hpar2, e2, f2, el2) -> - let n = exp_compare e2 e1 in - if n <> 0 then n - else let n = lseg_kind_compare k2 k1 in - if n <> 0 then n - else let n = hpara_compare hpar2 hpar1 in - if n <> 0 then n - else let n = exp_compare f2 f1 in - if n <> 0 then n - else exp_list_compare el2 el1 - | Hlseg _, Hdllseg _ -> - 1 - | Hdllseg _, Hlseg _ -> 1 - | Hdllseg (k1, hpar1, e1, f1, g1, h1, el1), Hdllseg (k2, hpar2, e2, f2, g2, h2, el2) -> - let n = exp_compare e2 e1 in - if n <> 0 then n - else let n = lseg_kind_compare k2 k1 in - if n <> 0 then n - else let n = hpara_dll_compare hpar2 hpar1 in - if n <> 0 then n - else let n = exp_compare f2 f1 in - if n <> 0 then n - else let n = exp_compare g2 g1 in - if n <> 0 then n - else let n = exp_compare h2 h1 in - if n <> 0 then n - else exp_list_compare el2 el1 - -and hpred_list_compare l1 l2 = - IList.compare hpred_compare l1 l2 - -and hpara_compare hp1 hp2 = - let n = Ident.compare hp1.root hp2.root in - if n <> 0 then n - else let n = Ident.compare hp1.next hp2.next in - if n <> 0 then n - else let n = Ident.ident_list_compare hp1.svars hp2.svars in - if n <> 0 then n - else let n = Ident.ident_list_compare hp1.evars hp2.evars in - if n <> 0 then n - else hpred_list_compare hp1.body hp2.body - -and hpara_dll_compare hp1 hp2 = - let n = Ident.compare hp1.cell hp2.cell in - if n <> 0 then n - else let n = Ident.compare hp1.blink hp2.blink in - if n <> 0 then n - else let n = Ident.compare hp1.flink hp2.flink in - if n <> 0 then n - else let n = Ident.ident_list_compare hp1.svars_dll hp2.svars_dll in - if n <> 0 then n - else let n = Ident.ident_list_compare hp1.evars_dll hp2.evars_dll in - if n <> 0 then n - else hpred_list_compare hp1.body_dll hp2.body_dll - -let strexp_equal se1 se2 = - (strexp_compare se1 se2 = 0) - -let hpred_equal hpred1 hpred2 = - (hpred_compare hpred1 hpred2 = 0) - -let hpara_equal hpara1 hpara2 = - (hpara_compare hpara1 hpara2 = 0) - -let hpara_dll_equal hpara1 hpara2 = - (hpara_dll_compare hpara1 hpara2 = 0) - -(** {2 Sets and maps of types} *) -module StructTypSet = Set.Make(struct - type t = struct_typ - let compare = struct_typ_compare - end) - -module TypSet = Set.Make(struct - type t = typ - let compare = typ_compare - end) - -module TypMap = Map.Make(struct - type t = typ - let compare = typ_compare - end) - -(** {2 Sets of expressions} *) - -module ExpSet = Set.Make - (struct - type t = exp - let compare = exp_compare - end) - -module ExpMap = Map.Make(struct - type t = exp - let compare = exp_compare - end) - - -let elist_to_eset es = - IList.fold_left (fun set e -> ExpSet.add e set) ExpSet.empty es - -(** {2 Sets of heap predicates} *) - -module HpredSet = Set.Make - (struct - type t = hpred - let compare = hpred_compare - end) - -(** {2 Pretty Printing} *) - -(** Begin change color if using diff printing, return updated printenv and change status *) -let color_pre_wrapper pe f x = - if Config.print_using_diff && pe.pe_kind != PP_TEXT then begin - let color = pe.pe_cmap_norm (Obj.repr x) in - if color != pe.pe_color then begin - (if pe.pe_kind == PP_HTML then Io_infer.Html.pp_start_color else Latex.pp_color) f color; - if color == Red - (** All subexpressiona red *) - then ({ pe with pe_cmap_norm = colormap_red; pe_color = Red }, true) - else ({ pe with pe_color = color }, true) end - else (pe, false) end - else (pe, false) - -(** Close color annotation if changed *) -let color_post_wrapper changed pe f = - if changed - then (if pe.pe_kind == PP_HTML then Io_infer.Html.pp_end_color f () - else Latex.pp_color f pe.pe_color) - -(** Print a sequence with difference mode if enabled. *) -let pp_seq_diff pp pe0 f = - if not Config.print_using_diff - then pp_comma_seq pp f - else - let rec doit = function - | [] -> () - | [x] -> - let _, changed = color_pre_wrapper pe0 f x in - F.fprintf f "%a" pp x; - color_post_wrapper changed pe0 f - | x :: l -> - let _, changed = color_pre_wrapper pe0 f x in - F.fprintf f "%a" pp x; - color_post_wrapper changed pe0 f; - F.fprintf f ", "; - doit l in - doit - -let text_binop = function - | PlusA -> "+" - | PlusPI -> "+" - | MinusA | MinusPP -> "-" - | MinusPI -> "-" - | Mult -> "*" - | Div -> "/" - | Mod -> "%" - | Shiftlt -> "<<" - | Shiftrt -> ">>" - | Lt -> "<" - | Gt -> ">" - | Le -> "<=" - | Ge -> ">=" - | Eq -> "==" - | Ne -> "!=" - | BAnd -> "&" - | BXor -> "^" - | BOr -> "|" - | LAnd -> "&&" - | LOr -> "||" - | PtrFld -> "_ptrfld_" - -(** String representation of unary operator. *) -let str_unop = function - | Neg -> "-" - | BNot -> "~" - | LNot -> "!" - -(** Pretty print a binary operator. *) -let str_binop pe binop = - match pe.pe_kind with - | PP_HTML -> - begin - match binop with - | Ge -> " >= " - | Le -> " <= " - | Gt -> " > " - | Lt -> " < " - | Shiftlt -> " << " - | Shiftrt -> " >> " - | _ -> text_binop binop - end - | PP_LATEX -> - begin - match binop with - | Ge -> " \\geq " - | Le -> " \\leq " - | _ -> text_binop binop - end - | _ -> - text_binop binop - -let ikind_to_string = function - | IChar -> "char" - | ISChar -> "signed char" - | IUChar -> "unsigned char" - | IBool -> "_Bool" - | IInt -> "int" - | IUInt -> "unsigned int" - | IShort -> "short" - | IUShort -> "unsigned short" - | ILong -> "long" - | IULong -> "unsigned long" - | ILongLong -> "long long" - | IULongLong -> "unsigned long long" - | I128 -> "__int128_t" - | IU128 -> "__uint128_t" - -let fkind_to_string = function - | FFloat -> "float" - | FDouble -> "double" - | FLongDouble -> "long double" - -let ptr_kind_string = function - | Pk_reference -> "&" - | Pk_pointer -> "*" - | Pk_objc_weak -> "__weak *" - | Pk_objc_unsafe_unretained -> "__unsafe_unretained *" - | Pk_objc_autoreleasing -> "__autoreleasing *" - -let java () = !Config.curr_language = Config.Java -let eradicate_java () = Config.eradicate && java () - -(** convert a dexp to a string *) -let rec dexp_to_string = function - | Darray (de1, de2) -> dexp_to_string de1 ^ "[" ^ dexp_to_string de2 ^ "]" - | Dbinop (op, de1, de2) -> - "(" ^ dexp_to_string de1 ^ (str_binop pe_text op) ^ dexp_to_string de2 ^ ")" - | Dconst (Cfun pn) -> - Procname.to_simplified_string pn - | Dconst c -> exp_to_string (Const c) - | Dderef de -> "*" ^ dexp_to_string de - | Dfcall (fun_dexp, args, _, { cf_virtual = isvirtual }) -> - let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in - let pp_args fmt des = - if eradicate_java () - then (if des <> [] then F.fprintf fmt "...") - else (pp_comma_seq) pp_arg fmt des in - let pp_fun fmt = function - | Dconst (Cfun pname) -> - let s = - match pname with - | Procname.Java pname_java -> - Procname.java_get_method pname_java - | _ -> - Procname.to_string pname in - F.fprintf fmt "%s" s - | de -> F.fprintf fmt "%s" (dexp_to_string de) in - let receiver, args' = match args with - | (Dpvar pv):: args' when isvirtual && Pvar.is_this pv -> - (None, args') - | a:: args' when isvirtual -> - (Some a, args') - | _ -> - (None, args) in - let pp fmt () = - let pp_receiver fmt = function - | None -> () - | Some arg -> F.fprintf fmt "%a." pp_arg arg in - F.fprintf fmt "%a%a(%a)" pp_receiver receiver pp_fun fun_dexp pp_args args' in - pp_to_string pp () - | Darrow ((Dpvar pv), f) when Pvar.is_this pv -> (* this->fieldname *) - Ident.fieldname_to_simplified_string f - | Darrow (de, f) -> - if Ident.fieldname_is_hidden f then dexp_to_string de - else if java() then dexp_to_string de ^ "." ^ Ident.fieldname_to_flat_string f - else dexp_to_string de ^ "->" ^ Ident.fieldname_to_string f - | Ddot (Dpvar _, fe) when eradicate_java () -> (* static field access *) - Ident.fieldname_to_simplified_string fe - | Ddot (de, f) -> - if Ident.fieldname_is_hidden f then "&" ^ dexp_to_string de - else if java() then dexp_to_string de ^ "." ^ Ident.fieldname_to_flat_string f - else dexp_to_string de ^ "." ^ Ident.fieldname_to_string f - | Dpvar pv -> Mangled.to_string (Pvar.get_name pv) - | Dpvaraddr pv -> - let s = - if eradicate_java () then Pvar.get_simplified_name pv - else Mangled.to_string (Pvar.get_name pv) in - let ampersand = - if eradicate_java () then "" - else "&" in - ampersand ^ s - | Dunop (op, de) -> str_unop op ^ dexp_to_string de - | Dsizeof (typ, _) -> pp_to_string (pp_typ_full pe_text) typ - | Dunknown -> "unknown" - | Dretcall (de, _, _, _) -> - "returned by " ^ (dexp_to_string de) - -(** Pretty print a dexp. *) -and pp_dexp fmt de = F.fprintf fmt "%s" (dexp_to_string de) - -(** Pretty print a value path *) -and pp_vpath pe fmt vpath = - let pp fmt = function - | Some de -> pp_dexp fmt de - | None -> () in - if pe.pe_kind == PP_HTML then - F.fprintf fmt " %a{vpath: %a}%a" - Io_infer.Html.pp_start_color Orange pp vpath Io_infer.Html.pp_end_color () - else - F.fprintf fmt "%a" pp vpath - -(** convert the attribute to a string *) -and attribute_to_string pe = function - | Aresource ra -> - let mk_name = function - | Mmalloc -> "ma" - | Mnew -> "ne" - | Mnew_array -> "na" - | Mobjc -> "oc" in - let name = match ra.ra_kind, ra.ra_res with - | Racquire, Rmemory mk -> "MEM" ^ mk_name mk - | Racquire, Rfile -> "FILE" - | Rrelease, Rmemory mk -> "FREED" ^ mk_name mk - | Rrelease, Rfile -> "CLOSED" - | _, Rignore -> "IGNORE" - | Racquire, Rlock -> "LOCKED" - | Rrelease, Rlock -> "UNLOCKED" in - let str_vpath = - if Config.trace_error - then pp_to_string (pp_vpath pe) ra.ra_vpath - else "" in - name ^ (str_binop pe Lt) ^ Procname.to_string ra.ra_pname ^ ":" ^ - (string_of_int ra.ra_loc.Location.line) ^ (str_binop pe Gt) ^ str_vpath - | Aautorelease -> "AUTORELEASE" - | Adangling dk -> - let dks = match dk with - | DAuninit -> "UNINIT" - | DAaddr_stack_var -> "ADDR_STACK" - | DAminusone -> "MINUS1" in - "DANGL" ^ (str_binop pe Lt) ^ dks ^ (str_binop pe Gt) - | Aundef (pn, _, loc, _) -> - "UND" ^ (str_binop pe Lt) ^ Procname.to_string pn ^ - (str_binop pe Gt) ^ ":" ^ (string_of_int loc.Location.line) - | Ataint { taint_source; } -> "TAINTED[" ^ (Procname.to_string taint_source) ^ "]" - | Auntaint -> "UNTAINTED" - | Alocked -> "LOCKED" - | Aunlocked -> "UNLOCKED" - | Adiv0 (_, _) -> "DIV0" - | Aobjc_null exp -> - let info_s = - match exp with - | Lvar var -> "FORMAL " ^ (Pvar.to_string var) - | Lfield _ -> "FIELD " ^ (exp_to_string exp) - | _ -> "" in - "OBJC_NULL["^ info_s ^"]" - | Aretval (pn, _) -> "RET" ^ str_binop pe Lt ^ Procname.to_string pn ^ str_binop pe Gt - | Aobserver -> "OBSERVER" - | Aunsubscribed_observer -> "UNSUBSCRIBED_OBSERVER" - -and pp_const pe f = function - | Cint i -> Int.pp f i - | Cfun fn -> - (match pe.pe_kind with - | PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn)) - | _ -> F.fprintf f "_fun_%s" (Procname.to_string fn)) - | Cstr s -> F.fprintf f "\"%s\"" (String.escaped s) - | Cfloat v -> F.fprintf f "%f" v - | Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att) - | Cexn e -> F.fprintf f "EXN %a" (pp_exp pe) e - | Cclass c -> F.fprintf f "%a" Ident.pp_name c - | Cptr_to_fld (fn, _) -> F.fprintf f "__fld_%a" Ident.pp_fieldname fn - | Cclosure { name; captured_vars; } -> - let id_exps = IList.map (fun (id_exp, _, _) -> id_exp) captured_vars in - F.fprintf f "(%a)" (pp_comma_seq (pp_exp pe)) ((Const (Cfun name)) :: id_exps) - -(** Pretty print a type. Do nothing by default. *) -and pp_typ pe f te = - if Config.print_types then pp_typ_full pe f te else () - -and pp_struct_typ pe pp_base f struct_typ = match struct_typ.struct_name with - | Some name when false -> - (* remove "when false" to print the details of struct *) - F.fprintf f "%s %a {%a} %a" - (Csu.name struct_typ.csu) - Mangled.pp name - (pp_seq (fun f (fld, t, _) -> - F.fprintf f "%a %a" - (pp_typ_full pe) t - Ident.pp_fieldname fld)) struct_typ.instance_fields - pp_base () - | Some name -> - F.fprintf f "%s %a %a" - (Csu.name struct_typ.csu) - Mangled.pp name - pp_base () - | None -> - F.fprintf f "%s {%a} %a" - (Csu.name struct_typ.csu) - (pp_seq (fun f (fld, t, _) -> - F.fprintf f "%a %a" - (pp_typ_full pe) t - Ident.pp_fieldname fld)) struct_typ.instance_fields - pp_base () - -(** Pretty print a type declaration. - pp_base prints the variable for a declaration, or can be skip to print only the type - pp_size prints the expression for the array size *) -and pp_type_decl pe pp_base pp_size f = function - | Tvar tname -> F.fprintf f "%s %a" (Typename.to_string tname) pp_base () - | Tint ik -> F.fprintf f "%s %a" (ikind_to_string ik) pp_base () - | Tfloat fk -> F.fprintf f "%s %a" (fkind_to_string fk) pp_base () - | Tvoid -> F.fprintf f "void %a" pp_base () - | Tfun false -> F.fprintf f "_fn_ %a" pp_base () - | Tfun true -> F.fprintf f "_fn_noreturn_ %a" pp_base () - | Tptr ((Tarray _ | Tfun _) as typ, pk) -> - let pp_base' fmt () = F.fprintf fmt "(%s%a)" (ptr_kind_string pk) pp_base () in - pp_type_decl pe pp_base' pp_size f typ - | Tptr (typ, pk) -> - let pp_base' fmt () = F.fprintf fmt "%s%a" (ptr_kind_string pk) pp_base () in - pp_type_decl pe pp_base' pp_size f typ - | Tstruct struct_typ -> pp_struct_typ pe pp_base f struct_typ - | Tarray (typ, size) -> - let pp_base' fmt () = F.fprintf fmt "%a[%a]" pp_base () (pp_size pe) size in - pp_type_decl pe pp_base' pp_size f typ - -(** Pretty print a type with all the details, using the C syntax. *) -and pp_typ_full pe = pp_type_decl pe (fun _ () -> ()) pp_exp_full - -(** Pretty print an expression. *) -and _pp_exp pe0 pp_t f e0 = - let pe, changed = color_pre_wrapper pe0 f e0 in - let e = match pe.pe_obj_sub with - | Some sub -> Obj.obj (sub (Obj.repr e0)) (* apply object substitution to expression *) - | None -> e0 in - (if not (exp_equal e0 e) - then - match e with - | Lvar pvar -> Pvar.pp_value pe f pvar - | _ -> assert false - else - let pp_exp = _pp_exp pe pp_t in - let print_binop_stm_output e1 op e2 = - match op with - | Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1 - | Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1 - | Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1 - | Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1 - | Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1 - | _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in - begin match e with - | Var id -> (Ident.pp pe) f id - | Const c -> F.fprintf f "%a" (pp_const pe) c - | Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e - | UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e - | BinOp (op, Const c, e2) when Config.smt_output -> print_binop_stm_output (Const c) op e2 - | BinOp (op, e1, e2) -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 - | Lvar pv -> Pvar.pp pe f pv - | Lfield (e, fld, _) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld - | Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 - | Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s - end); - color_post_wrapper changed pe0 f - -and pp_exp pe f e = - _pp_exp pe (pp_typ pe) f e -and pp_exp_full pe f e = - _pp_exp pe (pp_typ_full pe) f e - -(** Convert an expression to a string *) -and exp_to_string e = pp_to_string (pp_exp pe_text) e - -let typ_to_string typ = - let pp fmt () = pp_typ_full pe_text fmt typ in - pp_to_string pp () - -(** dump a type with all the details. *) -let d_typ_full (t: typ) = L.add_print_action (L.PTtyp_full, Obj.repr t) - -(** dump a list of types. *) -let d_typ_list (tl: typ list) = L.add_print_action (L.PTtyp_list, Obj.repr tl) - -(** dump an expression. *) -let d_exp (e: exp) = L.add_print_action (L.PTexp, Obj.repr e) - -(** Pretty print a list of expressions. *) -let pp_exp_list pe f expl = - (pp_seq (pp_exp pe)) f expl - -(** dump a list of expressions. *) -let d_exp_list (el: exp list) = L.add_print_action (L.PTexp_list, Obj.repr el) - -let pp_texp pe f = function - | Sizeof (t, s) -> F.fprintf f "%a%a" (pp_typ pe) t Subtype.pp s - | e -> (pp_exp pe) f e - -(** Pretty print a type with all the details. *) -let pp_texp_full pe f = function - | Sizeof (t, s) -> F.fprintf f "%a%a" (pp_typ_full pe) t Subtype.pp s - | e -> (_pp_exp pe) (pp_typ_full pe) f e - -(** Dump a type expression with all the details. *) -let d_texp_full (te: exp) = L.add_print_action (L.PTtexp_full, Obj.repr te) - -(** Pretty print an offset *) -let pp_offset pe f = function - | Off_fld (fld, _) -> F.fprintf f "%a" Ident.pp_fieldname fld - | Off_index exp -> F.fprintf f "%a" (pp_exp pe) exp - -(** dump an offset. *) -let d_offset (off: offset) = L.add_print_action (L.PToff, Obj.repr off) - -(** Pretty print a list of offsets *) -let rec pp_offset_list pe f = function - | [] -> () - | [off1; off2] -> F.fprintf f "%a.%a" (pp_offset pe) off1 (pp_offset pe) off2 - | off:: off_list -> F.fprintf f "%a.%a" (pp_offset pe) off (pp_offset_list pe) off_list - -(** Dump a list of offsets *) -let d_offset_list (offl: offset list) = L.add_print_action (L.PToff_list, Obj.repr offl) - -let pp_exp_typ pe f (e, t) = - F.fprintf f "%a:%a" (pp_exp pe) e (pp_typ pe) t - -(** Get the location of the instruction *) -let instr_get_loc = function - | Letderef (_, _, _, loc) - | Set (_, _, _, loc) - | Prune (_, loc, _, _) - | Call (_, _, _, loc, _) - | Nullify (_, loc) - | Abstract loc - | Remove_temps (_, loc) - | Stackop (_, loc) - | Declare_locals (_, loc) -> - loc - -(** get the expressions occurring in the instruction *) -let instr_get_exps = function - | Letderef (id, e, _, _) -> - [Var id; e] - | Set (e1, _, e2, _) -> - [e1; e2] - | Prune (cond, _, _, _) -> - [cond] - | Call (ret_ids, e, _, _, _) -> - e :: (IList.map (fun id -> Var id)) ret_ids - | Nullify (pvar, _) -> - [Lvar pvar] - | Abstract _ -> - [] - | Remove_temps (temps, _) -> - IList.map (fun id -> Var id) temps - | Stackop _ -> - [] - | Declare_locals _ -> - [] - -(** Pretty print call flags *) -let pp_call_flags f cf = - if cf.cf_virtual then F.fprintf f " virtual"; - if cf.cf_noreturn then F.fprintf f " noreturn" - -(** Pretty print an instruction. *) -let pp_instr pe0 f instr = - let pe, changed = color_pre_wrapper pe0 f instr in - (match instr with - | Letderef (id, e, t, loc) -> - F.fprintf f "%a=*%a:%a %a" - (Ident.pp pe) id - (pp_exp pe) e - (pp_typ pe) t - Location.pp loc - | Set (e1, t, e2, loc) -> - F.fprintf f "*%a:%a=%a %a" - (pp_exp pe) e1 - (pp_typ pe) t - (pp_exp pe) e2 - Location.pp loc - | Prune (cond, loc, true_branch, _) -> - F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch Location.pp loc - | Call (ret_ids, e, arg_ts, loc, cf) -> - (match ret_ids with - | [] -> () - | _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids); - F.fprintf f "%a(%a)%a %a" - (pp_exp pe) e - (pp_comma_seq (pp_exp_typ pe)) (arg_ts) - pp_call_flags cf - Location.pp loc - | Nullify (pvar, loc) -> - F.fprintf f "NULLIFY(%a); %a" (Pvar.pp pe) pvar Location.pp loc - | Abstract loc -> - F.fprintf f "APPLY_ABSTRACTION; %a" Location.pp loc - | Remove_temps (temps, loc) -> - F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps Location.pp loc - | Stackop (stackop, loc) -> - let s = match stackop with - | Push -> "Push" - | Swap -> "Swap" - | Pop -> "Pop" in - F.fprintf f "STACKOP.%s; %a" s Location.pp loc - | Declare_locals (ptl, loc) -> - let pp_typ fmt (pvar, _) = F.fprintf fmt "%a" (Pvar.pp pe) pvar in - F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_typ) ptl Location.pp loc - ); - color_post_wrapper changed pe0 f - -let has_block_prefix s = - match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) s with - | _ :: _ :: _ -> true - | _ -> false - -(** Check if type is a type for a block in objc *) -let is_block_type typ = - has_block_prefix (typ_to_string typ) - -(** Check if a pvar is a local pointing to a block in objc *) -let is_block_pvar pvar = - has_block_prefix (Mangled.to_string (Pvar.get_name pvar)) - -(* A block pvar used to explain retain cycles *) -let block_pvar = - Pvar.mk (Mangled.from_string "block") (Procname.from_string_c_fun "") - -(** Iterate over all the subtypes in the type (including the type itself) *) -let rec typ_iter_types (f : typ -> unit) typ = - f typ; - match typ with - | Tvar _ - | Tint _ - | Tfloat _ - | Tvoid - | Tfun _ -> - () - | Tptr (t', _) -> - typ_iter_types f t' - | Tstruct struct_typ -> - IList.iter (fun (_, t, _) -> typ_iter_types f t) struct_typ.instance_fields - | Tarray (t, e) -> - typ_iter_types f t; - exp_iter_types f e - -(** Iterate over all the subtypes in the type (including the type itself) *) -and exp_iter_types f e = - match e with - | Var _ -> () - | Const (Cexn e1) -> - exp_iter_types f e1 - | Const (Cclosure { captured_vars }) -> - IList.iter (fun (_, _, typ) -> f typ) captured_vars - | Const _ -> - () - | Cast (t, e1) -> - typ_iter_types f t; - exp_iter_types f e1 - | UnOp (_, e1, typo) -> - exp_iter_types f e1; - (match typo with - | Some t -> typ_iter_types f t - | None -> ()) - | BinOp (_, e1, e2) -> - exp_iter_types f e1; - exp_iter_types f e2 - | Lvar _ -> - () - | Lfield (e1, _, typ) -> - exp_iter_types f e1; - typ_iter_types f typ - | Lindex (e1, e2) -> - exp_iter_types f e1; - exp_iter_types f e2 - | Sizeof (t, _) -> - typ_iter_types f t - -(** Iterate over all the types (and subtypes) in the instruction *) -let instr_iter_types f instr = match instr with - | Letderef (_, e, t, _) -> - exp_iter_types f e; - typ_iter_types f t - | Set (e1, t, e2, _) -> - exp_iter_types f e1; - typ_iter_types f t; - exp_iter_types f e2 - | Prune (cond, _, _, _) -> - exp_iter_types f cond - | Call (_, e, arg_ts, _, _) -> - exp_iter_types f e; - IList.iter (fun (e, t) -> exp_iter_types f e; typ_iter_types f t) arg_ts - | Nullify (_, _) -> - () - | Abstract _ -> - () - | Remove_temps (_, _) -> - () - | Stackop (_, _) -> - () - | Declare_locals (ptl, _) -> - IList.iter (fun (_, t) -> typ_iter_types f t) ptl - -(** Dump an instruction. *) -let d_instr (i: instr) = L.add_print_action (L.PTinstr, Obj.repr i) - -let rec pp_instr_list pe f = function - | [] -> F.fprintf f "" - | i:: is -> F.fprintf f "%a;@\n%a" (pp_instr pe) i (pp_instr_list pe) is - -(** Dump a list of instructions. *) -let d_instr_list (il: instr list) = L.add_print_action (L.PTinstr_list, Obj.repr il) - -let pp_atom pe0 f a = - let pe, changed = color_pre_wrapper pe0 f a in - begin match a with - | Aeq (BinOp(op, e1, e2), Const (Cint i)) when Int.isone i -> - (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) - | PP_LATEX -> - F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2)) - ) - | Aeq (e1, e2) -> - (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2 - | PP_LATEX -> - F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2) - | Aneq ((Const (Cattribute _) as ea), e) - | Aneq (e, (Const (Cattribute _) as ea)) -> - F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e - | Aneq (e1, e2) -> - (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2 - | PP_LATEX -> - F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2) - end; - color_post_wrapper changed pe0 f - -(** dump an atom *) -let d_atom (a: atom) = L.add_print_action (L.PTatom, Obj.repr a) - -let pp_lseg_kind f = function - | Lseg_NE -> F.fprintf f "ne" - | Lseg_PE -> F.fprintf f "" - -(** Print a *-separated sequence. *) -let rec pp_star_seq pp f = function - | [] -> () - | [x] -> F.fprintf f "%a" pp x - | x:: l -> F.fprintf f "%a * %a" pp x (pp_star_seq pp) l - -(********* START OF MODULE Predicates **********) -(** Module Predicates records the occurrences of predicates as parameters - of (doubly -)linked lists and Epara. Provides unique numbering - for predicates and an iterator. *) -module Predicates : sig - (** predicate environment *) - type env - (** create an empty predicate environment *) - val empty_env : unit -> env - (** return true if the environment is empty *) - val is_empty : env -> bool - (** return the id of the hpara *) - val get_hpara_id : env -> hpara -> int - (** return the id of the hpara_dll *) - val get_hpara_dll_id : env -> hpara_dll -> int - (** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, - passing the unique id to the functions. The iterator can only be used once. *) - val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit - (** Process one hpred, updating the predicate environment *) - val process_hpred : env -> hpred -> unit -end = struct - - (** hash tables for hpara *) - module HparaHash = Hashtbl.Make (struct - type t = hpara - let equal = hpara_equal - let hash = Hashtbl.hash - end) - - (** hash tables for hpara_dll *) - module HparaDllHash = Hashtbl.Make (struct - type t = hpara_dll - let equal = hpara_dll_equal - let hash = Hashtbl.hash - end) - - (** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted, - also keep a list of hparas still to be emitted. Same for hpara_dll. *) - type env = - { - mutable num: int; - hash: (int * bool) HparaHash.t; - mutable todo: hpara list; - hash_dll: (int * bool) HparaDllHash.t; - mutable todo_dll: hpara_dll list; - } - - (** return true if the environment is empty *) - let is_empty env = env.num = 0 - - (** return the id of the hpara *) - let get_hpara_id env hpara = - fst (HparaHash.find env.hash hpara) - - (** return the id of the hpara_dll *) - let get_hpara_dll_id env hpara_dll = - fst (HparaDllHash.find env.hash_dll hpara_dll) - - (** Process one hpara, updating the map from hparas to numbers, and the todo list *) - let process_hpara env hpara = - if not (HparaHash.mem env.hash hpara) then - (HparaHash.add env.hash hpara (env.num, false); - env.num <- env.num + 1; - env.todo <- env.todo @ [hpara]) - - (** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *) - let process_hpara_dll env hpara_dll = - if not (HparaDllHash.mem env.hash_dll hpara_dll) - then - (HparaDllHash.add env.hash_dll hpara_dll (env.num, false); - env.num <- env.num + 1; - env.todo_dll <- env.todo_dll @ [hpara_dll]) - - (** Process a sexp, updating env *) - let rec process_sexp env = function - | Eexp _ -> () - | Earray (_, esel, _) -> - IList.iter (fun (_, se) -> process_sexp env se) esel - | Estruct (fsel, _) -> - IList.iter (fun (_, se) -> process_sexp env se) fsel - - (** Process one hpred, updating env *) - let rec process_hpred env = function - | Hpointsto (_, se, _) -> - process_sexp env se - | Hlseg (_, hpara, _, _, _) -> - IList.iter (process_hpred env) hpara.body; - process_hpara env hpara - | Hdllseg(_, hpara_dll, _, _, _, _, _) -> - IList.iter (process_hpred env) hpara_dll.body_dll; - process_hpara_dll env hpara_dll - - (** create an empty predicate environment *) - let empty_env () = - { - num = 0; - hash = HparaHash.create 3; - todo =[]; - hash_dll = HparaDllHash.create 3; - todo_dll =[]; - } - - (** iterator for predicates which are marked as todo in env, - unless they have been visited already. - This can in turn extend the todo list for the nested predicates, - which are then visited as well. - Can be applied only once, as it destroys the todo list *) - let iter (env: env) f f_dll = - while env.todo != [] || env.todo_dll != [] do - if env.todo != [] then - begin - let hpara = IList.hd env.todo in - let () = env.todo <- IList.tl env.todo in - let (n, emitted) = HparaHash.find env.hash hpara in - if not emitted then f n hpara - end - else if env.todo_dll != [] then - begin - let hpara_dll = IList.hd env.todo_dll in - let () = env.todo_dll <- IList.tl env.todo_dll in - let (n, emitted) = HparaDllHash.find env.hash_dll hpara_dll in - if not emitted then f_dll n hpara_dll - end - done -end -(********* END OF MODULE Predicates **********) - -let pp_texp_simple pe = match pe.pe_opt with - | PP_SIM_DEFAULT -> pp_texp pe - | PP_SIM_WITH_TYP -> pp_texp_full pe - -let inst_abstraction = Iabstraction -let inst_actual_precondition = Iactual_precondition -let inst_alloc = Ialloc -let inst_formal = Iformal (None, false) (** for formal parameters *) -let inst_initial = Iinitial (** for initial values *) -let inst_lookup = Ilookup -let inst_none = Inone -let inst_nullify = Inullify -let inst_rearrange b loc pos = Irearrange (Some b, false, loc.Location.line, pos) -let inst_taint = Itaint -let inst_update loc pos = Iupdate (None, false, loc.Location.line, pos) - -(** update the location of the instrumentation *) -let inst_new_loc loc inst = match inst with - | Iabstraction -> inst - | Iactual_precondition -> inst - | Ialloc -> inst - | Iformal _ -> inst - | Iinitial -> inst - | Ilookup -> inst - | Inone -> inst - | Inullify -> inst - | Irearrange (zf, ncf, _, pos) -> Irearrange (zf, ncf, loc.Location.line, pos) - | Itaint -> inst - | Iupdate (zf, ncf, _, pos) -> Iupdate (zf, ncf, loc.Location.line, pos) - | Ireturn_from_call _ -> Ireturn_from_call loc.Location.line - | Ireturn_from_pointer_wrapper_call _ -> Ireturn_from_pointer_wrapper_call loc.Location.line - -(** return a string representing the inst *) -let inst_to_string inst = - let zero_flag_to_string = function - | Some true -> "(z)" - | _ -> "" in - let null_case_flag_to_string ncf = - if ncf then "(ncf)" else "" in - match inst with - | Iabstraction -> "abstraction" - | Iactual_precondition -> "actual_precondition" - | Ialloc -> "alloc" - | Iformal (zf, ncf) -> - "formal" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf - | Iinitial -> "initial" - | Ilookup -> "lookup" - | Inone -> "none" - | Inullify -> "nullify" - | Irearrange (zf, ncf, n, _) -> - "rearrange:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n - | Itaint -> "taint" - | Iupdate (zf, ncf, n, _) -> - "update:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n - | Ireturn_from_call n -> "return_from_call: " ^ string_of_int n - | Ireturn_from_pointer_wrapper_call n -> "Ireturn_from_pointer_wrapper_call: " ^ string_of_int n - -(** join of instrumentations *) -let inst_partial_join inst1 inst2 = - let fail () = - L.d_strln ("inst_partial_join failed on " ^ inst_to_string inst1 ^ " " ^ inst_to_string inst2); - raise IList.Fail in - if inst1 = inst2 then inst1 - else match inst1, inst2 with - | _, Inone | Inone, _ -> inst_none - | _, Ialloc | Ialloc, _ -> fail () - | _, Iinitial | Iinitial, _ -> fail () - | _, Iupdate _ | Iupdate _, _ -> fail () - | _ -> inst_none - -(** meet of instrumentations *) -let inst_partial_meet inst1 inst2 = - if inst1 = inst2 then inst1 else inst_none - -(** Return the zero flag of the inst *) -let inst_zero_flag = function - | Iabstraction -> None - | Iactual_precondition -> None - | Ialloc -> None - | Iformal (zf, _) -> zf - | Iinitial -> None - | Ilookup -> None - | Inone -> None - | Inullify -> None - | Irearrange (zf, _, _, _) -> zf - | Itaint -> None - | Iupdate (zf, _, _, _) -> zf - | Ireturn_from_call _ - | Ireturn_from_pointer_wrapper_call _ -> None - -(** Set the null case flag of the inst. *) -let inst_set_null_case_flag = function - | Iformal (zf, false) -> - Iformal (zf, true) - | Irearrange (zf, false, n, pos) -> - Irearrange (zf, true, n, pos) - | Iupdate (zf, false, n, pos) -> - Iupdate (zf, true, n, pos) - | inst -> inst - -(** Get the null case flag of the inst. *) -let inst_get_null_case_flag = function - | Iupdate (_, ncf, _, _) -> Some ncf - | _ -> None - -(** Update [inst_old] to [inst_new] preserving the zero flag *) -let update_inst inst_old inst_new = - let combine_zero_flags z1 z2 = match z1, z2 with - | Some b1, Some b2 -> Some (b1 || b2) - | Some b, None -> Some b - | None, Some b -> Some b - | None, None -> None in - match inst_new with - | Iabstraction -> inst_new - | Iactual_precondition -> inst_new - | Ialloc -> inst_new - | Iformal (zf, ncf) -> - let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in - Iformal (zf', ncf) - | Iinitial -> inst_new - | Ilookup -> inst_new - | Inone -> inst_new - | Inullify -> inst_new - | Irearrange (zf, ncf, n, pos) -> - let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in - Irearrange (zf', ncf, n, pos) - | Itaint -> inst_new - | Iupdate (zf, ncf, n, pos) -> - let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in - Iupdate (zf', ncf, n, pos) - | Ireturn_from_call _ -> inst_new - | Ireturn_from_pointer_wrapper_call _ -> inst_new - -(** describe an instrumentation with a string *) -let pp_inst pe f inst = - let str = inst_to_string inst in - if pe.pe_kind == PP_HTML then - F.fprintf f " %a%s%a" Io_infer.Html.pp_start_color Orange str Io_infer.Html.pp_end_color () - else - F.fprintf f "%s%s%s" (str_binop pe Lt) str (str_binop pe Gt) - -let pp_inst_if_trace pe f inst = - if Config.trace_error then pp_inst pe f inst - -(** pretty print a strexp with an optional predicate env *) -let rec pp_sexp_env pe0 envo f se = - let pe, changed = color_pre_wrapper pe0 f se in - begin - match se with - | Eexp (e, inst) -> - F.fprintf f "%a%a" (pp_exp pe) e (pp_inst_if_trace pe) inst - | Estruct (fel, inst) -> - begin - match pe.pe_kind with - | PP_TEXT | PP_HTML -> - let pp_diff f (n, se) = - F.fprintf f "%a:%a" Ident.pp_fieldname n (pp_sexp_env pe envo) se in - F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst - | PP_LATEX -> - let pp_diff f (n, se) = - F.fprintf f "%a:%a" - (Ident.pp_fieldname_latex Latex.Boldface) n (pp_sexp_env pe envo) se in - F.fprintf f "\\{%a\\}%a" - (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst - end - | Earray (size, nel, inst) -> - let pp_diff f (i, se) = - F.fprintf f "%a:%a" - (pp_exp pe) i (pp_sexp_env pe envo) se in - F.fprintf f "[%a|%a]%a" - (pp_exp pe) size (pp_seq_diff pp_diff pe) nel (pp_inst_if_trace pe) inst - end; - color_post_wrapper changed pe0 f - -(** Pretty print an hpred with an optional predicate env *) -and pp_hpred_env pe0 envo f hpred = - let pe, changed = color_pre_wrapper pe0 f hpred in - begin match hpred with - | Hpointsto (e, se, te) -> - let pe' = match (e, se) with - | Lvar pvar, Eexp (Var _, _) when not (Pvar.is_global pvar) -> - { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) - | _ -> pe in - (match pe'.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "%a|->%a:%a" - (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te - | PP_LATEX -> - F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se) - | Hlseg (k, hpara, e1, e2, elist) -> - (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "lseg%a(%a,%a,[%a],%a)" - pp_lseg_kind k - (pp_exp pe) e1 - (pp_exp pe) e2 - (pp_comma_seq (pp_exp pe)) elist - (pp_hpara_env pe envo) hpara - | PP_LATEX -> - F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" - pp_lseg_kind k - (pp_exp pe) e1 - (pp_exp pe) e2 - (pp_comma_seq (pp_exp pe)) elist - (pp_hpara_env pe envo) hpara) - | Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) -> - (match pe.pe_kind with - | PP_TEXT | PP_HTML -> - F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" - pp_lseg_kind k - (pp_exp pe) iF - (pp_exp pe) oB - (pp_exp pe) oF - (pp_exp pe) iB - (pp_comma_seq (pp_exp pe)) elist - (pp_hpara_dll_env pe envo) hpara_dll - | PP_LATEX -> - F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" - pp_lseg_kind k - (pp_exp pe) iF - (pp_exp pe) oB - (pp_exp pe) oF - (pp_exp pe) iB - (pp_comma_seq (pp_exp pe)) elist - (pp_hpara_dll_env pe envo) hpara_dll) - end; - color_post_wrapper changed pe0 f - -and pp_hpara_env pe envo f hpara = match envo with - | None -> - let (r, n, svars, evars, b) = - (hpara.root, hpara.next, hpara.svars, hpara.evars, hpara.body) in - F.fprintf f "lam [%a,%a,%a]. exists [%a]. %a" - (Ident.pp pe) r - (Ident.pp pe) n - (pp_seq (Ident.pp pe)) svars - (pp_seq (Ident.pp pe)) evars - (pp_star_seq (pp_hpred_env pe envo)) b - | Some env -> - F.fprintf f "P%d" (Predicates.get_hpara_id env hpara) - -and pp_hpara_dll_env pe envo f hpara_dll = match envo with - | None -> - let (iF, oB, oF, svars, evars, b) = - (hpara_dll.cell, hpara_dll.blink, hpara_dll.flink, - hpara_dll.svars_dll, hpara_dll.evars_dll, hpara_dll.body_dll) in - F.fprintf f "lam [%a,%a,%a,%a]. exists [%a]. %a" - (Ident.pp pe) iF - (Ident.pp pe) oB - (Ident.pp pe) oF - (pp_seq (Ident.pp pe)) svars - (pp_seq (Ident.pp pe)) evars - (pp_star_seq (pp_hpred_env pe envo)) b - | Some env -> - F.fprintf f "P%d" (Predicates.get_hpara_dll_id env hpara_dll) - -(** pretty print a strexp *) -let pp_sexp pe f = pp_sexp_env pe None f - -(** pretty print a hpara *) -let pp_hpara pe f = pp_hpara_env pe None f - -(** pretty print a hpara_dll *) -let pp_hpara_dll pe f = pp_hpara_dll_env pe None f - -(** pretty print a hpred *) -let pp_hpred pe f = pp_hpred_env pe None f - -(** dump a strexp. *) -let d_sexp (se: strexp) = L.add_print_action (L.PTsexp, Obj.repr se) - -(** Pretty print a list of expressions. *) -let pp_sexp_list pe f sel = - F.fprintf f "%a" (pp_seq (fun f se -> F.fprintf f "%a" (pp_sexp pe) se)) sel - -(** dump a list of expressions. *) -let d_sexp_list (sel: strexp list) = L.add_print_action (L.PTsexp_list, Obj.repr sel) - -let rec pp_hpara_list pe f = function - | [] -> () - | [para] -> - F.fprintf f "PRED: %a" (pp_hpara pe) para - | para:: paras -> - F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara pe) para (pp_hpara_list pe) paras - -let rec pp_hpara_dll_list pe f = function - | [] -> () - | [para] -> - F.fprintf f "PRED: %a" (pp_hpara_dll pe) para - | para:: paras -> - F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara_dll pe) para (pp_hpara_dll_list pe) paras - -(** dump a hpred. *) -let d_hpred (hpred: hpred) = L.add_print_action (L.PThpred, Obj.repr hpred) - -(** {2 Functions for traversing SIL data types} *) - -let rec strexp_expmap (f: exp * inst option -> exp * inst option) = - let fe e = fst (f (e, None)) in - let fei (e, inst) = match f (e, Some inst) with - | e', None -> (e', inst) - | e', Some inst' -> (e', inst') in - function - | Eexp (e, inst) -> - let e', inst' = fei (e, inst) in - Eexp (e', inst') - | Estruct (fld_se_list, inst) -> - let f_fld_se (fld, se) = (fld, strexp_expmap f se) in - Estruct (IList.map f_fld_se fld_se_list, inst) - | Earray (size, idx_se_list, inst) -> - let size' = fe size in - let f_idx_se (idx, se) = - let idx' = fe idx in - (idx', strexp_expmap f se) in - Earray (size', IList.map f_idx_se idx_se_list, inst) - -let hpred_expmap (f: exp * inst option -> exp * inst option) = - let fe e = fst (f (e, None)) in - function - | Hpointsto (e, se, te) -> - let e' = fe e in - let se' = strexp_expmap f se in - let te' = fe te in - Hpointsto(e', se', te') - | Hlseg (k, hpara, root, next, shared) -> - let root' = fe root in - let next' = fe next in - let shared' = IList.map fe shared in - Hlseg (k, hpara, root', next', shared') - | Hdllseg (k, hpara, iF, oB, oF, iB, shared) -> - let iF' = fe iF in - let oB' = fe oB in - let oF' = fe oF in - let iB' = fe iB in - let shared' = IList.map fe shared in - Hdllseg (k, hpara, iF', oB', oF', iB', shared') - -let rec strexp_instmap (f: inst -> inst) strexp = match strexp with - | Eexp (e, inst) -> - Eexp (e, f inst) - | Estruct (fld_se_list, inst) -> - let f_fld_se (fld, se) = (fld, strexp_instmap f se) in - Estruct (IList.map f_fld_se fld_se_list, f inst) - | Earray (size, idx_se_list, inst) -> - let f_idx_se (idx, se) = - (idx, strexp_instmap f se) in - Earray (size, IList.map f_idx_se idx_se_list, f inst) - -and hpara_instmap (f: inst -> inst) hpara = - { hpara with body = IList.map (hpred_instmap f) hpara.body } - -and hpara_dll_instmap (f: inst -> inst) hpara_dll = - { hpara_dll with body_dll = IList.map (hpred_instmap f) hpara_dll.body_dll } - -and hpred_instmap (fn: inst -> inst) (hpred: hpred) : hpred = match hpred with - | Hpointsto (e, se, te) -> - let se' = strexp_instmap fn se in - Hpointsto(e, se', te) - | Hlseg (k, hpara, e, f, el) -> - Hlseg (k, hpara_instmap fn hpara, e, f, el) - | Hdllseg (k, hpar_dll, e, f, g, h, el) -> - Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el) - -let hpred_list_expmap (f: exp * inst option -> exp * inst option) (hlist: hpred list) = - IList.map (hpred_expmap f) hlist - -let atom_expmap (f: exp -> exp) = function - | Aeq (e1, e2) -> Aeq (f e1, f e2) - | Aneq (e1, e2) -> Aneq (f e1, f e2) - -let atom_list_expmap (f: exp -> exp) (alist: atom list) = - IList.map (atom_expmap f) alist - -(** {2 Function for computing lexps in sigma} *) - -let hpred_get_lexp acc = function - | Hpointsto(e, _, _) -> e:: acc - | Hlseg(_, _, e, _, _) -> e:: acc - | Hdllseg(_, _, e1, _, _, e2, _) -> e1:: e2:: acc - -let hpred_list_get_lexps (filter: exp -> bool) (hlist: hpred list) : exp list = - let lexps = IList.fold_left hpred_get_lexp [] hlist in - IList.filter filter lexps - -(** {2 Utility Functions for Expressions} *) - -let unsome_typ s = function - | Some default_typ -> default_typ - | None -> - L.err "No default typ in %s@." s; - assert false - -(** Turn an expression representing a type into the type it represents - If not a sizeof, return the default type if given, otherwise raise an exception *) -let texp_to_typ default_opt = function - | Sizeof (t, _) -> t - | _ -> - unsome_typ "texp_to_typ" default_opt - -(** If a struct type with field f, return the type of f. - If not, return the default type if given, otherwise raise an exception *) -let struct_typ_fld default_opt f = - let def () = unsome_typ "struct_typ_fld" default_opt in - function - | Tstruct struct_typ -> - (try (fun (_, y, _) -> y) - (IList.find (fun (_f, _, _) -> - Ident.fieldname_equal _f f) struct_typ.instance_fields) - with Not_found -> def ()) - | _ -> def () - -(** If an array type, return the type of the element. - If not, return the default type if given, otherwise raise an exception *) -let array_typ_elem default_opt = function - | Tarray (t_el, _) -> t_el - | _ -> - unsome_typ "array_typ_elem" default_opt - -(** Return the root of [lexp]. *) -let rec root_of_lexp lexp = match lexp with - | Var _ -> lexp - | Const _ -> lexp - | Cast (_, e) -> root_of_lexp e - | UnOp _ | BinOp _ -> lexp - | Lvar _ -> lexp - | Lfield(e, _, _) -> root_of_lexp e - | Lindex(e, _) -> root_of_lexp e - | Sizeof _ -> lexp - -(** Checks whether an expression denotes a location by pointer arithmetic. - Currently, catches array - indexing expressions such as a[i] only. *) -let rec exp_pointer_arith = function - | Lfield (e, _, _) -> exp_pointer_arith e - | Lindex _ -> true - | _ -> false - -let exp_get_undefined footprint = - Var (Ident.create_fresh (if footprint then Ident.kfootprint else Ident.kprimed)) - -(** Create integer constant *) -let exp_int i = Const (Cint i) - -(** Create float constant *) -let exp_float v = Const (Cfloat v) - -(** Integer constant 0 *) -let exp_zero = exp_int Int.zero - -(** Null constant *) -let exp_null = exp_int Int.null - -(** Integer constant 1 *) -let exp_one = exp_int Int.one - -(** Integer constant -1 *) -let exp_minus_one = exp_int Int.minus_one - -(** Create integer constant corresponding to the boolean value *) -let exp_bool b = - if b then exp_one else exp_zero - -(** Create expresstion [e1 == e2] *) -let exp_eq e1 e2 = - BinOp (Eq, e1, e2) - -(** Create expresstion [e1 != e2] *) -let exp_ne e1 e2 = - BinOp (Ne, e1, e2) - -(** Create expression [e1 <= e2] *) -let exp_le e1 e2 = - BinOp (Le, e1, e2) - -(** Create expression [e1 < e2] *) -let exp_lt e1 e2 = - BinOp (Lt, e1, e2) - -(** {2 Functions for computing program variables} *) - -let rec exp_fpv = function - | Var _ -> [] - | Const (Cexn e) -> exp_fpv e - | Const (Cclosure { captured_vars; }) -> - IList.map (fun (_, pvar, _) -> pvar) captured_vars - | Const _ -> [] - | Cast (_, e) | UnOp (_, e, _) -> exp_fpv e - | BinOp (_, e1, e2) -> exp_fpv e1 @ exp_fpv e2 - | Lvar name -> [name] - | Lfield (e, _, _) -> exp_fpv e - | Lindex (e1, e2) -> exp_fpv e1 @ exp_fpv e2 - | Sizeof _ -> [] - -and exp_list_fpv el = IList.flatten (IList.map exp_fpv el) - -let atom_fpv = function - | Aeq (e1, e2) -> exp_fpv e1 @ exp_fpv e2 - | Aneq (e1, e2) -> exp_fpv e1 @ exp_fpv e2 - -let rec strexp_fpv = function - | Eexp (e, _) -> exp_fpv e - | Estruct (fld_se_list, _) -> - let f (_, se) = strexp_fpv se in - IList.flatten (IList.map f fld_se_list) - | Earray (size, idx_se_list, _) -> - let fpv_in_size = exp_fpv size in - let f (idx, se) = exp_fpv idx @ strexp_fpv se in - fpv_in_size @ IList.flatten (IList.map f idx_se_list) - -and hpred_fpv = function - | Hpointsto (base, se, te) -> - exp_fpv base @ strexp_fpv se @ exp_fpv te - | Hlseg (_, para, e1, e2, elist) -> - let fpvars_in_elist = exp_list_fpv elist in - hpara_fpv para (* This set has to be empty. *) - @ exp_fpv e1 - @ exp_fpv e2 - @ fpvars_in_elist - | Hdllseg (_, para, e1, e2, e3, e4, elist) -> - let fpvars_in_elist = exp_list_fpv elist in - hpara_dll_fpv para (* This set has to be empty. *) - @ exp_fpv e1 - @ exp_fpv e2 - @ exp_fpv e3 - @ exp_fpv e4 - @ fpvars_in_elist - -(** hpara should not contain any program variables. - This is because it might cause problems when we do interprocedural - analysis. In interprocedural analysis, we should consider the issue - of scopes of program variables. *) -and hpara_fpv para = - let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body) in - match fpvars_in_body with - | [] -> [] - | _ -> assert false - -(** hpara_dll should not contain any program variables. - This is because it might cause problems when we do interprocedural - analysis. In interprocedural analysis, we should consider the issue - of scopes of program variables. *) -and hpara_dll_fpv para = - let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body_dll) in - match fpvars_in_body with - | [] -> [] - | _ -> assert false - -(** {2 Functions for computing free non-program variables} *) - -(** Type of free variables. These include primed, normal and footprint variables. - We keep a count of how many types the variables appear. *) -type fav = Ident.t list ref - -let fav_new () = - ref [] - -(** Emptyness check. *) -let fav_is_empty fav = match !fav with - | [] -> true - | _ -> false - -(** Check whether a predicate holds for all elements. *) -let fav_for_all fav predicate = - IList.for_all predicate !fav - -(** Check whether a predicate holds for some elements. *) -let fav_exists fav predicate = - IList.exists predicate !fav - -(** flag to indicate whether fav's are stored in duplicate form. - Only to be used with fav_to_list *) -let fav_duplicates = ref false - -(** extend [fav] with a [id] *) -let (++) fav id = - if !fav_duplicates || not (IList.exists (Ident.equal id) !fav) then fav := id::!fav - -(** extend [fav] with ident list [idl] *) -let (+++) fav idl = - IList.iter (fun id -> fav ++ id) idl - -(** add identity lists to fav *) -let ident_list_fav_add idl fav = - fav +++ idl - -(** Convert a list to a fav. *) -let fav_from_list l = - let fav = fav_new () in - let _ = IList.iter (fun id -> fav ++ id) l in - fav - -let rec remove_duplicates_from_sorted special_equal = function - | [] -> [] - | [x] -> [x] - | x:: y:: l -> - if (special_equal x y) - then remove_duplicates_from_sorted special_equal (y:: l) - else x:: (remove_duplicates_from_sorted special_equal (y:: l)) - -(** Convert a [fav] to a list of identifiers while preserving the order - that the identifiers were added to [fav]. *) -let fav_to_list fav = - IList.rev !fav - -(** Pretty print a fav. *) -let pp_fav pe f fav = - (pp_seq (Ident.pp pe)) f (fav_to_list fav) - -(** Copy a [fav]. *) -let fav_copy fav = - ref (IList.map (fun x -> x) !fav) - -(** Turn a xxx_fav_add function into a xxx_fav function *) -let fav_imperative_to_functional f x = - let fav = fav_new () in - let _ = f fav x in - fav - -(** [fav_filter_ident fav f] only keeps [id] if [f id] is true. *) -let fav_filter_ident fav filter = - fav := IList.filter filter !fav - -(** Like [fav_filter_ident] but return a copy. *) -let fav_copy_filter_ident fav filter = - ref (IList.filter filter !fav) - -(** checks whether every element in l1 appears l2 **) -let rec ident_sorted_list_subset l1 l2 = - match l1, l2 with - | [], _ -> true - | _:: _,[] -> false - | id1:: l1, id2:: l2 -> - let n = Ident.compare id1 id2 in - if n = 0 then ident_sorted_list_subset l1 (id2:: l2) - else if n > 0 then ident_sorted_list_subset (id1:: l1) l2 - else false - -(** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] - is in [fav2].*) -let fav_subset_ident fav1 fav2 = - ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2) - -let fav_mem fav id = - IList.exists (Ident.equal id) !fav - -let rec exp_fav_add fav = function - | Var id -> fav ++ id - | Const (Cexn e) -> exp_fav_add fav e - | Const (Cclosure { captured_vars; }) -> - IList.iter (fun (e, _, _) -> exp_fav_add fav e) captured_vars - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cattribute _ | Cclass _ | Cptr_to_fld _) -> () - | Cast (_, e) | UnOp (_, e, _) -> exp_fav_add fav e - | BinOp (_, e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2 - | Lvar _ -> () (* do nothing since we only count non-program variables *) - | Lfield (e, _, _) -> exp_fav_add fav e - | Lindex (e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2 - | Sizeof _ -> () - -let exp_fav = - fav_imperative_to_functional exp_fav_add - -let exp_fav_list e = - fav_to_list (exp_fav e) - -let ident_in_exp id e = - let fav = fav_new () in - exp_fav_add fav e; - fav_mem fav id - -let atom_fav_add fav = function - | Aeq (e1, e2) | Aneq(e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2 - -let atom_fav = - fav_imperative_to_functional atom_fav_add - -(** Atoms do not contain binders *) -let atom_av_add = atom_fav_add - -let rec strexp_fav_add fav = function - | Eexp (e, _) -> exp_fav_add fav e - | Estruct (fld_se_list, _) -> - IList.iter (fun (_, se) -> strexp_fav_add fav se) fld_se_list - | Earray (size, idx_se_list, _) -> - exp_fav_add fav size; - IList.iter (fun (e, se) -> exp_fav_add fav e; strexp_fav_add fav se) idx_se_list - -let hpred_fav_add fav = function - | Hpointsto (base, sexp, te) -> exp_fav_add fav base; strexp_fav_add fav sexp; exp_fav_add fav te - | Hlseg (_, _, e1, e2, elist) -> - exp_fav_add fav e1; exp_fav_add fav e2; - IList.iter (exp_fav_add fav) elist - | Hdllseg (_, _, e1, e2, e3, e4, elist) -> - exp_fav_add fav e1; exp_fav_add fav e2; - exp_fav_add fav e3; exp_fav_add fav e4; - IList.iter (exp_fav_add fav) elist - -let hpred_fav = - fav_imperative_to_functional hpred_fav_add - -(** This function should be used before adding a new - index to Earray. The [exp] is the newly created - index. This function "cleans" [exp] according to whether it is - the footprint or current part of the prop. - The function faults in the re - execution mode, as an internal check of the tool. *) -let array_clean_new_index footprint_part new_idx = - if footprint_part && not !Config.footprint then assert false; - let fav = exp_fav new_idx in - if footprint_part && fav_exists fav (fun id -> not (Ident.is_footprint id)) then - begin - L.d_warning ("Array index " ^ (exp_to_string new_idx) ^ - " has non-footprint vars: replaced by fresh footprint var"); - L.d_ln (); - let id = Ident.create_fresh Ident.kfootprint in - Var id - end - else new_idx - -(** {2 Functions for computing all free or bound non-program variables} *) - -let exp_av_add = exp_fav_add (** Expressions do not bind variables *) - -let strexp_av_add = strexp_fav_add (** Structured expressions do not bind variables *) - -let rec hpara_av_add fav para = - IList.iter (hpred_av_add fav) para.body; - fav ++ para.root; fav ++ para.next; - fav +++ para.svars; fav +++ para.evars - -and hpara_dll_av_add fav para = - IList.iter (hpred_av_add fav) para.body_dll; - fav ++ para.cell; fav ++ para.blink; fav ++ para.flink; - fav +++ para.svars_dll; fav +++ para.evars_dll - -and hpred_av_add fav = function - | Hpointsto (base, se, te) -> - exp_av_add fav base; strexp_av_add fav se; exp_av_add fav te - | Hlseg (_, para, e1, e2, elist) -> - hpara_av_add fav para; - exp_av_add fav e1; exp_av_add fav e2; - IList.iter (exp_av_add fav) elist - | Hdllseg (_, para, e1, e2, e3, e4, elist) -> - hpara_dll_av_add fav para; - exp_av_add fav e1; exp_av_add fav e2; - exp_av_add fav e3; exp_av_add fav e4; - IList.iter (exp_av_add fav) elist - -let hpara_shallow_av_add fav para = - IList.iter (hpred_fav_add fav) para.body; - fav ++ para.root; fav ++ para.next; - fav +++ para.svars; fav +++ para.evars - -let hpara_dll_shallow_av_add fav para = - IList.iter (hpred_fav_add fav) para.body_dll; - fav ++ para.cell; fav ++ para.blink; fav ++ para.flink; - fav +++ para.svars_dll; fav +++ para.evars_dll - -(** Variables in hpara, excluding bound vars in the body *) -let hpara_shallow_av = fav_imperative_to_functional hpara_shallow_av_add - -(** Variables in hpara_dll, excluding bound vars in the body *) -let hpara_dll_shallow_av = fav_imperative_to_functional hpara_dll_shallow_av_add - -(** {2 Functions for Substitution} *) - -let rec reverse_with_base base = function - | [] -> base - | x:: l -> reverse_with_base (x:: base) l - -let sorted_list_merge compare l1_in l2_in = - let rec merge acc l1 l2 = - match l1, l2 with - | [], l2 -> reverse_with_base l2 acc - | l1, [] -> reverse_with_base l1 acc - | x1 :: l1', x2 :: l2' -> - if compare x1 x2 <= 0 then merge (x1:: acc) l1' l2 - else merge (x2 :: acc) l1 l2' in - merge [] l1_in l2_in - -let rec sorted_list_check_consecutives f = function - | [] | [_] -> false - | x1:: ((x2:: _) as l) -> - if f x1 x2 then true else sorted_list_check_consecutives f l - -(** substitution *) -type subst = (Ident.t * exp) list - -(** Comparison between substitutions. *) -let rec sub_compare (sub1: subst) (sub2: subst) = - if sub1 == sub2 then 0 - else match sub1, sub2 with - | [],[] -> 0 - | [], _ :: _ -> - 1 - | (i1, e1) :: sub1', (i2, e2):: sub2' -> - let n = Ident.compare i1 i2 in - if n <> 0 then n - else let n = exp_compare e1 e2 in - if n <> 0 then n - else sub_compare sub1' sub2' - | _ :: _, [] -> 1 - -(** Equality for substitutions. *) -let sub_equal sub1 sub2 = - sub_compare sub1 sub2 = 0 - -let sub_check_duplicated_ids sub = - let f (id1, _) (id2, _) = Ident.equal id1 id2 in - sorted_list_check_consecutives f sub - -(** Create a substitution from a list of pairs. - For all (id1, e1), (id2, e2) in the input list, - if id1 = id2, then e1 = e2. *) -let sub_of_list sub = - let sub' = IList.sort ident_exp_compare sub in - let sub'' = remove_duplicates_from_sorted ident_exp_equal sub' in - (if sub_check_duplicated_ids sub'' then assert false); - sub' - -(** like sub_of_list, but allow duplicate ids and only keep the first occurrence *) -let sub_of_list_duplicates sub = - let sub' = IList.sort ident_exp_compare sub in - let rec remove_duplicate_ids = function - | (id1, e1) :: (id2, e2) :: l -> - if Ident.equal id1 id2 - then remove_duplicate_ids ((id1, e1) :: l) - else (id1, e1) :: remove_duplicate_ids ((id2, e2) :: l) - | l -> l in - remove_duplicate_ids sub' - -(** Convert a subst to a list of pairs. *) -let sub_to_list sub = - sub - -(** The empty substitution. *) -let sub_empty = sub_of_list [] - -(** Join two substitutions into one. - For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) -let sub_join sub1 sub2 = - let sub = sorted_list_merge ident_exp_compare sub1 sub2 in - let sub' = remove_duplicates_from_sorted ident_exp_equal sub in - (if sub_check_duplicated_ids sub' then assert false); - sub - -(** Compute the common id-exp part of two inputs [subst1] and [subst2]. - The first component of the output is this common part. - The second and third components are the remainder of [subst1] - and [subst2], respectively. *) -let sub_symmetric_difference sub1_in sub2_in = - let rec diff sub_common sub1_only sub2_only sub1 sub2 = - match sub1, sub2 with - | [], _ | _, [] -> - let sub1_only' = reverse_with_base sub1 sub1_only in - let sub2_only' = reverse_with_base sub2 sub2_only in - let sub_common = reverse_with_base [] sub_common in - (sub_common, sub1_only', sub2_only') - | id_e1 :: sub1', id_e2 :: sub2' -> - let n = ident_exp_compare id_e1 id_e2 in - if n = 0 then - diff (id_e1:: sub_common) sub1_only sub2_only sub1' sub2' - else if n < 0 then - diff sub_common (id_e1:: sub1_only) sub2_only sub1' sub2 - else - diff sub_common sub1_only (id_e2:: sub2_only) sub1 sub2' in - diff [] [] [] sub1_in sub2_in - -module Typtbl = Hashtbl.Make (struct type t = typ let equal = typ_equal let hash = Hashtbl.hash end) - -(** [sub_find filter sub] returns the expression associated to the first identifier - that satisfies [filter]. Raise [Not_found] if there isn't one. *) -let sub_find filter (sub: subst) = - snd (IList.find (fun (i, _) -> filter i) sub) - -(** [sub_filter filter sub] restricts the domain of [sub] to the - identifiers satisfying [filter]. *) -let sub_filter filter (sub: subst) = - IList.filter (fun (i, _) -> filter i) sub - -(** [sub_filter_pair filter sub] restricts the domain of [sub] to the - identifiers satisfying [filter(id, sub(id))]. *) -let sub_filter_pair = IList.filter - -(** [sub_range_partition filter sub] partitions [sub] according to - whether range expressions satisfy [filter]. *) -let sub_range_partition filter (sub: subst) = - IList.partition (fun (_, e) -> filter e) sub - -(** [sub_domain_partition filter sub] partitions [sub] according to - whether domain identifiers satisfy [filter]. *) -let sub_domain_partition filter (sub: subst) = - IList.partition (fun (i, _) -> filter i) sub - -(** Return the list of identifiers in the domain of the substitution. *) -let sub_domain sub = - IList.map fst sub - -(** Return the list of expressions in the range of the substitution. *) -let sub_range sub = - IList.map snd sub - -(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *) -let sub_range_map f sub = - sub_of_list (IList.map (fun (i, e) -> (i, f e)) sub) - -(** [sub_map f g sub] applies the renaming [f] to identifiers in the domain - of [sub] and the substitution [g] to the expressions in the range of [sub]. *) -let sub_map f g sub = - sub_of_list (IList.map (fun (i, e) -> (f i, g e)) sub) - -let mem_sub id sub = - IList.exists (fun (id1, _) -> Ident.equal id id1) sub - -(** Extend substitution and return [None] if not possible. *) -let extend_sub sub id exp : subst option = - let compare (id1, _) (id2, _) = Ident.compare id1 id2 in - if mem_sub id sub then None - else Some (sorted_list_merge compare sub [(id, exp)]) - -(** Free auxilary variables in the domain and range of the - substitution. *) -let sub_fav_add fav (sub: subst) = - IList.iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub - -let sub_fpv (sub: subst) = - IList.flatten (IList.map (fun (_, e) -> exp_fpv e) sub) - -(** Substitutions do not contain binders *) -let sub_av_add = sub_fav_add - -let rec typ_sub (subst: subst) typ = - match typ with - | Tvar _ - | Tint _ - | Tfloat _ - | Tvoid - | Tstruct _ - | Tfun _ -> - typ - | Tptr (t', pk) -> - Tptr (typ_sub subst t', pk) - | Tarray (t, e) -> - Tarray (typ_sub subst t, exp_sub subst e) - -and exp_sub (subst: subst) e = - match e with - | Var id -> - let rec apply_sub = function - | [] -> e - | (i, e):: l -> if Ident.equal i id then e else apply_sub l in - apply_sub subst - | Const (Cexn e1) -> - let e1' = exp_sub subst e1 in - Const (Cexn e1') - | Const (Cclosure c) -> - let captured_vars = - IList.map (fun (exp, pvar, typ) -> (exp_sub subst exp, pvar, typ)) c.captured_vars in - Const (Cclosure { c with captured_vars }) - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cattribute _ | Cclass _ | Cptr_to_fld _) -> - e - | Cast (t, e1) -> - let e1' = exp_sub subst e1 in - Cast (t, e1') - | UnOp (op, e1, typo) -> - let e1' = exp_sub subst e1 in - let typo' = match typo with - | None -> None - | Some typ -> Some (typ_sub subst typ) in - UnOp(op, e1', typo') - | BinOp (op, e1, e2) -> - let e1' = exp_sub subst e1 in - let e2' = exp_sub subst e2 in - BinOp (op, e1', e2') - | Lvar _ -> - e - | Lfield (e1, fld, typ) -> - let e1' = exp_sub subst e1 in - let typ' = typ_sub subst typ in - Lfield (e1', fld, typ') - | Lindex (e1, e2) -> - let e1' = exp_sub subst e1 in - let e2' = exp_sub subst e2 in - Lindex (e1', e2') - | Sizeof (t, s) -> - Sizeof (typ_sub subst t, s) - -let instr_sub (subst: subst) instr = - let id_s id = match exp_sub subst (Var id) with - | Var id' -> id' - | _ -> id in - let exp_s = exp_sub subst in - let typ_s = typ_sub subst in - match instr with - | Letderef (id, e, t, loc) -> - Letderef (id_s id, exp_s e, typ_s t, loc) - | Set (e1, t, e2, loc) -> - Set (exp_s e1, typ_s t, exp_s e2, loc) - | Prune (cond, loc, true_branch, ik) -> - Prune (exp_s cond, loc, true_branch, ik) - | Call (ret_ids, e, arg_ts, loc, cf) -> - let arg_s (e, t) = (exp_s e, typ_s t) in - Call (IList.map id_s ret_ids, exp_s e, IList.map arg_s arg_ts, loc, cf) - | Nullify _ -> - instr - | Abstract _ -> - instr - | Remove_temps (temps, loc) -> - Remove_temps (IList.map id_s temps, loc) - | Stackop _ -> - instr - | Declare_locals (ptl, loc) -> - let pt_s (pv, t) = (pv, typ_s t) in - Declare_locals (IList.map pt_s ptl, loc) - -let call_flags_compare cflag1 cflag2 = - bool_compare cflag1.cf_virtual cflag2.cf_virtual - |> next bool_compare cflag1.cf_interface cflag2.cf_interface - |> next bool_compare cflag1.cf_noreturn cflag2.cf_noreturn - |> next bool_compare cflag1.cf_is_objc_block cflag2.cf_is_objc_block - -let exp_typ_compare (exp1, typ1) (exp2, typ2) = - let n = exp_compare exp1 exp2 in - if n <> 0 then n else typ_compare typ1 typ2 - -let instr_compare instr1 instr2 = match instr1, instr2 with - | Letderef (id1, e1, t1, loc1), Letderef (id2, e2, t2, loc2) -> - let n = Ident.compare id1 id2 in - if n <> 0 then n else let n = exp_compare e1 e2 in - if n <> 0 then n else let n = typ_compare t1 t2 in - if n <> 0 then n else Location.compare loc1 loc2 - | Letderef _, _ -> -1 - | _, Letderef _ -> 1 - | Set (e11, t1, e21, loc1), Set (e12, t2, e22, loc2) -> - let n = exp_compare e11 e12 in - if n <> 0 then n else let n = typ_compare t1 t2 in - if n <> 0 then n else let n = exp_compare e21 e22 in - if n <> 0 then n else Location.compare loc1 loc2 - | Set _, _ -> -1 - | _, Set _ -> 1 - | Prune (cond1, loc1, true_branch1, ik1), Prune (cond2, loc2, true_branch2, ik2) -> - let n = exp_compare cond1 cond2 in - if n <> 0 then n else let n = Location.compare loc1 loc2 in - if n <> 0 then n else let n = bool_compare true_branch1 true_branch2 in - if n <> 0 then n else Pervasives.compare ik1 ik2 - | Prune _, _ -> -1 - | _, Prune _ -> 1 - | Call (ret_ids1, e1, arg_ts1, loc1, cf1), Call (ret_ids2, e2, arg_ts2, loc2, cf2) -> - let n = IList.compare Ident.compare ret_ids1 ret_ids2 in - if n <> 0 then n else let n = exp_compare e1 e2 in - if n <> 0 then n else let n = IList.compare exp_typ_compare arg_ts1 arg_ts2 in - if n <> 0 then n else let n = Location.compare loc1 loc2 in - if n <> 0 then n else call_flags_compare cf1 cf2 - | Call _, _ -> -1 - | _, Call _ -> 1 - | Nullify (pvar1, loc1), Nullify (pvar2, loc2) -> - let n = Pvar.compare pvar1 pvar2 in - if n <> 0 then n else Location.compare loc1 loc2 - | Nullify _, _ -> -1 - | _, Nullify _ -> 1 - | Abstract loc1, Abstract loc2 -> - Location.compare loc1 loc2 - | Abstract _, _ -> -1 - | _, Abstract _ -> 1 - | Remove_temps (temps1, loc1), Remove_temps (temps2, loc2) -> - let n = IList.compare Ident.compare temps1 temps2 in - if n <> 0 then n else Location.compare loc1 loc2 - | Remove_temps _, _ -> -1 - | _, Remove_temps _ -> 1 - | Stackop (stackop1, loc1), Stackop (stackop2, loc2) -> - let n = Pervasives.compare stackop1 stackop2 in - if n <> 0 then n else Location.compare loc1 loc2 - | Stackop _, _ -> -1 - | _, Stackop _ -> 1 - | Declare_locals (ptl1, loc1), Declare_locals (ptl2, loc2) -> - let pt_compare (pv1, t1) (pv2, t2) = - let n = Pvar.compare pv1 pv2 in - if n <> 0 then n else typ_compare t1 t2 in - - let n = IList.compare pt_compare ptl1 ptl2 in - if n <> 0 then n else Location.compare loc1 loc2 - -(** compare expressions from different procedures without considering loc's, ident's, and pvar's. - the [exp_map] param gives a mapping of names used in the procedure of [e1] to names used in the - procedure of [e2] *) -let rec exp_compare_structural e1 e2 exp_map = - let compare_exps_with_map e1 e2 exp_map = - try - let e1_mapping = ExpMap.find e1 exp_map in - exp_compare e1_mapping e2, exp_map - with Not_found -> - (* assume e1 and e2 equal, enforce by adding to [exp_map] *) - 0, ExpMap.add e1 e2 exp_map in - match (e1, e2) with - | Var _, Var _ -> compare_exps_with_map e1 e2 exp_map - | UnOp (o1, e1, to1), UnOp (o2, e2, to2) -> - let n = unop_compare o1 o2 in - if n <> 0 then n, exp_map - else - let n, exp_map = exp_compare_structural e1 e2 exp_map in - (if n <> 0 then n else typ_opt_compare to1 to2), exp_map - | BinOp (o1, e1, f1), BinOp (o2, e2, f2) -> - let n = binop_compare o1 o2 in - if n <> 0 then n, exp_map - else - let n, exp_map = exp_compare_structural e1 e2 exp_map in - if n <> 0 then n, exp_map - else exp_compare_structural f1 f2 exp_map - | Cast (t1, e1), Cast(t2, e2) -> - let n, exp_map = exp_compare_structural e1 e2 exp_map in - (if n <> 0 then n else typ_compare t1 t2), exp_map - | Lvar _, Lvar _ -> compare_exps_with_map e1 e2 exp_map - | Lfield (e1, f1, t1), Lfield (e2, f2, t2) -> - let n, exp_map = exp_compare_structural e1 e2 exp_map in - (if n <> 0 then n - else - let n = fld_compare f1 f2 in - if n <> 0 then n else typ_compare t1 t2), exp_map - | Lindex (e1, f1), Lindex (e2, f2) -> - let n, exp_map = exp_compare_structural e1 e2 exp_map in - if n <> 0 then n, exp_map - else exp_compare_structural f1 f2 exp_map - | _ -> exp_compare e1 e2, exp_map - -let exp_typ_compare_structural (e1, t1) (e2, t2) exp_map = - let n, exp_map = exp_compare_structural e1 e2 exp_map in - (if n <> 0 then n else typ_compare t1 t2), exp_map - -(** compare instructions from different procedures without considering loc's, ident's, and pvar's. - the [exp_map] param gives a mapping of names used in the procedure of [instr1] to identifiers - used in the procedure of [instr2] *) -let instr_compare_structural instr1 instr2 exp_map = - let id_list_compare_structural ids1 ids2 exp_map = - let n = Pervasives.compare (IList.length ids1) (IList.length ids2) in - if n <> 0 then n, exp_map - else - IList.fold_left2 - (fun (n, exp_map) id1 id2 -> - if n <> 0 then (n, exp_map) - else exp_compare_structural (Var id1) (Var id2) exp_map) - (0, exp_map) - ids1 - ids2 in - match instr1, instr2 with - | Letderef (id1, e1, t1, _), Letderef (id2, e2, t2, _) -> - let n, exp_map = exp_compare_structural (Var id1) (Var id2) exp_map in - if n <> 0 then n, exp_map - else - let n, exp_map = exp_compare_structural e1 e2 exp_map in - (if n <> 0 then n else typ_compare t1 t2), exp_map - | Set (e11, t1, e21, _), Set (e12, t2, e22, _) -> - let n, exp_map = exp_compare_structural e11 e12 exp_map in - if n <> 0 then n, exp_map - else - let n = typ_compare t1 t2 in - if n <> 0 then n, exp_map - else exp_compare_structural e21 e22 exp_map - | Prune (cond1, _, true_branch1, ik1), Prune (cond2, _, true_branch2, ik2) -> - let n, exp_map = exp_compare_structural cond1 cond2 exp_map in - (if n <> 0 then n - else let n = bool_compare true_branch1 true_branch2 in - if n <> 0 then n - else Pervasives.compare ik1 ik2), exp_map - | Call (ret_ids1, e1, arg_ts1, _, cf1), Call (ret_ids2, e2, arg_ts2, _, cf2) -> - let args_compare_structural args1 args2 exp_map = - let n = Pervasives.compare (IList.length args1) (IList.length args2) in - if n <> 0 then n, exp_map - else - IList.fold_left2 - (fun (n, exp_map) arg1 arg2 -> - if n <> 0 then (n, exp_map) - else exp_typ_compare_structural arg1 arg2 exp_map) - (0, exp_map) - args1 - args2 in - let n, exp_map = id_list_compare_structural ret_ids1 ret_ids2 exp_map in - if n <> 0 then n, exp_map - else let n, exp_map = exp_compare_structural e1 e2 exp_map in - if n <> 0 then n, exp_map - else - let n, exp_map = args_compare_structural arg_ts1 arg_ts2 exp_map in - (if n <> 0 then n else call_flags_compare cf1 cf2), exp_map - | Nullify (pvar1, _), Nullify (pvar2, _) -> - exp_compare_structural (Lvar pvar1) (Lvar pvar2) exp_map - | Abstract _, Abstract _ -> 0, exp_map - | Remove_temps (temps1, _), Remove_temps (temps2, _) -> - id_list_compare_structural temps1 temps2 exp_map - | Stackop (stackop1, _), Stackop (stackop2, _) -> - Pervasives.compare stackop1 stackop2, exp_map - | Declare_locals (ptl1, _), Declare_locals (ptl2, _) -> - let n = Pervasives.compare (IList.length ptl1) (IList.length ptl2) in - if n <> 0 then n, exp_map - else - IList.fold_left2 - (fun (n, exp_map) (pv1, t1) (pv2, t2) -> - if n <> 0 then (n, exp_map) - else - let n, exp_map = exp_compare_structural (Lvar pv1) (Lvar pv2) exp_map in - if n <> 0 then n, exp_map else typ_compare t1 t2, exp_map) - (0, exp_map) - ptl1 - ptl2 - | _ -> instr_compare instr1 instr2, exp_map - -let atom_sub subst = - atom_expmap (exp_sub subst) - -let hpred_sub subst = - let f (e, inst_opt) = (exp_sub subst e, inst_opt) in - hpred_expmap f - -(** {2 Functions for replacing occurrences of expressions.} *) - -let exp_replace_exp epairs e = - try - let (_, e') = IList.find (fun (e1, _) -> exp_equal e e1) epairs in - e' - with Not_found -> e - -let atom_replace_exp epairs = function - | Aeq (e1, e2) -> - let e1' = exp_replace_exp epairs e1 in - let e2' = exp_replace_exp epairs e2 in - Aeq (e1', e2') - | Aneq (e1, e2) -> - let e1' = exp_replace_exp epairs e1 in - let e2' = exp_replace_exp epairs e2 in - Aneq (e1', e2') - -let rec strexp_replace_exp epairs = function - | Eexp (e, inst) -> - Eexp (exp_replace_exp epairs e, inst) - | Estruct (fsel, inst) -> - let f (fld, se) = (fld, strexp_replace_exp epairs se) in - Estruct (IList.map f fsel, inst) - | Earray (size, isel, inst) -> - let size' = exp_replace_exp epairs size in - let f (idx, se) = - let idx' = exp_replace_exp epairs idx in - (idx', strexp_replace_exp epairs se) in - Earray (size', IList.map f isel, inst) - -let hpred_replace_exp epairs = function - | Hpointsto (root, se, te) -> - let root_repl = exp_replace_exp epairs root in - let strexp_repl = strexp_replace_exp epairs se in - let te_repl = exp_replace_exp epairs te in - Hpointsto (root_repl, strexp_repl, te_repl) - | Hlseg (k, para, root, next, shared) -> - let root_repl = exp_replace_exp epairs root in - let next_repl = exp_replace_exp epairs next in - let shared_repl = IList.map (exp_replace_exp epairs) shared in - Hlseg (k, para, root_repl, next_repl, shared_repl) - | Hdllseg (k, para, e1, e2, e3, e4, shared) -> - let e1' = exp_replace_exp epairs e1 in - let e2' = exp_replace_exp epairs e2 in - let e3' = exp_replace_exp epairs e3 in - let e4' = exp_replace_exp epairs e4 in - let shared_repl = IList.map (exp_replace_exp epairs) shared in - Hdllseg (k, para, e1', e2', e3', e4', shared_repl) - -(** {2 Compaction} *) -module ExpHash = Hashtbl.Make (struct - type t = exp - let equal = exp_equal - let hash = Hashtbl.hash end) - -module HpredHash = Hashtbl.Make (struct - type t = hpred - let equal = hpred_equal - let hash = Hashtbl.hash end) - -type sharing_env = - { exph : exp ExpHash.t; - hpredh : hpred HpredHash.t } - -(** Create a sharing env to store canonical representations *) -let create_sharing_env () = - { exph = ExpHash.create 3; - hpredh = HpredHash.create 3 } - -(** Return a canonical representation of the exp *) -let exp_compact sh e = - try ExpHash.find sh.exph e with - | Not_found -> - ExpHash.add sh.exph e e; - e - -let rec sexp_compact sh se = - match se with - | Eexp (e, inst) -> - Eexp (exp_compact sh e, inst) - | Estruct (fsel, inst) -> - Estruct (IList.map (fun (f, se) -> (f, sexp_compact sh se)) fsel, inst) - | Earray _ -> - se - -(** Return a compact representation of the hpred *) -let _hpred_compact sh hpred = match hpred with - | Hpointsto (e1, se, e2) -> - let e1' = exp_compact sh e1 in - let e2' = exp_compact sh e2 in - let se' = sexp_compact sh se in - Hpointsto (e1', se', e2') - | Hlseg _ -> hpred - | Hdllseg _ -> hpred - -let hpred_compact sh hpred = - try HpredHash.find sh.hpredh hpred with - | Not_found -> - let hpred' = _hpred_compact sh hpred in - HpredHash.add sh.hpredh hpred' hpred'; - hpred' - -(** {2 Functions for constructing or destructing entities in this module} *) - -(** Extract the ids and pvars from an expression *) -let exp_get_vars exp = - let rec exp_get_vars_ exp vars = match exp with - | Lvar pvar -> - (fst vars, pvar :: (snd vars)) - | Var id -> - (id :: (fst vars), snd vars) - | Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) | Const (Cexn e) -> - exp_get_vars_ e vars - | BinOp (_, e1, e2) | Lindex (e1, e2) -> - exp_get_vars_ e1 vars - |> exp_get_vars_ e2 - | Const (Cclosure { captured_vars }) -> - IList.fold_left - (fun vars_acc (captured_exp, _, _) -> exp_get_vars_ captured_exp vars_acc) - vars - captured_vars - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cattribute _ | Cclass _ | Cptr_to_fld _) - | Sizeof _ -> - vars in - exp_get_vars_ exp ([], []) - -(** Compute the offset list of an expression *) -let exp_get_offsets exp = - let rec f offlist_past e = match e with - | Var _ | Const _ | UnOp _ | BinOp _ | Lvar _ | Sizeof _ -> offlist_past - | Cast(_, sub_exp) -> f offlist_past sub_exp - | Lfield(sub_exp, fldname, typ) -> f (Off_fld (fldname, typ):: offlist_past) sub_exp - | Lindex(sub_exp, e) -> f (Off_index e :: offlist_past) sub_exp in - f [] exp - -let exp_add_offsets exp offsets = - let rec f acc = function - | [] -> acc - | Off_fld (fld, typ) :: offs' -> f (Lfield(acc, fld, typ)) offs' - | Off_index e :: offs' -> f (Lindex(acc, e)) offs' in - f exp offsets - -(** Convert all the lseg's in sigma to nonempty lsegs. *) -let sigma_to_sigma_ne sigma : (atom list * hpred list) list = - if Config.nelseg then - let f eqs_sigma_list hpred = match hpred with - | Hpointsto _ | Hlseg(Lseg_NE, _, _, _, _) | Hdllseg(Lseg_NE, _, _, _, _, _, _) -> - let g (eqs, sigma) = (eqs, hpred:: sigma) in - IList.map g eqs_sigma_list - | Hlseg(Lseg_PE, para, e1, e2, el) -> - let g (eqs, sigma) = - [(Aeq(e1, e2):: eqs, sigma); - (eqs, Hlseg(Lseg_NE, para, e1, e2, el):: sigma)] in - IList.flatten (IList.map g eqs_sigma_list) - | Hdllseg(Lseg_PE, para_dll, e1, e2, e3, e4, el) -> - let g (eqs, sigma) = - [(Aeq(e1, e3):: Aeq(e2, e4):: eqs, sigma); - (eqs, Hdllseg(Lseg_NE, para_dll, e1, e2, e3, e4, el):: sigma)] in - IList.flatten (IList.map g eqs_sigma_list) in - IList.fold_left f [([],[])] sigma - else - [([], sigma)] - -(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], - [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], - then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] - for some fresh [_zs'].*) -let hpara_instantiate para e1 e2 elist = - let subst_for_svars = - let g id e = (id, e) in - try (IList.map2 g para.svars elist) - with Invalid_argument _ -> assert false in - let ids_evars = - let g _ = Ident.create_fresh Ident.kprimed in - IList.map g para.evars in - let subst_for_evars = - let g id id' = (id, Var id') in - try (IList.map2 g para.evars ids_evars) - with Invalid_argument _ -> assert false in - let subst = sub_of_list ((para.root, e1):: (para.next, e2):: subst_for_svars@subst_for_evars) in - (ids_evars, IList.map (hpred_sub subst) para.body) - -(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], - [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], - then the result of the instantiation is - [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] - for some fresh [_zs'].*) -let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = - let subst_for_svars = - let g id e = (id, e) in - try (IList.map2 g para.svars_dll elist) - with Invalid_argument _ -> assert false in - let ids_evars = - let g _ = Ident.create_fresh Ident.kprimed in - IList.map g para.evars_dll in - let subst_for_evars = - let g id id' = (id, Var id') in - try (IList.map2 g para.evars_dll ids_evars) - with Invalid_argument _ -> assert false in - let subst = - sub_of_list - ((para.cell, cell) :: - (para.blink, blink) :: - (para.flink, flink) :: - subst_for_svars@subst_for_evars) in - (ids_evars, IList.map (hpred_sub subst) para.body_dll) - -let custom_error = - Pvar.mk_global (Mangled.from_string "INFER_CUSTOM_ERROR") diff --git a/infer/src/IR/sil.mli b/infer/src/IR/sil.mli deleted file mode 100644 index 1f38e4c37..000000000 --- a/infer/src/IR/sil.mli +++ /dev/null @@ -1,1294 +0,0 @@ -(* - * 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 - -(** The Smallfoot Intermediate Language *) - -module F = Format - -(** {2 Programs and Types} *) - -(** Type to represent one @Annotation. *) -type annotation = - { class_name: string; (* name of the annotation *) - parameters: string list; (* currently only one string parameter *) } - -(** Annotation for one item: a list of annotations with visibility. *) -type item_annotation = (annotation * bool) list - -(** Annotation for a method: return value and list of parameters. *) -type method_annotation = - item_annotation * item_annotation list - -type func_attribute = - | FA_sentinel of int * int - -(** Visibility modifiers. *) -type access = Default | Public | Private | Protected - -(** Unary operations *) -type unop = - | Neg (** Unary minus *) - | BNot (** Bitwise complement (~) *) - | LNot (** Logical Not (!) *) - -(** Binary operations *) -type binop = - | PlusA (** arithmetic + *) - | PlusPI (** pointer + integer *) - | MinusA (** arithmetic - *) - | MinusPI (** pointer - integer *) - | MinusPP (** pointer - pointer *) - | Mult (** * *) - | Div (** / *) - | Mod (** % *) - | Shiftlt (** shift left *) - | Shiftrt (** shift right *) - - | Lt (** < (arithmetic comparison) *) - | Gt (** > (arithmetic comparison) *) - | Le (** <= (arithmetic comparison) *) - | Ge (** >= (arithmetic comparison) *) - | Eq (** == (arithmetic comparison) *) - | Ne (** != (arithmetic comparison) *) - | BAnd (** bitwise and *) - | BXor (** exclusive-or *) - | BOr (** inclusive-or *) - - | LAnd (** logical and. Does not always evaluate both operands. *) - | LOr (** logical or. Does not always evaluate both operands. *) - | PtrFld (** field offset via pointer to field: takes the address of a - Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) *) - -(** Kinds of integers *) -type ikind = - IChar (** [char] *) - | ISChar (** [signed char] *) - | IUChar (** [unsigned char] *) - | IBool (** [bool] *) - | IInt (** [int] *) - | IUInt (** [unsigned int] *) - | IShort (** [short] *) - | IUShort (** [unsigned short] *) - | ILong (** [long] *) - | IULong (** [unsigned long] *) - | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) - | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) *) - | I128 (** [__int128_t] *) - | IU128 (** [__uint128_t] *) - -(** Kinds of floating-point numbers*) -type fkind = - | FFloat (** [float] *) - | FDouble (** [double] *) - | FLongDouble (** [long double] *) - -type mem_kind = - | Mmalloc (** memory allocated with malloc *) - | Mnew (** memory allocated with new *) - | Mnew_array (** memory allocated with new[] *) - | Mobjc (** memory allocated with objective-c alloc *) - -(** resource that can be allocated *) -type resource = - | Rmemory of mem_kind - | Rfile - | Rignore - | Rlock - -(** kind of resource action *) -type res_act_kind = - | Racquire - | Rrelease - -(** kind of dangling pointers *) -type dangling_kind = - (** pointer is dangling because it is uninitialized *) - | DAuninit - - (** pointer is dangling because it is the address of a stack variable which went out of scope *) - | DAaddr_stack_var - - (** pointer is -1 *) - | DAminusone - -(** kind of pointer *) -type ptr_kind = - | Pk_pointer (* C/C++, Java, Objc standard/__strong pointer*) - | Pk_reference (* C++ reference *) - | Pk_objc_weak (* Obj-C __weak pointer*) - | Pk_objc_unsafe_unretained (* Obj-C __unsafe_unretained pointer *) - | Pk_objc_autoreleasing (* Obj-C __autoreleasing pointer *) - -(** position in a path: proc name, node id *) -type path_pos = Procname.t * int - -(** module for subtypes, to be used with Sizeof info *) -module Subtype : sig - type t - val exact : t (** denotes the current type only *) - val subtypes : t (** denotes the current type and any subtypes *) - val subtypes_cast : t - val subtypes_instof : t - val join : t -> t -> t - (** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according - to [st1] and [st2] where f c1 c2 is true if c1 is a subtype of c2. - get_subtypes returning a pair: - - whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1] - - whether [st1] and [st2] admit [not(c1 <: c2)], and in case return - the updated subtype [st1] *) - val case_analysis : (Typename.t * t) -> (Typename.t * t) -> - (Typename.t -> Typename.t -> bool) -> (Typename.t -> bool) -> t option * t option - val check_subtype : (Typename.t -> Typename.t -> bool) -> Typename.t -> Typename.t -> bool - val subtypes_to_string : t -> string - val is_cast : t -> bool - val is_instof : t -> bool - (** equality ignoring flags in the subtype *) - val equal_modulo_flag : t -> t -> bool -end - -(** module for signed and unsigned integers *) -module Int : sig - type t - val add : t -> t -> t - - (** compare the value of the integers, notice this is different from const compare, - which distinguished between signed and unsigned +1 *) - val compare_value : t -> t -> int - val div : t -> t -> t - val eq : t -> t -> bool - val of_int : int -> t - val of_int32 : int32 -> t - val of_int64 : int64 -> t - val geq : t -> t -> bool - val gt : t -> t -> bool - val isminusone : t -> bool - val isnegative : t -> bool - val isnull : t -> bool - val isone : t -> bool - val iszero : t -> bool - val leq : t -> t -> bool - val logand : t -> t -> t - val lognot : t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - val lt : t -> t -> bool - val minus_one : t - val mul : t -> t -> t - val neg : t -> t - val neq : t -> t -> bool - val null : t (** null behaves like zero except for the function isnull *) - val one : t - val pp : F.formatter -> t -> unit - val rem : t -> t -> t - val sub : t -> t -> t - val to_int : t -> int - val to_signed : t -> t option (** convert to signed if the value is representable *) - val to_string : t -> string - val two : t - val zero : t -end - -(** Flags for a procedure call *) -type call_flags = { - cf_virtual : bool; - cf_interface : bool; - cf_noreturn : bool; - cf_is_objc_block : bool; - cf_targets : Procname.t list; -} - -(** Default value for call_flags where all fields are set to false *) -val cf_default : call_flags - -(** expression representing the result of decompilation *) -type dexp = - | Darray of dexp * dexp - | Dbinop of binop * dexp * dexp - | Dconst of const - | Dsizeof of typ * Subtype.t - | Dderef of dexp - | Dfcall of dexp * dexp list * Location.t * call_flags - | Darrow of dexp * Ident.fieldname - | Ddot of dexp * Ident.fieldname - | Dpvar of Pvar.t - | Dpvaraddr of Pvar.t - | Dunop of unop * dexp - | Dunknown - | Dretcall of dexp * dexp list * Location.t * call_flags - -(** Value paths: identify an occurrence of a value in a symbolic heap - each expression represents a path, with Dpvar being the simplest one *) -and vpath = - dexp option - -(** acquire/release action on a resource *) -and res_action = - { ra_kind : res_act_kind; (** kind of action *) - ra_res : resource; (** kind of resource *) - ra_pname : Procname.t; (** name of the procedure used to acquire/release the resource *) - ra_loc : Location.t; (** location of the acquire/release *) - ra_vpath: vpath; (** vpath of the resource value *) - } - -and taint_kind = - | Tk_unverified_SSL_socket - | Tk_shared_preferences_data - | Tk_privacy_annotation - | Tk_integrity_annotation - | Tk_unknown - -and taint_info = { - taint_source : Procname.t; - taint_kind : taint_kind; -} - -(** Attributes *) -and attribute = - | Aresource of res_action (** resource acquire/release *) - | Aautorelease - | Adangling of dangling_kind (** dangling pointer *) - (** undefined value obtained by calling the given procedure *) - | Aundef of Procname.t * item_annotation * Location.t * path_pos - | Ataint of taint_info - | Auntaint - | Alocked - | Aunlocked - (** value appeared in second argument of division at given path position *) - | Adiv0 of path_pos - (** the exp. is null because of a call to a method with exp as a null receiver *) - | Aobjc_null of exp - (** value was returned from a call to the given procedure *) - | Aretval of Procname.t * item_annotation - (** denotes an object registered as an observers to a notification center *) - | Aobserver - (** denotes an object unsubscribed from observers of a notification center *) - | Aunsubscribed_observer - -(** Categories of attributes *) -and attribute_category = - | ACresource - | ACautorelease - | ACtaint - | AClock - | ACdiv0 - | ACobjc_null - | ACundef - | ACretval - | ACobserver - - -and closure = { - name : Procname.t; - captured_vars : (exp * Pvar.t * typ) list; -} - -(** Constants *) -and const = - | Cint of Int.t (** integer constants *) - | Cfun of Procname.t (** function names *) - | Cstr of string (** string constants *) - | Cfloat of float (** float constants *) - | Cattribute of attribute (** attribute used in disequalities to annotate a value *) - | Cexn of exp (** exception *) - | Cclass of Ident.name (** class constant *) - | Cptr_to_fld of Ident.fieldname * typ (** pointer to field constant, - and type of the surrounding Csu.t type *) - | Cclosure of closure (** anonymous function *) - -and struct_fields = (Ident.fieldname * typ * item_annotation) list - -(** Type for a structured value. *) -and struct_typ = { - instance_fields : struct_fields; (** non-static fields *) - static_fields : struct_fields; (** static fields *) - csu : Csu.t; (** class/struct/union *) - struct_name : Mangled.t option; (** name *) - superclasses : Typename.t list; (** list of superclasses *) - def_methods : Procname.t list; (** methods defined *) - struct_annotations : item_annotation; (** annotations *) -} - -(** Types for sil (structured) expressions. *) -and typ = - | Tvar of Typename.t (** named type *) - | Tint of ikind (** integer type *) - | Tfloat of fkind (** float type *) - | Tvoid (** void type *) - | Tfun of bool (** function type with noreturn attribute *) - | Tptr of typ * ptr_kind (** pointer type *) - | Tstruct of struct_typ (** Type for a structured value *) - | Tarray of typ * exp (** array type with fixed size *) - -(** Program expressions. *) -and exp = - (** Pure variable: it is not an lvalue *) - | Var of Ident.t - - (** Unary operator with type of the result if known *) - | UnOp of unop * exp * typ option - - (** Binary operator *) - | BinOp of binop * exp * exp - - (** Constants *) - | Const of const - - (** Type cast *) - | Cast of typ * exp - - (** The address of a program variable *) - | Lvar of Pvar.t - - (** A field offset, the type is the surrounding struct type *) - | Lfield of exp * Ident.fieldname * typ - - (** An array index offset: [exp1\[exp2\]] *) - | Lindex of exp * exp - - (** A sizeof expression *) - | Sizeof of typ * Subtype.t - -val struct_typ_equal : struct_typ -> struct_typ -> bool - -(** Sets of types. *) -module StructTypSet : Set.S with type elt = struct_typ - -module TypSet : Set.S with type elt = typ - -(** Maps with type keys. *) -module TypMap : Map.S with type key = typ - -(** Sets of expressions. *) -module ExpSet : Set.S with type elt = exp - -(** Maps with expression keys. *) -module ExpMap : Map.S with type key = exp - -(** Hashtable with expressions as keys. *) -module ExpHash : Hashtbl.S with type key = exp - -(** Convert expression lists to expression sets. *) -val elist_to_eset : exp list -> ExpSet.t - -(** Kind of prune instruction *) -type if_kind = - | Ik_bexp (* boolean expressions, and exp ? exp : exp *) - | Ik_dowhile - | Ik_for - | Ik_if - | Ik_land_lor (* obtained from translation of && or || *) - | Ik_while - | Ik_switch - -(** Stack operation for symbolic execution on propsets *) -type stackop = - | Push (* copy the curreny propset to the stack *) - | Swap (* swap the current propset and the top of the stack *) - | Pop (* pop the stack and combine with the current propset *) - -(** An instruction. *) -type instr = - (** declaration [let x = *lexp:typ] where [typ] is the root type of [lexp] *) - | Letderef of Ident.t * exp * typ * Location.t - (** assignment [*lexp1:typ = exp2] where [typ] is the root type of [lexp1] *) - | Set of exp * typ * exp * Location.t - (** prune the state based on [exp=1], the boolean indicates whether true branch *) - | Prune of exp * Location.t * bool * if_kind - (** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions - [ret_id1..ret_idn = e_fun(arg_ts);] - where n = 0 for void return and n > 1 for struct return *) - | Call of Ident.t list * exp * (exp * typ) list * Location.t * call_flags - (** nullify stack variable *) - | Nullify of Pvar.t * Location.t - | Abstract of Location.t (** apply abstraction *) - | Remove_temps of Ident.t list * Location.t (** remove temporaries *) - | Stackop of stackop * Location.t (** operation on the stack of propsets *) - | Declare_locals of (Pvar.t * typ) list * Location.t (** declare local variables *) - -(** Check if an instruction is auxiliary, or if it comes from source instructions. *) -val instr_is_auxiliary : instr -> bool - -(** Offset for an lvalue. *) -type offset = Off_fld of Ident.fieldname * typ | Off_index of exp - -(** {2 Components of Propositions} *) - -(** an atom is a pure atomic formula *) -type atom = - | Aeq of exp * exp (** equality *) - | Aneq of exp * exp (** disequality*) - -(** kind of lseg or dllseg predicates *) -type lseg_kind = - | Lseg_NE (** nonempty (possibly circular) listseg *) - | Lseg_PE (** possibly empty (possibly circular) listseg *) - -(** The boolean is true when the pointer was dereferenced without testing for zero. *) -type zero_flag = bool option - -(** True when the value was obtained by doing case analysis on null in a procedure call. *) -type null_case_flag = bool - -(** instrumentation of heap values *) -type inst = - | Iabstraction - | Iactual_precondition - | Ialloc - | Iformal of zero_flag * null_case_flag - | Iinitial - | Ilookup - | Inone - | Inullify - | Irearrange of zero_flag * null_case_flag * int * path_pos - | Itaint - | Iupdate of zero_flag * null_case_flag * int * path_pos - | Ireturn_from_call of int - | Ireturn_from_pointer_wrapper_call of int - -val inst_abstraction : inst -val inst_actual_precondition : inst -val inst_alloc : inst -val inst_formal : inst (** for formal parameters and heap values at the beginning of the function *) -val inst_initial : inst (** for initial values *) -val inst_lookup : inst -val inst_none : inst -val inst_nullify : inst -(** the boolean indicates whether the pointer is known nonzero *) -val inst_rearrange : bool -> Location.t -> path_pos -> inst -val inst_taint : inst -val inst_update : Location.t -> path_pos -> inst - -(** Get the null case flag of the inst. *) -val inst_get_null_case_flag : inst -> bool option - -(** Set the null case flag of the inst. *) -val inst_set_null_case_flag : inst -> inst - -(** update the location of the instrumentation *) -val inst_new_loc : Location.t -> inst -> inst - -(** Update [inst_old] to [inst_new] preserving the zero flag *) -val update_inst : inst -> inst -> inst - -(** join of instrumentations *) -val inst_partial_join : inst -> inst -> inst - -(** meet of instrumentations *) -val inst_partial_meet : inst -> inst -> inst - -(** structured expressions represent a value of structured type, such as an array or a struct. *) -type strexp = - | Eexp of exp * inst (** Base case: expression with instrumentation *) - | Estruct of (Ident.fieldname * strexp) list * inst (** C structure *) - | Earray of exp * (exp * strexp) list * inst (** Array of given size. *) -(** There are two conditions imposed / used in the array case. - First, if some index and value pair appears inside an array - in a strexp, then the index is less than the size of the array. - For instance, x |->[10 | e1: v1] implies that e1 <= 9. - Second, if two indices appear in an array, they should be different. - For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) - -(** an atomic heap predicate *) -and hpred = - | Hpointsto of exp * strexp * exp - (** represents [exp|->strexp:typexp] where [typexp] - is an expression representing a type, e.h. [sizeof(t)]. *) - | Hlseg of lseg_kind * hpara * exp * exp * exp list - (** higher - order predicate for singly - linked lists. - Should ensure that exp1!= exp2 implies that exp1 is allocated. - This assumption is used in the rearrangement. The last [exp list] parameter - is used to denote the shared links by all the nodes in the list.*) - | Hdllseg of lseg_kind * hpara_dll * exp * exp * exp * exp * exp list - (** higher-order predicate for doubly-linked lists. *) - -(** parameter for the higher-order singly-linked list predicate. - Means "lambda (root,next,svars). Exists evars. body". - Assume that root, next, svars, evars are disjoint sets of - primed identifiers, and include all the free primed identifiers in body. - body should not contain any non - primed identifiers or program - variables (i.e. pvars). *) -and hpara = - { root: Ident.t; - next: Ident.t; - svars: Ident.t list; - evars: Ident.t list; - body: hpred list } - -(** parameter for the higher-order doubly-linked list predicates. - Assume that all the free identifiers in body_dll should belong to - cell, blink, flink, svars_dll, evars_dll. *) -and hpara_dll = - { cell: Ident.t; (** address cell *) - blink: Ident.t; (** backward link *) - flink: Ident.t; (** forward link *) - svars_dll: Ident.t list; - evars_dll: Ident.t list; - body_dll: hpred list } - -(** Sets of heap predicates *) -module HpredSet : Set.S with type elt = hpred - -(** {2 Compaction} *) - -type sharing_env - -(** Create a sharing env to store canonical representations *) -val create_sharing_env : unit -> sharing_env - -(** Return a canonical representation of the exp *) -val exp_compact : sharing_env -> exp -> exp - -(** Return a compact representation of the exp *) -val hpred_compact : sharing_env -> hpred -> hpred - - -(** {2 Comparision And Inspection Functions} *) - -val is_objc_ref_counter_field : (Ident.fieldname * typ * item_annotation) -> bool - -val has_objc_ref_counter : hpred -> bool - -val objc_class_annotation : (annotation * bool) list - -val cpp_class_annotation : (annotation * bool) list - -val is_objc_class : typ -> bool - -val is_cpp_class : typ -> bool - -val is_java_class : typ -> bool - -val is_array_of_cpp_class : typ -> bool - -val is_pointer_to_cpp_class : typ -> bool - -val exp_is_zero : exp -> bool - -val exp_is_null_literal : exp -> bool - -(** return true if [exp] is the special this/self expression *) -val exp_is_this : exp -> bool - -val path_pos_equal : path_pos -> path_pos -> bool - -(** turn a *T into a T. fails if [typ] is not a pointer type *) -val typ_strip_ptr : typ -> typ - -val zero_value_of_numerical_type : typ -> exp - -(** Make a static local name in objc *) -val mk_static_local_name : string -> string -> string - -(** Check if a pvar is a local static in objc *) -val is_static_local_name : string -> Pvar.t -> bool - -(* A block pvar used to explain retain cycles *) -val block_pvar : Pvar.t - -(** Check if a pvar is a local pointing to a block in objc *) -val is_block_pvar : Pvar.t -> bool - -(** Check if type is a type for a block in objc *) -val is_block_type : typ -> bool - -(** Comparision for fieldnames. *) -val fld_compare : Ident.fieldname -> Ident.fieldname -> int - -(** Equality for fieldnames. *) -val fld_equal : Ident.fieldname -> Ident.fieldname -> bool - -(** Check wheter the integer kind is a char *) -val ikind_is_char : ikind -> bool - -(** Check wheter the integer kind is unsigned *) -val ikind_is_unsigned : ikind -> bool - -(** Convert an int64 into an Int.t given the kind: - the int64 is interpreted as unsigned according to the kind *) -val int_of_int64_kind : int64 -> ikind -> Int.t - -(** Comparision for ptr_kind *) -val ptr_kind_compare : ptr_kind -> ptr_kind -> int - -(** Comparision for types. *) -val typ_compare : typ -> typ -> int - -(** Equality for types. *) -val typ_equal : typ -> typ -> bool - -(** Comparision for fieldnames * types * item annotations. *) -val fld_typ_ann_compare : - Ident.fieldname * typ * item_annotation -> Ident.fieldname * typ * item_annotation -> int - -val unop_equal : unop -> unop -> bool - -val binop_equal : binop -> binop -> bool - -(** This function returns true if the operation is injective - wrt. each argument: op(e,-) and op(-, e) is injective for all e. - The return value false means "don't know". *) -val binop_injective : binop -> bool - -(** This function returns true if the operation can be inverted. *) -val binop_invertible : binop -> bool - -(** This function inverts an injective binary operator - with respect to the first argument. It returns an expression [e'] such that - BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible, - the function raises an exception by calling "assert false". *) -val binop_invert : binop -> exp -> exp -> exp - -(** This function returns true if 0 is the right unit of [binop]. - The return value false means "don't know". *) -val binop_is_zero_runit : binop -> bool - -val mem_kind_compare : mem_kind -> mem_kind -> int - -val attribute_compare : attribute -> attribute -> int - -val attribute_equal : attribute -> attribute -> bool - -val attribute_category_compare : attribute_category -> attribute_category -> int - -val attribute_category_equal : attribute_category -> attribute_category -> bool - -(** Return the category to which the attribute belongs. *) -val attribute_to_category : attribute -> attribute_category - -val attr_is_undef : attribute -> bool - -val const_compare : const -> const -> int - -val const_equal : const -> const -> bool - -(** Return true if the constants have the same kind (both integers, ...) *) -val const_kind_equal : const -> const -> bool - -val exp_compare : exp -> exp -> int - -val exp_equal : exp -> exp -> bool - -(** exp_is_array_index_of index arr returns true is index is an array index of arr. *) -val exp_is_array_index_of : exp -> exp -> bool - -val call_flags_compare : call_flags -> call_flags -> int - -val exp_typ_compare : (exp * typ) -> (exp * typ) -> int - -val instr_compare : instr -> instr -> int - -(** compare instructions from different procedures without considering loc's, ident's, and pvar's. - the [exp_map] param gives a mapping of names used in the procedure of [instr1] to identifiers - used in the procedure of [instr2] *) -val instr_compare_structural : instr -> instr -> exp ExpMap.t -> (int * exp ExpMap.t) - -val exp_list_compare : exp list -> exp list -> int - -val exp_list_equal : exp list -> exp list -> bool - -val atom_compare : atom -> atom -> int - -val atom_equal : atom -> atom -> bool - -val strexp_compare : strexp -> strexp -> int - -val strexp_equal : strexp -> strexp -> bool - -val hpara_compare : hpara -> hpara -> int - -val hpara_equal : hpara -> hpara -> bool - -val hpara_dll_compare : hpara_dll -> hpara_dll -> int - -val hpara_dll_equal : hpara_dll -> hpara_dll -> bool - -val lseg_kind_compare : lseg_kind -> lseg_kind -> int - -val lseg_kind_equal : lseg_kind -> lseg_kind -> bool - -val hpred_compare : hpred -> hpred -> int - -val hpred_equal : hpred -> hpred -> bool - -val fld_strexp_compare : Ident.fieldname * strexp -> Ident.fieldname * strexp -> int - -val fld_strexp_list_compare : - (Ident.fieldname * strexp) list -> (Ident.fieldname * strexp) list -> int - -val exp_strexp_compare : exp * strexp -> exp * strexp -> int - -(** Return the lhs expression of a hpred *) -val hpred_get_lhs : hpred -> exp - -(** Field used for objective-c reference counting *) -val objc_ref_counter_field : (Ident.fieldname * typ * item_annotation) - - -(** Compare function for annotations. *) -val annotation_compare : annotation -> annotation -> int - -(** Compare function for annotation items. *) -val item_annotation_compare : item_annotation -> item_annotation -> int - -(** Compare function for Method annotations. *) -val method_annotation_compare : method_annotation -> method_annotation -> int - -(** Empty item annotation. *) -val item_annotation_empty : item_annotation - -(** Empty method annotation. *) -val method_annotation_empty : method_annotation - -(** Check if the item annodation is empty. *) -val item_annotation_is_empty : item_annotation -> bool - -(** Check if the method annodation is empty. *) -val method_annotation_is_empty : method_annotation -> bool - -(** Return the value of the FA_sentinel attribute in [attr_list] if it is found *) -val get_sentinel_func_attribute_value : func_attribute list -> (int * int) option - -(** {2 Pretty Printing} *) - -(** Begin change color if using diff printing, return updated printenv and change status *) -val color_pre_wrapper : printenv -> F.formatter -> 'a -> printenv * bool - -(** Close color annotation if changed *) -val color_post_wrapper : bool -> printenv -> F.formatter -> unit - -(** String representation of a unary operator. *) -val str_unop : unop -> string - -(** String representation of a binary operator. *) -val str_binop : printenv -> binop -> string - -(** name of the allocation function for the given memory kind *) -val mem_alloc_pname : mem_kind -> Procname.t - -(** name of the deallocation function for the given memory kind *) -val mem_dealloc_pname : mem_kind -> Procname.t - -(** Pretty print an annotation. *) -val pp_annotation : F.formatter -> annotation -> unit - -(** Pretty print a const. *) -val pp_const: printenv -> F.formatter -> const -> unit - -(** Pretty print an item annotation. *) -val pp_item_annotation : F.formatter -> item_annotation -> unit - -val item_annotation_to_string : item_annotation -> string - -(** Pretty print a method annotation. *) -val pp_method_annotation : string -> F.formatter -> method_annotation -> unit - -(** Pretty print a type. *) -val pp_typ : printenv -> F.formatter -> typ -> unit - -val pp_struct_typ : printenv -> (F.formatter -> unit -> unit) -> F.formatter -> struct_typ -> unit - -(** Pretty print a type with all the details. *) -val pp_typ_full : printenv -> F.formatter -> typ -> unit - -val typ_to_string : typ -> string - -(** [pp_type_decl pe pp_base pp_size f typ] pretty prints a type declaration. - pp_base prints the variable for a declaration, or can be skip to print only the type - pp_size prints the expression for the array size *) -val pp_type_decl: printenv -> (F.formatter -> unit -> unit) -> - (printenv -> F.formatter -> exp -> unit) -> - F.formatter -> typ -> unit - -(** Dump a type with all the details. *) -val d_typ_full : typ -> unit - -(** Dump a list of types. *) -val d_typ_list : typ list -> unit - -(** convert the attribute to a string *) -val attribute_to_string : printenv -> attribute -> string - -(** convert a dexp to a string *) -val dexp_to_string : dexp -> string - -(** Pretty print a dexp. *) -val pp_dexp : F.formatter -> dexp -> unit - -(** Pretty print an expression. *) -val pp_exp : printenv -> F.formatter -> exp -> unit - -(** Pretty print an expression with type. *) -val pp_exp_typ : printenv -> F.formatter -> exp * typ -> unit - -(** Convert an expression to a string *) -val exp_to_string : exp -> string - -(** dump an expression. *) -val d_exp : exp -> unit - -(** Pretty print a type. *) -val pp_texp : printenv -> F.formatter -> exp -> unit - -(** Pretty print a type with all the details. *) -val pp_texp_full : printenv -> F.formatter -> exp -> unit - -(** Dump a type expression with all the details. *) -val d_texp_full : exp -> unit - -(** Pretty print a list of expressions. *) -val pp_exp_list : printenv -> F.formatter -> exp list -> unit - -(** Dump a list of expressions. *) -val d_exp_list : exp list -> unit - -(** Pretty print an offset *) -val pp_offset : printenv -> F.formatter -> offset -> unit - -(** Dump an offset *) -val d_offset : offset -> unit - -(** Pretty print a list of offsets *) -val pp_offset_list : printenv -> F.formatter -> offset list -> unit - -(** Dump a list of offsets *) -val d_offset_list : offset list -> unit - -(** Get the location of the instruction *) -val instr_get_loc : instr -> Location.t - -(** get the expressions occurring in the instruction *) -val instr_get_exps : instr -> exp list - -(** Pretty print an instruction. *) -val pp_instr : printenv -> F.formatter -> instr -> unit - -(** Dump an instruction. *) -val d_instr : instr -> unit - -(** Pretty print a list of instructions. *) -val pp_instr_list : printenv -> F.formatter -> instr list -> unit - -(** Dump a list of instructions. *) -val d_instr_list : instr list -> unit - -(** Pretty print a value path *) -val pp_vpath : printenv -> F.formatter -> vpath -> unit - -(** Pretty print an atom. *) -val pp_atom : printenv -> F.formatter -> atom -> unit - -(** Dump an atom. *) -val d_atom : atom -> unit - -(** return a string representing the inst *) -val inst_to_string : inst -> string - -(** Pretty print a strexp. *) -val pp_sexp : printenv -> F.formatter -> strexp -> unit - -(** Dump a strexp. *) -val d_sexp : strexp -> unit - -(** Pretty print a strexp list. *) -val pp_sexp_list : printenv -> F.formatter -> strexp list -> unit - -(** Dump a strexp. *) -val d_sexp_list : strexp list -> unit - -(** Pretty print a hpred. *) -val pp_hpred : printenv -> F.formatter -> hpred -> unit - -(** Dump a hpred. *) -val d_hpred : hpred -> unit - -(** Pretty print a hpara. *) -val pp_hpara : printenv -> F.formatter -> hpara -> unit - -(** Pretty print a list of hparas. *) -val pp_hpara_list : printenv -> F.formatter -> hpara list -> unit - -(** Pretty print a hpara_dll. *) -val pp_hpara_dll : printenv -> F.formatter -> hpara_dll -> unit - -(** Pretty print a list of hpara_dlls. *) -val pp_hpara_dll_list : printenv -> F.formatter -> hpara_dll list -> unit - -(** Module Predicates records the occurrences of predicates as parameters - of (doubly -)linked lists and Epara. - Provides unique numbering for predicates and an iterator. *) -module Predicates : sig - (** predicate environment *) - type env - (** create an empty predicate environment *) - val empty_env : unit -> env - (** return true if the environment is empty *) - val is_empty : env -> bool - (** return the id of the hpara *) - val get_hpara_id : env -> hpara -> int - (** return the id of the hpara_dll *) - val get_hpara_dll_id : env -> hpara_dll -> int - (** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll, - passing the unique id to the functions. The iterator can only be used once. *) - val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit - (** Process one hpred, updating the predicate environment *) - val process_hpred : env -> hpred -> unit -end - -(** Pretty print a hpred with optional predicate env *) -val pp_hpred_env : printenv -> Predicates.env option -> F.formatter -> hpred -> unit - -(** {2 Functions for traversing SIL data types} *) - -(** This function should be used before adding a new - index to Earray. The [exp] is the newly created - index. This function "cleans" [exp] according to whether it is the - footprint or current part of the prop. - The function faults in the re - execution mode, as an internal check of the tool. *) -val array_clean_new_index : bool -> exp -> exp - -(** Change exps in strexp using [f]. *) -(** WARNING: the result might not be normalized. *) -val strexp_expmap : (exp * inst option -> exp * inst option) -> strexp -> strexp - -(** Change exps in hpred by [f]. *) -(** WARNING: the result might not be normalized. *) -val hpred_expmap : (exp * inst option -> exp * inst option) -> hpred -> hpred - -(** Change instrumentations in hpred using [f]. *) -val hpred_instmap : (inst -> inst) -> hpred -> hpred - -(** Change exps in hpred list by [f]. *) -(** WARNING: the result might not be normalized. *) -val hpred_list_expmap : (exp * inst option -> exp * inst option) -> hpred list -> hpred list - -(** Change exps in atom by [f]. *) -(** WARNING: the result might not be normalized. *) -val atom_expmap : (exp -> exp) -> atom -> atom - -(** Change exps in atom list by [f]. *) -(** WARNING: the result might not be normalized. *) -val atom_list_expmap : (exp -> exp) -> atom list -> atom list - -(** {2 Function for computing lexps in sigma} *) - -val hpred_list_get_lexps : (exp -> bool) -> hpred list -> exp list - -(** {2 Utility Functions for Expressions} *) - -(** Turn an expression representing a type into the type it represents - If not a sizeof, return the default type if given, otherwise raise an exception *) -val texp_to_typ : typ option -> exp -> typ - -(** If a struct type with field f, return the type of f. - If not, return the default type if given, otherwise raise an exception *) -val struct_typ_fld : typ option -> Ident.fieldname -> typ -> typ - -(** If an array type, return the type of the element. - If not, return the default type if given, otherwise raise an exception *) -val array_typ_elem : typ option -> typ -> typ - -(** Return the root of [lexp]. *) -val root_of_lexp : exp -> exp - -(** Get an expression "undefined", the boolean indicates - whether the undefined value goest into the footprint *) -val exp_get_undefined : bool -> exp - -(** Checks whether an expression denotes a location using pointer arithmetic. - Currently, catches array - indexing expressions such as a[i] only. *) -val exp_pointer_arith : exp -> bool - -(** Integer constant 0 *) -val exp_zero : exp - -(** Null constant *) -val exp_null : exp - -(** Integer constant 1 *) -val exp_one : exp - -(** Integer constant -1 *) -val exp_minus_one : exp - -(** Create integer constant *) -val exp_int : Int.t -> exp - -(** Create float constant *) -val exp_float : float -> exp - -(** Create integer constant corresponding to the boolean value *) -val exp_bool : bool -> exp - -(** Create expresstion [e1 == e2] *) -val exp_eq : exp -> exp -> exp - -(** Create expresstion [e1 != e2] *) -val exp_ne : exp -> exp -> exp - -(** Create expresstion [e1 <= e2] *) -val exp_le : exp -> exp -> exp - -(** Create expression [e1 < e2] *) -val exp_lt : exp -> exp -> exp - -(** {2 Functions for computing program variables} *) - -val exp_fpv : exp -> Pvar.t list - -val strexp_fpv : strexp -> Pvar.t list - -val atom_fpv : atom -> Pvar.t list - -val hpred_fpv : hpred -> Pvar.t list - -val hpara_fpv : hpara -> Pvar.t list - -(** {2 Functions for computing free non-program variables} *) - -(** Type of free variables. These include primed, normal and footprint variables. - We remember the order in which variables are added. *) -type fav - -(** flag to indicate whether fav's are stored in duplicate form. - Only to be used with fav_to_list *) -val fav_duplicates : bool ref - -(** Pretty print a fav. *) -val pp_fav : printenv -> F.formatter -> fav -> unit - -(** Create a new [fav]. *) -val fav_new : unit -> fav - -(** Emptyness check. *) -val fav_is_empty : fav -> bool - -(** Check whether a predicate holds for all elements. *) -val fav_for_all : fav -> (Ident.t -> bool) -> bool - -(** Check whether a predicate holds for some elements. *) -val fav_exists : fav -> (Ident.t -> bool) -> bool - -(** Membership test fot [fav] *) -val fav_mem : fav -> Ident.t -> bool - -(** Convert a list to a fav. *) -val fav_from_list : Ident.t list -> fav - -(** Convert a [fav] to a list of identifiers while preserving the order - that identifiers were added to [fav]. *) -val fav_to_list : fav -> Ident.t list - -(** Copy a [fav]. *) -val fav_copy : fav -> fav - -(** Turn a xxx_fav_add function into a xxx_fav function *) -val fav_imperative_to_functional : (fav -> 'a -> unit) -> 'a -> fav - -(** [fav_filter_ident fav f] only keeps [id] if [f id] is true. *) -val fav_filter_ident : fav -> (Ident.t -> bool) -> unit - -(** Like [fav_filter_ident] but return a copy. *) -val fav_copy_filter_ident : fav -> (Ident.t -> bool) -> fav - -(** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] - is in [fav2].*) -val fav_subset_ident : fav -> fav -> bool - -(** add identifier list to fav *) -val ident_list_fav_add : Ident.t list -> fav -> unit - -(** [exp_fav_add fav exp] extends [fav] with the free variables of [exp] *) -val exp_fav_add : fav -> exp -> unit - -val exp_fav : exp -> fav - -val exp_fav_list : exp -> Ident.t list - -val ident_in_exp : Ident.t -> exp -> bool - -val strexp_fav_add : fav -> strexp -> unit - -val atom_fav_add : fav -> atom -> unit - -val atom_fav: atom -> fav - -val hpred_fav_add : fav -> hpred -> unit - -val hpred_fav : hpred -> fav - -(** Variables in hpara, excluding bound vars in the body *) -val hpara_shallow_av : hpara -> fav - -(** Variables in hpara_dll, excluding bound vars in the body *) -val hpara_dll_shallow_av : hpara_dll -> fav - -(** {2 Functions for computing all free or bound non-program variables} *) - -(** Non-program variables include all of primed, normal and footprint - variables. Thus, the functions essentially compute all the - identifiers occuring in a parameter. Some variables can appear more - than once in the result. *) - -val exp_av_add : fav -> exp -> unit - -val strexp_av_add : fav -> strexp -> unit - -val atom_av_add : fav -> atom -> unit - -val hpred_av_add : fav -> hpred -> unit - -val hpara_av_add : fav -> hpara -> unit - -(** {2 Substitution} *) - -type subst - -(** Create a substitution from a list of pairs. - For all (id1, e1), (id2, e2) in the input list, - if id1 = id2, then e1 = e2. *) -val sub_of_list : (Ident.t * exp) list -> subst - -(** like sub_of_list, but allow duplicate ids and only keep the first occurrence *) -val sub_of_list_duplicates : (Ident.t * exp) list -> subst - -(** Convert a subst to a list of pairs. *) -val sub_to_list : subst -> (Ident.t * exp) list - -(** The empty substitution. *) -val sub_empty : subst - -(** Comparison for substitutions. *) -val sub_compare : subst -> subst -> int - -(** Equality for substitutions. *) -val sub_equal : subst -> subst -> bool - -(** Compute the common id-exp part of two inputs [subst1] and [subst2]. - The first component of the output is this common part. - The second and third components are the remainder of [subst1] - and [subst2], respectively. *) -val sub_join : subst -> subst -> subst - -(** Compute the common id-exp part of two inputs [subst1] and [subst2]. - The first component of the output is this common part. - The second and third components are the remainder of [subst1] - and [subst2], respectively. *) -val sub_symmetric_difference : subst -> subst -> subst * subst * subst - -(** [sub_find filter sub] returns the expression associated to the first identifier - that satisfies [filter]. - Raise [Not_found] if there isn't one. *) -val sub_find : (Ident.t -> bool) -> subst -> exp - -(** [sub_filter filter sub] restricts the domain of [sub] to the - identifiers satisfying [filter]. *) -val sub_filter : (Ident.t -> bool) -> subst -> subst - -(** [sub_filter_exp filter sub] restricts the domain of [sub] to the - identifiers satisfying [filter(id, sub(id))]. *) -val sub_filter_pair : (Ident.t * exp -> bool) -> subst -> subst - -(** [sub_range_partition filter sub] partitions [sub] according to - whether range expressions satisfy [filter]. *) -val sub_range_partition : (exp -> bool) -> subst -> subst * subst - -(** [sub_domain_partition filter sub] partitions [sub] according to - whether domain identifiers satisfy [filter]. *) -val sub_domain_partition : (Ident.t -> bool) -> subst -> subst * subst - -(** Return the list of identifiers in the domain of the substitution. *) -val sub_domain : subst -> Ident.t list - -(** Return the list of expressions in the range of the substitution. *) -val sub_range : subst -> exp list - -(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *) -val sub_range_map : (exp -> exp) -> subst -> subst - -(** [sub_map f g sub] applies the renaming [f] to identifiers in the domain - of [sub] and the substitution [g] to the expressions in the range of [sub]. *) -val sub_map : (Ident.t -> Ident.t) -> (exp -> exp) -> subst -> subst - -(** Checks whether [id] belongs to the domain of [subst]. *) -val mem_sub : Ident.t -> subst -> bool - -(** Extend substitution and return [None] if not possible. *) -val extend_sub : subst -> Ident.t -> exp -> subst option - -(** Free auxilary variables in the domain and range of the - substitution. *) -val sub_fav_add : fav -> subst -> unit - -(** Free or bound auxilary variables in the domain and range of the - substitution. *) -val sub_av_add : fav -> subst -> unit - -(** Compute free pvars in a sub *) -val sub_fpv : subst -> Pvar.t list - -(** substitution functions *) -(** WARNING: these functions do not ensure that the results are normalized. *) -val exp_sub : subst -> exp -> exp - -val atom_sub : subst -> atom -> atom - -val instr_sub : subst -> instr -> instr - -val hpred_sub : subst -> hpred -> hpred - -(** {2 Functions for replacing occurrences of expressions.} *) - -(** The first parameter should define a partial function. - No parts of hpara are replaced by these functions. *) - -val exp_replace_exp : (exp * exp) list -> exp -> exp - -val strexp_replace_exp : (exp * exp) list -> strexp -> strexp - -val atom_replace_exp : (exp * exp) list -> atom -> atom - -val hpred_replace_exp : (exp * exp) list -> hpred -> hpred - -(** {2 Functions for constructing or destructing entities in this module} *) - -(** Extract the ids and pvars from an expression *) -val exp_get_vars : exp -> (Ident.t list * Pvar.t list) - -(** Compute the offset list of an expression *) -val exp_get_offsets : exp -> offset list - -(** Add the offset list to an expression *) -val exp_add_offsets : exp -> offset list -> exp - -val sigma_to_sigma_ne : hpred list -> (atom list * hpred list) list - -(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], - [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], - then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] - for some fresh [_zs'].*) -val hpara_instantiate : hpara -> exp -> exp -> exp list -> Ident.t list * hpred list - -(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], - [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], - then the result of the instantiation is - [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]] - for some fresh [_zs'].*) -val hpara_dll_instantiate : hpara_dll -> exp -> exp -> exp -> exp list -> Ident.t list * hpred list - -(** Iterate over all the subtypes in the type (including the type itself) *) -val typ_iter_types : (typ -> unit) -> typ -> unit -(** Iterate over all the types (and subtypes) in the expression *) -val exp_iter_types : (typ -> unit) -> exp -> unit -(** Iterate over all the types (and subtypes) in the instruction *) -val instr_iter_types : (typ -> unit) -> instr -> unit - -val custom_error : Pvar.t diff --git a/infer/src/IR/tenv.ml b/infer/src/IR/tenv.ml deleted file mode 100644 index fc321d3cf..000000000 --- a/infer/src/IR/tenv.ml +++ /dev/null @@ -1,168 +0,0 @@ -(* - * 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! Utils - -(** Module for Type Environments. *) - -(** Hash tables on strings. *) -module TypenameHash = - Hashtbl.Make(struct - type t = Typename.t - let equal tn1 tn2 = Typename.equal tn1 tn2 - let hash = Hashtbl.hash - end) - -(** Type for type environment. *) -type t = Sil.struct_typ TypenameHash.t - -(** Create a new type environment. *) -let create () = TypenameHash.create 1000 - -(** 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 = - try Some (TypenameHash.find tenv name) - with Not_found -> None - -(** Lookup Java types by name *) -let lookup_java_typ_from_string tenv typ_str = - let rec loop = function - | "" | "void" -> - Some Sil.Tvoid - | "int" -> - Some (Sil.Tint Sil.IInt) - | "byte" -> - Some (Sil.Tint Sil.IShort) - | "short" -> - Some (Sil.Tint Sil.IShort) - | "boolean" -> - Some (Sil.Tint Sil.IBool) - | "char" -> - Some (Sil.Tint Sil.IChar) - | "long" -> - Some (Sil.Tint Sil.ILong) - | "float" -> - Some (Sil.Tfloat Sil.FFloat) - | "double" -> - Some (Sil.Tfloat Sil.FDouble) - | typ_str when String.contains typ_str '[' -> - let stripped_typ = String.sub typ_str 0 ((String.length typ_str) - 2) in - let array_typ_size = Sil.exp_get_undefined false in - begin - match loop stripped_typ with - | Some typ -> Some (Sil.Tptr (Sil.Tarray (typ, array_typ_size), Sil.Pk_pointer)) - | None -> None - end - | typ_str -> - (* non-primitive/non-array type--resolve it in the tenv *) - let typename = Typename.Java.from_string typ_str in - begin - match lookup tenv typename with - | Some struct_typ -> Some (Sil.Tstruct struct_typ) - | None -> None - end in - loop typ_str - -(** resolve a type string to a Java *class* type. For strings that may represent primitive or array - typs, use [lookup_java_typ_from_string] *) -let lookup_java_class_from_string tenv typ_str = - match lookup_java_typ_from_string tenv typ_str with - | Some (Sil.Tstruct struct_typ) -> Some struct_typ - | _ -> None - -(** Add a (name,type) pair to the global type environment. *) -let add tenv name struct_typ = - TypenameHash.replace tenv name struct_typ - -(** Return the declaring class type of [pname_java] *) -let proc_extract_declaring_class_typ tenv pname_java = - lookup_java_class_from_string tenv (Procname.java_get_class_name pname_java) - -(** Return the return type of [pname_java]. *) -let proc_extract_return_typ tenv pname_java = - lookup_java_typ_from_string tenv (Procname.java_get_return_type pname_java) - -(** Get method that is being overriden by java_pname (if any) **) -let get_overriden_method tenv pname_java = - let struct_typ_get_def_method_by_name struct_typ method_name = - IList.find - (fun def_method -> method_name = Procname.get_method def_method) - struct_typ.Sil.def_methods in - let rec get_overriden_method_in_superclasses pname_java superclasses= - match superclasses with - | superclass :: superclasses_tail -> - begin - match lookup tenv superclass with - | Some struct_typ -> - begin - try - Some (struct_typ_get_def_method_by_name - struct_typ - (Procname.java_get_method pname_java)) - with Not_found -> - get_overriden_method_in_superclasses - pname_java - (superclasses_tail @ struct_typ.Sil.superclasses) - end - | None -> get_overriden_method_in_superclasses pname_java superclasses_tail - end - | [] -> None in - match proc_extract_declaring_class_typ tenv pname_java with - | Some proc_struct_typ -> - get_overriden_method_in_superclasses pname_java proc_struct_typ.superclasses - | _ -> None - - -(** expand a type if it is a typename by looking it up in the type environment *) -let expand_type tenv typ = - match typ with - | Sil.Tvar tname -> - begin - match lookup tenv tname with - | None -> - assert false - | Some struct_typ -> - Sil.Tstruct struct_typ - end - | _ -> typ - -(** Serializer for type environments *) -let tenv_serializer : t Serialization.serializer = - Serialization.create_serializer Serialization.tenv_key - -let global_tenv: (t option) Lazy.t = - lazy (Serialization.from_file tenv_serializer (DB.global_tenv_fname ())) - -(** Load a type environment from a file *) -let load_from_file (filename : DB.filename) : t option = - if filename = DB.global_tenv_fname () then - Lazy.force global_tenv - else - Serialization.from_file tenv_serializer filename - -(** Save a type environment into a file *) -let store_to_file (filename : DB.filename) (tenv : t) = - Serialization.to_file tenv_serializer filename tenv - -let iter f tenv = - TypenameHash.iter f tenv - -let fold f tenv = - TypenameHash.fold f tenv - -let pp fmt (tenv : t) = - TypenameHash.iter - (fun name typ -> - Format.fprintf fmt "@[<6>NAME: %s@." (Typename.to_string name); - Format.fprintf fmt "@[<6>TYPE: %a@." (Sil.pp_struct_typ pe_text (fun _ () -> ())) typ) - tenv diff --git a/infer/src/IR/tenv.mli b/infer/src/IR/tenv.mli deleted file mode 100644 index 6bb1306be..000000000 --- a/infer/src/IR/tenv.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* - * 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! Utils - -(** Module for Type Environments. *) - -type t (** Type for type environment. *) - -(** Add a (name,typename) pair to the global type environment. *) -val add : t -> Typename.t -> Sil.struct_typ -> unit - -(** Create a new type environment. *) -val create : unit -> t - -(** Expand a type if it is a typename by looking it up in the type environment. *) -val expand_type : t -> Sil.typ -> Sil.typ - -(** Fold a function over the elements of the type environment. *) -val fold : (Typename.t -> Sil.struct_typ -> 'a -> 'a) -> t -> 'a -> 'a - -(** iterate over a type environment *) -val iter : (Typename.t -> Sil.struct_typ -> unit) -> t -> unit - -(** Load a type environment from a file *) -val load_from_file : DB.filename -> t option - -(** Look up a name in the global type environment. *) -val lookup : t -> Typename.t -> Sil.struct_typ option - -(** Lookup Java types by name. *) -val lookup_java_typ_from_string : t -> string -> Sil.typ option - -(** resolve a type string to a Java *class* type. For strings that may represent primitive or array - typs, use [lookup_java_typ_from_string]. *) -val lookup_java_class_from_string : t -> string -> Sil.struct_typ option - -(** Return the declaring class type of [pname_java] *) -val proc_extract_declaring_class_typ : t -> Procname.java -> Sil.struct_typ option - -(** Return the return type of [pname_java]. *) -val proc_extract_return_typ : t -> Procname.java -> Sil.typ option - -(** Check if typename is found in t *) -val mem : t -> Typename.t -> bool - -(** print a type environment *) -val pp : Format.formatter -> t -> unit - -(** Save a type environment into a file *) -val store_to_file : DB.filename -> t -> unit - -(** Get method that is being overriden by java_pname (if any) **) -val get_overriden_method : t -> Procname.java -> Procname.t option diff --git a/infer/src/IR/typename.ml b/infer/src/IR/typename.ml deleted file mode 100644 index b8e6a4213..000000000 --- a/infer/src/IR/typename.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -module F = Format - -(** Named types. *) -type t = - | TN_typedef of Mangled.t - | TN_enum of Mangled.t - | TN_csu of Csu.t * Mangled.t - -let to_string = function - | TN_enum name - | TN_typedef name -> Mangled.to_string name - | TN_csu (csu, name) -> - Csu.name csu ^ " " ^ Mangled.to_string name - -let pp f typename = - F.fprintf f "%s" (to_string typename) - -let name = function - | TN_enum name - | TN_typedef name - | TN_csu (_, name) -> Mangled.to_string name - -let compare tn1 tn2 = match tn1, tn2 with - | TN_typedef n1, TN_typedef n2 -> Mangled.compare n1 n2 - | TN_typedef _, _ -> - 1 - | _, TN_typedef _ -> 1 - | TN_enum n1, TN_enum n2 -> Mangled.compare n1 n2 - | TN_enum _, _ -> -1 - | _, TN_enum _ -> 1 - | TN_csu (csu1, n1), TN_csu (csu2, n2) -> - let n = Csu.compare csu1 csu2 in - if n <> 0 then n else Mangled.compare n1 n2 - -let equal tn1 tn2 = - compare tn1 tn2 = 0 - -module Java = -struct - - let from_string class_name_str = - TN_csu (Csu.Class Csu.Java, Mangled.from_string class_name_str) - -end - -type typename_t = t -module Set = Set.Make( - struct - type t = typename_t - let compare = compare - end) diff --git a/infer/src/IR/typename.mli b/infer/src/IR/typename.mli deleted file mode 100644 index 8cec9bd49..000000000 --- a/infer/src/IR/typename.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* - * Copyright (c) 2015 - 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 - -(** Named types. *) -type t = - | TN_typedef of Mangled.t - | TN_enum of Mangled.t - | TN_csu of Csu.t * Mangled.t - -(** convert the typename to a string *) -val to_string : t -> string - -val pp : Format.formatter -> t -> unit - -(** name of the typename without qualifier *) -val name : t -> string - -(** Comparison for typenames *) -val compare : t -> t -> int - -(** Equality for typenames *) -val equal : t -> t -> bool - -module Java : sig - - (** Create a typename from a Java classname in the form "package.class" *) - val from_string : string -> t - -end - -module Set : Set.S with type elt = t diff --git a/infer/src/Makefile.in b/infer/src/Makefile.in index 03893a43b..dee743128 100644 --- a/infer/src/Makefile.in +++ b/infer/src/Makefile.in @@ -132,7 +132,7 @@ endif DEPENDENCIES = IR backend checkers eradicate harness \ facebook/checkers facebook/checkers/graphql facebook/scripts $(EXTRA_DEPS) -OCAMLBUILD = ocamlbuild $(OCAMLBUILD_OPTIONS) -j $(NCPU) $(addprefix -I , $(DEPENDENCIES)) +OCAMLBUILD = rebuild $(OCAMLBUILD_OPTIONS) -j $(NCPU) $(addprefix -I , $(DEPENDENCIES)) .PHONY: all java clang llvm unit checkCopyright build_java build_clang build_llvm build_unit \ build_checkCopyright java_annotations clang_annotations llvm_annotations \