[infer] Add LRU hash table

Reviewed By: ngorogiannis

Differential Revision: D20199999

fbshipit-source-id: 93d26b822

infer/src/IR/Procname.ml

@@ -742,6 +742,7 @@ module Hashable = struct
 end
 
 module Hash = Hashtbl.Make (Hashable)
+module LRUHash = LRUHashtbl.Make (Hashable)
 module HashQueue = Hash_queue.Make (Hashable)
 
 module Map = PrettyPrintable.MakePPMap (struct

infer/src/IR/Procname.mli

@@ -223,6 +223,8 @@ val is_objc_method : t -> bool
 module Hash : Caml.Hashtbl.S with type key = t
 (** Hash tables with proc names as keys. *)
 
+module LRUHash : LRUHashtbl.S with type key = t
+
 module HashQueue : Hash_queue.S with type key = t
 
 module Map : PrettyPrintable.PPMap with type key = t

infer/src/bufferoverrun/bufferOverrunUtils.ml

@@ -363,13 +363,15 @@ module ReplaceCallee = struct
 
 
   module CacheForMakeShared = struct
-    let results : Procname.t option Procname.Hash.t lazy_t = lazy (Procname.Hash.create 128)
+    let results : Procname.t option Procname.LRUHash.t lazy_t =
+      lazy (Procname.LRUHash.create ~initial_size:128 ~max_size:200)
 
-    let add pname value = Procname.Hash.replace (Lazy.force results) pname value
 
-    let find_opt pname = Procname.Hash.find_opt (Lazy.force results) pname
+    let add pname value = Procname.LRUHash.replace (Lazy.force results) pname value
 
-    let clear () = if Lazy.is_val results then Procname.Hash.clear (Lazy.force results)
+    let find_opt pname = Procname.LRUHash.find_opt (Lazy.force results) pname
+
+    let clear () = if Lazy.is_val results then Procname.LRUHash.clear (Lazy.force results)
   end
 
   let get_cpp_constructor_of_make_shared =

infer/src/istd/LRUHashtbl.ml

@@ -0,0 +1,94 @@
+(*
+ * 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 Hashtbl = Caml.Hashtbl
+
+module type S = sig
+  type key
+
+  type 'a t
+
+  val create : initial_size:int -> max_size:int -> 'a t
+
+  val find_opt : 'a t -> key -> 'a option
+
+  val replace : 'a t -> key -> 'a -> unit
+
+  val clear : 'a t -> unit
+
+  val pp :
+       pp_key:(F.formatter -> key -> unit)
+    -> pp_v:(F.formatter -> 'a -> unit)
+    -> F.formatter
+    -> 'a t
+    -> unit
+
+  val bindings : 'a t -> (key * 'a) list
+end
+
+module Make (Key : Hashtbl.HashedType) = struct
+  type key = Key.t
+
+  module Hash = Hashtbl.Make (Key)
+
+  module LRU = struct
+    type t = {list: Key.t Doubly_linked.t; max: int}
+
+    let create max =
+      assert (max > 0) ;
+      {list= Doubly_linked.create (); max}
+
+
+    let insert_first {list; max} k =
+      let new_node = Doubly_linked.insert_first list k in
+      let removed_key =
+        if Doubly_linked.length list > max then Doubly_linked.remove_last list else None
+      in
+      (new_node, removed_key)
+
+
+    let use {list} n = Doubly_linked.move_to_front list n
+
+    let clear {list} = Doubly_linked.clear list
+  end
+
+  type 'a t = {map: ('a * key Doubly_linked.Elt.t) Hash.t; lru: LRU.t}
+
+  let create ~initial_size ~max_size = {map= Hash.create initial_size; lru= LRU.create max_size}
+
+  let find_opt {map; lru} k =
+    match Hash.find_opt map k with None -> None | Some (v, e) -> LRU.use lru e ; Some v
+
+
+  let replace {map; lru} k v =
+    let n =
+      match Hash.find_opt map k with
+      | None ->
+          let n, removed_key = LRU.insert_first lru k in
+          Option.iter removed_key ~f:(Hash.remove map) ;
+          n
+      | Some (_, n) ->
+          LRU.use lru n ; n
+    in
+    Hash.replace map k (v, n)
+
+
+  let clear {map; lru} = Hash.clear map ; LRU.clear lru
+
+  let pp ~pp_key ~pp_v f {map} =
+    let is_first = ref true in
+    let pp_key_v key (v, _node) =
+      if !is_first then is_first := false else F.pp_print_string f ", " ;
+      F.fprintf f "%a->%a" pp_key key pp_v v
+    in
+    F.pp_print_string f "{" ; Hash.iter pp_key_v map ; F.pp_print_string f "}"
+
+
+  let bindings {map} = Seq.fold_left (fun acc (k, (v, _node)) -> (k, v) :: acc) [] (Hash.to_seq map)
+end

