[topl] Added limits, to avoid high runtimes in corner-cases.

Summary:
Added a topl-max-disjuncts, which is analogous to pulse-max-disjuncts.
Note, however, that the maximum number of states tracked will be the
product of the two limits.

Added also topl-max-conjuncts, which drops Topl states that became too
complex.

Reviewed By: jvillard

Differential Revision: D25240386

fbshipit-source-id: 588c90390

infer/man/man1/infer-full.txt

@@ -1951,6 +1951,12 @@ INTERNAL OPTIONS
            Activates: Mode for testing, where no headers are translated, and
            dot files are created (clang only) (Conversely: --no-testing-mode)
 
+       --topl-max-conjuncts int
+           Stop tracking states that reach have at least int conjuncts
+
+       --topl-max-disjuncts int
+           Under-approximate after int disjunctions in the domain
+
        --topl-properties +path
            [EXPERIMENTAL] Specify a file containing a temporal property
            definition (e.g., jdk.topl).           One needs to also select one of the three implementations, by

infer/src/base/Config.ml

@@ -2317,6 +2317,16 @@ and test_filtering =
     "List all the files Infer can report on (should be called from the root of the project)"
 
 
+and topl_max_conjuncts =
+  CLOpt.mk_int ~long:"topl-max-conjuncts" ~default:20
+    "Stop tracking states that reach have at least $(i,int) conjuncts"
+
+
+and topl_max_disjuncts =
+  CLOpt.mk_int ~long:"topl-max-disjuncts" ~default:20
+    "Under-approximate after $(i,int) disjunctions in the domain"
+
+
 and topl_properties =
   CLOpt.mk_path_list ~default:[] ~long:"topl-properties"
     "[EXPERIMENTAL] Specify a file containing a temporal property definition (e.g., jdk.topl).\n\
@@ -3282,6 +3292,10 @@ and testing_mode = !testing_mode
 
 and threadsafe_aliases = !threadsafe_aliases
 
+and topl_max_conjuncts = !topl_max_conjuncts
+
+and topl_max_disjuncts = !topl_max_disjuncts
+
 and topl_properties = !topl_properties
 
 and trace_error = !trace_error

infer/src/base/Config.mli

@@ -597,6 +597,10 @@ val testing_mode : bool
 
 val threadsafe_aliases : Yojson.Basic.t
 
+val topl_max_conjuncts : int
+
+val topl_max_disjuncts : int
+
 val topl_properties : string list
 
 val trace_error : bool

infer/src/pulse/PulseTopl.ml

@@ -252,7 +252,43 @@ let drop_infeasible path_condition state =
   List.filter ~f state
 
 
+let normalize_memory memory = List.sort ~compare:[%compare: register * value] memory
+
+let normalize_configuration {vertex; memory} = {vertex; memory= normalize_memory memory}
+
+let normalize_pruned pruned = List.dedup_and_sort ~compare:compare_predicate pruned
+
+let normalize_simple_state {pre; post; pruned; last_step} =
+  { pre= normalize_configuration pre
+  ; post= normalize_configuration post
+  ; pruned= normalize_pruned pruned
+  ; last_step }
+
+
+let normalize_state state = List.map ~f:normalize_simple_state state
+
+let apply_conjuncts_limit state =
+  let f simple_state = List.length simple_state.pruned <= Config.topl_max_conjuncts in
+  IList.filter_changed ~f state
+
+
+let apply_disjuncts_limit state =
+  if List.length state <= Config.topl_max_disjuncts then state
+  else
+    let new_len = (Config.topl_max_disjuncts / 2) + 1 in
+    let add_score simple_state = (List.length simple_state.pruned, simple_state) in
+    let compare_score (score1, _simple_state1) (score2, _simple_state2) =
+      Int.compare score1 score2
+    in
+    let strip_score (_score, simple_state) = simple_state in
+    state |> List.map ~f:add_score |> List.sort ~compare:compare_score |> Fn.flip List.take new_len
+    |> List.map ~f:strip_score
+
+
+let apply_limits state = state |> apply_conjuncts_limit |> apply_disjuncts_limit
+
 let small_step loc path_condition event simple_states =
+  let simple_states = apply_limits simple_states in
   let tmatches = static_match event in
   let evolve_transition (old : simple_state) (transition, tcontext) : state =
     let mk ?(memory = old.post.memory) ?(pruned = []) significant =
@@ -318,13 +354,12 @@ let sub_list sub_elem (sub, xs) =
   (sub, List.rev xs)
 
 
-let of_unequal =
-  List.Or_unequal_lengths.(
-    function
-    | Ok x ->
-        x
-    | Unequal_lengths ->
-        L.die InternalError "PulseTopl expected lists to be of equal lengths")
+let of_unequal (or_unequal : 'a List.Or_unequal_lengths.t) =
+  match or_unequal with
+  | Ok x ->
+      x
+  | Unequal_lengths ->
+      L.die InternalError "PulseTopl expected lists to be of equal lengths"
 
 
 let sub_configuration (sub, {vertex; memory}) =
@@ -361,22 +396,8 @@ let sub_simple_state (sub, {pre; post; pruned; last_step}) =
   (sub, {pre; post; pruned; last_step})
 
 
-let normalize_memory memory = List.sort ~compare:[%compare: register * value] memory
-
-let normalize_configuration {vertex; memory} = {vertex; memory= normalize_memory memory}
-
-let normalize_pruned pruned = List.sort ~compare:compare_predicate pruned
-
-let normalize_simple_state {pre; post; pruned; last_step} =
-  { pre= normalize_configuration pre
-  ; post= normalize_configuration post
-  ; pruned= normalize_pruned pruned
-  ; last_step }
-
-
-let normalize_state state = List.map ~f:normalize_simple_state state
-
 let large_step ~call_location ~callee_proc_name ~substitution ~condition ~callee_prepost state =
+  let state = apply_limits state in
   let seq ((p : simple_state), (q : simple_state)) =
     if not (Int.equal p.post.vertex q.pre.vertex) then None
     else