v0.13-preview.120.27+112

Author: xclerc

.gitignore

@@ -1,4 +1,5 @@
 _build
 *.install
 *.merlin
+_opam
 

hash_types/README.org

@@ -0,0 +1,4 @@
+#+TITLE: Base_internalhash_types
+
+This micro-library allows hash states, seeds, and values to be type-equal
+between ~Base~ and ~Base_boot~.

hash_types/src/base_internalhash_types.ml

@@ -0,0 +1,12 @@
+(** [state] is defined as a subtype of [int] using the [private] keyword. This makes it an
+    opaque type for most purposes, and tells the compiler that the type is immediate. *)
+type state = private int
+type seed = int
+type hash_value = int
+
+external create_seeded  : seed            -> state = "%identity"                   [@@noalloc]
+external fold_int64     : state -> int64  -> state = "Base_internalhash_fold_int64"     [@@noalloc]
+external fold_int       : state -> int    -> state = "Base_internalhash_fold_int"       [@@noalloc]
+external fold_float     : state -> float  -> state = "Base_internalhash_fold_float"     [@@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]

hash_types/src/dune

@@ -0,0 +1,4 @@
+(library (name base_internalhash_types)
+ (public_name base.base_internalhash_types) (libraries)
+ (preprocess no_preprocessing) (js_of_ocaml (javascript_files runtime.js))
+ (c_names internalhash_stubs) (install_c_headers internalhash))

src/internalhash.h renamed to hash_types/src/internalhash.h

@@ -0,0 +1,18 @@
+//Provides: Base_internalhash_fold_int64
+//Requires: caml_hash_mix_int64
+var Base_internalhash_fold_int64 = caml_hash_mix_int64;
+//Provides: Base_internalhash_fold_int
+//Requires: caml_hash_mix_int
+var Base_internalhash_fold_int = caml_hash_mix_int;
+//Provides: Base_internalhash_fold_float
+//Requires: caml_hash_mix_float
+var Base_internalhash_fold_float = caml_hash_mix_float;
+//Provides: Base_internalhash_fold_string
+//Requires: caml_hash_mix_string
+var Base_internalhash_fold_string = caml_hash_mix_string;
+//Provides: Base_internalhash_get_hash_value
+//Requires: caml_hash_mix_final
+function Base_internalhash_get_hash_value(seed) {
+  var h = caml_hash_mix_final(seed);
+  return h & 0x3FFFFFFF;
+}

src/internalhash_stubs.c renamed to hash_types/src/internalhash_stubs.c

@@ -0,0 +1,4 @@
+(library (name base_internalhash_types_test)
+ (libraries base base_boot expect_test_helpers_kernel
+  replace_caml_modify_for_testing stdio)
+ (preprocess (pps ppx_jane)))

hash_types/src/runtime.js

@@ -0,0 +1,2 @@
+include Stdio
+include Expect_test_helpers_kernel

hash_types/test/dune

@@ -0,0 +1,29 @@
+open! Base
+open! Import
+
+let%expect_test "[Base.Hash.state] is still immediate" =
+  require_no_allocation [%here] (fun () ->
+    ignore (Sys.opaque_identity (Base.Hash.create ())));
+  [%expect {| |}]
+
+let%expect_test "[Base_boot.Hash.state] is still immediate" =
+  require_no_allocation [%here] (fun () ->
+    ignore (Sys.opaque_identity (Base_boot.Hash.create ())));
+  [%expect {| |}]
+
+type t = { mutable state : Base.Hash.state; mutable list : unit list }
+
+let%expect_test _ =
+  let count_caml_modify f =
+    Replace_caml_modify_for_testing.reset ();
+    f ();
+    print_s [%sexp (Replace_caml_modify_for_testing.count () : int)];
+  in
+  let t = { state = Base.Hash.create ~seed:1 (); list = [] } in
+  let list = [ (); () ] (* not an immediate type, requires caml_modify *) in
+  count_caml_modify (fun () -> t.list <- list);
+  [%expect {| 1 |}];
+  let state = Base.Hash.create ~seed:2 () (* immediate, I hope *) in
+  count_caml_modify (fun () -> t.state <- state);
+  [%expect {| 0 |}];
+;;

hash_types/test/import.ml

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

hash_types/test/test_immediate.ml

@@ -0,0 +1,7 @@
+open! Base
+open! Import
+
+let%expect_test "[Base.Hash.state] unifies with [Base_boot.Hash.state]" =
+  let _f (state : Base.Hash.state) : Base_boot.Hash.state = state in
+  [%expect {| |}]
+;;

hash_types/test/test_immediate.mli

@@ -0,0 +1 @@
+(*_ This signature is deliberately empty. *)

hash_types/test/test_unification.ml

@@ -1,5 +1,6 @@
 open! Import
 
+module Array = Array0
 let stage = Staged.stage
 
 module T = struct
@@ -68,6 +69,29 @@ let to_list t =
   in
   loop t (length t - 1) []
 