infer/src/istd/LRUHashtbl.mli

@@ -0,0 +1,35 @@
+(*
+ * 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
+
+(** Hash table the size of which is limited by LRU *)
+
+module type S = sig
+  type key
+
+  type 'a t
+
+  val create : initial_size:int -> max_size:int -> 'a t
+
+  val find_opt : 'a t -> key -> 'a option
+
+  val replace : 'a t -> key -> 'a -> unit
+
+  val clear : 'a t -> unit
+
+  val pp :
+       pp_key:(Format.formatter -> key -> unit)
+    -> pp_v:(Format.formatter -> 'a -> unit)
+    -> Format.formatter
+    -> 'a t
+    -> unit
+
+  val bindings : 'a t -> (key * 'a) list
+end
+
+module Make (Key : Caml.Hashtbl.HashedType) : S with type key = Key.t

infer/src/unit/LRUHashtblTests.ml

@@ -0,0 +1,58 @@
+(*
+ * 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
+open OUnit2
+module LRUHash = LRUHashtbl.Make (Int)
+
+let inputs =
+  [ ("empty", (fun () -> LRUHash.create ~initial_size:5 ~max_size:3), [])
+  ; ( "singleton"
+    , (fun () ->
+        let map = LRUHash.create ~initial_size:5 ~max_size:3 in
+        LRUHash.replace map 0 10 ; map )
+    , [(0, 10)] )
+  ; ( "LRU1"
+    , (fun () ->
+        let map = LRUHash.create ~initial_size:5 ~max_size:3 in
+        LRUHash.replace map 0 10 ;
+        LRUHash.replace map 1 10 ;
+        LRUHash.replace map 2 10 ;
+        let (_ : int option) = LRUHash.find_opt map 1 in
+        LRUHash.replace map 3 10 ; LRUHash.replace map 4 10 ; map )
+    , [(1, 10); (3, 10); (4, 10)] )
+  ; ( "LRU2"
+    , (fun () ->
+        let map = LRUHash.create ~initial_size:5 ~max_size:3 in
+        LRUHash.replace map 0 10 ;
+        LRUHash.replace map 1 10 ;
+        LRUHash.replace map 2 10 ;
+        LRUHash.replace map 0 20 ;
+        LRUHash.replace map 3 10 ;
+        map )
+    , [(0, 20); (2, 10); (3, 10)] )
+  ; ( "clear"
+    , (fun () ->
+        let map = LRUHash.create ~initial_size:5 ~max_size:3 in
+        LRUHash.replace map 0 10 ;
+        LRUHash.replace map 1 10 ;
+        LRUHash.replace map 2 10 ;
+        LRUHash.clear map ;
+        map )
+    , [] ) ]
+
+
+let tests =
+  let compare (k1, v1) (k2, v2) =
+    let c = k1 - k2 in
+    if c <> 0 then c else v1 - v2
+  in
+  "LRUHashtble"
+  >::: List.map inputs ~f:(fun (name, input, expected) ->
+           name
+           >:: fun _ -> assert_equal (input () |> LRUHash.bindings |> List.sort ~compare) expected
+       )

infer/src/unit/inferunit.ml

@@ -37,6 +37,7 @@ let () =
         ; IListTests.tests
         ; JavaProfilerSamplesTest.tests
         ; LivenessTests.tests
+        ; LRUHashtblTests.tests
         ; MaximumSharingTests.tests
         ; PerfProfilerATDParserTest.tests
         ; ProcCfgTests.tests