Skip to content

Commit 82eb91f

Browse files
Phoebe Nicholsfacebook-github-bot
Phoebe Nichols
authored and
facebook-github-bot
committed
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
1 parent 15246ec commit 82eb91f

File tree

5 files changed

+213
-187
lines changed

5 files changed

+213
-187
lines changed

‎infer/src/backend/CallGraph.ml‎

Lines changed: 136 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,136 @@
1+
(*
2+
* Copyright (c) Facebook, Inc. and its affiliates.
3+
*
4+
* This source code is licensed under the MIT license found in the
5+
* LICENSE file in the root directory of this source tree.
6+
*)
7+
open! IStd
8+
module F = Format
9+
10+
module type NodeSig = sig
11+
type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool}
12+
13+
val make : int -> Typ.Procname.t -> int list -> t
14+
15+
val set_flag : t -> unit
16+
17+
val unset_flag : t -> unit
18+
19+
val pp_dot : F.formatter -> t -> unit
20+
end
21+
22+
module Node : NodeSig = struct
23+
type t = {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool}
24+
25+
let make id pname successors = {id; pname; successors; flag= false}
26+
27+
let set_flag n = n.flag <- true
28+
29+
let unset_flag n = n.flag <- false
30+
31+
let pp_dot fmt {id; pname; successors} =
32+
let pp_id fmt id = F.fprintf fmt "N%d" id in
33+
let pp_edge fmt src dst = F.fprintf fmt " %a -> %a ;@\n" pp_id src pp_id dst in
34+
F.fprintf fmt " %a [ label = %S ];@\n" pp_id id (F.asprintf "%a" Typ.Procname.pp pname) ;
35+
List.iter successors ~f:(pp_edge fmt id) ;
36+
F.pp_print_newline fmt ()
37+
end
38+
39+
module IdMap = Typ.Procname.Hash
40+
module NodeMap = Caml.Hashtbl.Make (Int)
41+
42+
(** [node_map] is a map from ids (unique ints) to nodes corresponding to defined procedures.
43+
[id_map] is a map from all encountered (not necessarily defined) procnames to their ids,
44+
and thus its image is a superset of the domain of [node_map], and usually a strict superset.
45+
[trim_id_map] makes the image equal to the domain of [node_map]. *)
46+
type t = {id_map: int IdMap.t; node_map: Node.t NodeMap.t}
47+
48+
let reset {id_map; node_map} = IdMap.reset id_map ; NodeMap.reset node_map
49+
50+
let create initial_capacity =
51+
{id_map= IdMap.create initial_capacity; node_map= NodeMap.create initial_capacity}
52+
53+
54+
let id_of_procname {id_map} pname = IdMap.find_opt id_map pname
55+
56+
let node_of_id {node_map} id = NodeMap.find_opt node_map id
57+
58+
let mem {node_map} id = NodeMap.mem node_map id
59+
60+
(** [id_map] may contain undefined procedures, so use [node_map] for actual size *)
61+
let n_procs {node_map} = NodeMap.length node_map
62+
63+
let node_of_procname g pname = id_of_procname g pname |> Option.bind ~f:(node_of_id g)
64+
65+
let remove (g : t) pname id = IdMap.remove g.id_map pname ; NodeMap.remove g.node_map id
66+
67+
let add ({id_map; node_map} as graph) pname successor_pnames =
68+
let get_or_set_id procname =
69+
match id_of_procname graph procname with
70+
| None ->
71+
let id = IdMap.length id_map in
72+
IdMap.replace id_map procname id ; id
73+
| Some id ->
74+
id
75+
in
76+
let id = get_or_set_id pname in
77+
let successors = List.map successor_pnames ~f:get_or_set_id in
78+
let node = Node.make id pname successors in
79+
NodeMap.replace node_map id node
80+
81+
82+
let remove_reachable g start_pname =
83+
let add_live_successors_and_remove_self init (n : Node.t) =
84+
remove g n.pname n.id ;
85+
List.fold n.successors ~init ~f:(fun init succ_id ->
86+
node_of_id g succ_id |> Option.fold ~init ~f:(fun acc s -> s :: acc) )
87+
in
88+
let rec remove_list frontier =
89+
if not (List.is_empty frontier) then
90+
remove_list (List.fold frontier ~init:[] ~f:add_live_successors_and_remove_self)
91+
in
92+
node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> remove_list [start_node])
93+
94+
95+
let flag_reachable g start_pname =
96+
let process_node init (n : Node.t) =
97+
if n.flag then init
98+
else (
99+
Node.set_flag n ;
100+
List.fold n.successors ~init ~f:(fun acc id ->
101+
match node_of_id g id with Some n' when not n'.flag -> n' :: acc | _ -> acc ) )
102+
in
103+
let rec flag_list frontier =
104+
if not (List.is_empty frontier) then flag_list (List.fold frontier ~init:[] ~f:process_node)
105+
in
106+
node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> flag_list [start_node])
107+
108+
109+
let trim_id_map (g : t) =
110+
IdMap.filter_map_inplace (fun _pname id -> Option.some_if (mem g id) id) g.id_map
111+
112+
113+
let pp_dot fmt {node_map} =
114+
F.fprintf fmt "@\ndigraph callgraph {@\n" ;
115+
NodeMap.iter (fun _id n -> Node.pp_dot fmt n) node_map ;
116+
F.fprintf fmt "}@."
117+
118+
119+
let to_dotty g filename =
120+
let outc = Filename.concat Config.results_dir filename |> Out_channel.create in
121+
let fmt = F.formatter_of_out_channel outc in
122+
pp_dot fmt g ; Out_channel.close outc
123+
124+
125+
let remove_unflagged_and_unflag_all {id_map; node_map} =
126+
NodeMap.filter_map_inplace
127+
(fun _id (n : Node.t) ->
128+
if n.flag then ( Node.unset_flag n ; Some n ) else ( IdMap.remove id_map n.pname ; None ) )
129+
node_map
130+
131+
132+
let get_unflagged_leaves g =
133+
NodeMap.fold
134+
(fun _id (n : Node.t) acc ->
135+
if n.flag || List.exists n.successors ~f:(mem g) then acc else n :: acc )
136+
g.node_map []

‎infer/src/backend/CallGraph.mli‎

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
(*
2+
* Copyright (c) Facebook, Inc. and its affiliates.
3+
*
4+
* This source code is licensed under the MIT license found in the
5+
* LICENSE file in the root directory of this source tree.
6+
*)
7+
open! IStd
8+
module F = Format
9+
10+
module type NodeSig = sig
11+
type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool}
12+
13+
val make : int -> Typ.Procname.t -> int list -> t
14+
15+
val set_flag : t -> unit
16+
17+
val unset_flag : t -> unit
18+
19+
val pp_dot : F.formatter -> t -> unit
20+
end
21+
22+
module Node : NodeSig
23+
24+
module IdMap = Typ.Procname.Hash
25+
26+
type t
27+
28+
val reset : t -> unit
29+
(** empty the graph and shrink it to its initial size *)
30+
31+
val create : int -> t
32+
(** [create n] makes an empty graph with initial capacity [n] which grows as required *)
33+
34+
val n_procs : t -> int
35+
(** number of procedures in graph *)
36+
37+
val mem : t -> int -> bool
38+
(** is an int [id] the index of a node in the graph? *)
39+
40+
val flag_reachable : t -> Typ.Procname.t -> unit
41+
(** flag all nodes reachable from the node of the given procname, if it exists *)
42+
43+
val get_unflagged_leaves : t -> Node.t list
44+
(** get all leaves that have their flag set to false *)
45+
46+
val remove_reachable : t -> Typ.Procname.t -> unit
47+
(** remove all nodes reachable from procname *)
48+
49+
val to_dotty : t -> string -> unit
50+
(** output call graph in dotty format with the given filename in results dir *)
51+
52+
val trim_id_map : t -> unit
53+
(** remove all pnames that do not correspond to a defined procedure from id_map *)
54+
55+
val remove_unflagged_and_unflag_all : t -> unit
56+
(** remove all nodes with flag set to false, and set flag to false on all remaining nodes *)
57+
58+
val add : t -> IdMap.key -> IdMap.key sexp_list -> unit
59+
(** add edges from [pname] to [successor_pnames] in the graph *)