+let to_array t = Array.init (length t) ~f:(fun i -> (unsafe_get t i))
+
+let map t ~f = map t ~f
+let mapi t ~f = mapi t ~f
+
+let fold =
+  let rec loop t ~f ~len ~pos acc =
+    if Int_replace_polymorphic_compare.equal pos len
+    then acc
+    else loop t ~f ~len ~pos:(pos + 1) (f acc (unsafe_get t pos))
+  in
+  fun t ~init ~f ->
+    loop t ~f ~len:(length t) ~pos:0 init
+
+let foldi =
+  let rec loop t ~f ~len ~pos acc =
+    if Int_replace_polymorphic_compare.equal pos len
+    then acc
+    else loop t ~f ~len ~pos:(pos + 1) (f pos acc (unsafe_get t pos))
+  in
+  fun t ~init ~f ->
+    loop t ~f ~len:(length t) ~pos:0 init
+
 let tr ~target ~replacement s =
   for i = 0 to length s - 1 do
     if Char.equal (unsafe_get s i) target

hash_types/test/test_unification.mli

@@ -42,6 +42,13 @@ val create : int -> t
     with the byte [c]. *)
 val make : int -> char -> t
 
+(** [map f t] applies function [f] to every byte, in order, and builds the byte
+    sequence with the results returned by [f]. *)
+val map : t -> f : (char -> char) -> t
+
+(** Like [map], but passes each character's index to [f] along with the char. *)
+val mapi : t -> f : (int -> char -> char) -> t
+
 (** [copy t] returns a newly-allocated byte sequence that contains the same
     bytes as [t]. *)
 val copy : t -> t
@@ -89,6 +96,16 @@ val tr_multi : target:string -> replacement:string -> (t -> unit) Staged.t
 (** [to_list t] returns the bytes in [t] as a list of chars. *)
 val to_list : t -> char list
 
+(** [to_array t] returns the bytes in [t] as an array of chars. *)
+val to_array : t -> char array
+
+(** [fold a ~f ~init:b] is [f a1 (f a2 (...))] *)
+val fold : t -> init : 'a -> f : ('a -> char -> 'a) -> 'a
+
+(** [foldi] works similarly to [fold], but also passes the index of each character to
+    [f]. *)
+val foldi : t -> init : 'a -> f : (int -> 'a -> char -> 'a) -> 'a
+
 (** [contains ?pos ?len t c] returns [true] iff [c] appears in [t] between [pos]
     and [pos + len]. *)
 val contains : ?pos:int -> ?len:int -> t -> char -> bool

src/bytes.ml

@@ -45,6 +45,8 @@ let copy            = Caml.Bytes.copy
 let create          = Caml.Bytes.create
 let fill            = Caml.Bytes.fill
 let make            = Caml.Bytes.make
+let map             = Caml.Bytes.map
+let mapi            = Caml.Bytes.mapi
 let sub             = Caml.Bytes.sub
 let unsafe_blit     = Caml.Bytes.unsafe_blit
 

src/bytes.mli

@@ -15,9 +15,9 @@
  (action (run %{first_dep} -atomic -o %{targets})) (mode fallback))
 
 (library (name base) (public_name base)
- (libraries caml sexplib0 shadow_stdlib) (install_c_headers internalhash)
+ (libraries base_internalhash_types caml sexplib0 shadow_stdlib)
  (c_flags :standard -D_LARGEFILE64_SOURCE (:include mpopcnt.sexp))
- (c_names exn_stubs int_math_stubs internalhash_stubs hash_stubs am_testing)
+ (c_names exn_stubs int_math_stubs hash_stubs am_testing)
  (preprocess no_preprocessing)
   (lint 
   (pps ppx_base ppx_base_lint -check-doc-comments -type-conv-keep-w32=impl

src/bytes0.ml

@@ -138,9 +138,12 @@ end
 
 module Internalhash : sig
   include Hash_intf.S
-    with type state      = private int (* allow optimizations for immediate type *)
-     and type seed       = int
-     and type hash_value = int
+    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  -> state = "Base_internalhash_fold_int64"  [@@noalloc]
   external fold_int       : state -> int    -> state = "Base_internalhash_fold_int"    [@@noalloc]
@@ -150,24 +153,15 @@ module Internalhash : sig
 end = struct
   let description = "internalhash"
 
-  type state = int
-  type hash_value = int
-  type seed = int
-
-  external create_seeded  : seed            -> state = "%identity"                   [@@noalloc]
-  external fold_int64     : state -> int64  -> state = "Base_internalhash_fold_int64"     [@@noalloc]
-  external fold_int       : state -> int    -> state = "Base_internalhash_fold_int"       [@@noalloc]
-  external fold_float     : state -> float  -> state = "Base_internalhash_fold_float"     [@@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]
+  include Base_internalhash_types
 
   let alloc () = create_seeded 0
 
   let reset ?(seed=0) _t = create_seeded seed
 
   module For_tests = struct
-    let compare_state = compare
-    let state_to_string = Int.to_string
+    let compare_state (a : state) (b : state) = compare (a :> int) (b :> int)
+    let state_to_string (state : state) = Int.to_string (state :> int)
   end
 end
 

src/dune

@@ -189,8 +189,8 @@ module type Hash = sig
       tables and other structures. *)
 
   include Full
-    with type state      = private int
-     and type seed       = int
+    with type state      = Base_internalhash_types.state
+     and type seed       = Base_internalhash_types.seed
 
-     and type hash_value = int (** @open *)
+     and type hash_value = Base_internalhash_types.hash_value (** @open *)
 end

src/hash.ml

@@ -1,9 +1,6 @@
-(** This module is deprecated for external use.  Users should replace occurrences of
-    [Obj_array.t] in their code with [Obj.t Uniform_array.t].
-
-    This module is here for the implementing [Uniform_array] internally, and exposed
-    through [Not_exposed_properly] to ease the transition for users.
-*)
+(** This module is not exposed for external use, and is only here for the implementation
+    of [Uniform_array] internally.  [Obj.t Uniform_array.t] should be used in place of
+    [Obj_array.t].  *)
 
 open! Import
 
@@ -69,4 +66,3 @@ val unsafe_clear_if_pointer : t -> int -> unit
 (** [truncate t ~len] shortens [t]'s length to [len].  It is an error if [len <= 0] or
     [len > length t].*)
 val truncate : t -> len:int -> unit
-

src/hash_intf.ml

@@ -1,19 +1,36 @@
 open! Import
 
-type 'a t = 'a option [@@deriving_inline sexp, compare, hash]
-let t_of_sexp :
-  'a . (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t =
-  option_of_sexp
-let sexp_of_t :
-  'a . ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t =
-  sexp_of_option
-let compare : 'a . ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_option
-let hash_fold_t :
-  'a .
-  (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) ->
-  Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state
-  = hash_fold_option
-[@@@end]
+type 'a t = 'a option =
+  | None
+  | Some of 'a
+
+include
+  (struct type 'a t = 'a option [@@deriving_inline compare, hash, sexp]
+    let compare : 'a . ('a -> 'a -> int) -> 'a t -> 'a t -> int = compare_option
+    let hash_fold_t :
+      'a .
+      (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) ->
+      Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state
+      = hash_fold_option
+    let t_of_sexp :
+      'a . (Ppx_sexp_conv_lib.Sexp.t -> 'a) -> Ppx_sexp_conv_lib.Sexp.t -> 'a t =
+      option_of_sexp
+    let sexp_of_t :
+      'a . ('a -> Ppx_sexp_conv_lib.Sexp.t) -> 'a t -> Ppx_sexp_conv_lib.Sexp.t =
+      sexp_of_option
+    [@@@end] end
+   :  sig type 'a t = 'a option [@@deriving_inline compare, hash, sexp]
+     include
+     sig
+       [@@@ocaml.warning "-32"]
+       val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+       val hash_fold_t :
+         (Ppx_hash_lib.Std.Hash.state -> 'a -> Ppx_hash_lib.Std.Hash.state) ->
+         Ppx_hash_lib.Std.Hash.state -> 'a t -> Ppx_hash_lib.Std.Hash.state
+       include Ppx_sexp_conv_lib.Sexpable.S1 with type 'a t :=  'a t
+     end[@@ocaml.doc "@inline"]
+     [@@@end] end
+  with type 'a t := 'a t)
 
 let is_none = function None -> true | _ -> false
 

src/obj_array.mli

@@ -2,7 +2,10 @@
 
 open! Import
 
-type 'a t = 'a option [@@deriving_inline compare, hash, sexp]
+type 'a t = 'a option =
+  | None
+  | Some of 'a
+[@@deriving_inline compare, hash, sexp]
 include
 sig
   [@@@ocaml.warning "-32"]

src/option.ml

@@ -81,25 +81,6 @@ function Base_int_math_int64_pow_stub(base, exponent) {
   return res;
 }
 
-//Provides: Base_internalhash_fold_int64
-//Requires: caml_hash_mix_int64
-var Base_internalhash_fold_int64 = caml_hash_mix_int64;
-//Provides: Base_internalhash_fold_int
-//Requires: caml_hash_mix_int
-var Base_internalhash_fold_int = caml_hash_mix_int;
-//Provides: Base_internalhash_fold_float
-//Requires: caml_hash_mix_float
-var Base_internalhash_fold_float = caml_hash_mix_float;
-//Provides: Base_internalhash_fold_string
-//Requires: caml_hash_mix_string
-var Base_internalhash_fold_string = caml_hash_mix_string;
-//Provides: Base_internalhash_get_hash_value
-//Requires: caml_hash_mix_final
-function Base_internalhash_get_hash_value(seed) {
-  var h = caml_hash_mix_final(seed);
-  return h & 0x3FFFFFFF;
-}
-
 //Provides: Base_hash_string mutable
 //Requires: caml_hash
 function Base_hash_string(s) {