From 82eb91fe71eef70a628e04d7531e2948cc46b5cc Mon Sep 17 00:00:00 2001 From: Phoebe Nichols Date: Tue, 16 Jul 2019 06:01:43 -0700 Subject: [PATCH] Move core CallGraph API from SyntacticCallGraph.ml to CallGraph.ml Summary: Move the logic that is general to any call graph from SyntacticCallGraph.ml into CallGraph.ml This will allow the call graph logic to be re-used in a later diff Reviewed By: ezgicicek Differential Revision: D16265150 fbshipit-source-id: 10a067f28 --- infer/src/backend/CallGraph.ml | 136 +++++++++++++++++++++ infer/src/backend/CallGraph.mli | 59 ++++++++++ infer/src/backend/SyntacticCallGraph.ml | 144 ++--------------------- infer/src/backend/SyntacticCallGraph.mli | 41 +------ infer/src/backend/TaskScheduler.ml | 20 ++-- 5 files changed, 213 insertions(+), 187 deletions(-) create mode 100644 infer/src/backend/CallGraph.ml create mode 100644 infer/src/backend/CallGraph.mli diff --git a/infer/src/backend/CallGraph.ml b/infer/src/backend/CallGraph.ml new file mode 100644 index 000000000..9cac9bb4c --- /dev/null +++ b/infer/src/backend/CallGraph.ml @@ -0,0 +1,136 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) +open! IStd +module F = Format + +module type NodeSig = sig + type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool} + + val make : int -> Typ.Procname.t -> int list -> t + + val set_flag : t -> unit + + val unset_flag : t -> unit + + val pp_dot : F.formatter -> t -> unit +end + +module Node : NodeSig = struct + type t = {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool} + + let make id pname successors = {id; pname; successors; flag= false} + + let set_flag n = n.flag <- true + + let unset_flag n = n.flag <- false + + let pp_dot fmt {id; pname; successors} = + let pp_id fmt id = F.fprintf fmt "N%d" id in + let pp_edge fmt src dst = F.fprintf fmt " %a -> %a ;@\n" pp_id src pp_id dst in + F.fprintf fmt " %a [ label = %S ];@\n" pp_id id (F.asprintf "%a" Typ.Procname.pp pname) ; + List.iter successors ~f:(pp_edge fmt id) ; + F.pp_print_newline fmt () +end + +module IdMap = Typ.Procname.Hash +module NodeMap = Caml.Hashtbl.Make (Int) + +(** [node_map] is a map from ids (unique ints) to nodes corresponding to defined procedures. + [id_map] is a map from all encountered (not necessarily defined) procnames to their ids, + and thus its image is a superset of the domain of [node_map], and usually a strict superset. + [trim_id_map] makes the image equal to the domain of [node_map]. *) +type t = {id_map: int IdMap.t; node_map: Node.t NodeMap.t} + +let reset {id_map; node_map} = IdMap.reset id_map ; NodeMap.reset node_map + +let create initial_capacity = + {id_map= IdMap.create initial_capacity; node_map= NodeMap.create initial_capacity} + + +let id_of_procname {id_map} pname = IdMap.find_opt id_map pname + +let node_of_id {node_map} id = NodeMap.find_opt node_map id + +let mem {node_map} id = NodeMap.mem node_map id + +(** [id_map] may contain undefined procedures, so use [node_map] for actual size *) +let n_procs {node_map} = NodeMap.length node_map + +let node_of_procname g pname = id_of_procname g pname |> Option.bind ~f:(node_of_id g) + +let remove (g : t) pname id = IdMap.remove g.id_map pname ; NodeMap.remove g.node_map id + +let add ({id_map; node_map} as graph) pname successor_pnames = + let get_or_set_id procname = + match id_of_procname graph procname with + | None -> + let id = IdMap.length id_map in + IdMap.replace id_map procname id ; id + | Some id -> + id + in + let id = get_or_set_id pname in + let successors = List.map successor_pnames ~f:get_or_set_id in + let node = Node.make id pname successors in + NodeMap.replace node_map id node + + +let remove_reachable g start_pname = + let add_live_successors_and_remove_self init (n : Node.t) = + remove g n.pname n.id ; + List.fold n.successors ~init ~f:(fun init succ_id -> + node_of_id g succ_id |> Option.fold ~init ~f:(fun acc s -> s :: acc) ) + in + let rec remove_list frontier = + if not (List.is_empty frontier) then + remove_list (List.fold frontier ~init:[] ~f:add_live_successors_and_remove_self) + in + node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> remove_list [start_node]) + + +let flag_reachable g start_pname = + let process_node init (n : Node.t) = + if n.flag then init + else ( + Node.set_flag n ; + List.fold n.successors ~init ~f:(fun acc id -> + match node_of_id g id with Some n' when not n'.flag -> n' :: acc | _ -> acc ) ) + in + let rec flag_list frontier = + if not (List.is_empty frontier) then flag_list (List.fold frontier ~init:[] ~f:process_node) + in + node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> flag_list [start_node]) + + +let trim_id_map (g : t) = + IdMap.filter_map_inplace (fun _pname id -> Option.some_if (mem g id) id) g.id_map + + +let pp_dot fmt {node_map} = + F.fprintf fmt "@\ndigraph callgraph {@\n" ; + NodeMap.iter (fun _id n -> Node.pp_dot fmt n) node_map ; + F.fprintf fmt "}@." + + +let to_dotty g filename = + let outc = Filename.concat Config.results_dir filename |> Out_channel.create in + let fmt = F.formatter_of_out_channel outc in + pp_dot fmt g ; Out_channel.close outc + + +let remove_unflagged_and_unflag_all {id_map; node_map} = + NodeMap.filter_map_inplace + (fun _id (n : Node.t) -> + if n.flag then ( Node.unset_flag n ; Some n ) else ( IdMap.remove id_map n.pname ; None ) ) + node_map + + +let get_unflagged_leaves g = + NodeMap.fold + (fun _id (n : Node.t) acc -> + if n.flag || List.exists n.successors ~f:(mem g) then acc else n :: acc ) + g.node_map [] diff --git a/infer/src/backend/CallGraph.mli b/infer/src/backend/CallGraph.mli new file mode 100644 index 000000000..81b38476d --- /dev/null +++ b/infer/src/backend/CallGraph.mli @@ -0,0 +1,59 @@ +(* + * Copyright (c) Facebook, Inc. and its affiliates. + * + * This source code is licensed under the MIT license found in the + * LICENSE file in the root directory of this source tree. + *) +open! IStd +module F = Format + +module type NodeSig = sig + type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool} + + val make : int -> Typ.Procname.t -> int list -> t + + val set_flag : t -> unit + + val unset_flag : t -> unit + + val pp_dot : F.formatter -> t -> unit +end + +module Node : NodeSig + +module IdMap = Typ.Procname.Hash + +type t + +val reset : t -> unit +(** empty the graph and shrink it to its initial size *) + +val create : int -> t +(** [create n] makes an empty graph with initial capacity [n] which grows as required *) + +val n_procs : t -> int +(** number of procedures in graph *) + +val mem : t -> int -> bool +(** is an int [id] the index of a node in the graph? *) + +val flag_reachable : t -> Typ.Procname.t -> unit +(** flag all nodes reachable from the node of the given procname, if it exists *) + +val get_unflagged_leaves : t -> Node.t list +(** get all leaves that have their flag set to false *) + +val remove_reachable : t -> Typ.Procname.t -> unit +(** remove all nodes reachable from procname *) + +val to_dotty : t -> string -> unit +(** output call graph in dotty format with the given filename in results dir *) + +val trim_id_map : t -> unit +(** remove all pnames that do not correspond to a defined procedure from id_map *) + +val remove_unflagged_and_unflag_all : t -> unit +(** remove all nodes with flag set to false, and set flag to false on all remaining nodes *) + +val add : t -> IdMap.key -> IdMap.key sexp_list -> unit +(** add edges from [pname] to [successor_pnames] in the graph *) diff --git a/infer/src/backend/SyntacticCallGraph.ml b/infer/src/backend/SyntacticCallGraph.ml index 339727f4d..11a63cd91 100644 --- a/infer/src/backend/SyntacticCallGraph.ml +++ b/infer/src/backend/SyntacticCallGraph.ml @@ -5,131 +5,8 @@ * LICENSE file in the root directory of this source tree. *) open! IStd -module F = Format module L = Logging - -module type NodeSig = sig - type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool} - - val make : int -> Typ.Procname.t -> int list -> t - - val set_flag : t -> unit - - val unset_flag : t -> unit - - val pp_dot : F.formatter -> t -> unit -end - -module Node : NodeSig = struct - type t = {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool} - - let make id pname successors = {id; pname; successors; flag= false} - - let set_flag n = n.flag <- true - - let unset_flag n = n.flag <- false - - let pp_dot fmt {id; pname; successors} = - let pp_id fmt id = F.fprintf fmt "N%d" id in - let pp_edge fmt src dst = F.fprintf fmt " %a -> %a ;@\n" pp_id src pp_id dst in - F.fprintf fmt " %a [ label = %S ];@\n" pp_id id (F.asprintf "%a" Typ.Procname.pp pname) ; - List.iter successors ~f:(pp_edge fmt id) ; - F.pp_print_newline fmt () -end - module IdMap = Typ.Procname.Hash -module NodeMap = Caml.Hashtbl.Make (Int) - -(** [node_map] is a map from ids (unique ints) to nodes corresponding to defined procedures. - [id_map] is a map from all encountered (not necessarily defined) procnames to their ids, - and thus its image is a superset of the domain of [node_map], and usually a strict superset. - [trim_id_map] makes the image equal to the domain of [node_map]. *) -type t = {id_map: int IdMap.t; node_map: Node.t NodeMap.t} - -let reset {id_map; node_map} = IdMap.reset id_map ; NodeMap.reset node_map - -let create initial_capacity = - {id_map= IdMap.create initial_capacity; node_map= NodeMap.create initial_capacity} - - -let id_of_procname {id_map} pname = IdMap.find_opt id_map pname - -let node_of_id {node_map} id = NodeMap.find_opt node_map id - -let mem {node_map} id = NodeMap.mem node_map id - -(** [id_map] may contain undefined procedures, so use [node_map] for actual size *) -let n_procs {node_map} = NodeMap.length node_map - -let node_of_procname g pname = id_of_procname g pname |> Option.bind ~f:(node_of_id g) - -let remove (g : t) pname id = IdMap.remove g.id_map pname ; NodeMap.remove g.node_map id - -let add ({id_map; node_map} as graph) pname successor_pnames = - let get_or_set_id procname = - match id_of_procname graph procname with - | None -> - let id = IdMap.length id_map in - IdMap.replace id_map procname id ; id - | Some id -> - id - in - let id = get_or_set_id pname in - let successors = List.map successor_pnames ~f:get_or_set_id in - let node = Node.make id pname successors in - NodeMap.replace node_map id node - - -let remove_reachable g start_pname = - let add_live_successors_and_remove_self init (n : Node.t) = - remove g n.pname n.id ; - List.fold n.successors ~init ~f:(fun init succ_id -> - node_of_id g succ_id |> Option.fold ~init ~f:(fun acc s -> s :: acc) ) - in - let rec remove_list frontier = - if not (List.is_empty frontier) then - remove_list (List.fold frontier ~init:[] ~f:add_live_successors_and_remove_self) - in - node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> remove_list [start_node]) - - -let flag_reachable g start_pname = - let process_node init (n : Node.t) = - if n.flag then init - else ( - Node.set_flag n ; - List.fold n.successors ~init ~f:(fun acc id -> - match node_of_id g id with Some n' when not n'.flag -> n' :: acc | _ -> acc ) ) - in - let rec flag_list frontier = - if not (List.is_empty frontier) then flag_list (List.fold frontier ~init:[] ~f:process_node) - in - node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> flag_list [start_node]) - - -let remove_unflagged_and_unflag_all {id_map; node_map} = - NodeMap.filter_map_inplace - (fun _id (n : Node.t) -> - if n.flag then ( Node.unset_flag n ; Some n ) else ( IdMap.remove id_map n.pname ; None ) ) - node_map - - -(** remove pnames for all undefined procedures *) -let trim_id_map (g : t) = - IdMap.filter_map_inplace (fun _pname id -> Option.some_if (mem g id) id) g.id_map - - -let pp_dot fmt {node_map} = - F.fprintf fmt "@\ndigraph callgraph {@\n" ; - NodeMap.iter (fun _id n -> Node.pp_dot fmt n) node_map ; - F.fprintf fmt "}@." - - -let to_dotty g filename = - let outc = Filename.concat Config.results_dir filename |> Out_channel.create in - let fmt = F.formatter_of_out_channel outc in - pp_dot fmt g ; Out_channel.close outc - let build_from_captured_procs g = let hashcons_pname = @@ -148,27 +25,20 @@ let build_from_captured_procs g = let callees = Sqlite3.column stmt 1 |> Typ.Procname.SQLiteList.deserialize |> List.map ~f:hashcons_pname in - add g proc_name callees ) + CallGraph.add g proc_name callees ) let build_from_sources g sources = let time0 = Mtime_clock.counter () in L.progress "Building call graph...@\n%!" ; build_from_captured_procs g ; - let n_captured = n_procs g in + let n_captured = CallGraph.n_procs g in List.iter sources ~f:(fun sf -> - SourceFiles.proc_names_of_source sf |> List.iter ~f:(flag_reachable g) ) ; - remove_unflagged_and_unflag_all g ; - trim_id_map g ; - if Config.debug_level_analysis > 0 then to_dotty g "callgraph.dot" ; + SourceFiles.proc_names_of_source sf |> List.iter ~f:(CallGraph.flag_reachable g) ) ; + CallGraph.remove_unflagged_and_unflag_all g ; + CallGraph.trim_id_map g ; + if Config.debug_level_analysis > 0 then CallGraph.to_dotty g "callgraph.dot" ; L.progress "Built call graph in %a, from %d total procs, %d reachable defined procs and takes %d bytes@." - Mtime.Span.pp (Mtime_clock.count time0) n_captured (n_procs g) + Mtime.Span.pp (Mtime_clock.count time0) n_captured (CallGraph.n_procs g) (Obj.(reachable_words (repr g)) * (Sys.word_size / 8)) - - -let get_unflagged_leaves g = - NodeMap.fold - (fun _id (n : Node.t) acc -> - if n.flag || List.exists n.successors ~f:(mem g) then acc else n :: acc ) - g.node_map [] diff --git a/infer/src/backend/SyntacticCallGraph.mli b/infer/src/backend/SyntacticCallGraph.mli index cd3c4ea3c..063999a97 100644 --- a/infer/src/backend/SyntacticCallGraph.mli +++ b/infer/src/backend/SyntacticCallGraph.mli @@ -5,45 +5,6 @@ * LICENSE file in the root directory of this source tree. *) open! IStd -module F = Format -module type NodeSig = sig - type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool} - - val make : int -> Typ.Procname.t -> int list -> t - - val set_flag : t -> unit - - val unset_flag : t -> unit - - val pp_dot : F.formatter -> t -> unit -end - -module Node : NodeSig - -type t - -val reset : t -> unit - -val create : int -> t -(** [create n] makes an empty graph with initial capacity [n] which grows as required *) - -val n_procs : t -> int -(** number of procedures in graph *) - -val build_from_sources : t -> SourceFile.t list -> unit +val build_from_sources : CallGraph.t -> SourceFile.t list -> unit (** build restriction of call graph to procedures reachable from provided sources *) - -val mem : t -> int -> bool -(** is an int [id] the index of a node in the graph? *) - -val flag_reachable : t -> Typ.Procname.t -> unit -(** flag all nodes reachable from the node of the given procname, if it exists *) - -val remove_reachable : t -> Typ.Procname.t -> unit -(** remove all nodes reachable from procname *) - -val get_unflagged_leaves : t -> Node.t list - -val to_dotty : t -> string -> unit -(** output call graph in dotty format with the given filename in results dir *) diff --git a/infer/src/backend/TaskScheduler.ml b/infer/src/backend/TaskScheduler.ml index 289d6a457..fb17c54d2 100644 --- a/infer/src/backend/TaskScheduler.ml +++ b/infer/src/backend/TaskScheduler.ml @@ -45,33 +45,33 @@ let bottom_up sources : target task_generator = (* this will potentially grossly overapproximate the tasks *) let remaining = ref (count_procedures ()) in let remaining_tasks () = !remaining in - let g = SyntacticCallGraph.create initial_call_graph_capacity in + let syntactic_call_graph = CallGraph.create initial_call_graph_capacity in let initialized = ref false in - let pending : SyntacticCallGraph.Node.t list ref = ref [] in + let pending : CallGraph.Node.t list ref = ref [] in let scheduled = ref Typ.Procname.Set.empty in let is_empty () = let empty = !initialized && List.is_empty !pending && Typ.Procname.Set.is_empty !scheduled in if empty then ( remaining := 0 ; L.progress "Finished call graph scheduling, %d procs remaining (in cycles).@." - (SyntacticCallGraph.n_procs g) ; - if Config.debug_level_analysis > 0 then SyntacticCallGraph.to_dotty g "cycles.dot" ; + (CallGraph.n_procs syntactic_call_graph) ; + if Config.debug_level_analysis > 0 then CallGraph.to_dotty syntactic_call_graph "cycles.dot" ; (* save some memory *) - SyntacticCallGraph.reset g ) ; + CallGraph.reset syntactic_call_graph ) ; empty in let rec next_aux () = match !pending with | [] -> - pending := SyntacticCallGraph.get_unflagged_leaves g ; + pending := CallGraph.get_unflagged_leaves syntactic_call_graph ; if List.is_empty !pending then None else next_aux () - | n :: ns when n.flag || not (SyntacticCallGraph.mem g n.id) -> + | n :: ns when n.flag || not (CallGraph.mem syntactic_call_graph n.id) -> pending := ns ; next_aux () | n :: ns -> pending := ns ; scheduled := Typ.Procname.Set.add n.pname !scheduled ; - SyntacticCallGraph.flag_reachable g n.pname ; + CallGraph.flag_reachable syntactic_call_graph n.pname ; Some (Procname n.pname) in let finished = function @@ -80,12 +80,12 @@ let bottom_up sources : target task_generator = | Procname pname -> decr remaining ; scheduled := Typ.Procname.Set.remove pname !scheduled ; - SyntacticCallGraph.remove_reachable g pname + CallGraph.remove_reachable syntactic_call_graph pname in let next () = (* do construction here, to avoid having the call graph into forked workers *) if not !initialized then ( - SyntacticCallGraph.build_from_sources g sources ; + SyntacticCallGraph.build_from_sources syntactic_call_graph sources ; initialized := true ) ; next_aux () in