From 42b3958a0757049dee7eecb5a72519e22ebae771 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 30 May 2018 09:03:38 -0700 Subject: [PATCH] ProcCfg: fold on nodes only Summary: We never really need the list of nodes/succs/preds, we only need to fold over them. This will reduce garbage for computed lists like in the Exceptional CFG or the OneInstrPerNode CFG. Reviewed By: ngorogiannis Differential Revision: D8185665 fbshipit-source-id: d042beb --- infer/src/absint/AbstractInterpreter.ml | 21 ++- infer/src/absint/ProcCfg.ml | 147 ++++++++++-------- infer/src/absint/ProcCfg.mli | 26 ++-- infer/src/absint/Scheduler.ml | 4 +- infer/src/backend/preanal.ml | 6 +- infer/src/biabduction/interproc.ml | 15 +- .../src/bufferoverrun/bufferOverrunChecker.ml | 22 +-- infer/src/checkers/cost.ml | 18 +-- infer/src/checkers/liveness.ml | 2 +- infer/src/istd/IContainer.ml | 25 +++ infer/src/istd/IContainer.mli | 17 ++ infer/src/unit/procCfgTests.ml | 83 +++++----- infer/src/unit/schedulerTests.ml | 20 +-- 13 files changed, 228 insertions(+), 178 deletions(-) create mode 100644 infer/src/istd/IContainer.ml create mode 100644 infer/src/istd/IContainer.mli diff --git a/infer/src/absint/AbstractInterpreter.ml b/infer/src/absint/AbstractInterpreter.ml index 441a569ff..027d14680 100644 --- a/infer/src/absint/AbstractInterpreter.ml +++ b/infer/src/absint/AbstractInterpreter.ml @@ -104,17 +104,16 @@ struct let rec exec_worklist cfg work_queue inv_map proc_data ~debug = let compute_pre node inv_map = let extract_post_ pred = extract_post (CFG.id pred) inv_map in - CFG.preds cfg node - |> List.fold ~init:None ~f:(fun joined_post_opt pred -> - match extract_post_ pred with - | None -> - joined_post_opt - | Some post as some_post -> - match joined_post_opt with - | None -> - some_post - | Some joined_post -> - Some (Domain.join joined_post post) ) + CFG.fold_preds cfg node ~init:None ~f:(fun joined_post_opt pred -> + match extract_post_ pred with + | None -> + joined_post_opt + | Some post as some_post -> + match joined_post_opt with + | None -> + some_post + | Some joined_post -> + Some (Domain.join joined_post post) ) in match Scheduler.pop work_queue with | Some (_, [], work_queue') -> diff --git a/infer/src/absint/ProcCfg.ml b/infer/src/absint/ProcCfg.ml index bb807ea9b..1c9ff95f2 100644 --- a/infer/src/absint/ProcCfg.ml +++ b/infer/src/absint/ProcCfg.ml @@ -116,22 +116,22 @@ module type S = sig val instrs : node -> Sil.instr list (** get the instructions from a node *) - val succs : t -> node -> node list + val fold_succs : t -> (node, node, 'accum) Container.fold - val preds : t -> node -> node list - (** all predecessors (normal and exceptional) *) + val fold_preds : t -> (node, node, 'accum) Container.fold + (** fold over all predecessors (normal and exceptional) *) - val normal_succs : t -> node -> node list - (** non-exceptional successors *) + val fold_normal_succs : t -> (node, node, 'accum) Container.fold + (** fold over non-exceptional successors *) - val normal_preds : t -> node -> node list - (** non-exceptional predecessors *) + val fold_normal_preds : t -> (node, node, 'accum) Container.fold + (** fold over non-exceptional predecessors *) - val exceptional_succs : t -> node -> node list - (** exceptional successors *) + val fold_exceptional_succs : t -> (node, node, 'accum) Container.fold + (** fold over exceptional successors *) - val exceptional_preds : t -> node -> node list - (** exceptional predecessors *) + val fold_exceptional_preds : t -> (node, node, 'accum) Container.fold + (** fold over exceptional predecessors *) val start_node : t -> node @@ -139,7 +139,7 @@ module type S = sig val proc_desc : t -> Procdesc.t - val nodes : t -> node list + val fold_nodes : (t, node, 'accum) Container.fold val from_pdesc : Procdesc.t -> t @@ -156,18 +156,18 @@ module Normal = struct let instrs = Procdesc.Node.get_instrs - let normal_succs _ n = Procdesc.Node.get_succs n + let fold_normal_succs _ n ~init ~f = n |> Procdesc.Node.get_succs |> List.fold ~init ~f - let normal_preds _ n = Procdesc.Node.get_preds n + let fold_normal_preds _ n ~init ~f = n |> Procdesc.Node.get_preds |> List.fold ~init ~f (* prune away exceptional control flow *) - let exceptional_succs _ _ = [] + let fold_exceptional_succs _ _ ~init ~f:_ = init - let exceptional_preds _ _ = [] + let fold_exceptional_preds _ _ ~init ~f:_ = init - let succs = normal_succs + let fold_succs = fold_normal_succs - let preds = normal_preds + let fold_preds = fold_normal_preds let start_node = Procdesc.get_start_node @@ -175,7 +175,7 @@ module Normal = struct let proc_desc t = t - let nodes = Procdesc.get_nodes + let fold_nodes = Procdesc.fold_nodes let from_pdesc pdesc = pdesc @@ -192,7 +192,7 @@ module Exceptional = struct include (DefaultNode : module type of DefaultNode with type t := node) - let exceptional_succs _ n = Procdesc.Node.get_exn n + let fold_exceptional_succs _ n ~init ~f = n |> Procdesc.Node.get_exn |> List.fold ~init ~f let from_pdesc pdesc = (* map from a node to its exceptional predecessors *) @@ -207,46 +207,52 @@ module Exceptional = struct Procdesc.IdMap.add exn_succ_node_id (n :: existing_exn_preds) exn_preds_acc else exn_preds_acc in - List.fold ~f:add_exn_pred ~init:exn_preds_acc (exceptional_succs pdesc n) + fold_exceptional_succs pdesc n ~f:add_exn_pred ~init:exn_preds_acc in let exceptional_preds = - List.fold ~f:add_exn_preds ~init:Procdesc.IdMap.empty (Procdesc.get_nodes pdesc) + Procdesc.fold_nodes pdesc ~f:add_exn_preds ~init:Procdesc.IdMap.empty in (pdesc, exceptional_preds) let instrs = Procdesc.Node.get_instrs - let nodes (t, _) = Procdesc.get_nodes t + let fold_nodes (t, _) ~init ~f = Procdesc.fold_nodes t ~init ~f - let normal_succs _ n = Procdesc.Node.get_succs n + let fold_normal_succs _ n ~init ~f = n |> Procdesc.Node.get_succs |> List.fold ~init ~f - let normal_preds _ n = Procdesc.Node.get_preds n + let fold_normal_preds _ n ~init ~f = n |> Procdesc.Node.get_preds |> List.fold ~init ~f - let exceptional_preds (_, exn_pred_map) n = - try Procdesc.IdMap.find (Procdesc.Node.get_id n) exn_pred_map with Caml.Not_found -> [] + let fold_exceptional_preds (_, exn_pred_map) n ~init ~f = + match Procdesc.IdMap.find (Procdesc.Node.get_id n) exn_pred_map with + | exn_preds -> + List.fold exn_preds ~init ~f + | exception Caml.Not_found -> + init - (** get all normal and exceptional successors of [n]. *) - let succs t n = - let normal_succs = normal_succs t n in - match exceptional_succs t n with - | [] -> - normal_succs - | exceptional_succs -> - normal_succs @ exceptional_succs |> List.sort ~compare:Procdesc.Node.compare - |> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal + let fold_avoid_duplicates fold_normal_alpha fold_normal_idset fold_exceptional t n ~init ~f = + (* need a copy of [fold_normal] otherwise OCaml wants the types *) + let acc_normal = fold_normal_alpha t n ~init ~f in + let normal_set = + lazy + (fold_normal_idset t n ~init:IdSet.empty ~f:(fun set node -> + IdSet.add (Procdesc.Node.get_id node) set )) + in + let f acc node = + if IdSet.mem (Procdesc.Node.get_id node) (Lazy.force_val normal_set) then acc else f acc node + in + fold_exceptional t n ~init:acc_normal ~f + + (** fold over all normal and exceptional successors of [n]. *) + let fold_succs t n ~init ~f = + fold_avoid_duplicates fold_normal_succs fold_normal_succs fold_exceptional_succs t n ~init ~f - (** get all normal and exceptional predecessors of [n]. *) - let preds t n = - let normal_preds = normal_preds t n in - match exceptional_preds t n with - | [] -> - normal_preds - | exceptional_preds -> - normal_preds @ exceptional_preds |> List.sort ~compare:Procdesc.Node.compare - |> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal + + (** fold over all normal and exceptional predecessors of [n]. *) + let fold_preds t n ~init ~f = + fold_avoid_duplicates fold_normal_preds fold_normal_preds fold_exceptional_preds t n ~init ~f let proc_desc (pdesc, _) = pdesc @@ -264,21 +270,21 @@ module Backward (Base : S) = struct let instrs n = List.rev (Base.instrs n) - let succs = Base.preds + let fold_succs = Base.fold_preds - let preds = Base.succs + let fold_preds = Base.fold_succs let start_node = Base.exit_node let exit_node = Base.start_node - let normal_succs = Base.normal_preds + let fold_normal_succs = Base.fold_normal_preds - let normal_preds = Base.normal_succs + let fold_normal_preds = Base.fold_normal_succs - let exceptional_succs = Base.exceptional_preds + let fold_exceptional_succs = Base.fold_exceptional_preds - let exceptional_preds = Base.exceptional_succs + let fold_exceptional_preds = Base.fold_exceptional_succs end module OneInstrPerNode (Base : S with type node = Procdesc.Node.t and type id = Procdesc.Node.id) = @@ -305,27 +311,32 @@ struct let last_of_node node = (node, max 0 (List.length (Base.instrs node) - 1)) - let normal_succs _ _ = (* not used *) assert false + let fold_normal_succs _ _ ~init:_ ~f:_ = (* not used *) assert false - let exceptional_succs _ _ = (* not used *) assert false + let fold_exceptional_succs _ _ ~init:_ ~f:_ = (* not used *) assert false - let succs cfg (node, index) = + let fold_succs cfg (node, index) ~init ~f = let succ_index = index + 1 in - if IList.mem_nth (Base.instrs node) succ_index then [(node, succ_index)] - else List.map ~f:first_of_node (Base.succs cfg node) + if IList.mem_nth (Base.instrs node) succ_index then f init (node, succ_index) + else + let f acc node = f acc (first_of_node node) in + Base.fold_succs cfg node ~init ~f + + let call_on_last ~f acc node = f acc (last_of_node node) - let normal_preds cfg (node, index) = - if index >= 1 then [(node, index - 1)] - else List.map ~f:last_of_node (Base.normal_preds cfg node) + let fold_normal_preds cfg (node, index) ~init ~f = + if index >= 1 then f init (node, index - 1) + else Base.fold_normal_preds cfg node ~init ~f:(call_on_last ~f) - let exceptional_preds cfg (node, index) = - if index >= 1 then [] else List.map ~f:last_of_node (Base.exceptional_preds cfg node) + let fold_exceptional_preds cfg (node, index) ~init ~f = + if index >= 1 then init else Base.fold_exceptional_preds cfg node ~init ~f:(call_on_last ~f) - let preds cfg (node, index) = - if index >= 1 then [(node, index - 1)] else List.map ~f:last_of_node (Base.preds cfg node) + let fold_preds cfg (node, index) ~init ~f = + if index >= 1 then f init (node, index - 1) + else Base.fold_preds cfg node ~init ~f:(call_on_last ~f) let start_node cfg = first_of_node (Base.start_node cfg) @@ -334,15 +345,15 @@ struct let proc_desc = Base.proc_desc - let nodes = - let nodes_of_node node = + let fold_nodes cfg ~init ~f = + let f init node = match Base.instrs node with | [] -> - [(node, 0)] + f init (node, 0) | instrs -> - List.mapi ~f:(fun index _instr -> (node, index)) instrs + List.foldi instrs ~init ~f:(fun index acc _instr -> f acc (node, index)) in - fun cfg -> List.concat_map ~f:nodes_of_node (Base.nodes cfg) + Base.fold_nodes cfg ~init ~f let from_pdesc = Base.from_pdesc diff --git a/infer/src/absint/ProcCfg.mli b/infer/src/absint/ProcCfg.mli index c3a7e9ed1..ccf3a4fd0 100644 --- a/infer/src/absint/ProcCfg.mli +++ b/infer/src/absint/ProcCfg.mli @@ -49,23 +49,23 @@ module type S = sig val instrs : node -> Sil.instr list (** get the instructions from a node *) - val succs : t -> node -> node list - (** all successors (normal and exceptional) *) + val fold_succs : t -> (node, node, 'accum) Container.fold + (** fold over all successors (normal and exceptional) *) - val preds : t -> node -> node list - (** all predecessors (normal and exceptional) *) + val fold_preds : t -> (node, node, 'accum) Container.fold + (** fold over all predecessors (normal and exceptional) *) - val normal_succs : t -> node -> node list - (** non-exceptional successors *) + val fold_normal_succs : t -> (node, node, 'accum) Container.fold + (** fold over non-exceptional successors *) - val normal_preds : t -> node -> node list - (** non-exceptional predecessors *) + val fold_normal_preds : t -> (node, node, 'accum) Container.fold + (** fold over non-exceptional predecessors *) - val exceptional_succs : t -> node -> node list - (** exceptional successors *) + val fold_exceptional_succs : t -> (node, node, 'accum) Container.fold + (** fold over exceptional successors *) - val exceptional_preds : t -> node -> node list - (** exceptional predescessors *) + val fold_exceptional_preds : t -> (node, node, 'accum) Container.fold + (** fold over exceptional predescessors *) val start_node : t -> node @@ -73,7 +73,7 @@ module type S = sig val proc_desc : t -> Procdesc.t - val nodes : t -> node list + val fold_nodes : (t, node, 'accum) Container.fold val from_pdesc : Procdesc.t -> t diff --git a/infer/src/absint/Scheduler.ml b/infer/src/absint/Scheduler.ml index 8d5468fd8..a82065663 100644 --- a/infer/src/absint/Scheduler.ml +++ b/infer/src/absint/Scheduler.ml @@ -50,7 +50,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct let priority t = t.priority let compute_priority cfg node visited_preds = - List.length (CFG.preds cfg node) - IdSet.cardinal visited_preds + Container.length ~fold:(CFG.fold_preds cfg) node - IdSet.cardinal visited_preds let make cfg node = @@ -81,7 +81,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct let new_work = WorkUnit.add_visited_pred t.cfg old_work node_id in M.add id_to_schedule new_work worklist_acc in - let new_worklist = List.fold ~f:schedule_succ ~init:t.worklist (CFG.succs t.cfg node) in + let new_worklist = CFG.fold_succs t.cfg node ~f:schedule_succ ~init:t.worklist in {t with worklist= new_worklist} diff --git a/infer/src/backend/preanal.ml b/infer/src/backend/preanal.ml index de54a1525..37cd5e719 100644 --- a/infer/src/backend/preanal.ml +++ b/infer/src/backend/preanal.ml @@ -139,8 +139,7 @@ let add_nullify_instrs pdesc tenv liveness_inv_map = let node_removetmps_instruction loc ids = if ids <> [] then Some (Sil.Remove_temps (List.rev ids, loc)) else None in - List.iter - ~f:(fun node -> + Container.iter nullify_proc_cfg ~fold:ProcCfg.Exceptional.fold_nodes ~f:(fun node -> match NullifyAnalysis.extract_post (ProcCfg.Exceptional.id node) nullify_inv_map with | Some (_, to_nullify) -> let pvars_to_nullify, ids_to_remove = @@ -162,8 +161,7 @@ let add_nullify_instrs pdesc tenv liveness_inv_map = |> IList.opt_cons (node_removetmps_instruction loc ids_to_remove) |> Procdesc.Node.append_instrs node | None -> - () ) - (ProcCfg.Exceptional.nodes nullify_proc_cfg) ; + () ) ; (* nullify all address taken variables *) if not (AddressTaken.Domain.is_empty address_taken_vars) then let exit_node = ProcCfg.Exceptional.exit_node nullify_proc_cfg in diff --git a/infer/src/biabduction/interproc.ml b/infer/src/biabduction/interproc.ml index 7edd924d7..a8670e1b9 100644 --- a/infer/src/biabduction/interproc.ml +++ b/infer/src/biabduction/interproc.ml @@ -300,10 +300,12 @@ let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Pat Propgraph.d_proplist Prop.prop_emp (Paths.PathSet.to_proplist prop_incons) ; L.d_ln () ; propagate wl pname ~is_exception:false prop_incons exit_node ) ; - ProcCfg.Exceptional.normal_succs proc_cfg curr_node - |> List.iter ~f:(propagate wl pname ~is_exception:false pset_ok) ; - ProcCfg.Exceptional.exceptional_succs proc_cfg curr_node - |> List.iter ~f:(propagate wl pname ~is_exception:true pset_exn) + Container.iter curr_node + ~fold:(ProcCfg.Exceptional.fold_normal_succs proc_cfg) + ~f:(propagate wl pname ~is_exception:false pset_ok) ; + Container.iter curr_node + ~fold:(ProcCfg.Exceptional.fold_exceptional_succs proc_cfg) + ~f:(propagate wl pname ~is_exception:true pset_exn) (* ===================== END of symbolic execution ===================== *) @@ -313,13 +315,11 @@ let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Pat let do_symexec_join proc_cfg tenv wl curr_node (edgeset_todo: Paths.PathSet.t) = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in let curr_node_id = ProcCfg.Exceptional.id curr_node in - let succ_nodes = ProcCfg.Exceptional.normal_succs proc_cfg curr_node in let new_dset = edgeset_todo in let old_dset = Join_table.find wl.Worklist.join_table curr_node_id in let old_dset', new_dset' = Dom.pathset_join pname tenv old_dset new_dset in Join_table.add wl.Worklist.join_table curr_node_id (Paths.PathSet.union old_dset' new_dset') ; - List.iter - ~f:(fun node -> + Container.iter curr_node ~fold:(ProcCfg.Exceptional.fold_normal_succs proc_cfg) ~f:(fun node -> Paths.PathSet.iter (fun prop path -> State.set_path path None ; @@ -327,7 +327,6 @@ let do_symexec_join proc_cfg tenv wl curr_node (edgeset_todo: Paths.PathSet.t) = (Paths.PathSet.from_renamed_list [(prop, path)]) node ) new_dset' ) - succ_nodes let prop_max_size = ref (0, Prop.prop_emp) diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index a0a6bf2f8..e39872ecf 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/infer/src/bufferoverrun/bufferOverrunChecker.ml @@ -322,19 +322,14 @@ module Report = struct let rec is_end_of_block_or_procedure (cfg: CFG.t) node rem_instrs = List.for_all rem_instrs ~f:Sil.instr_is_auxiliary && - match CFG.succs cfg node with - | [] -> + match IContainer.singleton_or_more node ~fold:(CFG.fold_succs cfg) with + | IContainer.Empty -> true - | [succ] - -> ( - is_end_of_block_or_procedure cfg succ (CFG.instrs succ) - || - match CFG.preds cfg succ with - | _ :: _ :: _ -> - true (* [succ] is a join, i.e. [node] is the end of a block *) - | _ -> - false ) - | _ :: _ :: _ -> + | Singleton succ -> + (* [succ] is a join, i.e. [node] is the end of a block *) + IContainer.mem_nth succ 1 ~fold:(CFG.fold_preds cfg) + || is_end_of_block_or_procedure cfg succ (CFG.instrs succ) + | More -> false end @@ -503,8 +498,7 @@ module Report = struct let check_proc : Summary.t -> Procdesc.t -> Tenv.t -> CFG.t -> Analyzer.invariant_map -> PO.ConditionSet.t = fun summary pdesc tenv cfg inv_map -> - CFG.nodes cfg - |> List.fold ~f:(check_node summary pdesc tenv cfg inv_map) ~init:PO.ConditionSet.empty + CFG.fold_nodes cfg ~f:(check_node summary pdesc tenv cfg inv_map) ~init:PO.ConditionSet.empty let make_err_trace : Trace.t -> string -> Errlog.loc_trace = diff --git a/infer/src/checkers/cost.ml b/infer/src/checkers/cost.ml index 6724ed118..2c426766c 100644 --- a/infer/src/checkers/cost.ml +++ b/infer/src/checkers/cost.ml @@ -191,7 +191,7 @@ module BoundMap = struct Node.IdMap.add node_id BasicCost.zero bound_map in let bound_map = - List.fold (NodeCFG.nodes node_cfg) ~f:compute_node_upper_bound ~init:Node.IdMap.empty + NodeCFG.fold_nodes node_cfg ~f:compute_node_upper_bound ~init:Node.IdMap.empty in print_upper_bound_map bound_map ; bound_map @@ -215,10 +215,10 @@ end module StructuralConstraints = struct type t = {single: Node.id list; sum: Node.IdSet.t list} - (* - Finds subset of constraints of node k. - It returns a pair (single_constraints, sum_constraints) where single constraints are - of the form 'x_k <= x_j' and sum constraints are of the form 'x_k <= x_j1 +...+ x_jn'. + (* + Finds subset of constraints of node k. + It returns a pair (single_constraints, sum_constraints) where single constraints are + of the form 'x_k <= x_j' and sum constraints are of the form 'x_k <= x_j1 +...+ x_jn'. *) let get_constraints_of_node constraints k = let c = Node.IdMap.find_opt k constraints in @@ -267,7 +267,7 @@ module StructuralConstraints = struct {single= List.append preds.single succs.single; sum= List.append preds.sum succs.sum} acc in let constraints = - List.fold (NodeCFG.nodes node_cfg) ~f:compute_node_constraints ~init:Node.IdMap.empty + NodeCFG.fold_nodes node_cfg ~f:compute_node_constraints ~init:Node.IdMap.empty in print_constraints_map constraints ; constraints end @@ -411,12 +411,12 @@ module MinTree = struct with_cache (minimum_propagation bound_map constraints) |> Staged.unstage in let min_trees = - List.fold + NodeCFG.fold_nodes node_cfg ~f:(fun acc node -> let nid = Node.id node in let tree = minimum_propagation (nid, Node.IdSet.empty) in (nid, tree) :: acc ) - ~init:[] (NodeCFG.nodes node_cfg) + ~init:[] in List.iter ~f:(fun (nid, t) -> L.(debug Analysis Medium) "@\n node %a = %a @\n" Node.pp_id nid pp t) @@ -599,7 +599,7 @@ let checker ({Callbacks.tenv; proc_desc} as callback_args) : Summary.t = "@\n[COST ANALYSIS] PROCESSING MIN_TREE for PROCEDURE '%a' |CFG| = %i FINAL COST = %a @\n" Typ.Procname.pp (Procdesc.get_proc_name proc_desc) - (List.length (NodeCFG.nodes node_cfg)) + (Container.length ~fold:NodeCFG.fold_nodes node_cfg) BasicCost.pp exit_cost ; check_and_report_infinity exit_cost proc_desc summary ; Payload.update_summary {post= exit_cost} summary diff --git a/infer/src/checkers/liveness.ml b/infer/src/checkers/liveness.ml index 784e4fc8d..e5a1e1e20 100644 --- a/infer/src/checkers/liveness.ml +++ b/infer/src/checkers/liveness.ml @@ -201,5 +201,5 @@ let checker {Callbacks.tenv; summary; proc_desc} : Summary.t = | None -> () ) in - List.iter (CFG.nodes cfg) ~f:report_on_node ; + Container.iter cfg ~fold:CFG.fold_nodes ~f:report_on_node ; summary diff --git a/infer/src/istd/IContainer.ml b/infer/src/istd/IContainer.ml new file mode 100644 index 000000000..e9dd056d9 --- /dev/null +++ b/infer/src/istd/IContainer.ml @@ -0,0 +1,25 @@ +(* + * Copyright (c) 2018 - 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. + *) + +open! IStd + +type 'a singleton_or_more = Empty | Singleton of 'a | More + +let singleton_or_more ~fold t = + With_return.with_return (fun {return} -> + fold t ~init:Empty ~f:(fun acc item -> + match acc with Empty -> Singleton item | _ -> return More ) ) + + +let mem_nth ~fold t index = + With_return.with_return (fun {return} -> + let _ : int = + fold t ~init:index ~f:(fun index _ -> if index <= 0 then return true else index - 1) + in + false ) diff --git a/infer/src/istd/IContainer.mli b/infer/src/istd/IContainer.mli new file mode 100644 index 000000000..7cf2725ca --- /dev/null +++ b/infer/src/istd/IContainer.mli @@ -0,0 +1,17 @@ +(* + * Copyright (c) 2018 - 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. + *) + +open! IStd + +type 'a singleton_or_more = Empty | Singleton of 'a | More + +val singleton_or_more : + fold:('t, 'a, 'a singleton_or_more) Container.fold -> 't -> 'a singleton_or_more + +val mem_nth : fold:('t, _, int) Container.fold -> 't -> int -> bool diff --git a/infer/src/unit/procCfgTests.ml b/infer/src/unit/procCfgTests.ml index a6626761d..8738fca3b 100644 --- a/infer/src/unit/procCfgTests.ml +++ b/infer/src/unit/procCfgTests.ml @@ -51,7 +51,10 @@ let tests = let pp_node_list fmt l = F.pp_print_list ~pp_sep Procdesc.Node.pp fmt l in F.fprintf fmt "Expected output %a but got %a" pp_node_list expected pp_node_list actual in - let create_test input expected _ = assert_equal ~cmp ~pp_diff input expected in + let create_test ~fold input expected _ = + let input = Container.to_list input ~fold in + assert_equal ~cmp ~pp_diff input expected + in let instr_test = let instr_test_ _ = ( match ProcCfg.Normal.instrs n1 with @@ -83,66 +86,70 @@ let tests = let n1'' = BackwardInstrCfg.underlying_node backward_instr_n1 in assert_bool "underlying_node should return node of underlying CFG type" (phys_equal n1 n1'') ; (* test the preds/succs using backward + instr cfg *) - let check_backward_instr_ f backward_instr_node expected_instrs = - match f backward_instr_proc_cfg backward_instr_node with + let check_backward_instr_ fold backward_instr_node expected_instrs = + match Container.to_list ~fold:(fold backward_instr_proc_cfg) backward_instr_node with | [n] -> assert_equal (BackwardInstrCfg.instrs n) expected_instrs | _ -> assert_failure "Expected exactly one node" in - check_backward_instr_ BackwardInstrCfg.preds backward_instr_n1 [dummy_instr2] ; + check_backward_instr_ BackwardInstrCfg.fold_preds backward_instr_n1 [dummy_instr2] ; let backward_instr_n2 = BackwardInstrCfg.of_underlying_node n2 in - check_backward_instr_ BackwardInstrCfg.preds backward_instr_n2 [] ; + check_backward_instr_ BackwardInstrCfg.fold_preds backward_instr_n2 [] ; let backward_instr_n3 = BackwardInstrCfg.of_underlying_node n3 in - check_backward_instr_ BackwardInstrCfg.preds backward_instr_n3 [] ; - check_backward_instr_ BackwardInstrCfg.normal_succs backward_instr_n2 [dummy_instr2] + check_backward_instr_ BackwardInstrCfg.fold_preds backward_instr_n3 [] ; + check_backward_instr_ BackwardInstrCfg.fold_normal_succs backward_instr_n2 [dummy_instr2] in "instr_test" >:: instr_test_ in let graph_tests = [ (* test the succs of the normal cfg. forward... *) - ("succs_n1", ProcCfg.Normal.succs normal_proc_cfg n1, [n2]) - ; ("normal_succs_n1", ProcCfg.Normal.normal_succs normal_proc_cfg n1, [n2]) - ; ("succs_n2", ProcCfg.Normal.succs normal_proc_cfg n2, [n4]) - ; ("normal_succs_n2", ProcCfg.Normal.normal_succs normal_proc_cfg n2, [n4]) - ; ("succs_n3", ProcCfg.Normal.succs normal_proc_cfg n3, [n4]) - ; ("normal_succs_n3", ProcCfg.Normal.normal_succs normal_proc_cfg n3, [n4]) + ("succs_n1", ProcCfg.Normal.fold_succs normal_proc_cfg, n1, [n2]) + ; ("normal_succs_n1", ProcCfg.Normal.fold_normal_succs normal_proc_cfg, n1, [n2]) + ; ("succs_n2", ProcCfg.Normal.fold_succs normal_proc_cfg, n2, [n4]) + ; ("normal_succs_n2", ProcCfg.Normal.fold_normal_succs normal_proc_cfg, n2, [n4]) + ; ("succs_n3", ProcCfg.Normal.fold_succs normal_proc_cfg, n3, [n4]) + ; ("normal_succs_n3", ProcCfg.Normal.fold_normal_succs normal_proc_cfg, n3, [n4]) ; (* ... and backward... *) - ("succs_n1_bw", BackwardCfg.preds backward_proc_cfg n1, [n2]) - ; ("normal_succs_n1_bw", BackwardCfg.normal_preds backward_proc_cfg n1, [n2]) - ; ("succs_n2_bw", BackwardCfg.preds backward_proc_cfg n2, [n4]) - ; ("normal_succs_n2_bw", BackwardCfg.normal_preds backward_proc_cfg n2, [n4]) - ; ("succs_n3_bw", BackwardCfg.preds backward_proc_cfg n3, [n4]) - ; ("normal_succs_n3_bw", BackwardCfg.normal_preds backward_proc_cfg n3, [n4]) + ("succs_n1_bw", BackwardCfg.fold_preds backward_proc_cfg, n1, [n2]) + ; ("normal_succs_n1_bw", BackwardCfg.fold_normal_preds backward_proc_cfg, n1, [n2]) + ; ("succs_n2_bw", BackwardCfg.fold_preds backward_proc_cfg, n2, [n4]) + ; ("normal_succs_n2_bw", BackwardCfg.fold_normal_preds backward_proc_cfg, n2, [n4]) + ; ("succs_n3_bw", BackwardCfg.fold_preds backward_proc_cfg, n3, [n4]) + ; ("normal_succs_n3_bw", BackwardCfg.fold_normal_preds backward_proc_cfg, n3, [n4]) ; (* test the preds of the normal cfg... *) - ("preds_n2", ProcCfg.Normal.normal_preds normal_proc_cfg n2, [n1]) - ; ("normal_preds_n2", ProcCfg.Normal.normal_preds normal_proc_cfg n2, [n1]) + ("preds_n2", ProcCfg.Normal.fold_normal_preds normal_proc_cfg, n2, [n1]) + ; ("normal_preds_n2", ProcCfg.Normal.fold_normal_preds normal_proc_cfg, n2, [n1]) ; (* ...and the backward cfg... *) - ("preds_n2_bw", BackwardCfg.normal_succs backward_proc_cfg n2, [n1]) - ; ("normal_preds_n2_bw", BackwardCfg.normal_succs backward_proc_cfg n2, [n1]) + ("preds_n2_bw", BackwardCfg.fold_normal_succs backward_proc_cfg, n2, [n1]) + ; ("normal_preds_n2_bw", BackwardCfg.fold_normal_succs backward_proc_cfg, n2, [n1]) ; (* we shouldn't see any exn succs or preds even though we added them *) - ("no_exn_succs_n1", ProcCfg.Normal.exceptional_succs normal_proc_cfg n1, []) - ; ("no_exn_preds_n3", ProcCfg.Normal.exceptional_preds normal_proc_cfg n3, []) + ("no_exn_succs_n1", ProcCfg.Normal.fold_exceptional_succs normal_proc_cfg, n1, []) + ; ("no_exn_preds_n3", ProcCfg.Normal.fold_exceptional_preds normal_proc_cfg, n3, []) ; (* same in the backward cfg *) - ("no_exn_succs_n1_bw", BackwardCfg.exceptional_preds backward_proc_cfg n1, []) - ; ("no_exn_preds_n3_bw", BackwardCfg.exceptional_succs backward_proc_cfg n3, []) + ("no_exn_succs_n1_bw", BackwardCfg.fold_exceptional_preds backward_proc_cfg, n1, []) + ; ("no_exn_preds_n3_bw", BackwardCfg.fold_exceptional_succs backward_proc_cfg, n3, []) ; (* now, test the exceptional succs in the exceptional cfg. *) - ("exn_succs_n1", ProcCfg.Exceptional.exceptional_succs exceptional_proc_cfg n1, [n3]) - ; ("exn_succs_n2", ProcCfg.Exceptional.exceptional_succs exceptional_proc_cfg n2, [n3]) - ; ("exn_succs_n3", ProcCfg.Exceptional.exceptional_succs exceptional_proc_cfg n3, [n4]) + ("exn_succs_n1", ProcCfg.Exceptional.fold_exceptional_succs exceptional_proc_cfg, n1, [n3]) + ; ("exn_succs_n2", ProcCfg.Exceptional.fold_exceptional_succs exceptional_proc_cfg, n2, [n3]) + ; ("exn_succs_n3", ProcCfg.Exceptional.fold_exceptional_succs exceptional_proc_cfg, n3, [n4]) ; (* test exceptional pred links *) - ("exn_preds_n3", ProcCfg.Exceptional.exceptional_preds exceptional_proc_cfg n3, [n2; n1]) + ( "exn_preds_n3" + , ProcCfg.Exceptional.fold_exceptional_preds exceptional_proc_cfg + , n3 + , [n2; n1] ) ; (* succs should return both normal and exceptional successors *) - ("exn_all_succs_n1", ProcCfg.Exceptional.succs exceptional_proc_cfg n1, [n3; n2]) + ("exn_all_succs_n1", ProcCfg.Exceptional.fold_succs exceptional_proc_cfg, n1, [n3; n2]) ; (* but, should not return duplicates *) - ("exn_all_succs_n3", ProcCfg.Exceptional.succs exceptional_proc_cfg n3, [n4]) + ("exn_all_succs_n3", ProcCfg.Exceptional.fold_succs exceptional_proc_cfg, n3, [n4]) ; (* similarly, preds should return both normal and exceptional predecessors *) - ("exn_all_preds_n3", ProcCfg.Exceptional.preds exceptional_proc_cfg n3, [n2; n1]) - ; ("exn_all_preds_n4", ProcCfg.Exceptional.preds exceptional_proc_cfg n4, [n3; n2]) + ("exn_all_preds_n3", ProcCfg.Exceptional.fold_preds exceptional_proc_cfg, n3, [n2; n1]) + ; ("exn_all_preds_n4", ProcCfg.Exceptional.fold_preds exceptional_proc_cfg, n4, [n3; n2]) ; (* finally, normal_succs/normal_preds shouldn't return exceptional edges *) - ("exn_normal_succs_n1", ProcCfg.Exceptional.normal_succs exceptional_proc_cfg n1, [n2]) - ; ("exn_normal_preds_n2", ProcCfg.Exceptional.normal_preds exceptional_proc_cfg n2, [n1]) ] - |> List.map ~f:(fun (name, test, expected) -> name >:: create_test test expected) + ("exn_normal_succs_n1", ProcCfg.Exceptional.fold_normal_succs exceptional_proc_cfg, n1, [n2]) + ; ("exn_normal_preds_n2", ProcCfg.Exceptional.fold_normal_preds exceptional_proc_cfg, n2, [n1]) + ] + |> List.map ~f:(fun (name, fold, input, expected) -> name >:: create_test ~fold input expected) in let tests = instr_test :: graph_tests in "procCfgSuite" >::: tests diff --git a/infer/src/unit/schedulerTests.ml b/infer/src/unit/schedulerTests.ml index 035deed72..645158d6a 100644 --- a/infer/src/unit/schedulerTests.ml +++ b/infer/src/unit/schedulerTests.ml @@ -57,33 +57,33 @@ module MockProcCfg = struct let equal_id = Int.equal - let succs t n = + let fold_succs t n ~init ~f = let node_id = id n in List.find ~f:(fun (node, _) -> equal_id (id node) node_id) t - |> Option.value_map ~f:snd ~default:[] + |> Option.value_map ~f:snd ~default:[] |> List.fold ~init ~f - let preds t n = + let fold_preds t n ~init ~f = try let node_id = id n in List.filter ~f:(fun (_, succs) -> List.exists ~f:(fun node -> equal_id (id node) node_id) succs) t - |> List.map ~f:fst + |> List.map ~f:fst |> List.fold ~init ~f with | Not_found_s _ | Caml.Not_found -> - [] + init - let nodes t = List.map ~f:fst t + let fold_nodes t ~init ~f = List.map ~f:fst t |> List.fold ~init ~f - let normal_succs = succs + let fold_normal_succs = fold_succs - let normal_preds = preds + let fold_normal_preds = fold_preds - let exceptional_succs _ _ = [] + let fold_exceptional_succs _ _ ~init ~f:_ = init - let exceptional_preds _ _ = [] + let fold_exceptional_preds _ _ ~init ~f:_ = init let from_adjacency_list t = t