Source file hash.ml

(* This is the interface to the runtime support for [ppx_hash].

   The [ppx_hash] syntax extension supports: [@@deriving hash] and [%hash_fold: TYPE] and
   [%hash: TYPE]

   For type [t] a function [hash_fold_t] of type [Hash.state -> t -> Hash.state] is
   generated.

   The generated [hash_fold_<T>] function is compositional, following the structure of the
   type; allowing user overrides at every level. This is in contrast to ocaml's builtin
   polymorphic hashing [Hashtbl.hash] which ignores user overrides.

   The generator also provides a direct hash-function [hash] (named [hash_<T>] when <T> !=
   "t") of type: [t -> Hash.hash_value].

   The folding hash function can be accessed as [%hash_fold: TYPE] The direct hash
   function can be accessed as [%hash: TYPE]
*)

external unbox_float
  :  (float[@local_opt])
  -> (float#[@unboxed] [@local_opt])
  @@ portable
  = "%unbox_float"

external int_of_int32_u
  :  (int32#[@unboxed] [@local_opt])
  -> int
  @@ portable
  = "%int_of_int32#"

external unbox_int64
  :  (int64[@local_opt])
  -> (int64#[@unboxed] [@local_opt])
  @@ portable
  = "%unbox_int64"

external int64_u_of_nativeint_u
  :  (nativeint#[@unboxed])
  -> (int64#[@unboxed] [@local_opt])
  @@ portable
  = "%int64#_of_nativeint#"

let fold_unit_u s #() = s

let int_of_bool_u = function
  | #false -> 0
  | #true -> 1
;;

external int_of_char_u : (char#[@unboxed]) -> int @@ portable = "%int_of_int8#"
[@@warning "-187"]

let code_of_char_u x = int_of_char_u x land 255

open Basement.Or_null_shim.Export
include Hash_intf

(** Builtin folding-style hash functions, abstracted over [Hash_intf.S] *)
module Folding (Hash : Hash_intf.S) :
  Hash_intf.Builtin_intf
  with type state = Hash.state
   and type hash_value = Hash.hash_value = struct
  type state = Hash.state
  type hash_value = Hash.hash_value
  type ('a : any) folder = state -> 'a -> state

  let hash_fold_unit s () = s
  let hash_fold_unit_u = fold_unit_u
  let hash_fold_int = Hash.fold_int
  let hash_fold_int64_u = Hash.fold_int64_u
  let hash_fold_int64 s x = hash_fold_int64_u s (unbox_int64 x)
  let hash_fold_float_u = Hash.fold_float_u
  let hash_fold_float s x = hash_fold_float_u s (unbox_float x)
  let hash_fold_string = Hash.fold_string
  let as_int f s x = hash_fold_int s (f x)

  (* This ignores the sign bit on 32-bit architectures, but it's unlikely to lead to
     frequent collisions (min_value colliding with 0 is the most likely one). *)
  let hash_fold_int32 = as_int Stdlib.Int32.to_int
  let hash_fold_int32_u s x = hash_fold_int s (int_of_int32_u x)
  let hash_fold_char = as_int Char.code
  let hash_fold_char_u s x = hash_fold_int s (code_of_char_u x)

  let hash_fold_bool =
    as_int (function
      | true -> 1
      | false -> 0)
  ;;

  let hash_fold_bool_u s x = hash_fold_int s (int_of_bool_u x)
  let hash_fold_nativeint s x = hash_fold_int64 s (Stdlib.Int64.of_nativeint x)
  let hash_fold_nativeint_u s x = hash_fold_int64_u s (int64_u_of_nativeint_u x)

  let hash_fold_option hash_fold_elem s = function
    | None -> hash_fold_int s 0
    | Some x -> hash_fold_elem (hash_fold_int s 1) x
  ;;

  let hash_fold_or_null hash_fold_elem s = function
    | Null -> hash_fold_int s 0
    | This x -> hash_fold_elem (hash_fold_int s 1) x
  ;;

  let rec hash_fold_list_body hash_fold_elem s list =
    match list with
    | [] -> s
    | x :: xs -> hash_fold_list_body hash_fold_elem (hash_fold_elem s x) xs
  ;;

  let hash_fold_list hash_fold_elem s list =
    (* The [length] of the list must be incorporated into the hash-state so values of
       types such as [unit list] - ([], [()], [();()],..) are hashed differently. *)
    (* The [length] must come before the elements to avoid a violation of the rule
       enforced by Perfect_hash. *)
    let s = hash_fold_int s (List.length list) in
    let s = hash_fold_list_body hash_fold_elem s list in
    s
  ;;

  let hash_fold_lazy_t hash_fold_elem s x = hash_fold_elem s (Stdlib.Lazy.force x)
  let hash_fold_ref_frozen hash_fold_elem s x = hash_fold_elem s !x

  let rec hash_fold_array_frozen_i hash_fold_elem s array i =
    if i = Array.length array
    then s
    else (
      let e = Array.unsafe_get array i in
      hash_fold_array_frozen_i hash_fold_elem (hash_fold_elem s e) array (i + 1))
  ;;

  let hash_fold_array_frozen hash_fold_elem s array =
    hash_fold_array_frozen_i
      (* [length] must be incorporated for arrays, as it is for lists. See comment above *)
      hash_fold_elem
      (hash_fold_int s (Array.length array))
      array
      0
  ;;

  (* the duplication here is because we think ocaml can't eliminate indirect function
     calls otherwise. *)
  let hash_nativeint x =
    Hash.get_hash_value (hash_fold_nativeint (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_nativeint_u x =
    Hash.get_hash_value (hash_fold_nativeint_u (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_int64 x = Hash.get_hash_value (hash_fold_int64 (Hash.reset (Hash.alloc ())) x)

  let hash_int64_u x =
    Hash.get_hash_value (hash_fold_int64_u (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_int32 x = Hash.get_hash_value (hash_fold_int32 (Hash.reset (Hash.alloc ())) x)

  let hash_int32_u x =
    Hash.get_hash_value (hash_fold_int32_u (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_char x = Hash.get_hash_value (hash_fold_char (Hash.reset (Hash.alloc ())) x)

  let hash_char_u x =
    Hash.get_hash_value (hash_fold_char_u (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_int x = Hash.get_hash_value (hash_fold_int (Hash.reset (Hash.alloc ())) x)
  let hash_bool x = Hash.get_hash_value (hash_fold_bool (Hash.reset (Hash.alloc ())) x)

  let hash_bool_u x =
    Hash.get_hash_value (hash_fold_bool_u (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_string x =
    Hash.get_hash_value (hash_fold_string (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_float x = Hash.get_hash_value (hash_fold_float (Hash.reset (Hash.alloc ())) x)

  let hash_float_u x =
    Hash.get_hash_value (hash_fold_float_u (Hash.reset (Hash.alloc ())) x)
  ;;

  let hash_unit x = Hash.get_hash_value (hash_fold_unit (Hash.reset (Hash.alloc ())) x)

  let hash_unit_u x =
    Hash.get_hash_value (hash_fold_unit_u (Hash.reset (Hash.alloc ())) x)
  ;;
end

module F (Hash : Hash_intf.S) :
  Hash_intf.Full
  with type hash_value = Hash.hash_value
   and type state = Hash.state
   and type seed = Hash.seed = struct
  include Hash

  type ('a : any) folder = state -> 'a -> state

  let create ?seed () = reset ?seed (alloc ())
  let of_fold hash_fold_t t = get_hash_value (hash_fold_t (create ()) t)

  module Builtin = Folding (Hash)

  let run ?seed folder x =
    Hash.get_hash_value (folder (Hash.reset ?seed (Hash.alloc ())) x)
  ;;
end

module Internalhash : sig @@ portable
  include
    Hash_intf.S
    with type state = Base_internalhash_types.state
    (* We give a concrete type for [state], albeit only partially exposed (see
       Base_internalhash_types), so that it unifies with the same type in [Base_boot], and
       to allow optimizations for the immediate type. *)
     and type seed = Base_internalhash_types.seed
     and type hash_value = Base_internalhash_types.hash_value

  external fold_int64
    :  state
    -> (int64[@unboxed])
    -> state
    = "Base_internalhash_fold_int64" "Base_internalhash_fold_int64_unboxed"
  [@@noalloc]

  external fold_int : state -> int -> state = "Base_internalhash_fold_int" [@@noalloc]

  external fold_float
    :  state
    -> (float[@unboxed])
    -> state
    = "Base_internalhash_fold_float" "Base_internalhash_fold_float_unboxed"
  [@@noalloc]

  external fold_string : state -> string -> state = "Base_internalhash_fold_string"
  [@@noalloc]

  external get_hash_value : state -> hash_value = "Base_internalhash_get_hash_value"
  [@@noalloc]
end = struct
  let description = "internalhash"

  include Base_internalhash_types

  let alloc () = create_seeded 0
  let reset ?(seed = 0) _t = create_seeded seed

  module For_tests = struct
    let compare_state = Base_internalhash_types.compare_state
    let state_to_string = Base_internalhash_types.state_to_string
  end
end

module T = struct
  include Internalhash

  type ('a : any) folder = state -> 'a -> state

  let create ?seed () = reset ?seed (alloc ())
  let run ?seed folder x = get_hash_value (folder (reset ?seed (alloc ())) x)
  let of_fold hash_fold_t t = get_hash_value (hash_fold_t (create ()) t)

  module Builtin = struct
    module Folding = struct
      include Folding (Internalhash)

      (* Hack to make zero-alloc see that these functions are zero-alloc, even in
         BUILD_PROFILE=dev. dev builds do not inline functor applications like
         [Folding (Internalhash)] above.
      *)
      let hash_fold_string = Internalhash.fold_string
      let hash_fold_float = Internalhash.fold_float
      let hash_fold_int = Internalhash.fold_int
      let hash_fold_int64 = Internalhash.fold_int64
    end

    include Folding

    (* [Folding] provides some default implementations for the [hash_*] functions below,
       but they are inefficient for some use-cases because of the use of the [hash_fold]
       functions. At this point, the [hash_value] type has been fixed to [int], so this
       module can provide specialized implementations. *)

    let hash_char = Char.code

    (* This hash was chosen from here: https://gist.github.com/badboy/6267743

       It attempts to fulfill the primary goals of a non-cryptographic hash function:

       - a bit change in the input should change ~1/2 of the output bits
       - the output should be uniformly distributed across the output range
       - inputs that are close to each other shouldn't lead to outputs that are close to
         each other.
       - all bits of the input are used in generating the output

       In our case we also want it to be fast, non-allocating, and inlinable. *)
    let[@inline always] hash_int (t : int) =
      let t = lnot t + (t lsl 21) in
      let t = t lxor (t lsr 24) in
      let t = t + (t lsl 3) + (t lsl 8) in
      let t = t lxor (t lsr 14) in
      let t = t + (t lsl 2) + (t lsl 4) in
      let t = t lxor (t lsr 28) in
      t + (t lsl 31)
    ;;

    let hash_bool x = if x then 1 else 0

    external hash_float
      :  (float[@unboxed])
      -> int
      @@ portable
      = "Base_hash_double" "Base_hash_double_unboxed"
    [@@noalloc]

    let hash_unit () = 0
  end
end

include T