[sledge] Switch from Base.Hashtbl to Containers.Hashtbl

Reviewed By: ngorogiannis

Differential Revision: D24306054

fbshipit-source-id: 3ee9f8752

sledge/cli/frontend.ml

@@ -51,14 +51,24 @@ let invalid_llvm : string -> 'a =
 
 (* gather names and debug locations *)
 
-let sym_tbl : (Llvm.llvalue, string * Loc.t) Hashtbl.t =
+module LlvalueTbl = HashTable.Make (struct
-  Hashtbl.Poly.create ~size:4_194_304 ()
+  type t = Llvm.llvalue
 
-let scope_tbl :
+  include Poly
-    ( [`Fun of Llvm.llvalue | `Mod of Llvm.llmodule]
+end)
-    , int ref * (string, int) Hashtbl.t )
+
-    Hashtbl.t =
+module SymTbl = LlvalueTbl
-  Hashtbl.Poly.create ~size:32_768 ()
+
+let sym_tbl : (string * Loc.t) SymTbl.t = SymTbl.create ~size:4_194_304 ()
+
+module ScopeTbl = HashTable.Make (struct
+  type t = [`Fun of Llvm.llvalue | `Mod of Llvm.llmodule]
+
+  include Poly
+end)
+
+let scope_tbl : (int ref * int String.Tbl.t) ScopeTbl.t =
+  ScopeTbl.create ~size:32_768 ()
 
 open struct
   open struct
@@ -103,8 +113,8 @@ open struct
       | None -> ()
       | Some scope ->
           let next, void_tbl =
-            Hashtbl.find_or_add scope_tbl scope ~default:(fun () ->
+            ScopeTbl.find_or_add scope_tbl scope ~default:(fun () ->
-                (ref 0, Hashtbl.Poly.create ()) )
+                (ref 0, String.Tbl.create ()) )
           in
           let name =
             match Llvm.classify_type (Llvm.type_of llv) with
@@ -120,12 +130,12 @@ open struct
                     | s -> s )
                   | _ -> "void"
                 in
-                match Hashtbl.find void_tbl fname with
+                match String.Tbl.find void_tbl fname with
                 | None ->
-                    Hashtbl.set void_tbl ~key:fname ~data:1 ;
+                    String.Tbl.set void_tbl ~key:fname ~data:1 ;
                     fname ^ ".void"
                 | Some count ->
-                    Hashtbl.set void_tbl ~key:fname ~data:(count + 1) ;
+                    String.Tbl.set void_tbl ~key:fname ~data:(count + 1) ;
                     String.concat_array
                       [|fname; ".void."; Int.to_string count|] )
             | _ -> (
@@ -142,7 +152,7 @@ open struct
                     String.concat_array [|"\""; name; "\""|]
                 | exception _ -> name ) )
           in
-          Hashtbl.set sym_tbl ~key:llv ~data:(name, loc)
+          SymTbl.set sym_tbl ~key:llv ~data:(name, loc)
   end
 
   let scan_names_and_locs : Llvm.llmodule -> unit =
@@ -178,25 +188,30 @@ open struct
     Llvm.iter_functions scan_function m
 
   let find_name : Llvm.llvalue -> string =
-   fun v -> fst (Hashtbl.find_exn sym_tbl v)
+   fun v -> fst (SymTbl.find_exn sym_tbl v)
 
   let find_loc : Llvm.llvalue -> Loc.t =
-   fun v -> snd (Hashtbl.find_exn sym_tbl v)
+   fun v -> snd (SymTbl.find_exn sym_tbl v)
 end
 
 let label_of_block : Llvm.llbasicblock -> string =
  fun blk -> find_name (Llvm.value_of_block blk)
 
-let anon_struct_name : (Llvm.lltype, string) Hashtbl.t =
+module LltypeTbl = HashTable.Make (struct
-  Hashtbl.Poly.create ()
+  type t = Llvm.lltype
+
+  include Poly
+end)
+
+let anon_struct_name : string LltypeTbl.t = LltypeTbl.create ()
 
 let struct_name : Llvm.lltype -> string =
  fun llt ->
   match Llvm.struct_name llt with
   | Some name -> name
   | None ->
