diff options
| -rw-r--r-- | .depend | 22 | ||||
| -rw-r--r-- | bytecomp/matching.ml | 3 | ||||
| -rw-r--r-- | bytecomp/matching.mli | 2 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 20 | ||||
| -rw-r--r-- | byterun/caml/camlatomic.h | 8 | ||||
| -rw-r--r-- | byterun/major_gc.c | 19 | ||||
| -rw-r--r-- | byterun/obj.c | 24 | ||||
| -rw-r--r-- | stdlib/.depend | 10 | ||||
| -rw-r--r-- | stdlib/camlinternalLazy.ml | 24 | ||||
| -rw-r--r-- | stdlib/camlinternalLazy.mli | 3 | ||||
| -rw-r--r-- | stdlib/domain.ml | 4 | ||||
| -rw-r--r-- | stdlib/lazy.ml | 4 | ||||
| -rw-r--r-- | stdlib/lazy.mli | 13 | ||||
| -rw-r--r-- | stdlib/obj.ml | 1 | ||||
| -rw-r--r-- | stdlib/obj.mli | 1 |
15 files changed, 121 insertions, 37 deletions
@@ -546,19 +546,17 @@ bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi bytecomp/dll.cmi : bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ - bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ - parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \ - typing/ident.cmi typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - bytecomp/emitcode.cmi + bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/emitcode.cmi bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ - bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ - parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \ - typing/ident.cmx typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - bytecomp/emitcode.cmi -bytecomp/emitcode.cmi : bytecomp/instruct.cmi typing/ident.cmi \ - bytecomp/cmo_format.cmi + bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ + bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ + utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/emitcode.cmi +bytecomp/emitcode.cmi : utils/misc.cmi bytecomp/instruct.cmi \ + typing/ident.cmi bytecomp/cmo_format.cmi bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ bytecomp/instruct.cmi diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 12500874d0..e0f46b5f7b 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1470,6 +1470,9 @@ let code_force_lazy_block = get_mod_field "CamlinternalLazy" "force_lazy_block" ;; +let code_lazy_wrap_fun = + get_mod_field "CamlinternalLazy" "wrap_fun" + (* inline_lazy_force inlines the beginning of the code of Lazy.force. When the value argument is tagged as: - forward, take field 0 diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index cc75b7c839..30ce3aad78 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -46,3 +46,5 @@ val expand_stringswitch: Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda + +val code_lazy_wrap_fun : lambda Lazy.t diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 9a5ea8946a..b6932a5298 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -1064,8 +1064,24 @@ and transl_exp0 e = let fn = Lfunction {kind = Curried; params = [Ident.create "param"]; attr = default_function_attribute; loc = e.exp_loc; - body = transl_exp e} in - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) + body = transl_exp e} + in + let lz = Ident.create "lz" in + let lzvar = Lvar lz in + let wfn = Ident.create "wfn" in + let wfnvar = Lvar wfn in + Llet(Strict, Pgenval, lz, + Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [lambda_unit], e.exp_loc), + Llet(Strict, Pgenval, wfn, + Lapply{ap_should_be_tailcall=false; + ap_loc=e.exp_loc; + ap_func=Lazy.force Matching.code_lazy_wrap_fun; + ap_args=[fn;lzvar]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + Lsequence( + Lprim(Psetfield(0,Pointer,Assignment), [lzvar;wfnvar], e.exp_loc), + lzvar))) end | Texp_object (cs, meths) -> let cty = cs.cstr_type in diff --git a/byterun/caml/camlatomic.h b/byterun/caml/camlatomic.h index c903051c6d..f7b75489a0 100644 --- a/byterun/caml/camlatomic.h +++ b/byterun/caml/camlatomic.h @@ -1,10 +1,16 @@ #ifndef CAML_ATOMIC_H #define CAML_ATOMIC_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" +#include "misc.h" + /* On platforms supporting C11 atomics, this file just includes <stdatomic.h>. On other platforms, this file includes platform-specific stubs for - the subset of C11 atomics needed by the OCaml runtime + the subset of C11 atomics needed by the OCaml runtime */ #if defined(HAS_STDATOMIC_H) diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 82a66db594..e35aad9ef5 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -516,10 +516,21 @@ static intnat do_some_marking(struct mark_stack* stk, intnat budget) { caml_darken_cont(v); e = stk->stack[--stk->count]; } else { - atomic_store_explicit( - Hp_atomic_val(v), - With_status_hd(hd, global.MARKED), - memory_order_relaxed); +again: + if (Tag_hd(hd) == Lazy_tag) { + if (!atomic_compare_exchange_strong( + Hp_atomic_val(v), &hd, + With_status_hd(hd, global.MARKED))) { + hd = Hd_val(v); + goto again; + } + } + else { + atomic_store_explicit( + Hp_atomic_val(v), + With_status_hd(hd, global.MARKED), + memory_order_relaxed); + } if (Tag_hd(hd) < No_scan_tag) { mark_entry child = {v, 0, Wosize_hd(hd)}; mark_stack_push(stk, e); diff --git a/byterun/obj.c b/byterun/obj.c index 69fd2897af..bbacc56e3c 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -18,6 +18,7 @@ /* Operations on objects */ #include <string.h> +#include "caml/camlatomic.h" #include "caml/alloc.h" #include "caml/fail.h" #include "caml/gc.h" @@ -54,6 +55,29 @@ CAMLprim value caml_obj_set_tag (value arg, value new_tag) return Val_unit; } +CAMLprim value caml_obj_cas_tag (value arg, value old_tag, value new_tag) +{ + header_t hd; + tag_t tag; + +again: + hd = Hd_val(arg); + tag = Tag_hd(hd); + if (tag == Int_val(old_tag)) { + if (caml_domain_alone()) { + Tag_val (arg) = Int_val (new_tag); + return Val_unit; + } else if (atomic_compare_exchange_strong(Hp_atomic_val(arg), &hd, + (hd & ~0xFF) | Int_val(new_tag))) { + return Val_unit; + } else { + goto again; + } + } else { + caml_invalid_argument ("unexpected tag"); + } +} + /* [size] is a value encoding a number of blocks */ CAMLprim value caml_obj_block(value tag, value size) { diff --git a/stdlib/.depend b/stdlib/.depend index afe45b4fcb..bc89525ee7 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -34,9 +34,9 @@ camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi camlinternalFormatBasics.cmx : camlinternalFormatBasics.cmi camlinternalFormatBasics.cmi : -camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi -camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi -camlinternalLazy.cmi : +camlinternalLazy.cmo : obj.cmi domain.cmi camlinternalLazy.cmi +camlinternalLazy.cmx : obj.cmx domain.cmx camlinternalLazy.cmi +camlinternalLazy.cmi : obj.cmi camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ camlinternalMod.cmi camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \ @@ -218,8 +218,8 @@ camlinternalFormat.p.cmx : sys.cmx string.cmx char.cmx \ camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi camlinternalFormatBasics.p.cmx : camlinternalFormatBasics.cmi -camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi -camlinternalLazy.p.cmx : obj.cmx camlinternalLazy.cmi +camlinternalLazy.cmo : obj.cmi domain.cmi camlinternalLazy.cmi +camlinternalLazy.p.cmx : obj.cmx domain.cmx camlinternalLazy.cmi camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ camlinternalMod.cmi camlinternalMod.p.cmx : obj.cmx camlinternalOO.cmx array.cmx \ diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml index f64be62e30..16b740a30e 100644 --- a/stdlib/camlinternalLazy.ml +++ b/stdlib/camlinternalLazy.ml @@ -16,18 +16,33 @@ (* Internals of forcing lazy values. *) exception Undefined +exception RacyLazy + +external domain_self : unit -> int = "caml_ml_domain_id" + +let wrap_fun (f: unit -> 'a) l = + let myid = domain_self () in + let bomb () = + if myid = domain_self () then + raise Undefined + else raise RacyLazy + in + let rec wf () = + if Obj.compare_and_swap_field (Obj.repr l) 0 (Obj.repr wf) (Obj.repr bomb) then + f () + else raise RacyLazy + in + wf -let raise_undefined = Obj.repr (fun () -> raise Undefined) (* Assume [blk] is a block with tag lazy *) let force_lazy_block (blk : 'arg lazy_t) = let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in - Obj.set_field (Obj.repr blk) 0 raise_undefined; try let result = closure () in (* do set_field BEFORE set_tag *) Obj.set_field (Obj.repr blk) 0 (Obj.repr result); - Obj.set_tag (Obj.repr blk) Obj.forward_tag; + Obj.cas_tag (Obj.repr blk) Obj.lazy_tag Obj.forward_tag; result with e -> Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e)); @@ -37,11 +52,10 @@ let force_lazy_block (blk : 'arg lazy_t) = (* Assume [blk] is a block with tag lazy *) let force_val_lazy_block (blk : 'arg lazy_t) = let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in - Obj.set_field (Obj.repr blk) 0 raise_undefined; let result = closure () in (* do set_field BEFORE set_tag *) Obj.set_field (Obj.repr blk) 0 (Obj.repr result); - Obj.set_tag (Obj.repr blk) (Obj.forward_tag); + Obj.cas_tag (Obj.repr blk) Obj.lazy_tag Obj.forward_tag; result diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli index 101535cd45..37824f0082 100644 --- a/stdlib/camlinternalLazy.mli +++ b/stdlib/camlinternalLazy.mli @@ -18,6 +18,9 @@ casual user. *) exception Undefined +exception RacyLazy + +val wrap_fun : (unit -> 'a) -> Obj.t -> (unit -> 'a) val force_lazy_block : 'a lazy_t -> 'a diff --git a/stdlib/domain.ml b/stdlib/domain.ml index 310125c9fd..b5eb2476d9 100644 --- a/stdlib/domain.ml +++ b/stdlib/domain.ml @@ -55,7 +55,7 @@ type 'a t = exception Retry let rec spin f = try f () with Retry -> - (* fixme: spin more gently *) + (* fixme: spin more gently *) spin f let cas r vold vnew = @@ -105,7 +105,7 @@ let join { domain ; state } = match res with | Ok x -> x | Error ex -> raise ex - + let get_id { domain; _ } = domain diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml index 7dc1e9ddfe..5bff89377c 100644 --- a/stdlib/lazy.ml +++ b/stdlib/lazy.ml @@ -50,6 +50,7 @@ type 'a t = 'a lazy_t exception Undefined = CamlinternalLazy.Undefined +exception RacyLazy = CamlinternalLazy.RacyLazy external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward" @@ -61,7 +62,8 @@ let force_val = CamlinternalLazy.force_val let from_fun (f : unit -> 'arg) = let x = Obj.new_block Obj.lazy_tag 1 in - Obj.set_field x 0 (Obj.repr f); + let wf = CamlinternalLazy.wrap_fun f x in + Obj.set_field x 0 (Obj.repr wf); (Obj.obj x : 'arg t) diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index ee10366ee8..168ceb2c8b 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -41,15 +41,17 @@ type 'a t = 'a lazy_t exception Undefined +exception RacyLazy (* val force : 'a t -> 'a *) external force : 'a t -> 'a = "%lazy_force" (** [force x] forces the suspension [x] and returns its result. - If [x] has already been forced, [Lazy.force x] returns the - same value again without recomputing it. If it raised an exception, - the same exception is raised again. - Raise {!Undefined} if the forcing of [x] tries to force [x] itself - recursively. + If [x] has already been forced, [Lazy.force x] returns the + same value again without recomputing it. If it raised an exception, + the same exception is raised again. + Raise {!Undefined} if the forcing of [x] tries to force [x] itself + recursively. + Raise {!RacyLazy} if another domain is also concurrently forcing [x]. *) val force_val : 'a t -> 'a @@ -60,6 +62,7 @@ val force_val : 'a t -> 'a recursively. If the computation of [x] raises an exception, it is unspecified whether [force_val x] raises the same exception or {!Undefined}. + Raise {!RacyLazy} if another domain is also concurrently forcing [x]. *) val from_fun : (unit -> 'a) -> 'a t diff --git a/stdlib/obj.ml b/stdlib/obj.ml index 7dec9b38d2..355abb2e74 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -24,6 +24,7 @@ external is_int : t -> bool = "%obj_is_int" let [@inline always] is_block a = not (is_int a) external tag : t -> int = "caml_obj_tag" external set_tag : t -> int -> unit = "caml_obj_set_tag" +external cas_tag : t -> int -> int -> unit = "caml_obj_cas_tag" external size : t -> int = "%obj_size" external reachable_words : t -> int = "caml_obj_reachable_words" external field : t -> int -> t = "%obj_field" diff --git a/stdlib/obj.mli b/stdlib/obj.mli index f0f40ab5ac..d3f22bbd0d 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -58,6 +58,7 @@ external compare_and_swap_field : t -> int -> t -> t -> bool = "caml_obj_compare_and_swap" external is_shared : t -> bool = "caml_obj_is_shared" external set_tag : t -> int -> unit = "caml_obj_set_tag" +external cas_tag : t -> int -> int -> unit = "caml_obj_cas_tag" val [@inline always] double_field : t -> int -> float (* @since 3.11.2 *) val [@inline always] set_double_field : t -> int -> float -> unit |