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: 10a067f28master
Phoebe Nichols
5 years ago
committed by
Facebook Github Bot
parent
15246ec2a2
commit
82eb91fe71
@ -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 []
|
||||
@ -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 *)
|
||||
Loading…
Reference in new issue