‎infer/src/backend/SyntacticCallGraph.ml‎

Lines changed: 7 additions & 137 deletions
Original file line numberDiff line numberDiff line change
@@ -5,131 +5,8 @@
55
* LICENSE file in the root directory of this source tree.
66
*)
77
open! IStd
8-
module F = Format
98
module L = Logging
10-
11-
module type NodeSig = sig
12-
type t = private {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool}
13-
14-
val make : int -> Typ.Procname.t -> int list -> t
15-
16-
val set_flag : t -> unit
17-
18-
val unset_flag : t -> unit
19-
20-
val pp_dot : F.formatter -> t -> unit
21-
end
22-
23-
module Node : NodeSig = struct
24-
type t = {id: int; pname: Typ.Procname.t; successors: int list; mutable flag: bool}
25-
26-
let make id pname successors = {id; pname; successors; flag= false}
27-
28-
let set_flag n = n.flag <- true
29-
30-
let unset_flag n = n.flag <- false
31-
32-
let pp_dot fmt {id; pname; successors} =
33-
let pp_id fmt id = F.fprintf fmt "N%d" id in
34-
let pp_edge fmt src dst = F.fprintf fmt " %a -> %a ;@\n" pp_id src pp_id dst in
35-
F.fprintf fmt " %a [ label = %S ];@\n" pp_id id (F.asprintf "%a" Typ.Procname.pp pname) ;
36-
List.iter successors ~f:(pp_edge fmt id) ;
37-
F.pp_print_newline fmt ()
38-
end
39-
409
module IdMap = Typ.Procname.Hash
41-
module NodeMap = Caml.Hashtbl.Make (Int)
42-
43-
(** [node_map] is a map from ids (unique ints) to nodes corresponding to defined procedures.
44-
[id_map] is a map from all encountered (not necessarily defined) procnames to their ids,
45-
and thus its image is a superset of the domain of [node_map], and usually a strict superset.
46-
[trim_id_map] makes the image equal to the domain of [node_map]. *)
47-
type t = {id_map: int IdMap.t; node_map: Node.t NodeMap.t}
48-
49-
let reset {id_map; node_map} = IdMap.reset id_map ; NodeMap.reset node_map
50-
51-
let create initial_capacity =
52-
{id_map= IdMap.create initial_capacity; node_map= NodeMap.create initial_capacity}
53-
54-
55-
let id_of_procname {id_map} pname = IdMap.find_opt id_map pname
56-
57-
let node_of_id {node_map} id = NodeMap.find_opt node_map id
58-
59-
let mem {node_map} id = NodeMap.mem node_map id
60-
61-
(** [id_map] may contain undefined procedures, so use [node_map] for actual size *)
62-
let n_procs {node_map} = NodeMap.length node_map
63-
64-
let node_of_procname g pname = id_of_procname g pname |> Option.bind ~f:(node_of_id g)
65-
66-
let remove (g : t) pname id = IdMap.remove g.id_map pname ; NodeMap.remove g.node_map id
67-
68-
let add ({id_map; node_map} as graph) pname successor_pnames =
69-
let get_or_set_id procname =
70-
match id_of_procname graph procname with
71-
| None ->
72-
let id = IdMap.length id_map in
73-
IdMap.replace id_map procname id ; id
74-
| Some id ->
75-
id
76-
in
77-
let id = get_or_set_id pname in
78-
let successors = List.map successor_pnames ~f:get_or_set_id in
79-
let node = Node.make id pname successors in
80-
NodeMap.replace node_map id node
81-
82-
83-
let remove_reachable g start_pname =
84-
let add_live_successors_and_remove_self init (n : Node.t) =
85-
remove g n.pname n.id ;
86-
List.fold n.successors ~init ~f:(fun init succ_id ->
87-
node_of_id g succ_id |> Option.fold ~init ~f:(fun acc s -> s :: acc) )
88-
in
89-
let rec remove_list frontier =
90-
if not (List.is_empty frontier) then
91-
remove_list (List.fold frontier ~init:[] ~f:add_live_successors_and_remove_self)
92-
in
93-
node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> remove_list [start_node])
94-
95-
96-
let flag_reachable g start_pname =
97-
let process_node init (n : Node.t) =
98-
if n.flag then init
99-
else (
100-
Node.set_flag n ;
101-
List.fold n.successors ~init ~f:(fun acc id ->
102-
match node_of_id g id with Some n' when not n'.flag -> n' :: acc | _ -> acc ) )
103-
in
104-
let rec flag_list frontier =
105-
if not (List.is_empty frontier) then flag_list (List.fold frontier ~init:[] ~f:process_node)
106-
in
107-
node_of_procname g start_pname |> Option.iter ~f:(fun start_node -> flag_list [start_node])
108-
109-
110-
let remove_unflagged_and_unflag_all {id_map; node_map} =
111-
NodeMap.filter_map_inplace
112-
(fun _id (n : Node.t) ->
113-
if n.flag then ( Node.unset_flag n ; Some n ) else ( IdMap.remove id_map n.pname ; None ) )
114-
node_map
115-
116-
117-
(** remove pnames for all undefined procedures *)
118-
let trim_id_map (g : t) =
119-
IdMap.filter_map_inplace (fun _pname id -> Option.some_if (mem g id) id) g.id_map
120-
121-
122-
let pp_dot fmt {node_map} =
123-
F.fprintf fmt "@\ndigraph callgraph {@\n" ;
124-
NodeMap.iter (fun _id n -> Node.pp_dot fmt n) node_map ;
125-
F.fprintf fmt "}@."
126-
127-
128-
let to_dotty g filename =
129-
let outc = Filename.concat Config.results_dir filename |> Out_channel.create in
130-
let fmt = F.formatter_of_out_channel outc in
131-
pp_dot fmt g ; Out_channel.close outc
132-
13310

13411
let build_from_captured_procs g =
13512
let hashcons_pname =
@@ -148,27 +25,20 @@ let build_from_captured_procs g =
14825
let callees =
14926
Sqlite3.column stmt 1 |> Typ.Procname.SQLiteList.deserialize |> List.map ~f:hashcons_pname
15027
in
151-
add g proc_name callees )
28+
CallGraph.add g proc_name callees )
15229

