pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Move core CallGraph API from SyntacticCallGraph.ml to CallGraph.ml

Browse Source 
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
master
Phoebe Nichols 6 years ago committed by Facebook Github Bot
parent 15246ec2a2
commit 82eb91fe71
5 changed files with 213 additions and 187 deletions
Show Stats Download Patch File Download Diff File

136
infer/src/backend/CallGraph.ml
Unescape View File

@ -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 []

59
infer/src/backend/CallGraph.mli
Unescape View File

@ -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 *)

144
infer/src/backend/SyntacticCallGraph.ml
Unescape View File

@ -5,131 +5,8 @@
* LICENSE file in the root directory of this source tree. * LICENSE file in the root directory of this source tree.
*) *)
open! IStd open! IStd
module F = Format
module L = Logging 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 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 build_from_captured_procs g =
let hashcons_pname = let hashcons_pname =
@ -148,27 +25,20 @@ let build_from_captured_procs g =
let callees = let callees =
Sqlite3.column stmt 1 |> Typ.Procname.SQLiteList.deserialize |> List.map ~f:hashcons_pname Sqlite3.column stmt 1 |> Typ.Procname.SQLiteList.deserialize |> List.map ~f:hashcons_pname
in in
add g proc_name callees ) CallGraph.add g proc_name callees )
let build_from_sources g sources = let build_from_sources g sources =
let time0 = Mtime_clock.counter () in let time0 = Mtime_clock.counter () in
L.progress "Building call graph...@\n%!" ; L.progress "Building call graph...@\n%!" ;
build_from_captured_procs g ; 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 -> List.iter sources ~f:(fun sf ->
SourceFiles.proc_names_of_source sf |> List.iter ~f:(flag_reachable g) ) ; SourceFiles.proc_names_of_source sf |> List.iter ~f:(CallGraph.flag_reachable g) ) ;
remove_unflagged_and_unflag_all g ; CallGraph.remove_unflagged_and_unflag_all g ;
trim_id_map g ; CallGraph.trim_id_map g ;
if Config.debug_level_analysis > 0 then to_dotty g "callgraph.dot" ; if Config.debug_level_analysis > 0 then CallGraph.to_dotty g "callgraph.dot" ;
L.progress L.progress
"Built call graph in %a, from %d total procs, %d reachable defined procs and takes %d bytes@." "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)) (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 []

41
infer/src/backend/SyntacticCallGraph.mli
Unescape View File

@ -5,45 +5,6 @@
* LICENSE file in the root directory of this source tree. * LICENSE file in the root directory of this source tree.
*) *)
open! IStd open! IStd
module F = Format
module type NodeSig = sig val build_from_sources : CallGraph.t -> SourceFile.t list -> unit
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
(** build restriction of call graph to procedures reachable from provided sources *) (** 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 *)

20
infer/src/backend/TaskScheduler.ml
Unescape View File

@ -45,33 +45,33 @@ let bottom_up sources : target task_generator =
(* this will potentially grossly overapproximate the tasks *) (* this will potentially grossly overapproximate the tasks *)
let remaining = ref (count_procedures ()) in let remaining = ref (count_procedures ()) in
let remaining_tasks () = !remaining 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 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 scheduled = ref Typ.Procname.Set.empty in
let is_empty () = let is_empty () =
let empty = !initialized && List.is_empty !pending && Typ.Procname.Set.is_empty !scheduled in let empty = !initialized && List.is_empty !pending && Typ.Procname.Set.is_empty !scheduled in
if empty then ( if empty then (
remaining := 0 ; remaining := 0 ;
L.progress "Finished call graph scheduling, %d procs remaining (in cycles).@." L.progress "Finished call graph scheduling, %d procs remaining (in cycles).@."
(SyntacticCallGraph.n_procs g) ; (CallGraph.n_procs syntactic_call_graph) ;
if Config.debug_level_analysis > 0 then SyntacticCallGraph.to_dotty g "cycles.dot" ; if Config.debug_level_analysis > 0 then CallGraph.to_dotty syntactic_call_graph "cycles.dot" ;
(* save some memory *) (* save some memory *)
SyntacticCallGraph.reset g ) ; CallGraph.reset syntactic_call_graph ) ;
empty empty
in in
let rec next_aux () = let rec next_aux () =
match !pending with 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 () 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 ; pending := ns ;
next_aux () next_aux ()
| n :: ns -> | n :: ns ->
pending := ns ; pending := ns ;
scheduled := Typ.Procname.Set.add n.pname !scheduled ; 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) Some (Procname n.pname)
in in
let finished = function let finished = function
@ -80,12 +80,12 @@ let bottom_up sources : target task_generator =
| Procname pname -> | Procname pname ->
decr remaining ; decr remaining ;
scheduled := Typ.Procname.Set.remove pname !scheduled ; scheduled := Typ.Procname.Set.remove pname !scheduled ;
SyntacticCallGraph.remove_reachable g pname CallGraph.remove_reachable syntactic_call_graph pname
in in
let next () = let next () =
(* do construction here, to avoid having the call graph into forked workers *) (* do construction here, to avoid having the call graph into forked workers *)
if not !initialized then ( if not !initialized then (
SyntacticCallGraph.build_from_sources g sources ; SyntacticCallGraph.build_from_sources syntactic_call_graph sources ;
initialized := true ) ; initialized := true ) ;
next_aux () next_aux ()
in in

Write Preview
Loading…
Cancel
Save