From 9a238a76daf051f57e75630febdc95ee2d103af7 Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Tue, 20 Oct 2020 11:41:30 -0700 Subject: [PATCH] [sledge] Switch from Base.Hashtbl to Containers.Hashtbl Reviewed By: ngorogiannis Differential Revision: D24306054 fbshipit-source-id: 3ee9f8752 --- sledge/cli/frontend.ml | 89 ++++++++++++++++++------------ sledge/nonstdlib/NS.ml | 1 + sledge/nonstdlib/NS.mli | 3 +- sledge/nonstdlib/NS0.ml | 2 +- sledge/nonstdlib/hashTable.ml | 43 +++++++++++++++ sledge/nonstdlib/hashTable.mli | 13 +++++ sledge/nonstdlib/hashTable_intf.ml | 23 ++++++++ sledge/nonstdlib/q_ext.ml | 2 +- sledge/nonstdlib/string.ml | 1 + sledge/nonstdlib/string.mli | 1 + sledge/report/sledge_report.ml | 4 +- sledge/src/control.ml | 12 ++-- sledge/src/llair/typ.ml | 6 +- 13 files changed, 153 insertions(+), 47 deletions(-) create mode 100644 sledge/nonstdlib/hashTable.ml create mode 100644 sledge/nonstdlib/hashTable.mli create mode 100644 sledge/nonstdlib/hashTable_intf.ml diff --git a/sledge/cli/frontend.ml b/sledge/cli/frontend.ml index 528c61cb5..ffd244e9b 100644 --- a/sledge/cli/frontend.ml +++ b/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 = - Hashtbl.Poly.create ~size:4_194_304 () +module LlvalueTbl = HashTable.Make (struct + type t = Llvm.llvalue -let scope_tbl : - ( [`Fun of Llvm.llvalue | `Mod of Llvm.llmodule] - , int ref * (string, int) Hashtbl.t ) - Hashtbl.t = - Hashtbl.Poly.create ~size:32_768 () + include Poly +end) + +module SymTbl = LlvalueTbl + +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 () -> - (ref 0, Hashtbl.Poly.create ()) ) + ScopeTbl.find_or_add scope_tbl scope ~default:(fun () -> + (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 = - Hashtbl.Poly.create () +module LltypeTbl = HashTable.Make (struct + 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 () -> - Int.to_string (Hashtbl.length anon_struct_name) ) + LltypeTbl.find_or_add anon_struct_name llt ~default:(fun () -> + 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 = - Hashtbl.Poly.create () +module ValTbl = HashTable.Make (struct + 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 = - Hashtbl.Poly.create () +let memo_global : Global.t GlobTbl.t = GlobTbl.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 ; - Hashtbl.clear scope_tbl ; - Hashtbl.clear anon_struct_name ; - Hashtbl.clear memo_type ; - Hashtbl.clear memo_global ; - Hashtbl.clear memo_value ; + SymTbl.clear sym_tbl ; + ScopeTbl.clear scope_tbl ; + LltypeTbl.clear anon_struct_name ; + LltypeTbl.clear memo_type ; + GlobTbl.clear memo_global ; + ValTbl.clear memo_value ; StringS.clear ignored_callees ; Gc.full_major () ; Llvm.dispose_module llmodule ; diff --git a/sledge/nonstdlib/NS.ml b/sledge/nonstdlib/NS.ml index 50fca23f9..88c647667 100644 --- a/sledge/nonstdlib/NS.ml +++ b/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 diff --git a/sledge/nonstdlib/NS.mli b/sledge/nonstdlib/NS.mli index 8cbb8f54c..0fe52ec2a 100644 --- a/sledge/nonstdlib/NS.mli +++ b/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 diff --git a/sledge/nonstdlib/NS0.ml b/sledge/nonstdlib/NS0.ml index 4dd7a2924..f62a13f79 100644 --- a/sledge/nonstdlib/NS0.ml +++ b/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 diff --git a/sledge/nonstdlib/hashTable.ml b/sledge/nonstdlib/hashTable.ml new file mode 100644 index 000000000..1a1d68202 --- /dev/null +++ b/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 diff --git a/sledge/nonstdlib/hashTable.mli b/sledge/nonstdlib/hashTable.mli new file mode 100644 index 000000000..a65ed784a --- /dev/null +++ b/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 diff --git a/sledge/nonstdlib/hashTable_intf.ml b/sledge/nonstdlib/hashTable_intf.ml new file mode 100644 index 000000000..ac8554cc0 --- /dev/null +++ b/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 diff --git a/sledge/nonstdlib/q_ext.ml b/sledge/nonstdlib/q_ext.ml index 7240729e8..bde2a885c 100644 --- a/sledge/nonstdlib/q_ext.ml +++ b/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 diff --git a/sledge/nonstdlib/string.ml b/sledge/nonstdlib/string.ml index 69f1ad492..eb1753d23 100644 --- a/sledge/nonstdlib/string.ml +++ b/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) diff --git a/sledge/nonstdlib/string.mli b/sledge/nonstdlib/string.mli index 3d9df7636..66fc4dc0b 100644 --- a/sledge/nonstdlib/string.mli +++ b/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 diff --git a/sledge/report/sledge_report.ml b/sledge/report/sledge_report.ml index 8b1228ef7..419b0b7f9 100644 --- a/sledge/report/sledge_report.ml +++ b/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 diff --git a/sledge/src/control.ml b/sledge/src/control.ml index 8f1cf5ab9..8e250cc95 100644 --- a/sledge/src/control.ml +++ b/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 "@[%t@]" (fun fs -> - Hashtbl.iteri summary_table ~f:(fun ~key ~data -> + RegTbl.iteri summary_table ~f:(fun ~key ~data -> Format.fprintf fs "@[%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 diff --git a/sledge/src/llair/typ.ml b/sledge/src/llair/typ.ml index c2e66bc52..f4cab416a 100644 --- a/sledge/src/llair/typ.ml +++ b/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