From c12bbb0c38e0a2529773c2742a5131aebc09b97c Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 23 Aug 2024 09:47:49 +0100 Subject: [PATCH] flambda-backend: Resolve conflicts in, and fix, ocaml/stdlib/ (#2806) --- stdlib/Makefile | 27 +- stdlib/StdlibModules | 11 +- stdlib/atomic.mli | 17 +- stdlib/digest.ml | 6 - stdlib/digest.mli | 6 - stdlib/domain.ml | 686 ++++++++++--------------------------------- stdlib/dune | 12 +- stdlib/effect.ml | 1 - stdlib/effect.mli | 1 - stdlib/gc.mli | 156 ++++------ stdlib/int32.ml | 38 +-- stdlib/int64.ml | 38 +-- stdlib/marshal.mli | 62 ---- stdlib/nativeint.ml | 28 +- stdlib/obj.mli | 8 - stdlib/stdlib.ml | 11 +- stdlib/stdlib.mli | 12 +- stdlib/sys.mli | 25 +- 18 files changed, 256 insertions(+), 889 deletions(-) diff --git a/stdlib/Makefile b/stdlib/Makefile index 01c434601d0..1aa437a19da 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -34,18 +34,6 @@ include $(ROOTDIR)/Makefile.common # ../runtime/ocamlrun. USE_BOOT_OCAMLC ?= -<<<<<<< HEAD -COMPILER=$(ROOTDIR)/ocamlc$(EXE) -CAMLC=$(OCAMLRUN) $(COMPILER) -COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48-66-70 \ - -g -warn-error +A -bin-annot -nostdlib -principal \ - -nopervasives -no-alias-deps -||||||| 121bedcfd2 -COMPILER=$(ROOTDIR)/ocamlc$(EXE) -CAMLC=$(OCAMLRUN) $(COMPILER) -COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \ - -g -warn-error +A -bin-annot -nostdlib -principal -======= ifeq "$(USE_BOOT_OCAMLC)" "" CAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc$(EXE) else @@ -53,7 +41,6 @@ CAMLC = $(BOOT_OCAMLC) endif COMPFLAGS = -strict-sequence -absname -w +a-4-9-41-42-44-45-48 \ -g -warn-error +A -bin-annot -nostdlib -principal ->>>>>>> 5.2.0 ifeq "$(FLAMBDA)" "true" OPTCOMPFLAGS += -O3 endif @@ -206,3 +193,17 @@ depend: -e 's/^(${STDLIB_NAMESPACE_MODULES})(\.[^i]*)(i?) :/\1\2\3 : \1.ml\3/' \ -e 's#(^| )(${STDLIB_NAMESPACE_MODULES})[.]#\1stdlib__\u\2.#' \ > .$@ + +# The following are for compatibility with runtime4 + +camlheader: + touch camlheader + +camlheaderd: + touch camlheaderd + +camlheaderi: + touch camlheaderi + +camlheader_ur: + touch camlheader_ur diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index f54797ff87d..ce531dbcb6a 100644 --- a/stdlib/StdlibModules +++ b/stdlib/StdlibModules @@ -101,17 +101,8 @@ STDLIB_MODULE_BASENAMES = \ stringLabels \ moreLabels \ stdLabels \ -<<<<<<< HEAD - in_channel \ - out_channel \ + effect \ camlinternalComprehension -||||||| 121bedcfd2 - in_channel \ - out_channel \ - effect -======= - effect ->>>>>>> 5.2.0 STDLIB_PREFIXED_MODULES = \ $(filter-out stdlib camlinternal%, $(STDLIB_MODULE_BASENAMES)) diff --git a/stdlib/atomic.mli b/stdlib/atomic.mli index b52b8c83026..2d6db297e7c 100644 --- a/stdlib/atomic.mli +++ b/stdlib/atomic.mli @@ -29,9 +29,9 @@ type !'a t (** Create an atomic reference. *) val make : 'a -> 'a t -<<<<<<< HEAD (** Create an atomic reference that is alone on a cache line. It occupies 4-16x the memory of one allocated with [make v]. + The primary purpose is to prevent false-sharing and the resulting performance degradation. When a CPU performs an atomic operation, it temporarily takes ownership of an entire cache line that contains the @@ -42,24 +42,9 @@ val make : 'a -> 'a t enhance performance. CR ocaml 5 all-runtime5: does not support runtime4 *) -val make_contended : 'a -> 'a t - -||||||| 121bedcfd2 -======= -(** Create an atomic reference that is alone on a cache line. It occupies 4-16x - the memory of one allocated with [make v]. - The primary purpose is to prevent false-sharing and the resulting - performance degradation. When a CPU performs an atomic operation, it - temporarily takes ownership of an entire cache line that contains the - atomic reference. If multiple atomic references share the same cache line, - modifying these disjoint memory regions simultaneously becomes impossible, - which can create a bottleneck. Hence, as a general guideline, if an atomic - reference is experiencing contention, assigning it its own cache line may - enhance performance. *) val make_contended : 'a -> 'a t ->>>>>>> 5.2.0 (** Get the current value of the atomic reference. *) val get : 'a t -> 'a diff --git a/stdlib/digest.ml b/stdlib/digest.ml index e309641e43f..19c00c8a04f 100644 --- a/stdlib/digest.ml +++ b/stdlib/digest.ml @@ -14,17 +14,11 @@ (* *) (**************************************************************************) -<<<<<<< HEAD open! Stdlib [@@@ocaml.flambda_o3] -(* Message digest (MD5) *) -||||||| 121bedcfd2 -(* Message digest (MD5) *) -======= (* Utility functions *) ->>>>>>> 5.2.0 let hex_of_string d = let char_hex n = diff --git a/stdlib/digest.mli b/stdlib/digest.mli index 3e43ba3f14d..2ef6882840e 100644 --- a/stdlib/digest.mli +++ b/stdlib/digest.mli @@ -14,15 +14,9 @@ (* *) (**************************************************************************) -<<<<<<< HEAD open! Stdlib -(** MD5 message digest. -||||||| 121bedcfd2 -(** MD5 message digest. -======= (** Message digest. ->>>>>>> 5.2.0 This module provides functions to compute 'digests', also known as 'hashes', of arbitrary-length strings or files. diff --git a/stdlib/domain.ml b/stdlib/domain.ml index cac0d38fcf4..04d748369f6 100644 --- a/stdlib/domain.ml +++ b/stdlib/domain.ml @@ -17,117 +17,28 @@ (* *) (**************************************************************************) -<<<<<<< HEAD open! Stdlib -||||||| 121bedcfd2 -module Raw = struct - (* Low-level primitives provided by the runtime *) - type t = private int - external spawn : (unit -> unit) -> Mutex.t -> t - = "caml_domain_spawn" - external self : unit -> t - = "caml_ml_domain_id" - external cpu_relax : unit -> unit - = "caml_ml_domain_cpu_relax" - external get_recommended_domain_count: unit -> int - = "caml_recommended_domain_count" [@@noalloc] -end -======= -module Raw = struct - (* Low-level primitives provided by the runtime *) - type t = private int - - (* The layouts of [state] and [term_sync] are hard-coded in - [runtime/domain.c] *) - - type 'a state = - | Running - | Finished of ('a, exn) result [@warning "-unused-constructor"] - - type 'a term_sync = { - (* protected by [mut] *) - mutable state : 'a state [@warning "-unused-field"] ; - mut : Mutex.t ; - cond : Condition.t ; - } - - external spawn : (unit -> 'a) -> 'a term_sync -> t - = "caml_domain_spawn" - external self : unit -> t - = "caml_ml_domain_id" [@@noalloc] - external cpu_relax : unit -> unit - = "caml_ml_domain_cpu_relax" - external get_recommended_domain_count: unit -> int - = "caml_recommended_domain_count" [@@noalloc] -end ->>>>>>> 5.2.0 [@@@ocaml.flambda_o3] +external runtime5 : unit -> bool = "%runtime5" + module Runtime_4 = struct module DLS = struct -<<<<<<< HEAD let unique_value = Obj.repr (ref 0) let state = ref (Array.make 8 unique_value) let init () = () -||||||| 121bedcfd2 -type 'a state = -| Running -| Finished of ('a, exn) result - -type 'a t = { - domain : Raw.t; - term_mutex: Mutex.t; - term_condition: Condition.t; - term_state: 'a state ref (* protected by [term_mutex] *) -} -======= -type 'a t = { - domain : Raw.t; - term_sync : 'a Raw.term_sync; -} ->>>>>>> 5.2.0 type 'a key = int * (unit -> 'a) -<<<<<<< HEAD let key_counter = ref 0 -||||||| 121bedcfd2 - type dls_state = Obj.t array -======= - module Obj_opt : sig - type t - val none : t - val some : 'a -> t - val is_some : t -> bool ->>>>>>> 5.2.0 - -<<<<<<< HEAD + let new_key ?split_from_parent:_ init_orphan = let idx = !key_counter in key_counter := idx + 1; (idx, init_orphan) -||||||| 121bedcfd2 - let unique_value = Obj.repr (ref 0) -======= - (** [unsafe_get obj] may only be called safely - if [is_some] is true. - - [unsafe_get (some v)] is equivalent to - [Obj.obj (Obj.repr v)]. *) - val unsafe_get : t -> 'a - end = struct - type t = Obj.t - let none = Obj.repr (ref 0) - let some v = Obj.repr v - let is_some obj = (obj != none) - let unsafe_get obj = Obj.obj obj - end - - type dls_state = Obj_opt.t array ->>>>>>> 5.2.0 (* If necessary, grow the current domain's local state array such that [idx] * is a valid index in the array. *) @@ -153,7 +64,6 @@ type 'a t = { * We do not want OCaml's float array optimisation kicking in here. *) st.(idx) <- Obj.repr (Sys.opaque_identity x) -<<<<<<< HEAD let get (idx, init) = let st = maybe_grow idx in let v = st.(idx) in @@ -163,18 +73,6 @@ type 'a t = { Obj.magic v' else Obj.magic v end -||||||| 121bedcfd2 - let create_dls () = - let st = Array.make 8 unique_value in - set_dls_state st -======= - external compare_and_set_dls_state : dls_state -> dls_state -> bool = - "caml_domain_dls_compare_and_set" [@@noalloc] - - let create_dls () = - let st = Array.make 8 Obj_opt.none in - set_dls_state st ->>>>>>> 5.2.0 (******** Callbacks **********) @@ -183,115 +81,17 @@ type 'a t = { let first_spawn_function = ref (fun () -> ()) -<<<<<<< HEAD let before_first_spawn f = if Atomic.get first_domain_spawned then raise (Invalid_argument "first domain already spawned") -||||||| 121bedcfd2 - type key_initializer = - KI: 'a key * ('a -> 'a) -> key_initializer - - let parent_keys = Atomic.make ([] : key_initializer list) - - let rec add_parent_key ki = - let l = Atomic.get parent_keys in - if not (Atomic.compare_and_set parent_keys l (ki :: l)) - then add_parent_key ki - - let new_key ?split_from_parent init_orphan = - let idx = Atomic.fetch_and_add key_counter 1 in - let k = (idx, init_orphan) in - begin match split_from_parent with - | None -> () - | Some split -> add_parent_key (KI(k, split)) - end; - k - - (* If necessary, grow the current domain's local state array such that [idx] - * is a valid index in the array. *) - let maybe_grow idx = - let st = get_dls_state () in - let sz = Array.length st in - if idx < sz then st -======= - type key_initializer = - KI: 'a key * ('a -> 'a) -> key_initializer - - let parent_keys = Atomic.make ([] : key_initializer list) - - let rec add_parent_key ki = - let l = Atomic.get parent_keys in - if not (Atomic.compare_and_set parent_keys l (ki :: l)) - then add_parent_key ki - - let new_key ?split_from_parent init_orphan = - let idx = Atomic.fetch_and_add key_counter 1 in - let k = (idx, init_orphan) in - begin match split_from_parent with - | None -> () - | Some split -> add_parent_key (KI(k, split)) - end; - k - - (* If necessary, grow the current domain's local state array such that [idx] - * is a valid index in the array. *) - let rec maybe_grow idx = - let st = get_dls_state () in - let sz = Array.length st in - if idx < sz then st ->>>>>>> 5.2.0 else begin -<<<<<<< HEAD let old_f = !first_spawn_function in let new_f () = old_f (); f () in first_spawn_function := new_f -||||||| 121bedcfd2 - let rec compute_new_size s = - if idx < s then s else compute_new_size (2 * s) - in - let new_sz = compute_new_size sz in - let new_st = Array.make new_sz unique_value in - Array.blit st 0 new_st 0 sz; - set_dls_state new_st; - new_st -======= - let rec compute_new_size s = - if idx < s then s else compute_new_size (2 * s) - in - let new_sz = compute_new_size sz in - let new_st = Array.make new_sz Obj_opt.none in - Array.blit st 0 new_st 0 sz; - (* We want a implementation that is safe with respect to - single-domain multi-threading: retry if the DLS state has - changed under our feet. - Note that the number of retries will be very small in - contended scenarios, as the array only grows, with - exponential resizing. *) - if compare_and_set_dls_state st new_st - then new_st - else maybe_grow idx ->>>>>>> 5.2.0 end -<<<<<<< HEAD let at_exit_key = DLS.new_key (fun () -> (fun () -> ())) -||||||| 121bedcfd2 - let set (idx, _init) x = - let st = maybe_grow idx in - (* [Sys.opaque_identity] ensures that flambda does not look at the type of - * [x], which may be a [float] and conclude that the [st] is a float array. - * We do not want OCaml's float array optimisation kicking in here. *) - st.(idx) <- Obj.repr (Sys.opaque_identity x) -======= - let set (type a) (idx, _init) (x : a) = - let st = maybe_grow idx in - (* [Sys.opaque_identity] ensures that flambda does not look at the type of - * [x], which may be a [float] and conclude that the [st] is a float array. - * We do not want OCaml's float array optimisation kicking in here. *) - st.(idx) <- Obj_opt.some (Sys.opaque_identity x) ->>>>>>> 5.2.0 - -<<<<<<< HEAD + let at_exit f = let old_exit : unit -> unit = DLS.get at_exit_key in let new_exit () = @@ -302,39 +102,7 @@ type 'a t = { f (); old_exit () in DLS.set at_exit_key new_exit -||||||| 121bedcfd2 - let get (idx, init) = - let st = maybe_grow idx in - let v = st.(idx) in - if v == unique_value then - let v' = Obj.repr (init ()) in - st.(idx) <- (Sys.opaque_identity v'); - Obj.magic v' - else Obj.magic v -======= - - let[@inline never] array_compare_and_set a i oldval newval = - (* Note: we cannot use [@poll error] due to the - allocations on a.(i) in the Double_array case. *) - let curval = a.(i) in - if curval == oldval then ( - Array.unsafe_set a i newval; - true - ) else false - - let get (type a) ((idx, init) : a key) : a = - let st = maybe_grow idx in - let obj = st.(idx) in - if Obj_opt.is_some obj - then (Obj_opt.unsafe_get obj : a) - else begin - let v : a = init () in - let new_obj = Obj_opt.some (Sys.opaque_identity v) in - (* At this point, [st] or [st.(idx)] may have been changed - by another thread on the same domain. ->>>>>>> 5.2.0 -<<<<<<< HEAD let do_at_exit () = let f : unit -> unit = DLS.get at_exit_key in f () @@ -351,59 +119,31 @@ type 'a t = { let cpu_relax () = not_implemented () let is_main_domain () = not_implemented () let recommended_domain_count () = not_implemented () -||||||| 121bedcfd2 - let get_initial_keys () : (int * Obj.t) list = - List.map - (fun (KI ((idx, _) as k, split)) -> - (idx, Obj.repr (split (get k)))) - (Atomic.get parent_keys) - - let set_initial_keys (l: (int * Obj.t) list) = - List.iter - (fun (idx, v) -> - let st = maybe_grow idx in st.(idx) <- v) - l - -======= - If [st] changed, it was resized into a larger value, - we can just reuse the new value. - - If [st.(idx)] changed, we drop the current value to avoid - letting other threads observe a 'revert' that forgets - previous modifications. *) - let st = get_dls_state () in - if array_compare_and_set st idx obj new_obj - then v - else begin - (* if st.(idx) changed, someone must have initialized - the key in the meantime. *) - let updated_obj = st.(idx) in - if Obj_opt.is_some updated_obj - then (Obj_opt.unsafe_get updated_obj : a) - else assert false - end - end - - type key_value = KV : 'a key * 'a -> key_value - - let get_initial_keys () : key_value list = - List.map - (fun (KI (k, split)) -> KV (k, (split (get k)))) - (Atomic.get parent_keys) - - let set_initial_keys (l: key_value list) = - List.iter (fun (KV (k, v)) -> set k v) l ->>>>>>> 5.2.0 end module Runtime_5 = struct module Raw = struct (* Low-level primitives provided by the runtime *) type t = private int - external spawn : (unit -> unit) -> Mutex.t -> t + + (* The layouts of [state] and [term_sync] are hard-coded in + [runtime/domain.c] *) + + type 'a state = + | Running + | Finished of ('a, exn) result [@warning "-unused-constructor"] + + type 'a term_sync = { + (* protected by [mut] *) + mutable state : 'a state [@warning "-unused-field"] ; + mut : Mutex.t ; + cond : Condition.t ; + } + + external spawn : (unit -> 'a) -> 'a term_sync -> t = "caml_domain_spawn" external self : unit -> t - = "caml_ml_domain_id" + = "caml_ml_domain_id" [@@noalloc] external cpu_relax : unit -> unit = "caml_ml_domain_cpu_relax" external get_recommended_domain_count: unit -> int @@ -414,30 +154,45 @@ module Runtime_5 = struct type id = Raw.t - type 'a state = - | Running - | Finished of ('a, exn) result - type 'a t = { domain : Raw.t; - term_mutex: Mutex.t; - term_condition: Condition.t; - term_state: 'a state ref (* protected by [term_mutex] *) + term_sync : 'a Raw.term_sync; } module DLS = struct - type dls_state = Obj.t array + module Obj_opt : sig + type t + val none : t + val some : 'a -> t + val is_some : t -> bool + + (** [unsafe_get obj] may only be called safely + if [is_some] is true. + + [unsafe_get (some v)] is equivalent to + [Obj.obj (Obj.repr v)]. *) + val unsafe_get : t -> 'a + end = struct + type t = Obj.t + let none = Obj.repr (ref 0) + let some v = Obj.repr v + let is_some obj = (obj != none) + let unsafe_get obj = Obj.obj obj + end - let unique_value = Obj.repr (ref 0) + type dls_state = Obj_opt.t array external get_dls_state : unit -> dls_state = "%dls_get" external set_dls_state : dls_state -> unit = "caml_domain_dls_set" [@@noalloc] + external compare_and_set_dls_state : dls_state -> dls_state -> bool = + "caml_domain_dls_compare_and_set" [@@noalloc] + let create_dls () = - let st = Array.make 8 unique_value in + let st = Array.make 8 Obj_opt.none in set_dls_state st let init () = create_dls () @@ -467,7 +222,11 @@ module Runtime_5 = struct (* If necessary, grow the current domain's local state array such that [idx] * is a valid index in the array. *) - let maybe_grow idx = + let rec maybe_grow idx = + (* CR ocaml 5 all-runtime5: remove this hack which is here to stop + the backend seeing the dls_get operation and failing on runtime4 *) + if not (runtime5 ()) then assert false else + (* end of hack *) let st = get_dls_state () in let sz = Array.length st in if idx < sz then st @@ -476,65 +235,80 @@ module Runtime_5 = struct if idx < s then s else compute_new_size (2 * s) in let new_sz = compute_new_size sz in - let new_st = Array.make new_sz unique_value in + let new_st = Array.make new_sz Obj_opt.none in Array.blit st 0 new_st 0 sz; - set_dls_state new_st; - new_st + (* We want a implementation that is safe with respect to + single-domain multi-threading: retry if the DLS state has + changed under our feet. + Note that the number of retries will be very small in + contended scenarios, as the array only grows, with + exponential resizing. *) + if compare_and_set_dls_state st new_st + then new_st + else maybe_grow idx end - let set (idx, _init) x = + let set (type a) (idx, _init) (x : a) = let st = maybe_grow idx in (* [Sys.opaque_identity] ensures that flambda does not look at the type of * [x], which may be a [float] and conclude that the [st] is a float array. * We do not want OCaml's float array optimisation kicking in here. *) - st.(idx) <- Obj.repr (Sys.opaque_identity x) + st.(idx) <- Obj_opt.some (Sys.opaque_identity x) - let get (idx, init) = + + let[@inline never] array_compare_and_set a i oldval newval = + (* Note: we cannot use [@poll error] due to the + allocations on a.(i) in the Double_array case. *) + let curval = a.(i) in + if curval == oldval then ( + Array.unsafe_set a i newval; + true + ) else false + + let get (type a) ((idx, init) : a key) : a = let st = maybe_grow idx in - let v = st.(idx) in - if v == unique_value then - let v' = Obj.repr (init ()) in - st.(idx) <- (Sys.opaque_identity v'); - Obj.magic v' - else Obj.magic v + let obj = st.(idx) in + if Obj_opt.is_some obj + then (Obj_opt.unsafe_get obj : a) + else begin + let v : a = init () in + let new_obj = Obj_opt.some (Sys.opaque_identity v) in + (* At this point, [st] or [st.(idx)] may have been changed + by another thread on the same domain. + + If [st] changed, it was resized into a larger value, + we can just reuse the new value. + + If [st.(idx)] changed, we drop the current value to avoid + letting other threads observe a 'revert' that forgets + previous modifications. *) + let st = get_dls_state () in + if array_compare_and_set st idx obj new_obj + then v + else begin + (* if st.(idx) changed, someone must have initialized + the key in the meantime. *) + let updated_obj = st.(idx) in + if Obj_opt.is_some updated_obj + then (Obj_opt.unsafe_get updated_obj : a) + else assert false + end + end - let get_initial_keys () : (int * Obj.t) list = + type key_value = KV : 'a key * 'a -> key_value + + let get_initial_keys () : key_value list = List.map - (fun (KI ((idx, _) as k, split)) -> - (idx, Obj.repr (split (get k)))) + (fun (KI (k, split)) -> KV (k, (split (get k)))) (Atomic.get parent_keys) - let set_initial_keys (l: (int * Obj.t) list) = - List.iter - (fun (idx, v) -> - let st = maybe_grow idx in st.(idx) <- v) - l - + let set_initial_keys (l: key_value list) = + List.iter (fun (KV (k, v)) -> set k v) l end (******** Identity **********) -<<<<<<< HEAD let get_id { domain; _ } = domain -||||||| 121bedcfd2 -let at_exit f = - let old_exit : unit -> unit = DLS.get at_exit_key in - let new_exit () = - (* The domain termination callbacks ([at_exit]) are run in - last-in-first-out (LIFO) order in order to be symmetric with the domain - creation callbacks ([at_each_spawn]) which run in first-in-fisrt-out - (FIFO) order. *) - f (); old_exit () - in - DLS.set at_exit_key new_exit -======= -let at_exit f = - let old_exit : unit -> unit = DLS.get at_exit_key in - let new_exit () = - f (); old_exit () - in - DLS.set at_exit_key new_exit ->>>>>>> 5.2.0 let self () = Raw.self () @@ -556,15 +330,19 @@ let at_exit f = first_spawn_function := new_f end + let do_before_first_spawn () = + if not (Atomic.get first_domain_spawned) then begin + Atomic.set first_domain_spawned true; + !first_spawn_function(); + (* Release the old function *) + first_spawn_function := (fun () -> ()) + end + let at_exit_key = DLS.new_key (fun () -> (fun () -> ())) let at_exit f = let old_exit : unit -> unit = DLS.get at_exit_key in let new_exit () = - (* The domain termination callbacks ([at_exit]) are run in - last-in-first-out (LIFO) order in order to be symmetric with the domain - creation callbacks ([at_each_spawn]) which run in first-in-fisrt-out - (FIFO) order. *) f (); old_exit () in DLS.set at_exit_key new_exit @@ -573,86 +351,57 @@ let at_exit f = let f : unit -> unit = DLS.get at_exit_key in f () - (******* Creation and Termination ********) + let _ = Stdlib.do_domain_local_at_exit := do_at_exit - let do_before_first_spawn () = - if not (Atomic.get first_domain_spawned) then begin - Atomic.set first_domain_spawned true; - !first_spawn_function(); - (* Release the old function *) - first_spawn_function := (fun () -> ()) - end + (******* Creation and Termination ********) let spawn f = do_before_first_spawn (); let pk = DLS.get_initial_keys () in - (* The [term_mutex] and [term_condition] are used to - synchronize with the joining domains *) - let term_mutex = Mutex.create () in - let term_condition = Condition.create () in - let term_state = ref Running in + (* [term_sync] is used to synchronize with the joining domains *) + let term_sync = + Raw.{ state = Running ; + mut = Mutex.create () ; + cond = Condition.create () } + in let body () = - let result = - match - DLS.create_dls (); - DLS.set_initial_keys pk; - let res = f () in + match + DLS.create_dls (); + DLS.set_initial_keys pk; + let res = f () in + res + with + (* Run the [at_exit] callbacks when the domain computation either + terminates normally or exceptionally. *) + | res -> + (* If the domain computation terminated normally, but the + [at_exit] callbacks raised an exception, then return the + exception. *) + do_at_exit (); res - with - | x -> Ok x - | exception ex -> Error ex - in - - let result' = - (* Run the [at_exit] callbacks when the domain computation either - terminates normally or exceptionally. *) - match do_at_exit () with - | () -> result - | exception ex -> - begin match result with - | Ok _ -> - (* If the domain computation terminated normally, but the - [at_exit] callbacks raised an exception, then return the - exception. *) - Error ex - | Error _ -> - (* If both the domain computation and the [at_exit] callbacks - raised exceptions, then ignore the exception from the - [at_exit] callbacks and return the original exception. *) - result - end - in - - (* Synchronize with joining domains *) - Mutex.lock term_mutex; - match !term_state with - | Running -> - term_state := Finished result'; - Condition.broadcast term_condition; - | Finished _ -> - failwith "internal error: Am I already finished?" - (* [term_mutex] is unlocked in the runtime after the cleanup functions on - the C side are finished. *) + | exception exn -> + (* If both the domain computation and the [at_exit] callbacks + raise exceptions, then ignore the exception from the + [at_exit] callbacks and return the original exception. *) + (try do_at_exit () with _ -> ()); + raise exn in - { domain = Raw.spawn body term_mutex; - term_mutex; - term_condition; - term_state } + let domain = Raw.spawn body term_sync in + { domain ; term_sync } - let join { term_mutex; term_condition; term_state; _ } = - Mutex.lock term_mutex; + let join { term_sync ; _ } = + let open Raw in let rec loop () = - match !term_state with + match term_sync.state with | Running -> - Condition.wait term_condition term_mutex; + Condition.wait term_sync.cond term_sync.mut; loop () | Finished res -> - Mutex.unlock term_mutex; res in - match loop () with + match Mutex.protect term_sync.mut loop with | Ok x -> x | Error ex -> raise ex @@ -692,8 +441,6 @@ end let runtime_4_impl = (module Runtime_4 : S') let runtime_5_impl = (module Runtime_5 : S') -external runtime5 : unit -> bool = "%runtime5" - let impl = if runtime5 () then runtime_5_impl else runtime_4_impl include (val impl : S') @@ -701,138 +448,3 @@ include (val impl : S') let () = DLS.init () let _ = Stdlib.do_domain_local_at_exit := do_at_exit -<<<<<<< HEAD -||||||| 121bedcfd2 - -(******* Creation and Termination ********) - -let spawn f = - do_before_first_spawn (); - let pk = DLS.get_initial_keys () in - - (* The [term_mutex] and [term_condition] are used to - synchronize with the joining domains *) - let term_mutex = Mutex.create () in - let term_condition = Condition.create () in - let term_state = ref Running in - - let body () = - let result = - match - DLS.create_dls (); - DLS.set_initial_keys pk; - let res = f () in - res - with - | x -> Ok x - | exception ex -> Error ex - in - - let result' = - (* Run the [at_exit] callbacks when the domain computation either - terminates normally or exceptionally. *) - match do_at_exit () with - | () -> result - | exception ex -> - begin match result with - | Ok _ -> - (* If the domain computation terminated normally, but the - [at_exit] callbacks raised an exception, then return the - exception. *) - Error ex - | Error _ -> - (* If both the domain computation and the [at_exit] callbacks - raised exceptions, then ignore the exception from the - [at_exit] callbacks and return the original exception. *) - result - end - in - - (* Synchronize with joining domains *) - Mutex.lock term_mutex; - match !term_state with - | Running -> - term_state := Finished result'; - Condition.broadcast term_condition; - | Finished _ -> - failwith "internal error: Am I already finished?" - (* [term_mutex] is unlocked in the runtime after the cleanup functions on - the C side are finished. *) - in - { domain = Raw.spawn body term_mutex; - term_mutex; - term_condition; - term_state } - -let join { term_mutex; term_condition; term_state; _ } = - Mutex.lock term_mutex; - let rec loop () = - match !term_state with - | Running -> - Condition.wait term_condition term_mutex; - loop () - | Finished res -> - Mutex.unlock term_mutex; - res - in - match loop () with - | Ok x -> x - | Error ex -> raise ex - -let recommended_domain_count = Raw.get_recommended_domain_count -======= - -(******* Creation and Termination ********) - -let spawn f = - do_before_first_spawn (); - let pk = DLS.get_initial_keys () in - - (* [term_sync] is used to synchronize with the joining domains *) - let term_sync = - Raw.{ state = Running ; - mut = Mutex.create () ; - cond = Condition.create () } - in - - let body () = - match - DLS.create_dls (); - DLS.set_initial_keys pk; - let res = f () in - res - with - (* Run the [at_exit] callbacks when the domain computation either - terminates normally or exceptionally. *) - | res -> - (* If the domain computation terminated normally, but the - [at_exit] callbacks raised an exception, then return the - exception. *) - do_at_exit (); - res - | exception exn -> - (* If both the domain computation and the [at_exit] callbacks - raise exceptions, then ignore the exception from the - [at_exit] callbacks and return the original exception. *) - (try do_at_exit () with _ -> ()); - raise exn - in - let domain = Raw.spawn body term_sync in - { domain ; term_sync } - -let join { term_sync ; _ } = - let open Raw in - let rec loop () = - match term_sync.state with - | Running -> - Condition.wait term_sync.cond term_sync.mut; - loop () - | Finished res -> - res - in - match Mutex.protect term_sync.mut loop with - | Ok x -> x - | Error ex -> raise ex - -let recommended_domain_count = Raw.get_recommended_domain_count ->>>>>>> 5.2.0 diff --git a/stdlib/dune b/stdlib/dune index 1fd2b7f679f..ae3392fe97b 100644 --- a/stdlib/dune +++ b/stdlib/dune @@ -47,13 +47,14 @@ ../Makefile.config ../%{env:RUNTIME_DIR=runtime-dir-env-var-not-set}/sak) (action - (run make -s COMPUTE_DEPS=false %{targets}))) + (run make COMPUTE_DEPS=false %{targets}))) (copy_files ../Makefile.config) (install (files Makefile.config + ; CR mshinwell all-runtime5: delete all camlheader* stuff camlheader camlheaderd camlheaderi @@ -110,6 +111,8 @@ digest.mli domain.ml domain.mli + dynarray.ml + dynarray.mli either.ml either.mli ephemeron.ml @@ -249,6 +252,9 @@ .stdlib.objs/byte/stdlib__Domain.cmi .stdlib.objs/byte/stdlib__Domain.cmt .stdlib.objs/byte/stdlib__Domain.cmti + .stdlib.objs/byte/stdlib__Dynarray.cmi + .stdlib.objs/byte/stdlib__Dynarray.cmt + .stdlib.objs/byte/stdlib__Dynarray.cmti .stdlib.objs/byte/stdlib__Either.cmi .stdlib.objs/byte/stdlib__Either.cmt .stdlib.objs/byte/stdlib__Either.cmti @@ -470,11 +476,13 @@ .stdlib.objs/native/stdlib__BytesLabels.cmx .stdlib.objs/native/stdlib__Digest.cmx .stdlib.objs/native/stdlib__Domain.cmx + .stdlib.objs/native/stdlib__Dynarray.cmx .stdlib.objs/native/stdlib__Atomic.cmx .stdlib.objs/native/stdlib__Effect.cmx .stdlib.objs/native/stdlib__Either.cmx .stdlib.objs/native/stdlib__In_channel.cmx .stdlib.objs/native/stdlib__Out_channel.cmx - (META as stdlib/META)) + (META as stdlib/META) + (runtime.info as runtime-launch-info)) (section lib) (package ocaml_runtime_stdlib)) diff --git a/stdlib/effect.ml b/stdlib/effect.ml index db4b6fe5139..611dfb6fdf1 100644 --- a/stdlib/effect.ml +++ b/stdlib/effect.ml @@ -1,4 +1,3 @@ -# 1 "effect.ml" (**************************************************************************) (* *) (* OCaml *) diff --git a/stdlib/effect.mli b/stdlib/effect.mli index 537260f309b..10a347481cc 100644 --- a/stdlib/effect.mli +++ b/stdlib/effect.mli @@ -1,4 +1,3 @@ -# 1 "effect.mli" (**************************************************************************) (* *) (* OCaml *) diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 7dd76f65ef0..c4a6b62e470 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -95,22 +95,9 @@ type stat = stack_size: int; (** Current size of the stack, in words. -<<<<<<< HEAD - - This metrics will not be available in the OCaml 5 runtime: the field - value will always be [0]. - -||||||| 121bedcfd2 -======= This metrics is currently not available in OCaml 5: the field value is always [0]. ->>>>>>> 5.2.0 @since 3.12 *) - (* CR ocaml 5 all-runtime5: Update the above comment to what it is upstream: - - This metrics is currently not available in OCaml 5: the field value is - always [0]. - *) forced_major_collections: int; (** Number of forced full major collections completed since the program @@ -126,6 +113,8 @@ type stat = the number of bytes. *) +(* CR ocaml 5 all-runtime5: pretty much revert this file to upstream *) + type control = { minor_heap_size : int; (** The size (in words) of the minor heap. Changing @@ -173,6 +162,8 @@ type control = compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If [max_overhead >= 1000000], compaction is never triggered. + On runtime4, if compaction is permanently disabled, it is strongly + suggested to set [allocation_policy] to 2. Default: 500. *) stack_limit : int; @@ -182,9 +173,9 @@ type control = allocation_policy : int; (** The policy used for allocating in the major heap. - This option is ignored in OCaml 5.x. + This option is ignored when using runtime5. - Prior to OCaml 5.0, possible values were 0, 1 and 2. + Prior to runtime5, possible values were 0, 1 and 2. - 0 was the next-fit policy @@ -192,6 +183,42 @@ type control = - 2 was the best-fit policy (since OCaml 4.10) + More details for runtime4: ------------------------------------- + + Possible values are 0, 1 and 2. + + - 0 is the next-fit policy, which is usually fast but can + result in fragmentation, increasing memory consumption. + + - 1 is the first-fit policy, which avoids fragmentation but + has corner cases (in certain realistic workloads) where it + is sensibly slower. + + - 2 is the best-fit policy, which is fast and avoids + fragmentation. In our experiments it is faster and uses less + memory than both next-fit and first-fit. + (since OCaml 4.10) + + The default is best-fit. + + On one example that was known to be bad for next-fit and first-fit, + next-fit takes 28s using 855Mio of memory, + first-fit takes 47s using 566Mio of memory, + best-fit takes 27s using 545Mio of memory. + + Note: If you change to next-fit, you may need to reduce + the [space_overhead] setting, for example using [80] instead + of the default [120] which is tuned for best-fit. Otherwise, + your program will need more memory. + + Note: changing the allocation policy at run-time forces + a heap compaction, which is a lengthy operation unless the + heap is small (e.g. at the start of the program). + + Default: 2. + + ---------------------------------------------------------------- + @since 3.11 *) window_size : int; @@ -225,12 +252,24 @@ type control = @since 4.08 *) custom_minor_max_size : int; - (** Maximum amount of out-of-heap memory for each custom value + (** For runtime4: + Maximum amount of out-of-heap memory for each custom value + allocated in the minor heap. When a custom value is allocated + on the minor heap and holds more than this many bytes, only + this value is counted against [custom_minor_ratio] and the + rest is directly counted against [custom_major_ratio]. + Note: this only applies to values allocated with + [caml_alloc_custom_mem] (e.g. bigarrays). + Default: 8192 bytes. + + For runtime5: + Maximum amount of out-of-heap memory for each custom value allocated in the minor heap. Custom values that hold more than this many bytes are allocated on the major heap. Note: this only applies to values allocated with [caml_alloc_custom_mem] (e.g. bigarrays). Default: 70000 bytes. + @since 4.08 *) } (** The GC parameters are given as a [control] record. Note that @@ -440,10 +479,10 @@ val delete_alarm : alarm -> unit (** [delete_alarm a] will stop the calls to the function associated to [a]. Calling [delete_alarm a] again has no effect. *) -external eventlog_pause : unit -> unit = "caml_eventlog_pause" +val eventlog_pause : unit -> unit [@@ocaml.deprecated "Use Runtime_events.pause instead."] -external eventlog_resume : unit -> unit = "caml_eventlog_resume" +val eventlog_resume : unit -> unit [@@ocaml.deprecated "Use Runtime_events.resume instead."] (** [Memprof] is a profiling engine which randomly samples allocated @@ -463,7 +502,12 @@ external eventlog_resume : unit -> unit = "caml_eventlog_resume" profiler as an OCaml library. Note: this API is EXPERIMENTAL. It may change without prior - notice. *) + notice. + + (The docs in the comments here relate to runtime5; runtime4 should be + similar in most regards.) + + *) module Memprof : sig type t @@ -478,14 +522,8 @@ module Memprof : (** The size of the block, in words, excluding the header. *) source : allocation_source; -<<<<<<< HEAD - (** The cause of the allocation. *) -||||||| 121bedcfd2 - (** The type of the allocation. *) -======= (** The cause of the allocation; [Marshal] cannot be produced since OCaml 5. *) ->>>>>>> 5.2.0 callstack : Printexc.raw_backtrace (** The callstack for the allocation. *) @@ -525,24 +563,11 @@ module Memprof : (** Start a profile with the given parameters. Raises an exception if a profile is already sampling in the current domain. -<<<<<<< HEAD Sampling begins immediately. The parameter [sampling_rate] is the sampling rate in samples per word (including headers). Usually, with cheap callbacks, a rate of 1e-4 has no visible effect on performance, and 1e-3 causes the program to run a few - percent slower. 0.0 <= sampling_rate <= 1.0. -||||||| 121bedcfd2 - The parameter [sampling_rate] is the sampling rate in samples - per word (including headers). Usually, with cheap callbacks, a - rate of 1e-4 has no visible effect on performance, and 1e-3 - causes the program to run a few percent slower -======= - Sampling begins immediately. The parameter [sampling_rate] is - the sampling rate in samples per word (including headers). - Usually, with cheap callbacks, a rate of 1e-4 has no visible - effect on performance, and 1e-3 causes the program to run a few - percent slower. ->>>>>>> 5.2.0 + percent slower. 0.0 <= sampling_rate <= 1.0 The parameter [callstack_size] is the length of the callstack recorded at every sample. Its default is [max_int]. @@ -550,57 +575,13 @@ module Memprof : The parameter [tracker] determines how to track sampled blocks over their lifetime in the minor and major heap. -<<<<<<< HEAD - Sampling and running callbacks are temporarily disabled on the - current thread when calling a callback, so callbacks do not - need to be re-entrant if the program is single-threaded and - single-domain. However, if threads or multiple domains are - used, it is possible that several callbacks will run in - parallel. In this case, callback functions must be re-entrant. -||||||| 121bedcfd2 - Sampling is temporarily disabled when calling a callback - for the current thread. So they do not need to be re-entrant if - the program is single-threaded. However, if threads are used, - it is possible that a context switch occurs during a callback, - in this case the callback functions must be re-entrant. -======= Sampling is temporarily disabled on the current thread when calling a callback, so callbacks do not need to be re-entrant if the program is single-threaded and single-domain. However, if threads or multiple domains are used, it is possible that several callbacks will run in parallel. In this case, callback functions must be re-entrant. ->>>>>>> 5.2.0 -<<<<<<< HEAD - Note that a callback may be postponed slightly after the actual - event. The callstack passed to an allocation callback always - accurately reflects the allocation, but the program state may - have evolved between the allocation and the call to the - callback. - - If a new thread or domain is created when the current domain is - sampling for a profile, the child thread or domain joins that - profile (using the same [sampling_rate], [callstack_size], and - [tracker] callbacks). - - An allocation callback is always run by the thread which - allocated the block. If the thread exits or the profile is - stopped before the callback is called, the allocation callback - is not called and the block is not tracked. - - Each subsequent callback is generally run by the domain which - allocated the block. If the domain terminates or the profile is - stopped before the callback is called, the callback may be run - by a different domain. - - Different domains may sample for different profiles - simultaneously. *) -||||||| 121bedcfd2 - Note that the callback can be postponed slightly after the - actual event. The callstack passed to the callback is always - accurate, but the program state may have evolved. *) -======= Note that a callback may be postponed slightly after the actual event. The callstack passed to an allocation callback always accurately reflects the allocation, but the program state may @@ -623,23 +604,14 @@ module Memprof : Different domains may run different profiles simultaneously. *) ->>>>>>> 5.2.0 val stop : unit -> unit (** Stop sampling for the current profile. Fails if no profile is sampling in the current domain. Stops sampling in all threads and domains sharing the profile. -<<<<<<< HEAD - Promotion and deallocation callbacks from a profile may run - after [stop] is called, until [discard] is applied to the - profile. -||||||| 121bedcfd2 - This function does not allocate memory. -======= Callbacks from a profile may run after [stop] is called, until [discard] is applied to the profile. ->>>>>>> 5.2.0 A profile is implicitly stopped (but not discarded) if all domains and threads sampling for it are terminated. diff --git a/stdlib/int32.ml b/stdlib/int32.ml index c890db8776e..81b46f8a47a 100644 --- a/stdlib/int32.ml +++ b/stdlib/int32.ml @@ -61,16 +61,8 @@ let unsigned_to_int = match Sys.word_size with | 32 -> let max_int = of_int Stdlib.max_int in -<<<<<<< HEAD fun[@inline available] n -> - if compare zero n <= 0 && compare n max_int <= 0 then -||||||| 121bedcfd2 - fun n -> - if compare zero n <= 0 && compare n max_int <= 0 then -======= - fun n -> if n >= 0l && n <= max_int then ->>>>>>> 5.2.0 Some (to_int n) else None @@ -87,47 +79,23 @@ let[@inline available] to_string n = format "%d" n external of_string : string -> (int32[@unboxed]) = "caml_int32_of_string" "caml_int32_of_string_unboxed" -<<<<<<< HEAD let[@inline available] of_string_opt s = - (* TODO: expose a non-raising primitive directly. *) -||||||| 121bedcfd2 -let of_string_opt s = - (* TODO: expose a non-raising primitive directly. *) -======= -let of_string_opt s = ->>>>>>> 5.2.0 try Some (of_string s) with Failure _ -> None type t = int32 -<<<<<<< HEAD let[@inline available] compare (x: t) (y: t) = Stdlib.compare x y -let[@inline available] equal (x: t) (y: t) = compare x y = 0 -||||||| 121bedcfd2 -let compare (x: t) (y: t) = Stdlib.compare x y -let equal (x: t) (y: t) = compare x y = 0 -======= -let compare (x: t) (y: t) = Stdlib.compare x y -let equal (x: t) (y: t) = x = y ->>>>>>> 5.2.0 +let[@inline available] equal (x: t) (y: t) = x = y let[@inline available] unsigned_compare n m = compare (sub n min_int) (sub m min_int) -<<<<<<< HEAD -let[@inline available] min x y : t = if x <= y then x else y -let[@inline available] max x y : t = if x >= y then x else y -||||||| 121bedcfd2 -let min x y : t = if x <= y then x else y -let max x y : t = if x >= y then x else y -======= let unsigned_lt n m = sub n min_int < sub m min_int -let min x y : t = if x <= y then x else y -let max x y : t = if x >= y then x else y ->>>>>>> 5.2.0 +let[@inline available] min x y : t = if x <= y then x else y +let[@inline available] max x y : t = if x >= y then x else y (* Unsigned division from signed division of the same bitness. See Warren Jr., Henry S. (2013). Hacker's Delight (2 ed.), Sec 9-3. diff --git a/stdlib/int64.ml b/stdlib/int64.ml index db64e30e3ad..bea6e25eb9b 100644 --- a/stdlib/int64.ml +++ b/stdlib/int64.ml @@ -57,16 +57,8 @@ let[@inline available] lognot n = logxor n (-1L) let unsigned_to_int = let max_int = of_int Stdlib.max_int in -<<<<<<< HEAD fun[@inline available] n -> - if compare zero n <= 0 && compare n max_int <= 0 then -||||||| 121bedcfd2 - fun n -> - if compare zero n <= 0 && compare n max_int <= 0 then -======= - fun n -> if n >= 0L && n <= max_int then ->>>>>>> 5.2.0 Some (to_int n) else None @@ -77,15 +69,7 @@ let[@inline available] to_string n = format "%d" n external of_string : string -> (int64[@unboxed]) = "caml_int64_of_string" "caml_int64_of_string_unboxed" -<<<<<<< HEAD let[@inline available] of_string_opt s = - (* TODO: expose a non-raising primitive directly. *) -||||||| 121bedcfd2 -let of_string_opt s = - (* TODO: expose a non-raising primitive directly. *) -======= -let of_string_opt s = ->>>>>>> 5.2.0 try Some (of_string s) with Failure _ -> None @@ -98,33 +82,17 @@ external float_of_bits : int64 -> float type t = int64 -<<<<<<< HEAD let[@inline available] compare (x: t) (y: t) = Stdlib.compare x y -let[@inline available] equal (x: t) (y: t) = compare x y = 0 -||||||| 121bedcfd2 -let compare (x: t) (y: t) = Stdlib.compare x y -let equal (x: t) (y: t) = compare x y = 0 -======= -let compare (x: t) (y: t) = Stdlib.compare x y -let equal (x: t) (y: t) = x = y ->>>>>>> 5.2.0 +let[@inline available] equal (x: t) (y: t) = x = y let[@inline available] unsigned_compare n m = compare (sub n min_int) (sub m min_int) -<<<<<<< HEAD -let[@inline available] min x y : t = if x <= y then x else y -let[@inline available] max x y : t = if x >= y then x else y -||||||| 121bedcfd2 -let min x y : t = if x <= y then x else y -let max x y : t = if x >= y then x else y -======= let unsigned_lt n m = sub n min_int < sub m min_int -let min x y : t = if x <= y then x else y -let max x y : t = if x >= y then x else y ->>>>>>> 5.2.0 +let[@inline available] min x y : t = if x <= y then x else y +let[@inline available] max x y : t = if x >= y then x else y (* Unsigned division from signed division of the same bitness. See Warren Jr., Henry S. (2013). Hacker's Delight (2 ed.), Sec 9-3. diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli index 13e523825c4..5b5e9cc8666 100644 --- a/stdlib/marshal.mli +++ b/stdlib/marshal.mli @@ -101,32 +101,6 @@ val to_channel : out_channel -> 'a -> extern_flags list -> unit corresponding closure will create a new reference, different from the global one. -<<<<<<< HEAD - If [flags] contains [Marshal.Compression], the marshaled data - representing value [v] is compressed before being written to - channel [chan]. Decompression takes place automatically in - the unmarshaling functions {!Stdlib.input_value}, {!Marshal.from_channel}, - {!Marshal.from_string}, etc. For large values [v], compression - typically reduces the size of marshaled data by a factor 2 to 4, - but slows down marshaling and, to a lesser extent, unmarshaling. - Compression is not supported on some platforms; in this case, - the [Marshal.Compression] flag is silently ignored and uncompressed - data is written to channel [chan]. - -||||||| 121bedcfd2 - If [flags] contains [Marshal.Compression], the marshaled data - representing value [v] is compressed before being written to - channel [chan]. Decompression takes place automatically in - the unmarshaling functions {!input_value}, {!Marshal.from_channel}, - {!Marshal.from_string}, etc. For large values [v], compression - typically reduces the size of marshaled data by a factor 2 to 4, - but slows down marshaling and, to a lesser extent, unmarshaling. - Compression is not supported on some platforms; in this case, - the [Marshal.Compression] flag is silently ignored and uncompressed - data is written to channel [chan]. - -======= ->>>>>>> 5.2.0 If [flags] contains [Marshal.Compat_32], marshaling fails when it encounters an integer value outside the range [-2]{^[30]}, [2]{^[30]}[-1] of integers that are representable on a 32-bit platform. This @@ -217,45 +191,9 @@ val total_size : bytes -> int -> int (** {1:marshal_concurrency Marshal and domain safety} -<<<<<<< HEAD - If [Marshal.compression_supported()] is [true], compressed data - is unmarshaled safely by {!Stdlib.input_value}, {!Marshal.from_channel}, - {!Marshal.from_string} and related functions. Moreover, the - [Marshal.Compression] flag is honored by the {!Marshal.to_channel}, - {!Marshal.to_string} and related functions, resulting in the - production of compressed data. - - If [Marshal.compression_supported()] is [false], compressed data - causes {!Stdlib.input_value}, {!Marshal.from_channel}, - {!Marshal.from_string} and related functions to fail and a - [Failure] exception to be raised. Moreover, - {!Marshal.to_channel}, {!Marshal.to_string} and related functions - ignore the [Marshal.Compression] flag and produce uncompressed - data. - - @since 5.1 -||||||| 121bedcfd2 - If [Marshal.compression_supported()] is [true], compressed data - is unmarshaled safely by {!input_value}, {!Marshal.from_channel}, - {!Marshal.from_string} and related functions. Moreover, the - [Marshal.Compression] flag is honored by the {!Marshal.to_channel}, - {!Marshal.to_string} and related functions, resulting in the - production of compressed data. - - If [Marshal.compression_supported()] is [false], compressed data - causes {!input_value}, {!Marshal.from_channel}, - {!Marshal.from_string} and related functions to fail and a - [Failure] exception to be raised. Moreover, - {!Marshal.to_channel}, {!Marshal.to_string} and related functions - ignore the [Marshal.Compression] flag and produce uncompressed - data. - - @since 5.1 -======= Care must be taken when marshaling a mutable value that may be modified by a different domain. Mutating a value that is being marshaled (i.e., turned into a sequence of bytes) is a programming error and might result in suprising values (when unmarshaling) due to tearing, since marshaling involves byte-per-byte copy. ->>>>>>> 5.2.0 *) diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml index ba34c02da17..a249bb0e90e 100644 --- a/stdlib/nativeint.ml +++ b/stdlib/nativeint.ml @@ -56,16 +56,8 @@ let[@inline available] lognot n = logxor n (-1n) let unsigned_to_int = let max_int = of_int Stdlib.max_int in -<<<<<<< HEAD fun[@inline available] n -> - if compare zero n <= 0 && compare n max_int <= 0 then -||||||| 121bedcfd2 - fun n -> - if compare zero n <= 0 && compare n max_int <= 0 then -======= - fun n -> if n >= 0n && n <= max_int then ->>>>>>> 5.2.0 Some (to_int n) else None @@ -76,15 +68,7 @@ let[@inline available] to_string n = format "%d" n external of_string: string -> (nativeint[@unboxed]) = "caml_nativeint_of_string" "caml_nativeint_of_string_unboxed" -<<<<<<< HEAD let[@inline available] of_string_opt s = - (* TODO: expose a non-raising primitive directly. *) -||||||| 121bedcfd2 -let of_string_opt s = - (* TODO: expose a non-raising primitive directly. *) -======= -let of_string_opt s = ->>>>>>> 5.2.0 try Some (of_string s) with Failure _ -> None @@ -96,19 +80,11 @@ let[@inline available] equal (x: t) (y: t) = compare x y = 0 let[@inline available] unsigned_compare n m = compare (sub n min_int) (sub m min_int) -<<<<<<< HEAD -let[@inline available] min x y : t = if x <= y then x else y -let[@inline available] max x y : t = if x >= y then x else y -||||||| 121bedcfd2 -let min x y : t = if x <= y then x else y -let max x y : t = if x >= y then x else y -======= let unsigned_lt n m = sub n min_int < sub m min_int -let min x y : t = if x <= y then x else y -let max x y : t = if x >= y then x else y ->>>>>>> 5.2.0 +let[@inline available] min x y : t = if x <= y then x else y +let[@inline available] max x y : t = if x >= y then x else y (* Unsigned division from signed division of the same bitness. See Warren Jr., Henry S. (2013). Hacker's Delight (2 ed.), Sec 9-3. diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 9a4167fcd24..737b63bd32a 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -27,16 +27,8 @@ type raw_data = nativeint (* @since 4.12 *) external repr : 'a -> t = "%identity" external obj : t -> 'a = "%identity" -<<<<<<< HEAD external magic : 'a -> 'b = "%obj_magic" val is_block : t -> bool -||||||| 121bedcfd2 -external magic : 'a -> 'b = "%identity" -val [@inline always] is_block : t -> bool -======= -external magic : 'a -> 'b = "%identity" -val is_block : t -> bool ->>>>>>> 5.2.0 external is_int : t -> bool = "%obj_is_int" external tag : t -> int = "caml_obj_tag" [@@noalloc] val size : t -> int diff --git a/stdlib/stdlib.ml b/stdlib/stdlib.ml index 6162862098f..08a548368e4 100644 --- a/stdlib/stdlib.ml +++ b/stdlib/stdlib.ml @@ -608,20 +608,11 @@ module Complex = Complex module Condition = Condition module Digest = Digest module Domain = Domain -<<<<<<< HEAD -<<<<<<< HEAD -(* CR ocaml 5 effects: - BACKPORT -||||||| 121bedcfd2 -======= module Dynarray = Dynarray ->>>>>>> 5.2.0 -||||||| 2572783060 (* CR ocaml 5 effects: BACKPORT -======= ->>>>>>> ocaml-jst/flambda-patches module Effect = Effect +*) module Either = Either module Ephemeron = Ephemeron module Filename = Filename diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli index e2a0eda884c..de95b9047ff 100644 --- a/stdlib/stdlib.mli +++ b/stdlib/stdlib.mli @@ -1410,23 +1410,15 @@ module Domain = Domain [@@alert unstable "The Domain interface may change in incompatible ways in the future." ] -<<<<<<< HEAD -<<<<<<< HEAD -(* CR ocaml 5 effects: -BACKPORT -||||||| 121bedcfd2 -======= module Dynarray = Dynarray ->>>>>>> 5.2.0 -||||||| 2572783060 (* CR ocaml 5 effects: BACKPORT -======= ->>>>>>> ocaml-jst/flambda-patches module Effect = Effect +[@@alert "-unstable"] [@@alert unstable "The Effect interface may change in incompatible ways in the future." ] +*) module Either = Either module Ephemeron = Ephemeron module Filename = Filename diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 49b41a36ed7..52fbef4c515 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -362,7 +362,6 @@ exception Break val catch_break : bool -> unit (** [catch_break] governs whether interactive interrupt (ctrl-C) -<<<<<<< HEAD terminates the program or raises the [Break] exception. Call [catch_break true] to enable raising [Break], and [catch_break false] to let the system @@ -371,7 +370,12 @@ val catch_break : bool -> unit By default, having done [catch_break true], [Break] will be delivered to the toplevel uncaught exception handler. To deliver it elsewhere, use [with_async_exns], below. -*) + + Inside multi-threaded programs, the [Break] exception will arise in + any one of the active threads, and will keep arising on further + interactive interrupt until all threads are terminated. Use + signal masks from [Thread.sigmask] to direct the interrupt towards a + specific thread. *) val with_async_exns : (unit -> 'a) -> 'a (** [with_async_exns f] runs [f] and returns its result, in addition to @@ -382,23 +386,6 @@ val with_async_exns : (unit -> 'a) -> 'a The asynchronous exception handler context is per-domain, not per-fiber: delimited continuations do not capture it. *) -||||||| 121bedcfd2 - terminates the program or raises the [Break] exception. - Call [catch_break true] to enable raising [Break], - and [catch_break false] to let the system - terminate the program on user interrupt. *) -======= - terminates the program or raises the [Break] exception. - Call [catch_break true] to enable raising [Break], - and [catch_break false] to let the system - terminate the program on user interrupt. - - Inside multi-threaded programs, the [Break] exception will arise in - any one of the active threads, and will keep arising on further - interactive interrupt until all threads are terminated. Use - signal masks from [Thread.sigmask] to direct the interrupt towards a - specific thread. *) ->>>>>>> 5.2.0 val ocaml_version : string