v0.18~preview.130.50+1016

Author: public-release

src/array.ml

@@ -199,6 +199,13 @@ let fill a ~pos ~len v =
   if pos < 0 || len < 0 || pos > length a - len
   then invalid_arg "Array.fill"
   else (unsafe_fill [@kind k1]) a pos len v
+;;
+
+let swap t i j =
+  let elt_i = t.(i) in
+  let elt_j = t.(j) in
+  unsafe_set t i elt_j;
+  unsafe_set t j elt_i
 ;;]
 
 [@@@array.iter]
@@ -310,10 +317,3 @@ let fill a ~pos ~len v =
 [@@@end]
 
 let stable_sort t ~compare = Stdlib.Array.stable_sort t ~cmp:compare
-
-let swap t i j =
-  let elt_i = t.(i) in
-  let elt_j = t.(j) in
-  unsafe_set t i elt_j;
-  unsafe_set t j elt_i
-;;

src/array0.ml

@@ -58,7 +58,6 @@ val%template fold_right : 'a array -> f:('a -> 'b -> 'b) -> init:'b -> 'b
 [@@mode m = (uncontended, shared)]
 
 val stable_sort : 'a array -> compare:('a -> 'a -> int) -> unit
-val swap : 'a array -> int -> int -> unit
 
 [%%template:
 [@@@kind.default k1 = (value, immediate, immediate64, float64, bits32, bits64, word)]
@@ -73,6 +72,7 @@ val of_list : ('a List0.Constructors.t[@kind k1]) -> 'a array
 val sub : 'a. 'a array -> pos:int -> len:int -> 'a array
 val append : 'a. 'a array -> 'a array -> 'a array
 val fill : 'a. 'a array -> pos:int -> len:int -> 'a -> unit
+val swap : 'a. 'a array -> int -> int -> unit
 
 [@@@kind.default k2 = (value, immediate, immediate64, float64, bits32, bits64, word)]
 

src/array0.mli

@@ -1,27 +1,34 @@
 (** Fixed-length, mutable vector of elements with O(1) [get] and [set] operations. *)
 
 open! Import
+module Option = Option0
+module List = List0.Constructors
 
 module Definitions = struct
   module type Public = sig
     type 'a t
 
-    [%%rederive:
-      type nonrec 'a t = 'a t
-      [@@deriving
-        compare ~localize, equal ~localize, globalize, sexp ~stackify, sexp_grammar]]
-
     include Binary_searchable.S1 with type 'a t := 'a t
 
     include
       Indexed_container.S1_with_creators__base
       with type 'a t := 'a t
-       and type 'a t__float64 := 'a t
-       and type 'a t__bits32 := 'a t
-       and type 'a t__bits64 := 'a t
-       and type 'a t__word := 'a t
-       and type 'a t__immediate := 'a t
-       and type 'a t__immediate64 := 'a t
+       and type 'a t__float64 = 'a t
+       and type 'a t__bits32 = 'a t
+       and type 'a t__bits64 = 'a t
+       and type 'a t__word = 'a t
+       and type 'a t__immediate = 'a t
+       and type 'a t__immediate64 = 'a t
+
+    [%%template:
+    [@@@kind k = (value, float64, bits32, bits64, word, immediate, immediate64)]
+
+    [%%rederive:
+      type nonrec 'a t = 'a t
+      [@@kind k]
+      [@@deriving compare ~localize, equal ~localize, sexp ~stackify, globalize]]]
+
+    [%%rederive: type nonrec 'a t = 'a t [@@deriving sexp_grammar]]
 
     include Indexed_container.S1_with_creators with type 'a t := 'a t
     include Invariant.S1 with type 'a t := 'a t
@@ -223,54 +230,58 @@ module Definitions = struct
     val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
     val fold2_exn : 'a t -> 'b t -> init:'acc -> f:('acc -> 'a -> 'b -> 'acc) -> 'acc
 
-    (** [for_all2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *)
-    val for_all2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool
+    (** Modifies an array in place, applying [f] to every element of the array *)
+    val map_inplace : 'a t -> f:('a -> 'a) -> unit
 
-    (** [exists2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *)
-    val exists2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool
+    [%%template:
+    [@@@kind.default k1 = (value, float64, bits32, bits64, word, immediate, immediate64)]
+
+    (** [find_exn f t] returns the first [a] in [t] for which [f t.(i)] is true. It raises
+        [Stdlib.Not_found] or [Not_found_s] if there is no such [a]. *)
+    val find_exn : 'a. 'a t -> f:('a -> bool) -> 'a
 
     (** [swap arr i j] swaps the value at index [i] with that at index [j]. *)
-    val swap : 'a t -> int -> int -> unit
+    val swap : 'a. 'a t -> int -> int -> unit
 
     (** [rev_inplace t] reverses [t] in place. *)
-    val rev_inplace : 'a t -> unit
+    val rev_inplace : 'a. 'a t -> unit
 
     (** [rev t] returns a reversed copy of [t] *)
-    val rev : 'a t -> 'a t
+    val rev : 'a. 'a t -> 'a t
 
     (** [of_list_rev l] converts from list then reverses in place. *)
-    val of_list_rev : 'a list -> 'a t
+    val of_list_rev : 'a. ('a List.t[@kind k1]) -> 'a t
+
+    [@@@kind.default k2 = (value, float64, bits32, bits64, word, immediate, immediate64)]
+
+    (** Returns the first evaluation of [f] that returns [Some]. Raises [Stdlib.Not_found]
+        or [Not_found_s] if [f] always returns [None]. *)
+    val find_map_exn : 'a 'b. 'a t -> f:('a -> ('b Option.t[@kind k2])) -> 'b
+
+    (** [find_mapi_exn] is like [find_map_exn] but passes the index as an argument. *)
+    val find_mapi_exn : 'a 'b. 'a t -> f:(int -> 'a -> ('b Option.t[@kind k2])) -> 'b
 
     (** [of_list_map l ~f] is the same as [of_list (List.map l ~f)]. *)
-    val of_list_map : 'a list -> f:('a -> 'b) -> 'b t
+    val of_list_map : 'a 'b. ('a List.t[@kind k1]) -> f:('a -> 'b) -> 'b t
 
     (** [of_list_mapi l ~f] is the same as [of_list (List.mapi l ~f)]. *)
-    val of_list_mapi : 'a list -> f:(int -> 'a -> 'b) -> 'b t
+    val of_list_mapi : 'a 'b. ('a List.t[@kind k1]) -> f:(int -> 'a -> 'b) -> 'b t
 
     (** [of_list_rev_map l ~f] is the same as [of_list (List.rev_map l ~f)]. *)
-    val of_list_rev_map : 'a list -> f:('a -> 'b) -> 'b t
+    val of_list_rev_map : 'a 'b. ('a List.t[@kind k1]) -> f:('a -> 'b) -> 'b t
 
     (** [of_list_rev_mapi l ~f] is the same as [of_list (List.rev_mapi l ~f)]. *)
-    val of_list_rev_mapi : 'a list -> f:(int -> 'a -> 'b) -> 'b t
-
-    (** Modifies an array in place, applying [f] to every element of the array *)
-    val map_inplace : 'a t -> f:('a -> 'a) -> unit
+    val of_list_rev_mapi : 'a 'b. ('a List.t[@kind k1]) -> f:(int -> 'a -> 'b) -> 'b t
 
     [%%template:
-    [@@@kind.default k1 = (value, float64, bits32, bits64, word, immediate, immediate64)]
+    [@@@kind.default k1 k2]
+    [@@@mode.default m = (global, local)]
 
-    (** [find_exn f t] returns the first [a] in [t] for which [f t.(i)] is true. It raises
-        [Stdlib.Not_found] or [Not_found_s] if there is no such [a]. *)
-    val find_exn : 'a. 'a t -> f:('a -> bool) -> 'a
-
-    [@@@kind.default k2 = (value, float64, bits32, bits64, word, immediate, immediate64)]
-
-    (** Returns the first evaluation of [f] that returns [Some]. Raises [Stdlib.Not_found]
-        or [Not_found_s] if [f] always returns [None]. *)
-    val find_map_exn : 'a 'b. 'a t -> f:('a -> ('b Option.t[@kind k2])) -> 'b
+    (** [for_all2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *)
+    val for_all2_exn : 'a 'b. 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool
 
-    (** [find_mapi_exn] is like [find_map_exn] but passes the index as an argument. *)
-    val find_mapi_exn : 'a 'b. 'a t -> f:(int -> 'a -> ('b Option.t[@kind k2])) -> 'b]
+    (** [exists2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *)
+    val exists2_exn : 'a 'b. 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool]]
 
     (** [findi_exn t f] returns the first index [i] of [t] for which [f i t.(i)] is true.
         It raises [Stdlib.Not_found] or [Not_found_s] if there is no such element. *)

src/array_intf.ml

@@ -29,12 +29,6 @@ let () =
 ;;
 
 let create_s sexp = Sexp sexp
-
-let create_s_uncontended sexp =
-  let exn = Sexp sexp |> Portability_hacks.magic_portable__needs_mode_crossing_exns in
-  fun () -> Portability_hacks.magic_uncontended__needs_mode_crossing_exns exn
-;;
-
 let create_s_lazy lazy_sexp = Sexp_lazy lazy_sexp
 
 let raise_with_original_backtrace t backtrace =

src/exn.ml

@@ -24,13 +24,6 @@ exception Reraised of string * t
     particular exn constructor doesn't matter. *)
 val create_s : Sexp.t -> t
 
-(** [create_s_uncontended] returns a function that can be used to obtain uncontended
-    access to the resulting exception from within a portable function.
-
-    The [@ uncontended] below is redundant, as that is the default. It is written for
-    clarity. *)
-val create_s_uncontended : Sexp.t -> unit -> t
-
 (** [create_s_lazy lazy_sexp] is like [create_s], but takes a lazily generated sexp. *)
 val create_s_lazy : Sexp.t Lazy.t -> t
 

src/exn.mli

@@ -21,9 +21,12 @@ external globalize_string : string -> string = "caml_obj_dup"
 
 let globalize_unit (() as u) = u
 
+[%%template
+[@@@kind k = (float64, bits32, bits64, word, immediate, immediate64, value)]
+
 external globalize_array' : 'a array -> 'a array = "caml_obj_dup"
 
-let globalize_array _ a = globalize_array' a
+let globalize_array _ a = globalize_array' a [@@kind k]]
 
 external globalize_floatarray : floatarray -> floatarray = "caml_obj_dup"
 

src/globalize.ml

@@ -18,7 +18,10 @@ val globalize_nativeint : nativeint -> nativeint
 val globalize_bytes : bytes -> bytes
 val globalize_string : string -> string
 val globalize_unit : unit -> unit
-val globalize_array : ('a -> 'b) -> 'a array -> 'a array
+
+val%template globalize_array : 'a 'b. ('a -> 'b) -> 'a array -> 'a array
+[@@kind k = (float64, bits32, bits64, word, immediate, immediate64, value)]
+
 val globalize_floatarray : floatarray -> floatarray
 val globalize_lazy_t : ('a -> 'b) -> 'a lazy_t -> 'a lazy_t
 val globalize_list : ('a -> 'b) -> 'a list -> 'b list
@@ -30,9 +33,7 @@ val globalize_or_null
   -> 'b Basement.Or_null_shim.t
 
 val globalize_result
-  :  ('ok -> 'ok)
-  -> ('err -> 'err)
-  -> ('ok, 'err) result
-  -> ('ok, 'err) result
+  : 'ok 'err.
+  ('ok -> 'ok) -> ('err -> 'err) -> ('ok, 'err) result -> ('ok, 'err) result
 
 val globalize_ref : ('a -> 'b) -> 'a ref -> 'a ref

src/globalize.mli

@@ -13,7 +13,7 @@ module Message = struct
   type t =
     | Could_not_construct of Sexp.t
     | String of string
-    | Exn of (unit -> exn) Modes.Global.t
+    | Exn of exn Modes.Global.t
     | Sexp of Sexp.t
     | Tag_sexp of string * Sexp.t * Source_code_position0.t option
     | Tag_t of string * t
@@ -26,7 +26,7 @@ module Message = struct
     match t with
     | Could_not_construct _ as t -> sexp_of_t t :: ac
     | String string -> Atom string :: ac
-    | Exn { global = exn } -> Exn.sexp_of_t (exn ()) :: ac
+    | Exn { global = exn } -> Exn.sexp_of_t exn :: ac
     | Sexp sexp -> sexp :: ac
     | Tag_sexp (tag, sexp, here) ->
       List
@@ -53,25 +53,6 @@ module Message = struct
     | [ sexp ] -> sexp
     | sexps -> Sexp.List sexps
   ;;
-
-  let rec portabilize : t -> t = function
-    | Exn { global = exn } ->
-      let exn = exn () in
-      let copied_exn = Exn.create_s_uncontended (Exn.sexp_of_t exn) in
-      Exn { global = copied_exn }
-    | Sexp sexp -> Sexp sexp
-    | String str -> String str
-    | Of_list (i, xs) ->
-      Of_list
-        ( i
-        , List.map xs ~f:(fun x -> portabilize x |> Modes.Portable.wrap)
-          |> Modes.Portable.unwrap_list )
-    | Could_not_construct sexp -> Could_not_construct sexp
-    | Tag_sexp (sexp, string, src_pos) -> Tag_sexp (sexp, string, src_pos)
-    | Tag_t (string, t) -> Tag_t (string, portabilize t)
-    | Tag_arg (string, sexp, t) -> Tag_arg (string, sexp, portabilize t)
-    | With_backtrace (t, backtrace) -> With_backtrace (portabilize t, backtrace)
-  ;;
 end
 
 open Message
@@ -511,13 +492,22 @@ let () =
       assert false)
 ;;
 
+let portabilize (t : t) : t =
+  match t.global with
+  (* As an optimization: if the value is already known-portable, there's no need to
+     force its computation. *)
+  | Staged_portable x -> { global = Staged_portable x }
+  | Constant x -> { global = Constant x }
+  | Staged_nonportable _ -> [%template of_message [@mode portable]] (to_message t)
+;;
+
 let to_exn t =
   if not (is_computed t)
-  then Exn t
+  then Exn (portabilize t)
   else (
     match to_message t with
-    | Exn { global = exn } -> exn ()
-    | _ -> Exn t)
+    | Exn { global = exn } -> exn
+    | _ -> Exn (portabilize t))
 ;;
 
 let of_exn ?backtrace exn =
@@ -531,23 +521,11 @@ let of_exn ?backtrace exn =
   | Exn t, None -> t
   | Exn t, Some backtrace ->
     of_thunked_message (fun () -> With_backtrace (to_message t, backtrace))
-  | _, None -> of_message (Exn { global = (fun () -> exn) })
+  | _, None -> of_message (Exn { global = exn })
   | _, Some backtrace ->
     of_thunked_message (fun () -> With_backtrace (Sexp (Exn.sexp_of_t exn), backtrace))
 ;;
 
-let portabilize (t : t) : t =
-  match t.global with
-  | Staged_portable x ->
-    (* As an optimization: if the value is already known-portable, there's no need to
-       force its computation. *)
-    { global = Staged_portable x }
-  | Constant _ | Staged_nonportable _ ->
-    let message = to_message t in
-    let message = Message.portabilize message in
-    [%template of_message [@mode portable]] message
-;;
-
 include%template Pretty_printer.Register_pp [@mode portable] (struct
     type nonrec t = t
 

src/info0.ml

@@ -50,7 +50,7 @@ module Definitions = struct
     type t =
       | Could_not_construct of Sexp.t
       | String of string
-      | Exn of (unit -> exn) Modes.Global.t
+      | Exn of exn Modes.Global.t
       | Sexp of Sexp.t
       | Tag_sexp of string * Sexp.t * Source_code_position0.t option
       | Tag_t of string * t
@@ -209,15 +209,8 @@ module Definitions = struct
     (** Constructs a portable info out of a possibly non-portable info. This operation is
         less expensive than [err |> sexp_of_t |> create_s], but it's not a no-op.
 
-        It's not a no-op for two reasons:
-        - It forces the computation of the input info.
-        - It forces any [exn]s contained in the [Info.t] to their sexp representation.
-
-        For the latter reason, [of_exn exn |> portabilize |> to_exn] won't return [exn],
-        unlike [of_exn exn |> to_exn]. Instead, it will return a sexpified version of the
-        [exn]. We take this approach -- of converting exns to sexps -- mainly because
-        [exn]s can't safely be moved between domains unless all accesses to them are at
-        mode contended. *)
+        It's not a no-op because it needs to force any non-portable computation of the
+        input info. *)
     val portabilize : t -> t
   end