v0.18~preview.130.33+516

Author: public-release

composition_infix/src/composition_infix.mli

@@ -3,5 +3,10 @@
     - [ a |> (f >> g) = a |> f |> g ]
     - [ (f << g) a = f (g a) ] *)
 
-val ( >> ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
-val ( << ) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c
+val ( >> )
+  : ('a : value_or_null) ('b : value_or_null) ('c : value_or_null).
+  ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c
+
+val ( << )
+  : ('a : value_or_null) ('b : value_or_null) ('c : value_or_null).
+  ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c

md5/src/md5_lib.ml

@@ -4,6 +4,7 @@ type t = string
 let empty = Digest.string ""
 let make s = if s = empty then empty else s
 let make_local s = if s = empty then empty else s
+let compare__local = compare
 let compare = compare
 let length = 16
 let to_binary s = s
@@ -16,6 +17,7 @@ let of_binary_exn s =
 
 let unsafe_of_binary = make
 let unsafe_of_binary_local = make_local
+let unsafe_of_binary__local = make_local
 
 external globalize : local_ t -> t @@ portable = "%obj_dup"
 

md5/src/md5_lib.mli

@@ -1,8 +1,9 @@
 @@ portable
 
-type t
+type t : immutable_data
 
 val compare : t -> t -> int
+val compare__local : t @ local -> t @ local -> int
 
 (** [length = 16] is the size of the digest in bytes. *)
 val length : int
@@ -15,6 +16,7 @@ val of_binary_exn : string -> t
 val unsafe_of_binary : string -> t
 
 val unsafe_of_binary_local : local_ string -> local_ t
+val unsafe_of_binary__local : local_ string -> local_ t
 val globalize : local_ t -> t
 val to_hex : t -> string
 val of_hex_exn : string -> t

src/array.ml

@@ -2,8 +2,11 @@ open! Import
 include Array_intf.Definitions
 include Array0
 
-type 'a t = 'a array
-[@@deriving compare ~localize, globalize, sexp ~localize, sexp_grammar]
+type ('a : any_non_null) t = 'a array
+
+[%%rederive.portable
+  type nonrec 'a t = 'a array
+  [@@deriving compare ~localize, globalize, sexp ~localize, sexp_grammar]]
 
 [@@@warning "-incompatible-with-upstream"]
 
@@ -415,6 +418,21 @@ let foldi t ~init ~f =
   !acc
 ;;
 
+let%template foldi_right (t @ local) ~(init @ m) ~(f @ local) =
+  (let rec (aux @ local) (t @ local) ~idx ~(acc @ m) ~(f @ local) =
+     (if idx < 0
+      then acc
+      else (
+        (* [unsafe_get] is safe, since [idx >= 0 && idx < Array.length t] *)
+        let acc = f idx (unsafe_get t idx) acc in
+        aux t ~idx:(idx - 1) ~acc ~f))
+     [@exclave_if_stack a]
+   in
+   aux t ~idx:(length t - 1) ~acc:init ~f [@nontail])
+  [@exclave_if_stack a]
+[@@alloc a @ m = (stack_local, heap_global)]
+;;
+
 let folding_mapi t ~init ~f =
   let acc = ref init in
   mapi t ~f:(fun i x ->

src/array0.ml

@@ -14,52 +14,68 @@ module Sys = Sys0
 let invalid_argf = Printf.invalid_argf
 
 module Array = struct
-  external create : int -> 'a -> 'a array @@ portable = "caml_make_vect"
+  [%%template
+    external create
+      : ('a : any_non_null).
+      len:int -> 'a -> 'a array @ m
+      @@ portable
+      = "%makearray_dynamic"
+    [@@alloc __ @ m = (heap_global, stack_local)] [@@layout_poly]]
 
   external create_local
-    :  int
-    -> 'a
-    -> local_ 'a array
+    : ('a : any_non_null).
+    len:int -> 'a -> local_ 'a array
+    @@ portable
+    = "%makearray_dynamic"
+  [@@layout_poly]
+
+  external magic_create_uninitialized
+    : ('a : any_non_null).
+    len:int -> ('a array[@local_opt])
     @@ portable
-    = "caml_make_local_vect"
+    = "%makearray_dynamic_uninit"
+  [@@layout_poly]
 
   external create_float_uninitialized
     :  int
     -> float array
     @@ portable
     = "caml_make_float_vect"
 
-  external get
-    :  ('a array[@local_opt])
-    -> (int[@local_opt])
-    -> 'a
+  external%template get
+    : ('a : any_non_null).
+    ('a array[@local_opt]) @ m -> (int[@local_opt]) -> 'a @ m
     @@ portable
     = "%array_safe_get"
+  [@@layout_poly] [@@mode m = (uncontended, shared)]
 
-  external length : ('a array[@local_opt]) -> int @@ portable = "%array_length"
+  external length
+    : ('a : any_non_null).
+    ('a array[@local_opt]) @ contended -> int
+    @@ portable
+    = "%array_length"
+  [@@layout_poly]
 
   external set
-    :  ('a array[@local_opt])
-    -> (int[@local_opt])
-    -> 'a
-    -> unit
+    : ('a : any_non_null).
+    ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit
     @@ portable
     = "%array_safe_set"
+  [@@layout_poly]
 
-  external unsafe_get
-    :  ('a array[@local_opt])
-    -> (int[@local_opt])
-    -> 'a
+  external%template unsafe_get
+    : ('a : any_non_null).
+    ('a array[@local_opt]) @ m -> (int[@local_opt]) -> 'a @ m
     @@ portable
     = "%array_unsafe_get"
+  [@@mode m = (uncontended, shared)] [@@layout_poly]
 
   external unsafe_set
-    :  ('a array[@local_opt])
-    -> (int[@local_opt])
-    -> 'a
-    -> unit
+    : ('a : any_non_null).
+    ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit
     @@ portable
     = "%array_unsafe_set"
+  [@@layout_poly]
 
   external unsafe_blit
     :  src:('a array[@local_opt])
@@ -95,16 +111,6 @@ include Array
 
 let max_length = Sys.max_array_length
 
-let create ~len x =
-  try create len x with
-  | Invalid_argument _ -> invalid_argf "Array.create ~len:%d: invalid length" len ()
-;;
-
-let create_local ~len x = exclave_
-  try create_local len x with
-  | Invalid_argument _ -> invalid_argf "Array.create_local ~len:%d: invalid length" len ()
-;;
-
 let create_float_uninitialized ~len =
   try create_float_uninitialized len with
   | Invalid_argument _ ->
@@ -163,12 +169,13 @@ let fold t ~init ~(local_ f : _ -> _ -> _) =
   !r
 ;;
 
-let fold_right t ~(local_ f : _ -> _ -> _) ~init =
+let%template fold_right (t @ m) ~(local_ f : _ @ m -> _ -> _) ~init =
   let r = ref init in
   for i = length t - 1 downto 0 do
-    r := f (unsafe_get t i) !r
+    r := f ((unsafe_get [@mode m]) t i) !r
   done;
   !r
+[@@mode m = (uncontended, shared)]
 ;;
 
 let iter t ~(local_ f : _ -> _) =

src/array_intf.ml

@@ -6,9 +6,12 @@ open! Import
 
 module Definitions = struct
   module type Public = sig
-    type 'a t
-    [@@deriving
-      compare ~localize, equal ~localize, globalize, sexp ~localize, sexp_grammar]
+    type ('a : any_non_null) t
+
+    [%%rederive:
+      type nonrec 'a t = 'a t
+      [@@deriving
+        compare ~localize, equal ~localize, globalize, sexp ~localize, sexp_grammar]]
 
     include Binary_searchable.S1 with type 'a t := 'a t
     include Indexed_container.S1_with_creators with type 'a t := 'a t
@@ -18,55 +21,95 @@ module Definitions = struct
         [max_length/2] on 32-bit machines and [max_length] on 64-bit machines. *)
     val max_length : int
 
-    (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even when
-    compiling without cross library inlining. *)
+    (*_ Declared as externals so that the compiler skips the caml_apply_X wrapping even
+        when compiling without cross library inlining. *)
 
-    external length : ('a t[@local_opt]) -> int = "%array_length"
+    external length
+      : ('a : any_non_null).
+      ('a array[@local_opt]) @ contended -> int
+      = "%array_length"
+    [@@layout_poly]
 
     (** [Array.get a n] returns the element number [n] of array [a]. The first element has
         number 0. The last element has number [Array.length a - 1]. You can also write
         [a.(n)] instead of [Array.get a n].
 
         Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to
         [(Array.length a - 1)]. *)
-    external get : ('a t[@local_opt]) -> (int[@local_opt]) -> 'a = "%array_safe_get"
+    external%template get
+      : ('a : any_non_null).
+      ('a array[@local_opt]) @ m -> (int[@local_opt]) -> 'a @ m
+      = "%array_safe_get"
+    [@@layout_poly] [@@mode m = (uncontended, shared)]
 
     (** [Array.set a n x] modifies array [a] in place, replacing element number [n] with
         [x]. You can also write [a.(n) <- x] instead of [Array.set a n x].
 
         Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to
         [Array.length a - 1]. *)
     external set
-      :  ('a t[@local_opt])
-      -> (int[@local_opt])
-      -> 'a
-      -> unit
+      : ('a : any_non_null).
+      ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit
       = "%array_safe_set"
+    [@@layout_poly]
 
     (** Unsafe version of [get]. Can cause arbitrary behavior when used for an
         out-of-bounds array access. *)
-    external unsafe_get
-      :  ('a t[@local_opt])
-      -> (int[@local_opt])
-      -> 'a
+    external%template unsafe_get
+      : ('a : any_non_null).
+      ('a array[@local_opt]) @ m -> (int[@local_opt]) -> 'a @ m
       = "%array_unsafe_get"
+    [@@layout_poly] [@@mode m = (uncontended, shared)]
 
     (** Unsafe version of [set]. Can cause arbitrary behavior when used for an
         out-of-bounds array access. *)
     external unsafe_set
-      :  ('a t[@local_opt])
-      -> (int[@local_opt])
-      -> 'a
-      -> unit
+      : ('a : any_non_null).
+      ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit
       = "%array_unsafe_set"
-
-    (** [create ~len x] creates an array of length [len] with the value [x] populated in
-        each element. *)
-    val create : len:int -> 'a -> 'a t
-
-    (** [create_local ~len x] is like [create]. It allocates the array on the local stack.
-        The array's elements are still global. *)
-    val create_local : len:int -> 'a -> local_ 'a t
+    [@@layout_poly]
+
+    [%%template:
+      external create
+        : ('a : any_non_null).
+        len:int -> 'a -> 'a array @ m
+        = "%makearray_dynamic"
+      [@@ocaml.doc
+        " [create ~len x] creates an array of length [len] with the value [x] populated in\n\
+        \          each element. "]
+      [@@layout_poly]
+      [@@alloc __ @ m = (heap_global, stack_local)]]
+
+    external create_local
+      : ('a : any_non_null).
+      len:int -> 'a -> local_ 'a array
+      = "%makearray_dynamic"
+    [@@ocaml.doc
+      " [create_local ~len x] is like [create]. It allocates the array on the local\n\
+      \          stack. The array's elements are still global. "]
+    [@@layout_poly]
+
+    external magic_create_uninitialized
+      : ('a : any_non_null).
+      len:int -> ('a array[@local_opt])
+      = "%makearray_dynamic_uninit"
+    [@@ocaml.doc
+      " [magic_create_uninitialized ~len] creates an array of length [len] with\n\
+      \          uninitialized elements -- that is, they may contain arbitrary, \
+       nondeterministic\n\
+      \          'a values. This can be significantly faster than using [create].\n\n\
+      \          [magic_create_uninitialized] can only be used for GC-ignorable arrays not\n\
+      \          involving tagged immediates and arrays of elements with unboxed number \
+       layout.\n\
+      \          The compiler rejects attempts to use [magic_create_uninitialized] to \
+       produce\n\
+      \          e.g. an [('a : value) array].\n\n\
+      \          [magic_create_uninitialized] can break abstraction boundaries and type \
+       safety\n\
+      \          (e.g. by creating phony witnesses to type equality) and so should be \
+       used with\n\
+      \          caution. "]
+    [@@layout_poly]
 
     (** [create_float_uninitialized ~len] creates a float array of length [len] with
         uninitialized elements -- that is, they may contain arbitrary, nondeterministic
@@ -116,6 +159,13 @@ module Definitions = struct
         types. The unsafe versions do not bound-check the arguments. *)
     include Blit.S1 with type 'a t := 'a t
 
+    val%template foldi_right
+      :  'a t @ local
+      -> init:'acc @ m
+      -> f:(int -> 'a -> 'acc @ m -> 'acc @ m)
+      -> 'acc @ m
+    [@@alloc a @ m = (stack_local, heap_global)]
+
     (** [folding_map] is a version of [map] that threads an accumulator through calls to
         [f]. *)
     val folding_map : 'a t -> init:'acc -> f:local_ ('acc -> 'a -> 'acc * 'b) -> 'b t
@@ -139,7 +189,12 @@ module Definitions = struct
     (** [Array.fold_right f a ~init] computes
         [f a.(0) (f a.(1) ( ... (f a.(n-1) init) ...))], where [n] is the length of the
         array [a]. *)
-    val fold_right : 'a t -> f:local_ ('a -> 'acc -> 'acc) -> init:'acc -> 'acc
+    val%template fold_right
+      :  'a t @ m
+      -> f:local_ ('a @ m -> 'acc -> 'acc)
+      -> init:'acc
+      -> 'acc
+    [@@mode m = (uncontended, shared)]
 
     (** All sort functions in this module sort in increasing order by default. *)
 
@@ -309,7 +364,7 @@ module type Array = sig @@ portable
     include Definitions
   end
 
-  include Public with type 'a t = 'a array (** @inline *)
+  include Public with type ('a : any_non_null) t = 'a array (** @inline *)
 
   (**/**)