You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
665 lines
26 KiB
665 lines
26 KiB
(*
|
|
* 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.
|
|
*)
|
|
|
|
(** Execution Paths *)
|
|
|
|
module L = Logging
|
|
module F = Format
|
|
open Utils
|
|
|
|
(* =============== START of the Path module ===============*)
|
|
|
|
module Path : sig
|
|
(** type for paths *)
|
|
type t
|
|
|
|
type session = int
|
|
|
|
(** add a call with its sub-path, the boolean indicates whether the subtrace for the procedure should be included *)
|
|
val add_call : bool -> t -> Procname.t -> t -> t
|
|
|
|
(** check whether a path contains another path *)
|
|
val contains : t -> t -> bool
|
|
|
|
(** check wether the path contains the given position *)
|
|
val contains_position : t -> Sil.path_pos -> bool
|
|
|
|
(** Create the location trace of the path, up to the path position if specified *)
|
|
val create_loc_trace : t -> Sil.path_pos option -> Errlog.loc_trace
|
|
|
|
(** return the current node of the path *)
|
|
val curr_node : t -> Cfg.node
|
|
|
|
(** dump a path *)
|
|
val d : t -> unit
|
|
|
|
(** dump statistics of the path *)
|
|
val d_stats : t -> unit
|
|
|
|
(** equality for paths *)
|
|
val equal : t -> t -> bool
|
|
|
|
(** extend a path with a new node reached from the given session, with an optional string for exceptions *)
|
|
val extend : Cfg.node -> Mangled.t option -> session -> t -> t
|
|
|
|
(** extend a path with a new node reached from the given session, with an optional string for exceptions *)
|
|
val add_description : t -> string -> t
|
|
|
|
val get_description : t -> string option
|
|
|
|
(** iterate over each node in the path, excluding calls, once *)
|
|
val iter_all_nodes_nocalls : (Cfg.node -> unit) -> t -> unit
|
|
|
|
(** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
|
|
Do not iterate past the given position.
|
|
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *)
|
|
val iter_longest_sequence : (int -> t -> int -> Mangled.t option -> unit) -> Sil.path_pos option -> t -> unit
|
|
|
|
(** join two paths *)
|
|
val join : t -> t -> t
|
|
|
|
(** pretty print a path *)
|
|
val pp : Format.formatter -> t -> unit
|
|
|
|
(** pretty print statistics of the path *)
|
|
val pp_stats : Format.formatter -> t -> unit
|
|
|
|
(** create a new path with given start node *)
|
|
val start : Cfg.node -> t
|
|
end = struct
|
|
type session = int
|
|
type stats =
|
|
{ mutable max_length : int; (* length of the longest linear sequence *)
|
|
mutable linear_num : float; (* number of linear sequences described by the path *) }
|
|
|
|
type path =
|
|
(* INVARIANT: stats are always set to dummy_stats unless we are in the middle of a traversal *)
|
|
(* in particular: a new traversal cannot be initiated during an existing traversal *)
|
|
| Pstart of Cfg.node * stats (** start node *)
|
|
| Pnode of Cfg.node * Mangled.t option * session * path * stats * string option (** we got to [node] from last [session] perhaps propagating exception [exn_opt], and continue with [path]. *)
|
|
| Pjoin of path * path * stats (** join of two paths *)
|
|
| Pcall of path * Procname.t * path * stats (** add a sub-path originating from a call *)
|
|
|
|
type t = path
|
|
|
|
let get_dummy_stats () =
|
|
{ max_length = - 1;
|
|
linear_num = - 1.0 }
|
|
|
|
let get_description path =
|
|
match path with
|
|
| Pnode (node, exn_opt, session, path, stats, descr_opt) ->
|
|
descr_opt
|
|
| _ -> None
|
|
|
|
let add_description path description =
|
|
let add_descr descr_option description =
|
|
match descr_option with
|
|
| Some descr -> descr^" "^description
|
|
| None -> description in
|
|
match path with
|
|
| Pnode (node, exn_opt, session, path, stats, descr_opt) ->
|
|
let description = add_descr descr_opt description in
|
|
Pnode (node, exn_opt, session, path, stats, Some description)
|
|
| _ -> path
|
|
|
|
let set_dummy_stats stats =
|
|
stats.max_length <- - 1;
|
|
stats.linear_num <- - 1.0
|
|
|
|
let rec curr_node = function
|
|
| Pstart (node, _) -> node
|
|
| Pnode (node, _, _, _, _, _) -> node
|
|
| Pcall(p1, _, _, _) -> curr_node p1
|
|
| Pjoin _ -> assert false
|
|
|
|
let exname_opt_compare eo1 eo2 = match eo1, eo2 with
|
|
| None, None -> 0
|
|
| None, _ -> -1
|
|
| _, None -> 1
|
|
| Some n1, Some n2 -> Mangled.compare n1 n2
|
|
|
|
let rec compare p1 p2 : int =
|
|
if p1 == p2 then 0 else match p1, p2 with
|
|
| Pstart (n1, _), Pstart (n2, _) ->
|
|
Cfg.Node.compare n1 n2
|
|
| Pstart _, _ -> - 1
|
|
| _, Pstart _ -> 1
|
|
| Pnode (n1, eo1, s1, p1, _, _), Pnode (n2, eo2, s2, p2, _, _) ->
|
|
let n = Cfg.Node.compare n1 n2 in
|
|
if n <> 0 then n else let n = exname_opt_compare eo1 eo2 in
|
|
if n <> 0 then n else let n = int_compare s1 s2 in
|
|
if n <> 0 then n else compare p1 p2
|
|
| Pnode _, _ -> - 1
|
|
| _, Pnode _ -> 1
|
|
| Pjoin (p1, q1, _), Pjoin (p2, q2, _) ->
|
|
let n = compare p1 p2 in
|
|
if n <> 0 then n else compare q1 q2
|
|
| Pjoin _, _ -> -1
|
|
| _, Pjoin _ -> 1
|
|
| Pcall(p1, _, sub1, _), Pcall(p2, _, sub2, _) ->
|
|
let n = compare p1 p2 in
|
|
if n <> 0 then n else compare sub1 sub2
|
|
|
|
let equal p1 p2 =
|
|
compare p1 p2 = 0
|
|
|
|
let start node = Pstart (node, get_dummy_stats ())
|
|
|
|
let extend (node: Cfg.node) exn_opt session path =
|
|
Pnode (node, exn_opt, session, path, get_dummy_stats (), None)
|
|
|
|
let join p1 p2 =
|
|
Pjoin (p1, p2, get_dummy_stats ())
|
|
|
|
let add_call include_subtrace p pname p_sub =
|
|
if include_subtrace then Pcall(p, pname, p_sub, get_dummy_stats ())
|
|
else p
|
|
|
|
module Invariant = (** functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *)
|
|
struct
|
|
(** check whether a stats is the dummy stats *)
|
|
let stats_is_dummy stats =
|
|
stats.max_length == - 1
|
|
|
|
(** return the stats of the path *)
|
|
(** assumes that the stats are computed *)
|
|
let get_stats = function
|
|
| Pstart (_, stats) -> stats
|
|
| Pnode (_, _, _, _, stats, _) -> stats
|
|
| Pjoin (_, _, stats) -> stats
|
|
| Pcall (_, _, _, stats) -> stats
|
|
|
|
(** restore the invariant that all the stats are dummy, so the path is ready for another traversal *)
|
|
(** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *)
|
|
let rec reset_stats = function
|
|
| Pstart (node, stats) ->
|
|
if not (stats_is_dummy stats) then set_dummy_stats stats
|
|
| Pnode (node, exn_opt, session, path, stats, _) ->
|
|
if not (stats_is_dummy stats) then
|
|
begin
|
|
reset_stats path;
|
|
set_dummy_stats stats
|
|
end
|
|
| Pjoin (path1, path2, stats) ->
|
|
if not (stats_is_dummy stats) then
|
|
begin
|
|
reset_stats path1;
|
|
reset_stats path2;
|
|
set_dummy_stats stats
|
|
end
|
|
| Pcall (path1, pname, path2, stats) ->
|
|
if not (stats_is_dummy stats) then
|
|
begin
|
|
reset_stats path1;
|
|
reset_stats path2;
|
|
set_dummy_stats stats
|
|
end
|
|
|
|
(** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *)
|
|
(** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats
|
|
is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node.
|
|
max_length is 0 if the path was visited but no node satisfying [f] was found. *)
|
|
(** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *)
|
|
(** Since this breaks the invariant, it must be followed by reset_stats. *)
|
|
let rec compute_stats do_calls (f : Cfg.Node.t -> bool) =
|
|
let nodes_found stats = stats.max_length > 0 in
|
|
function
|
|
| Pstart (node, stats) ->
|
|
if stats_is_dummy stats then
|
|
begin
|
|
let found = f node in
|
|
stats.max_length <- if found then 1 else 0;
|
|
stats.linear_num <- 1.0;
|
|
end
|
|
| Pnode (node, exn_opt, session, path, stats, _) ->
|
|
if stats_is_dummy stats then
|
|
begin
|
|
compute_stats do_calls f path;
|
|
let stats1 = get_stats path in
|
|
let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in
|
|
stats.max_length <- if found then 1 + stats1.max_length else 0;
|
|
stats.linear_num <- stats1.linear_num;
|
|
end
|
|
| Pjoin (path1, path2, stats) ->
|
|
if stats_is_dummy stats then
|
|
begin
|
|
compute_stats do_calls f path1;
|
|
compute_stats do_calls f path2;
|
|
let stats1, stats2 = get_stats path1, get_stats path2 in
|
|
stats.max_length <- max stats1.max_length stats2.max_length;
|
|
stats.linear_num <- stats1.linear_num +. stats2.linear_num
|
|
end
|
|
| Pcall (path1, pname, path2, stats) ->
|
|
if stats_is_dummy stats then
|
|
begin
|
|
let stats2 = match do_calls with
|
|
| true ->
|
|
compute_stats do_calls f path2;
|
|
get_stats path2
|
|
| false ->
|
|
{ max_length = 0;
|
|
linear_num = 0.0 } in
|
|
let stats1 =
|
|
let f' =
|
|
if nodes_found stats2
|
|
then fun _ -> true (* already found in call, no need to search before the call *)
|
|
else f in
|
|
compute_stats do_calls f' path1;
|
|
get_stats path1 in
|
|
stats.max_length <- stats1.max_length + stats2.max_length;
|
|
stats.linear_num <- stats1.linear_num;
|
|
end
|
|
end (* End of module Invariant *)
|
|
|
|
(** iterate over each node in the path, excluding calls, once *)
|
|
let iter_all_nodes_nocalls f path =
|
|
Invariant.compute_stats false (fun node -> f node; true) path;
|
|
Invariant.reset_stats path
|
|
|
|
let get_path_pos node =
|
|
let pn = Cfg.Procdesc.get_proc_name (Cfg.Node.get_proc_desc node) in
|
|
let n_id = Cfg.Node.get_id node in
|
|
(pn, n_id)
|
|
|
|
let contains_position path pos =
|
|
let found = ref false in
|
|
let f node =
|
|
if Sil.path_pos_equal (get_path_pos node) pos then found := true;
|
|
true in
|
|
Invariant.compute_stats true f path;
|
|
Invariant.reset_stats path;
|
|
!found
|
|
|
|
(** iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element.
|
|
if a node is reached via an exception, pass the exception information to [f] on the previous node *)
|
|
let iter_longest_sequence_filter (f : int -> t -> int -> Mangled.t option -> unit) (filter: Cfg.Node.t -> bool) (path: t) : unit =
|
|
let rec doit level session path prev_exn_opt = match path with
|
|
| Pstart _ -> f level path session prev_exn_opt
|
|
| Pnode (node, exn_opt, session', p, _, _) ->
|
|
let next_exn_opt = if prev_exn_opt <> None then None else exn_opt in (* no two consecutive exceptions *)
|
|
doit level session' p next_exn_opt;
|
|
f level path session prev_exn_opt
|
|
| Pjoin (p1, p2, _) ->
|
|
if (Invariant.get_stats p1).max_length >= (Invariant.get_stats p2).max_length then doit level session p1 prev_exn_opt else doit level session p2 prev_exn_opt
|
|
| Pcall (p1, _, p2, _) ->
|
|
let next_exn_opt = None in (* exn must already be inside the call *)
|
|
doit level session p1 next_exn_opt;
|
|
doit (level +1) session p2 next_exn_opt in
|
|
Invariant.compute_stats true filter path;
|
|
doit 0 0 path None;
|
|
Invariant.reset_stats path
|
|
|
|
(** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
|
|
Do not iterate past the last occurrence of the given position.
|
|
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *)
|
|
let iter_longest_sequence (f : int -> t -> int -> Mangled.t option -> unit) (pos_opt : Sil.path_pos option) (path: t) : unit =
|
|
let filter node = match pos_opt with
|
|
| None -> true
|
|
| Some pos -> Sil.path_pos_equal (get_path_pos node) pos in
|
|
let path_pos_at_path p =
|
|
try
|
|
let node = curr_node p in
|
|
pos_opt <> None && filter node
|
|
with exn when exn_not_timeout exn -> false in
|
|
let position_seen = ref false in
|
|
let inverse_sequence =
|
|
let log = ref [] in
|
|
let g level p session exn_opt =
|
|
if path_pos_at_path p then position_seen := true;
|
|
log := (level, p, session, exn_opt) :: !log in
|
|
iter_longest_sequence_filter g filter path;
|
|
!log in
|
|
let sequence_up_to_last_seen =
|
|
if !position_seen then
|
|
let rec remove_until_seen = function
|
|
| ((level, p, session, exn_opt) as x):: l ->
|
|
if path_pos_at_path p then list_rev (x :: l)
|
|
else remove_until_seen l
|
|
| [] -> [] in
|
|
remove_until_seen inverse_sequence
|
|
else list_rev inverse_sequence in
|
|
list_iter (fun (level, p, session, exn_opt) -> f level p session exn_opt) sequence_up_to_last_seen
|
|
|
|
module NodeMap = Map.Make (Cfg.Node)
|
|
|
|
(** return the node visited most, and number of visits, in the longest linear sequence *)
|
|
let repetitions path =
|
|
let map = ref NodeMap.empty in
|
|
let add_node node =
|
|
try
|
|
let n = NodeMap.find node !map in
|
|
map := NodeMap.add node (n + 1) !map
|
|
with Not_found ->
|
|
map := NodeMap.add node 1 !map in
|
|
iter_longest_sequence (fun level p s exn_opt -> add_node (curr_node p)) None path;
|
|
let max_rep_node = ref (Cfg.Node.dummy ()) in
|
|
let max_rep_num = ref 0 in
|
|
NodeMap.iter (fun node num -> if num > !max_rep_num then (max_rep_node := node; max_rep_num := num)) !map;
|
|
(!max_rep_node, !max_rep_num)
|
|
|
|
let stats_string path =
|
|
Invariant.compute_stats true (fun _ -> true) path;
|
|
let node, repetitions = repetitions path in
|
|
let str =
|
|
"linear paths: " ^ string_of_float (Invariant.get_stats path).linear_num ^
|
|
" max length: " ^ string_of_int (Invariant.get_stats path).max_length ^
|
|
" has repetitions: " ^ string_of_int repetitions ^
|
|
" of node " ^ (string_of_int (Cfg.Node.get_id node)) in
|
|
Invariant.reset_stats path;
|
|
str
|
|
|
|
let pp_stats fmt path =
|
|
F.fprintf fmt "%s" (stats_string path)
|
|
|
|
let d_stats path =
|
|
L.d_str (stats_string path)
|
|
|
|
module PathMap = Map.Make (struct
|
|
type t = path
|
|
let compare = compare
|
|
end)
|
|
|
|
let pp fmt path =
|
|
let delayed_num = ref 0 in
|
|
let delayed = ref PathMap.empty in
|
|
let add_path p =
|
|
try ignore (PathMap.find p !delayed) with Not_found ->
|
|
incr delayed_num;
|
|
delayed := PathMap.add p !delayed_num !delayed in
|
|
let path_seen p = (* path seen before *)
|
|
PathMap.mem p !delayed in
|
|
let rec add_delayed path =
|
|
if not (path_seen path) (* avoid exponential blowup *)
|
|
then match path with (* build a map from delayed paths to a unique number *)
|
|
| Pstart _ -> ()
|
|
| Pnode (_, _, _, p, _, _) -> add_delayed p
|
|
| Pjoin (p1, p2, _) | Pcall(p1, _, p2, _) -> (* delay paths occurring in a join *)
|
|
add_delayed p1;
|
|
add_delayed p2;
|
|
add_path p1;
|
|
add_path p2 in
|
|
let rec doit n fmt path =
|
|
try
|
|
if n > 0 then raise Not_found;
|
|
let num = PathMap.find path !delayed in
|
|
F.fprintf fmt "P%d" num
|
|
with Not_found ->
|
|
match path with
|
|
| Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node
|
|
| Pnode (node, exn_top, session, path, _, _) -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node
|
|
| Pjoin (path1, path2, _) -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2
|
|
| Pcall (path1, _, path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in
|
|
let print_delayed () =
|
|
if not (PathMap.is_empty !delayed) then begin
|
|
let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in
|
|
F.fprintf fmt "where@\n";
|
|
PathMap.iter f !delayed
|
|
end in
|
|
add_delayed path;
|
|
doit 0 fmt path;
|
|
print_delayed ()
|
|
|
|
let d p =
|
|
L.add_print_action (L.PTpath, Obj.repr p)
|
|
|
|
let rec contains p1 p2 = match p2 with
|
|
| Pjoin (p2', p2'', _) ->
|
|
contains p1 p2' || contains p1 p2''
|
|
| _ -> p1 == p2
|
|
|
|
let create_loc_trace path pos_opt : Errlog.loc_trace =
|
|
let trace = ref [] in
|
|
let mk_trace_elem level loc descr node_tags =
|
|
{ Errlog.lt_level = level;
|
|
Errlog.lt_loc = loc;
|
|
Errlog.lt_description = descr;
|
|
Errlog.lt_node_tags = node_tags } in
|
|
let g level path session exn_opt =
|
|
let curr_node = curr_node path in
|
|
let curr_loc = Cfg.Node.get_loc curr_node in
|
|
match Cfg.Node.get_kind curr_node with
|
|
| Cfg.Node.Join_node -> () (* omit join nodes from error traces *)
|
|
| Cfg.Node.Start_node pdesc ->
|
|
let pname = Cfg.Procdesc.get_proc_name pdesc in
|
|
let name = Procname.to_string pname in
|
|
let name_id = Procname.to_filename pname in
|
|
let descr = "start of procedure " ^ (Procname.to_simplified_string pname) in
|
|
let node_tags = [(Io_infer.Xml.tag_kind,"procedure_start"); (Io_infer.Xml.tag_name, name); (Io_infer.Xml.tag_name_id, name_id)] in
|
|
trace := mk_trace_elem level curr_loc descr node_tags :: !trace
|
|
| Cfg.Node.Prune_node (is_true_branch, if_kind, _) ->
|
|
let descr = match is_true_branch, if_kind with
|
|
| true, Sil.Ik_if -> "Taking true branch"
|
|
| false, Sil.Ik_if -> "Taking false branch"
|
|
| true, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) -> "Loop condition is true. Entering loop body"
|
|
| false, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) -> "Loop condition is false. Leaving loop"
|
|
| true, Sil.Ik_switch -> "Switch condition is true. Entering switch case"
|
|
| false, Sil.Ik_switch -> "Switch condition is false. Skipping switch case"
|
|
| true, (Sil.Ik_bexp | Sil.Ik_land_lor) -> "Condition is true"
|
|
| false, (Sil.Ik_bexp | Sil.Ik_land_lor) -> "Condition is false" in
|
|
let node_tags = [(Io_infer.Xml.tag_kind,"condition"); (Io_infer.Xml.tag_branch, if is_true_branch then "true" else "false")] in
|
|
trace := mk_trace_elem level curr_loc descr node_tags :: !trace
|
|
| Cfg.Node.Exit_node pdesc ->
|
|
let pname = Cfg.Procdesc.get_proc_name pdesc in
|
|
let descr = "return from a call to " ^ (Procname.to_string pname) in
|
|
let name = Procname.to_string pname in
|
|
let name_id = Procname.to_filename pname in
|
|
let node_tags = [(Io_infer.Xml.tag_kind,"procedure_end"); (Io_infer.Xml.tag_name, name); (Io_infer.Xml.tag_name_id, name_id)] in
|
|
trace := mk_trace_elem level curr_loc descr node_tags :: !trace
|
|
| _ ->
|
|
let descr, node_tags =
|
|
match exn_opt with
|
|
| None -> "", []
|
|
| Some exn_name ->
|
|
let exn_str = Mangled.to_string exn_name in
|
|
if exn_str = ""
|
|
then "exception", [(Io_infer.Xml.tag_kind,"exception")]
|
|
else "exception " ^ exn_str, [(Io_infer.Xml.tag_kind,"exception"); (Io_infer.Xml.tag_name, exn_str)] in
|
|
let descr =
|
|
match get_description path with
|
|
| Some path_descr ->
|
|
if String.length descr > 0 then descr^" "^path_descr else path_descr
|
|
| None -> descr in
|
|
trace := mk_trace_elem level curr_loc descr node_tags :: !trace in
|
|
iter_longest_sequence g pos_opt path;
|
|
let compare lt1 lt2 =
|
|
let n = int_compare lt1.Errlog.lt_level lt2.Errlog.lt_level in
|
|
if n <> 0 then n else Location.compare lt1.Errlog.lt_loc lt2.Errlog.lt_loc in
|
|
let relevant lt = lt.Errlog.lt_node_tags <> [] in
|
|
list_remove_irrelevant_duplicates compare relevant (list_rev !trace)
|
|
(* list_remove_duplicates compare (list_sort compare !trace) *)
|
|
|
|
end
|
|
(* =============== END of the Path module ===============*)
|
|
|
|
module PropMap = Map.Make (struct
|
|
type t = Prop.normal Prop.t
|
|
let compare = Prop.prop_compare
|
|
end)
|
|
|
|
(* =============== START of the PathSet module ===============*)
|
|
module PathSet : sig
|
|
type t
|
|
|
|
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *)
|
|
val add_renamed_prop : Prop.normal Prop.t -> Path.t -> t -> t
|
|
|
|
(** dump the pathset *)
|
|
val d : t -> unit
|
|
|
|
(** difference between two pathsets *)
|
|
val diff : t -> t -> t
|
|
|
|
(** empty pathset *)
|
|
val empty : t
|
|
|
|
(** list of elements in a pathset *)
|
|
val elements : t -> (Prop.normal Prop.t * Path.t) list
|
|
|
|
(** equality for pathsets *)
|
|
val equal : t -> t -> bool
|
|
|
|
(** filter a pathset on the prop component *)
|
|
val filter : (Prop.normal Prop.t -> bool) -> t -> t
|
|
|
|
(** find the list of props whose associated path contains the given path *)
|
|
val filter_path : Path.t -> t -> Prop.normal Prop.t list
|
|
|
|
(** fold over a pathset *)
|
|
val fold : (Prop.normal Prop.t -> Path.t -> 'a -> 'a) -> t -> 'a -> 'a
|
|
|
|
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *)
|
|
val from_renamed_list: (Prop.normal Prop.t * Path.t) list -> t
|
|
|
|
(** check whether the pathset is empty *)
|
|
val is_empty : t -> bool
|
|
|
|
(** iterate over a pathset *)
|
|
val iter : (Prop.normal Prop.t -> Path.t -> unit) -> t -> unit
|
|
|
|
(** map over the prop component of a pathset *)
|
|
val map : (Prop.normal Prop.t -> Prop.normal Prop.t) -> t -> t
|
|
|
|
(** map over the prop component of a pathset using a partial function; elements mapped to None are discarded *)
|
|
val map_option : (Prop.normal Prop.t -> Prop.normal Prop.t option) -> t -> t
|
|
|
|
(** partition a pathset on the prop component *)
|
|
val partition : (Prop.normal Prop.t -> bool) -> t -> t * t
|
|
|
|
(** pretty print the pathset *)
|
|
val pp : printenv -> Format.formatter -> t -> unit
|
|
|
|
(** number of elements in the pathset *)
|
|
val size : t -> int
|
|
|
|
(** convert to a list of props *)
|
|
val to_proplist : t -> Prop.normal Prop.t list
|
|
|
|
(** convert to a set of props *)
|
|
val to_propset : t -> Propset.t
|
|
|
|
(** union of two pathsets *)
|
|
val union : t -> t -> t
|
|
end = struct
|
|
type t = Path.t PropMap.t
|
|
|
|
let equal = PropMap.equal (fun p1 p2 -> true) (* only discriminate props, and ignore paths *) (* Path.equal *)
|
|
|
|
let empty : t = PropMap.empty
|
|
|
|
let elements ps =
|
|
let plist = ref [] in
|
|
let f prop path = plist := (prop, path) :: !plist in
|
|
PropMap.iter f ps;
|
|
!plist
|
|
|
|
let to_proplist ps =
|
|
list_map fst (elements ps)
|
|
|
|
let to_propset ps =
|
|
Propset.from_proplist (to_proplist ps)
|
|
|
|
let filter f ps =
|
|
let elements = ref [] in
|
|
PropMap.iter (fun p _ -> elements := p :: !elements) ps;
|
|
elements := list_filter (fun p -> not (f p)) !elements;
|
|
let filtered_map = ref ps in
|
|
list_iter (fun p -> filtered_map := PropMap.remove p !filtered_map) !elements;
|
|
!filtered_map
|
|
|
|
let partition f ps =
|
|
let elements = ref [] in
|
|
PropMap.iter (fun p _ -> elements := p :: !elements) ps;
|
|
let el1, el2 = ref ps, ref ps in
|
|
list_iter (fun p -> if f p then el2 := PropMap.remove p !el2 else el1 := PropMap.remove p !el1) !elements;
|
|
!el1, !el2
|
|
|
|
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *)
|
|
let add_renamed_prop (p: Prop.normal Prop.t) (path: Path.t) (ps: t) : t =
|
|
let path_new =
|
|
try
|
|
let path_old = PropMap.find p ps in
|
|
Path.join path_old path
|
|
with Not_found -> path in
|
|
PropMap.add p path_new ps
|
|
|
|
let union (ps1: t) (ps2: t) : t =
|
|
PropMap.fold add_renamed_prop ps1 ps2
|
|
|
|
(** check if the nodes in path p1 are a subset of those in p2 (not trace subset) *)
|
|
let path_nodes_subset p1 p2 =
|
|
let get_nodes p =
|
|
let s = ref Cfg.NodeSet.empty in
|
|
Path.iter_all_nodes_nocalls (fun n -> s := Cfg.NodeSet.add n !s) p;
|
|
!s in
|
|
Cfg.NodeSet.subset (get_nodes p1) (get_nodes p2)
|
|
|
|
(** difference between pathsets for the differential fixpoint *)
|
|
let diff (ps1: t) (ps2: t) : t =
|
|
let res = ref ps1 in
|
|
let rem p path =
|
|
try
|
|
let path_old = PropMap.find p !res in
|
|
if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *)
|
|
then res := PropMap.remove p !res
|
|
with Not_found ->
|
|
res := PropMap.remove p !res in
|
|
PropMap.iter rem ps2;
|
|
!res
|
|
|
|
let is_empty = PropMap.is_empty
|
|
|
|
let iter = PropMap.iter
|
|
|
|
let fold = PropMap.fold
|
|
|
|
let map_option f ps =
|
|
let res = ref empty in
|
|
let do_elem prop path = match f prop with
|
|
| None -> ()
|
|
| Some prop' -> res := add_renamed_prop prop' path !res in
|
|
iter do_elem ps;
|
|
!res
|
|
|
|
let map f ps =
|
|
map_option (fun p -> Some (f p)) ps
|
|
|
|
let size ps =
|
|
let res = ref 0 in
|
|
let add p _ = incr res in
|
|
let () = PropMap.iter add ps
|
|
in !res
|
|
|
|
let pp pe fmt ps =
|
|
let count = ref 0 in
|
|
let pp_path fmt path =
|
|
F.fprintf fmt "[path: %a@\n%a]" Path.pp_stats path Path.pp path in
|
|
let f prop path =
|
|
incr count;
|
|
F.fprintf fmt "PROP %d:%a@\n%a@\n" !count pp_path path (Prop.pp_prop pe) prop in
|
|
iter f ps
|
|
|
|
let d (ps: t) = L.add_print_action (L.PTpathset, Obj.repr ps)
|
|
|
|
let filter_path path ps =
|
|
let plist = ref [] in
|
|
let f prop path' =
|
|
if Path.contains path path'
|
|
then plist := prop :: !plist in
|
|
iter f ps;
|
|
!plist
|
|
|
|
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *)
|
|
let from_renamed_list (pl : ('a Prop.t * Path.t) list) : t =
|
|
list_fold_left (fun ps (p, pa) -> add_renamed_prop p pa ps) empty pl
|
|
end
|
|
(* =============== END of the PathSet module ===============*)
|
|
|