-      Hashtbl.find_or_add anon_struct_name llt ~default:(fun () ->
+      LltypeTbl.find_or_add anon_struct_name llt ~default:(fun () ->
-          Int.to_string (Hashtbl.length anon_struct_name) )
+          Int.to_string (LltypeTbl.length anon_struct_name) )
 
 type x = {llcontext: Llvm.llcontext; lldatalayout: Llvm_target.DataLayout.t}
 
@@ -214,7 +229,7 @@ let size_of, bit_size_of =
   ( size_to_int Llvm_target.DataLayout.abi_size
   , size_to_int Llvm_target.DataLayout.size_in_bits )
 
-let memo_type : (Llvm.lltype, Typ.t) Hashtbl.t = Hashtbl.Poly.create ()
+let memo_type : Typ.t LltypeTbl.t = LltypeTbl.create ()
 
 let rec xlate_type : x -> Llvm.lltype -> Typ.t =
  fun x llt ->
@@ -277,7 +292,7 @@ let rec xlate_type : x -> Llvm.lltype -> Typ.t =
           fail "expected to be sized: %a" pp_lltype llt ()
       | Void | Label | Metadata -> assert false
   in
-  Hashtbl.find_or_add memo_type llt ~default:(fun () ->
+  LltypeTbl.find_or_add memo_type llt ~default:(fun () ->
       [%Trace.call fun {pf} -> pf "%a" pp_lltype llt]
       ;
       xlate_type_ llt
@@ -335,11 +350,17 @@ let pp_prefix_exp fs (insts, exp) =
    of 'undef' to a distinct register *)
 let undef_count = ref 0
 
-let memo_value : (bool * Llvm.llvalue, Inst.t list * Exp.t) Hashtbl.t =
+module ValTbl = HashTable.Make (struct
-  Hashtbl.Poly.create ()
+  type t = bool * Llvm.llvalue
+
+  include Poly
+end)
+
+let memo_value : (Inst.t list * Exp.t) ValTbl.t = ValTbl.create ()
+
+module GlobTbl = LlvalueTbl
 
-let memo_global : (Llvm.llvalue, Global.t) Hashtbl.t =
+let memo_global : Global.t GlobTbl.t = GlobTbl.create ()
-  Hashtbl.Poly.create ()
 
 let should_inline : Llvm.llvalue -> bool =
  fun llv ->
@@ -485,7 +506,7 @@ and xlate_value ?(inline = false) stk :
      |NullValue | BasicBlock | InlineAsm | MDNode | MDString ->
         fail "xlate_value: %a" pp_llvalue llv ()
   in
-  Hashtbl.find_or_add memo_value (inline, llv) ~default:(fun () ->
+  ValTbl.find_or_add memo_value (inline, llv) ~default:(fun () ->
       [%Trace.call fun {pf} -> pf "%a" pp_llvalue llv]
       ;
       xlate_value_ llv
@@ -709,14 +730,14 @@ and xlate_opcode stk :
 
 and xlate_global stk : x -> Llvm.llvalue -> Global.t =
  fun x llg ->
-  Hashtbl.find_or_add memo_global llg ~default:(fun () ->
+  GlobTbl.find_or_add memo_global llg ~default:(fun () ->
       [%Trace.call fun {pf} -> pf "%a" pp_llvalue llg]
       ;
       let g = xlate_name x ~global:() llg in
       let loc = find_loc llg in
       (* add to tbl without initializer in case of recursive occurrences in
          its own initializer *)
-      Hashtbl.set memo_global ~key:llg ~data:(Global.mk g loc) ;
+      GlobTbl.set memo_global ~key:llg ~data:(Global.mk g loc) ;
       let init =
         match Llvm.classify_value llg with
         | GlobalVariable ->
@@ -1520,12 +1541,12 @@ let check_datalayout llcontext lldatalayout =
    Gc.full_major) before freeing the memory with Llvm.dispose_module and
    Llvm.dispose_context. *)
 let cleanup llmodule llcontext =
-  Hashtbl.clear sym_tbl ;
+  SymTbl.clear sym_tbl ;
-  Hashtbl.clear scope_tbl ;
+  ScopeTbl.clear scope_tbl ;
-  Hashtbl.clear anon_struct_name ;
+  LltypeTbl.clear anon_struct_name ;
-  Hashtbl.clear memo_type ;
+  LltypeTbl.clear memo_type ;
-  Hashtbl.clear memo_global ;
+  GlobTbl.clear memo_global ;
-  Hashtbl.clear memo_value ;
+  ValTbl.clear memo_value ;
   StringS.clear ignored_callees ;
   Gc.full_major () ;
   Llvm.dispose_module llmodule ;

sledge/nonstdlib/NS.ml

@@ -11,6 +11,7 @@ include NS0
 module Array = Array
 module Float = Float
 module HashSet = HashSet
+module HashTable = HashTable
 module IArray = IArray
 include IArray.Import
 module Int = Int

sledge/nonstdlib/NS.mli

@@ -146,7 +146,7 @@ include module type of IArray.Import
 module Set = Set
 module Map = Map
 module Multiset = Multiset
-module Hashtbl = Base.Hashtbl
+module HashTable = HashTable
 module HashSet = HashSet
 module Hash_queue = Core_kernel.Hash_queue
 
@@ -214,4 +214,5 @@ val violates : ('a -> unit) -> 'a -> _
 
 (**)
 
+module Hashtbl : sig end [@@deprecated "Use HashTable instead of Hashtbl"]
 module With_return = Base.With_return

sledge/nonstdlib/NS0.ml

@@ -125,7 +125,6 @@ module Either = struct
   let right v = Right v
 end
 
-module Hashtbl = Base.Hashtbl
 module Hash_queue = Core_kernel.Hash_queue
 
 (** Input / Output *)
@@ -228,4 +227,5 @@ let violates f x =
 
 (** Deprecated *)
 
+module Hashtbl = struct end
 module With_return = Base.With_return

sledge/nonstdlib/hashTable.ml

@@ -0,0 +1,43 @@
+(*
+ * 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! NS0
+
+(** Hash tables *)
+
+include HashTable_intf
+
+module Make (Key : HashedType) = struct
+  include CCHashtbl.Make (Key)
+
+  let create ?(size = 0) () = create size
+  let set tbl ~key ~data = replace tbl key data
+
+  let add_multi tbl ~key ~data =
+    update tbl ~k:key ~f:(fun _ -> function
+      | None -> Some [data] | Some datas -> Some (data :: datas) )
+
+  let find_exn = find
+  let find = find_opt
+
+  let find_or_add tbl key ~default =
+    let found = ref None in
+    update tbl ~k:key ~f:(fun _ -> function
+      | None ->
+          let v = default () in
+          found := Some v ;
+          Some v
+      | Some v ->
+          found := Some v ;
+          Some v ) ;
+    Option.value_exn !found
+
+  let iteri tbl ~f = iter (fun key data -> f ~key ~data) tbl
+
+  let fold tbl ~init ~f =
+    fold (fun key data acc -> f ~key ~data acc) tbl init
+end

sledge/nonstdlib/hashTable.mli

@@ -0,0 +1,13 @@
+(*
+ * 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! NS0
+
+(** Hash tables *)
+
+include module type of HashTable_intf
+module Make (Key : HashedType) : S with type key = Key.t

sledge/nonstdlib/hashTable_intf.ml

@@ -0,0 +1,23 @@
+(*
+ * 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! NS0
+
+module type HashedType = Stdlib.Hashtbl.HashedType
+
+module type S = sig
+  include CCHashtbl.S
+
+  val create : ?size:int -> unit -> 'a t
+  val set : 'a t -> key:key -> data:'a -> unit
+  val add_multi : 'a list t -> key:key -> data:'a -> unit
+  val find_exn : 'a t -> key -> 'a
+  val find : 'a t -> key -> 'a option
+  val find_or_add : 'a t -> key -> default:(unit -> 'a) -> 'a
+  val iteri : 'a t -> f:(key:key -> data:'a -> unit) -> unit
+  val fold : 'a t -> init:'s -> f:(key:key -> data:'a -> 's -> 's) -> 's
+end

sledge/nonstdlib/q_ext.ml

@@ -8,7 +8,7 @@
 open NS0
 
 let pp = Q.pp_print
-let hash = Hashtbl.hash
+let hash = Poly.hash
 let hash_fold_t s q = Int.hash_fold_t s (hash q)
 let sexp_of_t q = Sexp.Atom (Q.to_string q)
 let t_of_sexp = function Sexp.Atom s -> Q.of_string s | _ -> assert false

sledge/nonstdlib/string.ml

@@ -9,3 +9,4 @@ open! NS0
 include Base.String
 module Set = Set.Make (Base.String)
 module Map = Map.Make (Base.String)
+module Tbl = HashTable.Make (Base.String)

sledge/nonstdlib/string.mli

@@ -9,3 +9,4 @@ open! NS0
 include module type of Base.String
 module Set : Set.S with type elt = string
 module Map : Map.S with type key = string
+module Tbl : HashTable.S with type key = string

sledge/report/sledge_report.ml

@@ -6,10 +6,10 @@
  *)
 
 module Command = Core.Command
-module Tbl = CCHashtbl.Make (String)
+module Tbl = String.Tbl
 
 let read filename =
-  let tbl = Tbl.create 64 in
+  let tbl = Tbl.create () in
   List.iter (Sexp.load_sexps filename) ~f:(fun sexp ->
       let {Report.name; entry} = Report.t_of_sexp sexp in
       match (Tbl.find_opt tbl name, entry) with

sledge/src/control.ml

@@ -258,7 +258,9 @@ module Make (Dom : Domain_intf.Dom) = struct
   let exec_jump stk state block Llair.{dst; retreating} =
     Work.add ~prev:block ~retreating stk state dst
 
-  let summary_table = Hashtbl.create (module Llair.Reg)
+  module RegTbl = HashTable.Make (Llair.Reg)
+
+  let summary_table = RegTbl.create ()
 
   let exec_call opts stk state block call globals =
     let Llair.{callee; actuals; areturn; return; recursive} = call in
@@ -279,7 +281,7 @@ module Make (Dom : Domain_intf.Dom) = struct
           else
             let maybe_summary_post =
               let state = fst (domain_call ~summaries:false state) in
-              let* summary = Hashtbl.find summary_table name.reg in
+              let* summary = RegTbl.find summary_table name.reg in
               List.find_map ~f:(Dom.apply_summary state) summary
             in
             [%Trace.info
@@ -308,7 +310,7 @@ module Make (Dom : Domain_intf.Dom) = struct
   let pp_st () =
     [%Trace.printf
       "@[<v>%t@]" (fun fs ->
-          Hashtbl.iteri summary_table ~f:(fun ~key ~data ->
+          RegTbl.iteri summary_table ~f:(fun ~key ~data ->
               Format.fprintf fs "@[<v>%a:@ @[%a@]@]@ " Llair.Reg.pp key
                 (List.pp "@," Dom.pp_summary)
                 data ) )]
@@ -328,7 +330,7 @@ module Make (Dom : Domain_intf.Dom) = struct
             ~formals:
               (Llair.Reg.Set.union (Llair.Reg.Set.of_list formals) globals)
         in
-        Hashtbl.add_multi summary_table ~key:name.reg ~data:function_summary ;
+        RegTbl.add_multi summary_table ~key:name.reg ~data:function_summary ;
         pp_st () ;
         post_state
     in
@@ -511,7 +513,7 @@ module Make (Dom : Domain_intf.Dom) = struct
   let compute_summaries opts pgm : Dom.summary list Llair.Reg.Map.t =
     assert opts.function_summaries ;
     exec_pgm opts pgm ;
-    Hashtbl.fold summary_table ~init:Llair.Reg.Map.empty
+    RegTbl.fold summary_table ~init:Llair.Reg.Map.empty
       ~f:(fun ~key ~data map ->
         match data with [] -> map | _ -> Llair.Reg.Map.set map ~key ~data )
 end

sledge/src/llair/typ.ml

@@ -91,10 +91,10 @@ let tuple elts ~bits ~byts ~packed =
 let opaque ~name = Opaque {name} |> check invariant
 
 let struct_ =
-  let defns : (string, t) Hashtbl.t = Hashtbl.create (module String) in
+  let defns = String.Tbl.create () in
   let dummy_typ = Opaque {name= "dummy"} in
   fun ~name ~bits ~byts ~packed elt_thks ->
-    match Hashtbl.find defns name with
+    match String.Tbl.find defns name with
     | Some typ -> typ
     | None ->
         (* Add placeholder defn to prevent computing [elts] in calls to
@@ -103,7 +103,7 @@ let struct_ =
         let typ =
           Struct {name; elts= IArray.of_array elts; bits; byts; packed}
         in
-        Hashtbl.set defns ~key:name ~data:typ ;
+        String.Tbl.set defns ~key:name ~data:typ ;
         IArray.iteri elt_thks ~f:(fun i (lazy elt) -> elts.(i) <- elt) ;
         typ |> check invariant