v0.17~preview.129.00+111

public-release · public-release · commit c63acd3a4fc0 · 2023-11-23T14:23:10.000Z
diff --git a/core/src/bigstring_stubs.c b/core/src/bigstring_stubs.c
@@ -38,7 +38,7 @@
 #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
 #include <sys/endian.h>
 #else
-#ifndef _MSC_VER
+#ifndef _WIN32
 #include <endian.h>
 #endif
 #endif
diff --git a/core/src/core.ml b/core/src/core.ml
@@ -122,11 +122,6 @@ module Percent = Percent
 module Perms = Perms
 module Pid = Pid
 module Poly = Poly
-
-module Popcount = Base.Popcount
-[@@warning "-3"]
-[@@deprecated "[since 2018-10] use [popcount] functions in individual int modules"]
-
 module Pretty_printer = Pretty_printer
 module Printexc = Printexc
 module Printf = Printf
diff --git a/core/src/dune b/core/src/dune
@@ -10,9 +10,13 @@
  (c_flags :standard -D_LARGEFILE64_SOURCE)
  (c_names bigstring_stubs md5_stubs array_stubs gc_stubs time_ns_stubs)
  (ocamlopt_flags :standard (:include ocamlopt-flags))
- (preprocess (pps ppx_jane ppx_optcomp)) (preprocessor_deps config.h)
+ (preprocess (pps ppx_jane ppx_optcomp))
+ (preprocessor_deps config.h gc_stubs.h)
  (js_of_ocaml (javascript_files strftime.js runtime.js)))
 
+(rule (targets gc_stubs.h) (deps)
+ (action (bash "echo \"#define OCAML_5_HAS_OCAML_4_GC false\" > %{targets}")))
+
 (documentation)
 
 (rule (targets ocamlopt-flags) (deps)
diff --git a/core/src/gc.ml b/core/src/gc.ml
@@ -408,7 +408,8 @@ external major_plus_minor_words : unit -> int = "core_gc_major_plus_minor_words"
 external allocated_words : unit -> int = "core_gc_allocated_words"
 external run_memprof_callbacks : unit -> unit = "core_gc_run_memprof_callbacks"
 
-[%%if ocaml_version < (5, 0, 0)]
+[%%import "gc_stubs.h"]
+[%%if ocaml_version < (5, 0, 0) || OCAML_5_HAS_OCAML_4_GC]
 
 external heap_words : unit -> int = "core_gc_heap_words" [@@noalloc]
 external heap_chunks : unit -> int = "core_gc_heap_chunks" [@@noalloc]
diff --git a/core/src/gc.mli b/core/src/gc.mli
@@ -335,7 +335,7 @@ module Control : sig
         Default: 8192 bytes.
         @since 4.08.0 *)
     }
-  [@@deriving sexp_of]
+  [@@deriving sexp_of, fields ~iterators:to_list]
 
   [%%endif]
 