15330

15431
let build_from_sources g sources =
15532
let time0 = Mtime_clock.counter () in
15633
L.progress "Building call graph...@\n%!" ;
15734
build_from_captured_procs g ;
158-
let n_captured = n_procs g in
35+
let n_captured = CallGraph.n_procs g in
15936
List.iter sources ~f:(fun sf ->
160-
SourceFiles.proc_names_of_source sf |> List.iter ~f:(flag_reachable g) ) ;
161-
remove_unflagged_and_unflag_all g ;
162-
trim_id_map g ;
163-
if Config.debug_level_analysis > 0 then to_dotty g "callgraph.dot" ;
37+
SourceFiles.proc_names_of_source sf |> List.iter ~f:(CallGraph.flag_reachable g) ) ;
38+
CallGraph.remove_unflagged_and_unflag_all g ;
39+
CallGraph.trim_id_map g ;
40+
if Config.debug_level_analysis > 0 then CallGraph.to_dotty g "callgraph.dot" ;
16441
L.progress
16542
"Built call graph in %a, from %d total procs, %d reachable defined procs and takes %d bytes@."
166-
Mtime.Span.pp (Mtime_clock.count time0) n_captured (n_procs g)
43+
Mtime.Span.pp (Mtime_clock.count time0) n_captured (CallGraph.n_procs g)
16744
(Obj.(reachable_words (repr g)) * (Sys.word_size / 8))
168-
169-
170-
let get_unflagged_leaves g =
171-
NodeMap.fold
172-
(fun _id (n : Node.t) acc ->
173-
if n.flag || List.exists n.successors ~f:(mem g) then acc else n :: acc )
174-
g.node_map []

0 commit comments

Comments
 (0)