@@ -384,7 +384,8 @@ external minor_collections : unit -> int = "core_gc_minor_collections" [@@noallo
 external major_collections : unit -> int = "core_gc_major_collections" [@@noalloc]
 external compactions : unit -> int = "core_gc_compactions" [@@noalloc]
 
-[%%if ocaml_version < (5, 0, 0)]
+[%%import "gc_stubs.h"]
+[%%if ocaml_version < (5, 0, 0) || OCAML_5_HAS_OCAML_4_GC]
 
 external heap_words : unit -> int = "core_gc_heap_words" [@@noalloc]
 external heap_chunks : unit -> int = "core_gc_heap_chunks" [@@noalloc]
diff --git a/core/src/gc_stubs.c b/core/src/gc_stubs.c
@@ -4,6 +4,12 @@
 #include <caml/memory.h>
 #include <caml/memprof.h>
 #include <caml/version.h>
+#include <stdbool.h>
+#include "gc_stubs.h"
+
+#if OCAML_VERSION >= 50100 && !OCAML_5_HAS_OCAML_4_GC
+#define HAS_OCAML_5_GC
+#endif
 
 static intnat minor_words(void) {
   return (intnat)(caml_stat_minor_words +
@@ -35,9 +41,9 @@ CAMLprim value core_gc_promoted_words(value unit) {
 
 CAMLprim value core_gc_minor_collections(value unit) {
   (void)unit;
-// In OCaml 5.1.0, the number of minor collections is an atomic global state
-// variable.
-#if OCAML_VERSION < 50100
+  // In OCaml 5.1.0, the number of minor collections is an atomic global state
+  // variable.
+#ifndef HAS_OCAML_5_GC
   return Val_long(caml_stat_minor_collections);
 #else
   return Val_long(atomic_load(&caml_minor_collections_count));
@@ -75,7 +81,7 @@ CAMLprim value core_gc_run_memprof_callbacks(value unit) {
   return Val_unit;
 }
 
-#if OCAML_VERSION < 50000
+#if OCAML_VERSION < 50000 || OCAML_VERSION >= 50100 && OCAML_5_HAS_OCAML_4_GC
 
 CAMLprim value core_gc_heap_words(value unit) {
   (void)unit;
diff --git a/core/src/import.ml b/core/src/import.ml
@@ -19,11 +19,6 @@ module Int_math = Base.Int_math
 module Invariant = Base.Invariant
 module Monad = Base.Monad
 module Poly = Base.Poly
-
-module Popcount = Base.Popcount
-[@@warning "-3"]
-[@@deprecated "[since 2018-10] use [popcount] functions in individual int modules"]
-
 module Pretty_printer = Base.Pretty_printer
 module Random = Base.Random
 module Staged = Base.Staged
diff --git a/core/src/map.ml b/core/src/map.ml
@@ -47,19 +47,8 @@ module Merge_element = Base.Map.Merge_element
 module Continue_or_stop = Base.Map.Continue_or_stop
 module Finished_or_unfinished = Base.Map.Finished_or_unfinished
 
-type ('k, 'cmp) comparator =
-  (module Comparator.S with type t = 'k and type comparator_witness = 'cmp)
-
-let to_comparator (type k cmp) ((module M) : (k, cmp) Comparator.Module.t) = M.comparator
-
-let of_comparator (type k cmp) comparator : (k, cmp) Comparator.Module.t =
-  (module struct
-    type t = k
-    type comparator_witness = cmp
-
-    let comparator = comparator
-  end)
-;;
+let to_comparator = Comparator.of_module
+let of_comparator = Comparator.to_module
 
 module For_quickcheck = struct
   let gen_tree ~comparator k_gen v_gen =
diff --git a/core/src/map.mli b/core/src/map.mli
@@ -43,9 +43,6 @@ open Map_intf
 
 type (!'key, +!'value, !'cmp) t = ('key, 'value, 'cmp) Base.Map.t
 
-type ('k, 'cmp) comparator = ('k, 'cmp) Comparator.Module.t
-[@@deprecated "[since 2022-07] use [Comparator.Module.t] instead"]
-
 (** Test if invariants of internal AVL search tree hold. *)
 val invariants : (_, _, _) t -> bool
 
diff --git a/core/src/set.ml b/core/src/set.ml
@@ -7,16 +7,8 @@ module type Elt_plain = Elt_plain
 module type Elt = Elt
 module type Elt_binable = Elt_binable
 
-let to_comparator (type k cmp) ((module M) : (k, cmp) Comparator.Module.t) = M.comparator
-
-let of_comparator (type k cmp) comparator : (k, cmp) Comparator.Module.t =
-  (module struct
-    type t = k
-    type comparator_witness = cmp
-
-    let comparator = comparator
-  end)
-;;
+let to_comparator = Comparator.of_module
+let of_comparator = Comparator.to_module
 
 module For_quickcheck = struct
   let quickcheck_generator ~comparator elt_gen =
@@ -101,9 +93,6 @@ include (
           with module Named = Set.Named
     end)
 
-type ('k, 'cmp) comparator =
-  (module Comparator.S with type t = 'k and type comparator_witness = 'cmp)
-
 let compare _ _ t1 t2 = compare_direct t1 t2
 
 module Using_comparator = struct
diff --git a/core/src/set.mli b/core/src/set.mli
@@ -13,9 +13,6 @@ open Set_intf
     that they be passed sets with the same element type and the same comparator type. *)
 type ('elt, 'cmp) t = ('elt, 'cmp) Base.Set.t [@@deriving compare]
 
-type ('k, 'cmp) comparator = ('k, 'cmp) Comparator.Module.t
-[@@deprecated "[since 2022-07] use [Comparator.Module.t] instead"]
-
 module Tree : sig
   (** A [Tree.t] contains just the tree data structure that a set is based on, without
       including the comparator.  Accordingly, any operation on a [Tree.t] must also take
diff --git a/core/src/span_ns.ml b/core/src/span_ns.ml
@@ -120,7 +120,7 @@ let of_int_hr i = Int63.(of_int i * hour)
 let of_int_day i = Int63.(of_int i * day)
 let of_us f = round_nearest_ns (f *. float_microsecond)
 let of_ms f = round_nearest_ns (f *. float_millisecond)
-let of_sec f = round_nearest_ns (f *. float_second)
+let[@inline] of_sec f = round_nearest_ns (f *. float_second)
 let of_min f = round_nearest_ns (f *. float_minute)
 let of_hr f = round_nearest_ns (f *. float_hour)
 let of_day f = round_nearest_ns (f *. float_day)
@@ -199,7 +199,7 @@ let to_unit_of_time t : Unit_of_time.t =
 ;;
 
 let to_span_float_round_nearest t = Span_float.of_sec (to_sec t)
-let of_span_float_round_nearest s = of_sec (Span_float.to_sec s)
+let[@inline] of_span_float_round_nearest s = of_sec (Span_float.to_sec s)
 let round_up t ~to_multiple_of = Int63.round_up ~to_multiple_of t
 let round_down t ~to_multiple_of = Int63.round_down ~to_multiple_of t
 let round_nearest t ~to_multiple_of = Int63.round_nearest ~to_multiple_of t
diff --git a/core/src/string_id_intf.ml b/core/src/string_id_intf.ml
@@ -82,12 +82,12 @@ module type String_id = sig
     val validate : string -> unit Or_error.t
 
     (** By default, String_id performs some validation of its own in addition to calling
-          [validate], namely:
+             [validate], namely:
 
-          - The string cannot be empty;
-          - The string may not have whitespace at the beginning or the end.
+             - The string cannot be empty;
+             - The string may not have whitespace at the beginning or the end.
 
-          You can turn this validation off using this flag. *)
+             You can turn this validation off using this flag. *)
     val include_default_validation : bool
   end)
   () : S_with_extras
diff --git a/core/src/time_ns.ml b/core/src/time_ns.ml
@@ -106,7 +106,7 @@ let check_before_conversion_for_1us_rounding time =
       [%sexp_of: Time_float.Stable.With_utc_sexp.V2.t]
 ;;
 
-let of_time_float_round_nearest time =
+let[@inline] of_time_float_round_nearest time =
   of_span_since_epoch
     (Span.of_span_float_round_nearest (Time_float.to_span_since_epoch time))
 ;;
@@ -450,6 +450,44 @@ module Option0 = struct
     end
   end
 
+  module Alternate_sexp = struct
+    module T = struct
+      type nonrec t = t [@@deriving bin_io, compare, hash]
+
+      let sexp_of_t t = [%sexp_of: Alternate_sexp.t option] (to_option t)
+      let t_of_sexp s = of_option ([%of_sexp: Alternate_sexp.t option] s)
+
+      let t_sexp_grammar =
+        Sexplib.Sexp_grammar.coerce [%sexp_grammar: Alternate_sexp.t option]
+      ;;
+    end
+
+    include T
+    include Comparable.Make (T)
+
+    module Stable = struct
+      module V1 = struct
+        module T = struct
+          type nonrec t = t [@@deriving bin_io, compare, hash, sexp, sexp_grammar]
+
+          let stable_witness : t Stable_witness.t =
+            Stable_witness.of_serializable
+              [%stable_witness: Alternate_sexp.Stable.V1.t option]
+              of_option
+              to_option
+          ;;
+
+          type nonrec comparator_witness = comparator_witness
+
+          let comparator = comparator
+        end
+
+        include T
+        include Comparable.Stable.V1.With_stable_witness.Make (T)
+      end
+    end
+  end
+
   module Stable = struct
     module V1 = struct
       type nonrec t = t [@@deriving compare, bin_io]
@@ -458,6 +496,8 @@ module Option0 = struct
       let to_int63 t = Span.Option.Stable.V1.to_int63 t
       let of_int63_exn t = Span.Option.Stable.V1.of_int63_exn t
     end
+
+    module Alternate_sexp = Alternate_sexp.Stable
   end
 
   let sexp_of_t = `Use_Time_ns_unix
diff --git a/core/src/time_ns_intf.ml b/core/src/time_ns_intf.ml
@@ -300,6 +300,14 @@ module type Time_ns = sig
       [@@deprecated "[since 2023-09] Use [Time_ns_unix.Option]"]
 
     include Comparisons.S with type t := t
+
+    (** Just like [Time_ns.Alternate_sexp], this is different from the sexp format exposed
+        in [Time_ns_unix].  See the comment above. *)
+    module Alternate_sexp : sig
+      type nonrec t = t [@@deriving bin_io, compare, equal, hash, sexp, sexp_grammar]
+
+      include Comparable.S with type t := t
+    end
   end
 
   include
@@ -515,6 +523,23 @@ module type Time_ns = sig
         val to_int63 : t -> Int63.t
         val of_int63_exn : Int63.t -> t
       end
+
+      module Alternate_sexp : sig
+        module V1 : sig
+          type nonrec t = Option.Alternate_sexp.t
+          [@@deriving bin_io, compare, hash, sexp, sexp_grammar, stable_witness]
+
+          include
+            Comparator.Stable.V1.S
+              with type t := t
+               and type comparator_witness = Option.Alternate_sexp.comparator_witness
+
+          include
+            Comparable.Stable.V1.With_stable_witness.S
+              with type comparable := t
+              with type comparator_witness := comparator_witness
+        end
+      end
     end
 
     module Alternate_sexp : sig
diff --git a/core/test/export_base_buffer.mlt b/core/test/export_base_buffer.mlt
diff --git a/core/test/test_time_ns.ml b/core/test/test_time_ns.ml
diff --git a/univ_map/src/univ_map.ml b/univ_map/src/univ_map.ml
diff --git a/univ_map/src/univ_map_intf.ml b/univ_map/src/univ_map_intf.ml
