From 4f6d880b2754bb62e8407f84cfd056eff3b3119b Mon Sep 17 00:00:00 2001 From: Anton Lorenzen Date: Thu, 3 Oct 2024 14:35:53 -0400 Subject: [PATCH] Use alloc_mode with uniqueness for block allocations in lambda --- .../flambda2/from_lambda/lambda_to_flambda.ml | 2 + .../lambda_to_flambda_primitives.ml | 4 + ocaml/lambda/lambda.ml | 80 ++++++++++++++++--- ocaml/lambda/lambda.mli | 36 +++++++-- ocaml/lambda/matching.ml | 2 +- ocaml/lambda/matching.mli | 2 +- ocaml/lambda/printlambda.ml | 41 ++++++---- ocaml/lambda/printlambda.mli | 1 + ocaml/lambda/simplif.mli | 2 +- ocaml/lambda/tmc.ml | 10 +-- ocaml/lambda/transl_array_comprehension.ml | 2 +- ocaml/lambda/transl_list_comprehension.ml | 8 +- ocaml/lambda/translclass.ml | 32 ++++---- ocaml/lambda/translcore.ml | 76 +++++++++--------- ocaml/lambda/translmod.ml | 28 +++---- ocaml/lambda/translmode.ml | 20 ++++- ocaml/lambda/translmode.mli | 6 +- ocaml/lambda/translobj.ml | 2 +- ocaml/lambda/translprim.ml | 37 +++++---- ocaml/lambda/value_rec_compiler.ml | 6 +- ocaml/typing/mode_intf.mli | 4 + 21 files changed, 258 insertions(+), 143 deletions(-) diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 2da498b946a..4d5ad51d931 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -1775,6 +1775,7 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents List.concat_map (fun (({ name; layout; mode; attributes } : L.lparam), kinds) : Function_decl.param list -> + let mode = L.todo_mode_propagation mode in match kinds with | [] -> [] | [kind] -> [{ name; kind; mode; attributes }] @@ -1819,6 +1820,7 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents in cps_tail acc new_env ccenv body body_cont body_exn_cont in + let ret_mode = L.todo_mode_propagation ret_mode in Function_decl.create ~let_rec_ident:(Some fid) ~function_slot ~kind ~params ~params_arity ~removed_params ~return ~calling_convention ~return_continuation:body_cont ~exn_continuation ~my_region ~my_ghost_region diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index a1e2bb0307a..e63f42bea8c 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -968,6 +968,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) match prim, args with | Pmakeblock (tag, mutability, shape, mode), _ -> let args = List.flatten args in + let mode = L.todo_mode_propagation mode in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let tag = Tag.Scannable.create_exn tag in let shape = convert_block_shape shape ~num_fields:(List.length args) in @@ -1005,6 +1006,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) List.map (fun arg : H.expr_primitive -> Simple arg) projected_args | Pmakefloatblock (mutability, mode), _ -> let args = List.flatten args in + let mode = L.todo_mode_propagation mode in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let mutability = Mutability.from_lambda mutability in [ Variadic @@ -1012,6 +1014,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) ] | Pmakeufloatblock (mutability, mode), _ -> let args = List.flatten args in + let mode = L.todo_mode_propagation mode in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let mutability = Mutability.from_lambda mutability in [Variadic (Make_block (Naked_floats, mutability, mode), args)] @@ -1027,6 +1030,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Flat_suffix Float_boxed -> unbox_float arg) args in + let mode = L.todo_mode_propagation mode in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in let mutability = Mutability.from_lambda mutability in let tag = Tag.Scannable.create_exn tag in diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 132a0b2b7f2..bb94606f1d4 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -49,6 +49,12 @@ include (struct | Alloc_heap | Alloc_local + type uniqueness_mode = + | Alloc_unique + | Alloc_aliased + + type alloc_mode = locality_mode * uniqueness_mode + type modify_mode = | Modify_heap | Modify_maybe_stack @@ -59,6 +65,13 @@ include (struct if Config.stack_allocation then Alloc_local else Alloc_heap + let alloc_unique = Alloc_unique + let alloc_aliased = Alloc_aliased + let alloc_heap_unique = alloc_heap, alloc_unique + let alloc_heap_aliased = alloc_heap, Alloc_aliased + let alloc_local_unique = alloc_local, alloc_unique + let alloc_local_aliased = alloc_local, Alloc_aliased + let modify_heap = Modify_heap let modify_maybe_stack : modify_mode = @@ -69,12 +82,26 @@ include (struct match a, b with | Alloc_local, _ | _, Alloc_local -> Alloc_local | Alloc_heap, Alloc_heap -> Alloc_heap + + let join_uniqueness_mode a b = + match a, b with + | Alloc_aliased, _ | _, Alloc_aliased -> Alloc_aliased + | Alloc_unique, Alloc_unique -> Alloc_unique + + let join_mode (al, au) (bl, bu) = + (join_locality_mode al bl, join_uniqueness_mode au bu) end : sig type locality_mode = private | Alloc_heap | Alloc_local + type uniqueness_mode = private + | Alloc_unique + | Alloc_aliased + + type alloc_mode = locality_mode * uniqueness_mode + type modify_mode = private | Modify_heap | Modify_maybe_stack @@ -82,13 +109,25 @@ end : sig val alloc_heap : locality_mode val alloc_local : locality_mode + val alloc_unique : uniqueness_mode + val alloc_aliased : uniqueness_mode + + val alloc_heap_unique : alloc_mode + val alloc_heap_aliased : alloc_mode + val alloc_local_unique : alloc_mode + val alloc_local_aliased : alloc_mode + val modify_heap : modify_mode val modify_maybe_stack : modify_mode val join_locality_mode : locality_mode -> locality_mode -> locality_mode + val join_mode : alloc_mode -> alloc_mode -> alloc_mode end) +let todo_mode_propagation mode = + fst mode + let is_local_mode = function | Alloc_heap -> false | Alloc_local -> true @@ -103,6 +142,15 @@ let sub_locality_mode a b = | _, Alloc_local -> true | Alloc_local, Alloc_heap -> false +let sub_uniqueness_mode a b = + match a, b with + | Alloc_unique, _ -> true + | _, Alloc_aliased -> true + | Alloc_aliased, Alloc_unique -> false + +let sub_mode (al, au) (bl, bu) = + sub_locality_mode al bl && sub_uniqueness_mode au bu + let eq_locality_mode a b = match a, b with | Alloc_heap, Alloc_heap -> true @@ -110,6 +158,16 @@ let eq_locality_mode a b = | Alloc_heap, Alloc_local -> false | Alloc_local, Alloc_heap -> false +let eq_uniqueness_mode a b = + match a, b with + | Alloc_unique, Alloc_unique -> true + | Alloc_aliased, Alloc_aliased -> true + | Alloc_unique, Alloc_aliased -> false + | Alloc_aliased, Alloc_unique -> false + +let eq_mode (al, au) (bl, bu) = + eq_locality_mode al bl && eq_uniqueness_mode au bu + type initialization_or_assignment = | Assignment of modify_mode | Heap_initialization @@ -129,10 +187,10 @@ type primitive = | Psetglobal of Compilation_unit.t | Pgetpredef of Ident.t (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag * block_shape * locality_mode - | Pmakefloatblock of mutable_flag * locality_mode - | Pmakeufloatblock of mutable_flag * locality_mode - | Pmakemixedblock of int * mutable_flag * mixed_block_shape * locality_mode + | Pmakeblock of int * mutable_flag * block_shape * alloc_mode + | Pmakefloatblock of mutable_flag * alloc_mode + | Pmakeufloatblock of mutable_flag * alloc_mode + | Pmakemixedblock of int * mutable_flag * mixed_block_shape * alloc_mode | Pfield of int * immediate_or_pointer * field_read_semantics | Pfield_computed of field_read_semantics | Psetfield of int * immediate_or_pointer * initialization_or_assignment @@ -714,7 +772,7 @@ type lparam = { name : Ident.t; layout : layout; attributes : parameter_attribute; - mode : locality_mode + mode : alloc_mode } type pop_region = @@ -765,7 +823,7 @@ and lfunction = attr: function_attribute; (* specified with [@inline] attribute *) loc: scoped_location; mode: locality_mode; - ret_mode: locality_mode; + ret_mode: alloc_mode; region: bool; } and lambda_while = @@ -1700,10 +1758,10 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Parray_to_iarray | Parray_of_iarray | Pignore -> None | Pgetglobal _ | Psetglobal _ | Pgetpredef _ -> None - | Pmakeblock (_, _, _, m) -> Some m - | Pmakefloatblock (_, m) -> Some m - | Pmakeufloatblock (_, m) -> Some m - | Pmakemixedblock (_, _, _, m) -> Some m + | Pmakeblock (_, _, _, m) -> Some (fst m) + | Pmakefloatblock (_, m) -> Some (fst m) + | Pmakeufloatblock (_, m) -> Some (fst m) + | Pmakemixedblock (_, _, _, m) -> Some (fst m) | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ -> None | Pfloatfield (_, _, m) -> Some m | Pufloatfield _ -> None @@ -1785,7 +1843,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Punboxed_float32_array_load_128 { mode = m; _ } | Punboxed_int32_array_load_128 { mode = m; _ } | Punboxed_int64_array_load_128 { mode = m; _ } - | Punboxed_nativeint_array_load_128 { mode = m; _ } + | Punboxed_nativeint_array_load_128 { mode = m; _ } -> Some m | Pget_header m -> Some m | Pstring_load_32 { boxed = false; _ } | Pstring_load_f32 { boxed = false; _ } diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 5e67c3b5994..b292980d96c 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -41,6 +41,12 @@ type locality_mode = private | Alloc_heap | Alloc_local +type uniqueness_mode = private + | Alloc_unique (* Might be reused *) + | Alloc_aliased (* No reuse *) + +type alloc_mode = locality_mode * uniqueness_mode + type modify_mode = private | Modify_heap | Modify_maybe_stack @@ -50,10 +56,20 @@ val alloc_heap : locality_mode (* Actually [Alloc_heap] if [Config.stack_allocation] is [false] *) val alloc_local : locality_mode +val alloc_aliased : uniqueness_mode +val alloc_unique : uniqueness_mode + +val alloc_heap_unique : alloc_mode +val alloc_heap_aliased : alloc_mode +val alloc_local_unique : alloc_mode +val alloc_local_aliased : alloc_mode + val modify_heap : modify_mode val modify_maybe_stack : modify_mode +val todo_mode_propagation : alloc_mode -> locality_mode + type initialization_or_assignment = (* [Assignment Alloc_local] is a mutation of a block that may be heap or local. [Assignment Alloc_heap] is a mutation of a block that's definitely heap. *) @@ -113,10 +129,10 @@ type primitive = | Psetglobal of Compilation_unit.t | Pgetpredef of Ident.t (* Operations on heap blocks *) - | Pmakeblock of int * mutable_flag * block_shape * locality_mode - | Pmakefloatblock of mutable_flag * locality_mode - | Pmakeufloatblock of mutable_flag * locality_mode - | Pmakemixedblock of int * mutable_flag * mixed_block_shape * locality_mode + | Pmakeblock of int * mutable_flag * block_shape * alloc_mode + | Pmakefloatblock of mutable_flag * alloc_mode + | Pmakeufloatblock of mutable_flag * alloc_mode + | Pmakemixedblock of int * mutable_flag * mixed_block_shape * alloc_mode | Pfield of int * immediate_or_pointer * field_read_semantics | Pfield_computed of field_read_semantics | Psetfield of int * immediate_or_pointer * initialization_or_assignment @@ -641,7 +657,7 @@ type lparam = { name : Ident.t; layout : layout; attributes : parameter_attribute; - mode : locality_mode + mode : alloc_mode } type scoped_location = Debuginfo.Scoped_location.t @@ -714,7 +730,7 @@ and lfunction = private attr: function_attribute; (* specified with [@inline] attribute *) loc : scoped_location; mode : locality_mode; (* locality of the closure itself *) - ret_mode: locality_mode; + ret_mode: alloc_mode; region : bool; (* false if this function may locally allocate in the caller's region *) } @@ -848,7 +864,7 @@ val lfunction : attr:function_attribute -> (* specified with [@inline] attribute *) loc:scoped_location -> mode:locality_mode -> - ret_mode:locality_mode -> + ret_mode:alloc_mode -> region:bool -> lambda @@ -860,7 +876,7 @@ val lfunction' : attr:function_attribute -> (* specified with [@inline] attribute *) loc:scoped_location -> mode:locality_mode -> - ret_mode:locality_mode -> + ret_mode:alloc_mode -> region:bool -> lfunction @@ -967,6 +983,10 @@ val max_arity : unit -> int This is unlimited ([max_int]) for bytecode, but limited (currently to 126) for native code. *) +val join_mode : alloc_mode -> alloc_mode -> alloc_mode +val sub_mode : alloc_mode -> alloc_mode -> bool +val eq_mode : alloc_mode -> alloc_mode -> bool + val join_locality_mode : locality_mode -> locality_mode -> locality_mode val sub_locality_mode : locality_mode -> locality_mode -> bool val eq_locality_mode : locality_mode -> locality_mode -> bool diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 83cb1cfea2b..dfcd29b8bce 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -3907,7 +3907,7 @@ let failure_handler ~scopes loc ~failer () = Lprim ( Praise Raise_regular, [ Lprim - ( Pmakeblock (0, Immutable, None, alloc_heap), + ( Pmakeblock (0, Immutable, None, alloc_heap_aliased), [ slot; Lconst (Const_block diff --git a/ocaml/lambda/matching.mli b/ocaml/lambda/matching.mli index cd87113064c..04fc298cceb 100644 --- a/ocaml/lambda/matching.mli +++ b/ocaml/lambda/matching.mli @@ -36,7 +36,7 @@ val for_let: lambda val for_multiple_match: scopes:scopes -> return_layout:layout -> Location.t -> - (lambda * Jkind.sort * layout) list -> locality_mode -> + (lambda * Jkind.sort * layout) list -> alloc_mode -> (pattern * lambda) list -> partial -> lambda diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 176c952284b..d27ec0400d7 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -124,6 +124,12 @@ let locality_mode ppf = function | Alloc_heap -> fprintf ppf "heap" | Alloc_local -> fprintf ppf "local" +let alloc_mode_if_local alloc_mode = + locality_mode_if_local (fst alloc_mode) + +let alloc_mode ppf alloc_mode = + locality_mode ppf (fst alloc_mode) + let boxed_integer_name = function | Pnativeint -> "nativeint" | Pint32 -> "int32" @@ -205,9 +211,9 @@ let rec layout' is_top ppf layout_ = let layout ppf layout_ = layout' true ppf layout_ let return_kind ppf (mode, kind) = - let smode = locality_mode_if_local mode in + let smode = alloc_mode_if_local mode in match kind with - | Pvalue Pgenval when is_heap_mode mode -> () + | Pvalue Pgenval when is_heap_mode (fst mode) -> () | Pvalue Pgenval -> fprintf ppf ": %s@ " smode | Pvalue Pintval -> fprintf ppf ": int@ " | Pvalue (Pboxedfloatval bf) -> @@ -245,6 +251,9 @@ let locality_kind = function | Alloc_heap -> "" | Alloc_local -> "[L]" +let alloc_kind alloc_mode = + locality_kind (fst alloc_mode) + let print_boxed_integer_conversion ppf bi1 bi2 m = fprintf ppf "%s_of_%s%s" (boxed_integer_name bi2) (boxed_integer_name bi1) (locality_kind m) @@ -398,40 +407,40 @@ let primitive ppf = function | Pgetpredef id -> fprintf ppf "getpredef %a!" Ident.print id | Pmakeblock(tag, Immutable, shape, mode) -> fprintf ppf "make%sblock %i%a" - (locality_mode_if_local mode) tag block_shape shape + (alloc_mode_if_local mode) tag block_shape shape | Pmakeblock(tag, Immutable_unique, shape, mode) -> fprintf ppf "make%sblock_unique %i%a" - (locality_mode_if_local mode) tag block_shape shape + (alloc_mode_if_local mode) tag block_shape shape | Pmakeblock(tag, Mutable, shape, mode) -> fprintf ppf "make%smutable %i%a" - (locality_mode_if_local mode) tag block_shape shape + (alloc_mode_if_local mode) tag block_shape shape | Pmakefloatblock (Immutable, mode) -> fprintf ppf "make%sfloatblock Immutable" - (locality_mode_if_local mode) + (alloc_mode_if_local mode) | Pmakefloatblock (Immutable_unique, mode) -> fprintf ppf "make%sfloatblock Immutable_unique" - (locality_mode_if_local mode) + (alloc_mode_if_local mode) | Pmakefloatblock (Mutable, mode) -> fprintf ppf "make%sfloatblock Mutable" - (locality_mode_if_local mode) + (alloc_mode_if_local mode) | Pmakeufloatblock (Immutable, mode) -> fprintf ppf "make%sufloatblock Immutable" - (locality_mode_if_local mode) + (alloc_mode_if_local mode) | Pmakeufloatblock (Immutable_unique, mode) -> fprintf ppf "make%sufloatblock Immutable_unique" - (locality_mode_if_local mode) + (alloc_mode_if_local mode) | Pmakeufloatblock (Mutable, mode) -> fprintf ppf "make%sufloatblock Mutable" - (locality_mode_if_local mode) + (alloc_mode_if_local mode) | Pmakemixedblock (tag, Immutable, abs, mode) -> fprintf ppf "make%amixedblock %i Immutable%a" - locality_mode mode tag mixed_block_shape abs + alloc_mode mode tag mixed_block_shape abs | Pmakemixedblock (tag, Immutable_unique, abs, mode) -> fprintf ppf "make%amixedblock %i Immutable_unique%a" - locality_mode mode tag mixed_block_shape abs + alloc_mode mode tag mixed_block_shape abs | Pmakemixedblock (tag, Mutable, abs, mode) -> fprintf ppf "make%amixedblock %i Mutable%a" - locality_mode mode tag mixed_block_shape abs + alloc_mode mode tag mixed_block_shape abs | Pfield (n, ptr, sem) -> let instr = match ptr, sem with @@ -1253,7 +1262,7 @@ and lfunction ppf {kind; params; return; body; attr; ret_mode; mode} = List.iter (fun (p : Lambda.lparam) -> let { unbox_param } = p.attributes in fprintf ppf "@ %a%s%a%s" - Ident.print p.name (locality_kind p.mode) layout p.layout + Ident.print p.name (alloc_kind p.mode) layout p.layout (if unbox_param then "[@unboxable]" else "") ) params | Tupled -> @@ -1264,7 +1273,7 @@ and lfunction ppf {kind; params; return; body; attr; ret_mode; mode} = let { unbox_param } = p.attributes in if !first then first := false else fprintf ppf ",@ "; Ident.print ppf p.name; - Format.fprintf ppf "%s" (locality_kind p.mode); + Format.fprintf ppf "%s" (alloc_kind p.mode); layout ppf p.layout; if unbox_param then Format.fprintf ppf "[@unboxable]" ) diff --git a/ocaml/lambda/printlambda.mli b/ocaml/lambda/printlambda.mli index fc4b898a224..4385b5c2c8d 100644 --- a/ocaml/lambda/printlambda.mli +++ b/ocaml/lambda/printlambda.mli @@ -43,6 +43,7 @@ val print_bigarray : Lambda.bigarray_layout -> unit val zero_alloc_attribute : formatter -> zero_alloc_attribute -> unit val locality_mode : formatter -> locality_mode -> unit +val alloc_mode : formatter -> alloc_mode -> unit val array_kind : array_kind -> string val tag_and_constructor_shape : diff --git a/ocaml/lambda/simplif.mli b/ocaml/lambda/simplif.mli index c6d776f3449..cf3453c1c42 100644 --- a/ocaml/lambda/simplif.mli +++ b/ocaml/lambda/simplif.mli @@ -38,6 +38,6 @@ val split_default_wrapper -> attr:function_attribute -> loc:Lambda.scoped_location -> mode:Lambda.locality_mode - -> ret_mode:Lambda.locality_mode + -> ret_mode:Lambda.alloc_mode -> region:bool -> rec_binding list diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 0405a099b41..f3ca76949d9 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -63,9 +63,9 @@ let offset_code (Offset t) = t let add_dst_params ({var; offset} : Ident.t destination) params = { name = var ; layout = Lambda.layout_block ; - attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: + attributes = Lambda.default_param_attribute ; mode = alloc_heap_aliased } :: { name = offset ; layout = Lambda.layout_int ; - attributes = Lambda.default_param_attribute ; mode = alloc_heap } :: + attributes = Lambda.default_param_attribute ; mode = alloc_heap_aliased } :: params let add_dst_args ({var; offset} : offset destination) args = @@ -124,7 +124,7 @@ end = struct let apply constr t = let block_args = List.append constr.before @@ t :: constr.after in - Lprim (Pmakeblock (constr.tag, constr.flag, constr.shape, alloc_heap), + Lprim (Pmakeblock (constr.tag, constr.flag, constr.shape, alloc_heap_aliased), block_args, constr.loc) let tmc_placeholder = @@ -565,10 +565,10 @@ let find_candidate = function | Lfunction lfun when lfun.attr.tmc_candidate -> (* TMC does not make sense for local-returning functions *) begin match lfun.ret_mode with - | Alloc_local -> + | Alloc_local, _ -> raise (Error (Debuginfo.Scoped_location.to_location lfun.loc, Tmc_local_returning)) - | Alloc_heap -> Some lfun + | Alloc_heap, _ -> Some lfun end | _ -> None diff --git a/ocaml/lambda/transl_array_comprehension.ml b/ocaml/lambda/transl_array_comprehension.ml index 2eec81015f6..95083b8b63f 100644 --- a/ocaml/lambda/transl_array_comprehension.ml +++ b/ocaml/lambda/transl_array_comprehension.ml @@ -218,7 +218,7 @@ end = struct Lprim ( Praise Raise_regular, [ Lprim - ( Pmakeblock (0, Immutable, None, alloc_heap), + ( Pmakeblock (0, Immutable, None, alloc_heap_aliased), [ slot; string ~loc:loc' "integer overflow when precomputing the size of an array \ diff --git a/ocaml/lambda/transl_list_comprehension.ml b/ocaml/lambda/transl_list_comprehension.ml index bf72dfe2ead..f13ddcb0ad5 100644 --- a/ocaml/lambda/transl_list_comprehension.ml +++ b/ocaml/lambda/transl_list_comprehension.ml @@ -113,7 +113,7 @@ let ( rev_list_to_list, building the intermediate restults of list comprehensions; see the documentation for [CamlinternalComprehension.rev_list] for more details. *) let rev_list_snoc_local ~loc ~init ~last = - Lprim (Pmakeblock (0, Immutable, None, alloc_local), [init; last], loc) + Lprim (Pmakeblock (0, Immutable, None, alloc_local_unique), [init; last], loc) (** The [CamlinternalComprehension.Nil] constructor, for building the intermediate restults of list comprehensions; see the documentation for @@ -244,15 +244,15 @@ let rec translate_bindings ~transl_exp ~scopes ~loc ~inner_body ~accumulator = layout = element_kind; attributes = Lambda.default_param_attribute; (* CR ncourant: check *) - mode = alloc_heap + mode = alloc_heap_aliased }; { name = inner_acc; layout = Pvalue Pgenval; attributes = Lambda.default_param_attribute; - mode = alloc_local + mode = alloc_local_aliased } ] ~return:(Pvalue Pgenval) ~attr:default_function_attribute ~loc - ~mode:alloc_local ~ret_mode:alloc_local ~region:false + ~mode:alloc_local ~ret_mode:alloc_local_aliased ~region:false ~body:(add_bindings body) in let result = diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index ca2cf4d3b18..3383793e6b9 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -37,7 +37,7 @@ let layout_meth = layout_any_value let layout_tables = Lambda.Pvalue Pgenval -let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) ?(ret_mode=alloc_heap) return_layout params body = +let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) ?(ret_mode=alloc_heap_aliased) return_layout params body = if params = [] then body else match kind, body with | Curried {nlocal=0}, @@ -71,7 +71,7 @@ let lapply ap = let lparam name layout : Lambda.lparam = { name; layout; - attributes = Lambda.default_param_attribute; mode = alloc_heap } + attributes = Lambda.default_param_attribute; mode = alloc_heap_aliased } let mkappl (func, args, layout) = Lprim @@ -229,7 +229,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = ~loc:(of_location ~scopes pat.pat_loc) ~body ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true in begin match obj_init with @@ -305,7 +305,7 @@ let output_methods tbl methods lam = lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code], layout_unit)) lam | _ -> let methods = - Lprim(Pmakeblock(0,Immutable,None,alloc_heap), methods, Loc_unknown) + Lprim(Pmakeblock(0,Immutable,None,alloc_heap_aliased), methods, Loc_unknown) in lsequence (mkappl(oo_prim "set_methods", [Lvar tbl; Lprim (Popaque layout_block, @@ -519,7 +519,7 @@ let rec transl_class_rebind ~scopes obj_init cl vf = ~loc:(of_location ~scopes pat.pat_loc) ~body ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true in (path, path_lam, @@ -598,7 +598,7 @@ let transl_class_rebind ~scopes cl vf = Strict, layout_function, new_init, lfunction layout_function [lparam obj_init layout_function] obj_init', Llet( Alias, layout_block, cla, path_lam, - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), [mkappl(Lvar new_init, [lfield cla 0], layout_function); lfunction layout_function [lparam table layout_table] (Llet(Strict, layout_function, env_init, @@ -884,7 +884,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~loc:Loc_unknown ~return:layout_function ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~params:[lparam cla layout_table] ~body:cl_init, @@ -903,20 +903,20 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Strict, layout_function, env_init, mkappl (Lvar class_init, [Lvar table], layout_function), Lsequence( mkappl (oo_prim "init_class", [Lvar table], layout_unit), - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), [mkappl (Lvar env_init, [lambda_unit], layout_obj); Lvar class_init; Lvar env_init; lambda_unit], Loc_unknown)))), Static and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), [lambda_unit; Lambda.lfunction ~kind:(Curried {nlocal=0}) ~attr:default_function_attribute ~loc:Loc_unknown ~return:layout_function ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~params:[lparam cla layout_table] ~body:cl_init; lambda_unit; lenvs], @@ -937,11 +937,11 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let lenv = let menv = if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map (fun id -> Lvar id) !new_ids_meths, Loc_unknown) in if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), menv :: List.map (fun id -> Lvar id) !new_ids_init, Loc_unknown) and linh_envs = @@ -952,7 +952,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let make_envs (lam, rkind) = Llet(StrictOpt, layout_block, envs, (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), lenv :: linh_envs, Loc_unknown)), lam), rkind @@ -979,7 +979,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~attr:default_function_attribute ~loc:Loc_unknown ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~body:(def_ids cla cl_init), lam) and lset cached i lam = @@ -998,7 +998,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~attr:default_function_attribute ~loc:Loc_unknown ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~return:layout_function ~params:[lparam cla layout_table] @@ -1038,7 +1038,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = if ids = [] then mkappl (lfield cached 0, [lenvs], layout_obj), Dynamic else - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), (if concrete then [mkappl (lfield cached 0, [lenvs], layout_obj); lfield cached 1; diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 246521bf055..d3ccf74c524 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -102,7 +102,7 @@ let transl_extension_constructor ~scopes env path ext = (* Extension constructors are currently always Alloc_heap. They could be Alloc_local, but that would require changes to pattern typing, as patterns can close over them. *) - Lprim (Pmakeblock (Obj.object_tag, Immutable_unique, None, alloc_heap), + Lprim (Pmakeblock (Obj.object_tag, Immutable_unique, None, alloc_heap_aliased), [Lconst (Const_base (Const_string (name, ext.ext_loc, None))); Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)], loc) @@ -186,7 +186,7 @@ let function_attribute_disallowing_arity_fusion = *) let curried_function_kind : (function_curry * Mode.Alloc.l) list - -> return_mode:locality_mode + -> return_mode:alloc_mode -> mode:locality_mode -> curried_function_kind = @@ -198,9 +198,9 @@ let curried_function_kind | [ Final_arg, final_arg_mode ] -> let nlocal = if running_count = 0 - && is_alloc_heap return_mode + && is_alloc_heap (fst return_mode) && is_alloc_heap mode - && is_alloc_heap (transl_alloc_mode_l final_arg_mode) + && is_alloc_heap (fst (transl_alloc_mode_l final_arg_mode)) then 0 else running_count + 1 in @@ -208,13 +208,13 @@ let curried_function_kind | (Final_arg, _) :: _ -> Misc.fatal_error "Found [Final_arg] too early" | (More_args { partial_mode }, _) :: params -> match transl_alloc_mode_l partial_mode with - | Alloc_heap when not found_local_already -> + | Alloc_heap, _ when not found_local_already -> loop params ~return_mode ~mode ~running_count:0 ~found_local_already - | Alloc_local -> + | Alloc_local, _ -> loop params ~return_mode ~mode ~running_count:(running_count + 1) ~found_local_already:true - | Alloc_heap -> + | Alloc_heap, _ -> Misc.fatal_error "A function argument with a Global partial_mode unexpectedly \ found following a function argument with a Local partial_mode" @@ -255,7 +255,7 @@ let assert_failed loc ~scopes exp = in let loc = of_location ~scopes exp.exp_loc in Lprim(Praise Raise_regular, [event_after ~scopes exp - (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), [slot; Lconst(Const_block(0, [Const_base(Const_string (fname, exp.exp_loc, None)); @@ -266,7 +266,7 @@ type fusable_function = { params : function_param list ; body : function_body ; return_sort : Jkind.sort - ; return_mode : locality_mode + ; return_mode : alloc_mode ; region : bool } @@ -283,7 +283,7 @@ type fusable_function = let fuse_method_arity (parent : fusable_function) : fusable_function = match parent with | { params = [ self_param ]; - return_mode = Alloc_heap; + return_mode = Alloc_heap, _; body = Tfunction_body { exp_desc = Texp_function method_; exp_extra; } } @@ -293,8 +293,8 @@ let fuse_method_arity (parent : fusable_function) : fusable_function = exp_extra -> begin match transl_alloc_mode method_.alloc_mode with - | Alloc_heap -> () - | Alloc_local -> + | Alloc_heap, _ -> () + | Alloc_local, _ -> (* If we support locally-allocated objects, we'll also have to pass the new mode back to the caller. *) @@ -649,7 +649,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | Boxing (alloc_mode, _) -> alloc_mode | Non_boxing _ -> assert false in - let mode = transl_alloc_mode alloc_mode in + let mode = fst (transl_alloc_mode alloc_mode) in Lprim (Pfloatfield (lbl.lbl_pos, sem, mode), [targ], of_location ~scopes e.exp_loc) | Record_ufloat -> @@ -676,7 +676,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | Float_boxed -> (match float with | Boxing (mode, _) -> - flat_read_float_boxed (transl_alloc_mode mode) + flat_read_float_boxed (fst (transl_alloc_mode mode)) | Non_boxing _ -> Misc.fatal_error "expected typechecking to make [float] boxing mode\ @@ -738,7 +738,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = transl_exp ~scopes lbl_sort newval], of_location ~scopes e.exp_loc) | Texp_array (amut, element_sort, expr_list, alloc_mode) -> - let mode = transl_alloc_mode alloc_mode in + let mode, _ = transl_alloc_mode alloc_mode in let kind = array_kind e element_sort in let ll = transl_list ~scopes @@ -974,7 +974,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = block will never be shortcutted since it points to a float and Config.flat_float_array is true. *) Lprim(Pmakeblock(Obj.forward_tag, Immutable, None, - alloc_heap), + alloc_heap_aliased), [transl_exp ~scopes Jkind.Sort.for_lazy_body e], of_location ~scopes e.exp_loc) | `Identifier `Forward_value -> @@ -986,7 +986,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = value may subsequently turn into an immediate... *) Lprim (Popaque Lambda.layout_lazy, [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None, - alloc_heap), + alloc_heap_aliased), [transl_exp ~scopes Jkind.Sort.for_lazy_body e], of_location ~scopes e.exp_loc)], of_location ~scopes e.exp_loc) @@ -1000,7 +1000,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ~params:[{ name = Ident.create_local "param"; layout = Lambda.layout_unit; attributes = Lambda.default_param_attribute; - mode = alloc_heap}] + mode = alloc_heap_aliased}] ~return:Lambda.layout_lazy_contents (* The translation of [e] may be a function, in which case disallowing arity fusion gives a very @@ -1009,13 +1009,13 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ~attr:function_attribute_disallowing_arity_fusion ~loc:(of_location ~scopes e.exp_loc) ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~body:(maybe_region_layout Lambda.layout_lazy_contents (transl_exp ~scopes Jkind.Sort.for_lazy_body e)) in - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None, alloc_heap), [fn], + Lprim(Pmakeblock(Config.lazy_tag, Mutable, None, alloc_heap_aliased), [fn], of_location ~scopes e.exp_loc) end | Texp_object (cs, meths) -> @@ -1136,13 +1136,13 @@ and transl_exp0 ~in_new_scope ~scopes sort e = probes. *) ~params:(List.map (fun name -> { name; layout = layout_probe_arg; attributes = Lambda.default_param_attribute; - mode = alloc_local }) param_idents) + mode = alloc_local_aliased }) param_idents) ~return:return_layout ~body:body ~loc:(of_location ~scopes exp.exp_loc) ~attr ~mode:alloc_heap - ~ret_mode:alloc_local + ~ret_mode:alloc_local_aliased (* CR zqian: the handler function doesn't have a region. However, the [region] field is currently broken. *) ~region:true @@ -1367,16 +1367,16 @@ and transl_apply ~scopes let mode = transl_alloc_mode_r mode_closure in let arg_mode = transl_alloc_mode_l mode_arg in let ret_mode = transl_alloc_mode_l mode_ret in - let body = build_apply handle [Lvar id_arg] loc Rc_normal ret_mode l in + let body = build_apply handle [Lvar id_arg] loc Rc_normal (fst ret_mode) l in let nlocal = - match join_locality_mode mode (join_locality_mode arg_mode ret_mode) with - | Alloc_local -> 1 - | Alloc_heap -> 0 + match join_mode mode (join_mode arg_mode ret_mode) with + | Alloc_local, _ -> 1 + | Alloc_heap, _ -> 0 in let region = match ret_mode with - | Alloc_local -> false - | Alloc_heap -> true + | Alloc_local, _ -> false + | Alloc_heap, _ -> true in let layout_arg = layout_of_sort (to_location loc) sort_arg in let params = [{ @@ -1386,7 +1386,7 @@ and transl_apply ~scopes mode = arg_mode }] in lfunction ~kind:(Curried {nlocal}) ~params - ~return:result_layout ~body ~mode ~ret_mode ~region + ~return:result_layout ~body ~mode:(fst mode) ~ret_mode ~region ~attr:{ default_stub_attribute with may_fuse_arity = false } ~loc in (* Wrap "protected" definitions, starting from the left, @@ -1406,7 +1406,7 @@ and transl_apply ~scopes Arg (transl_exp ~scopes sort_arg exp, layout_exp sort_arg exp)) sargs in - build_apply lam [] loc position mode args + build_apply lam [] loc position (mode : locality_mode) args (* There are two cases in function translation: - [Tupled]. It takes a tupled argument, and we can flatten it. @@ -1461,7 +1461,7 @@ and transl_tupled_function (cases, partial, ({ pat_desc = Tpat_tuple pl } as arg_pat), arg_mode, arg_sort) when is_alloc_heap mode - && is_alloc_heap (transl_alloc_mode_l arg_mode) + && is_alloc_heap (fst (transl_alloc_mode_l arg_mode)) && !Clflags.native_code && List.length pl <= (Lambda.max_arity ()) -> begin try @@ -1489,7 +1489,7 @@ and transl_tupled_function name = Ident.create_local "param"; layout = kind; attributes = Lambda.default_param_attribute; - mode = alloc_heap + mode = alloc_heap_aliased }) kinds in let params = List.map (fun p -> p.name) tparams in @@ -1605,7 +1605,7 @@ and transl_curried_function ~scopes loc repr params body type acc = { body : lambda; (* The function body of those params *) return_layout : layout; (* The layout of [body] *) - return_mode : locality_mode; (* The mode of [body]. *) + return_mode : alloc_mode; (* The mode of [body]. *) region : bool; (* Whether the function has its own region *) nlocal : int; (* An upper bound on the [nlocal] field for the function. If [nlocal] @@ -1648,7 +1648,7 @@ and transl_curried_function ~scopes loc repr params body (* we return Pgenval (for a function) after the rightmost chunk *) { body; return_layout = Pvalue Pgenval; - return_mode = if enclosing_region then alloc_heap else alloc_local; + return_mode = (if enclosing_region then alloc_heap else alloc_local), alloc_aliased; nlocal = enclosing_nlocal; region = enclosing_region; } @@ -1677,7 +1677,7 @@ and transl_function ~in_new_scope ~scopes e params body ~alloc_mode ~ret_mode:sreturn_mode ~ret_sort:sreturn_sort ~region:sregion ~zero_alloc = let attrs = e.exp_attributes in - let mode = transl_alloc_mode alloc_mode in + let mode, _ = transl_alloc_mode alloc_mode in let zero_alloc = Zero_alloc.get zero_alloc in let assume_zero_alloc = match zero_alloc with @@ -1817,7 +1817,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let no_init = match opt_init_expr with None -> true | _ -> false in let on_heap = match mode with | None -> false (* unboxed is not on heap *) - | Some m -> is_heap_mode m + | Some m -> is_heap_mode (fst m) in if no_init || size < Config.max_young_wosize || not on_heap then begin @@ -2032,7 +2032,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = begin match opt_init_expr with None -> assert false | Some init_expr -> - assert (is_heap_mode (Option.get mode)); (* Pduprecord must be Alloc_heap and not unboxed *) + assert (is_heap_mode (fst (Option.get mode))); (* Pduprecord must be Alloc_heap and not unboxed *) Llet(Strict, Lambda.layout_block, copy_id, Lprim(Pduprecord (repres, size), [transl_exp ~scopes Jkind.Sort.for_record init_expr], @@ -2215,7 +2215,7 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort (transl_exp ~scopes let_.bop_exp_sort let_.bop_exp) ands in let func = - let return_mode = alloc_heap (* XXX fixme: use result of is_function_type *) in + let return_mode = alloc_heap_aliased (* XXX fixme: use result of is_function_type *) in let (kind, params, return, _region, ret_mode), body = event_function ~scopes case.c_rhs (function repr -> diff --git a/ocaml/lambda/translmod.ml b/ocaml/lambda/translmod.ml index 70b8c4f5860..7f1ca533cfb 100644 --- a/ocaml/lambda/translmod.ml +++ b/ocaml/lambda/translmod.ml @@ -117,7 +117,7 @@ let rec apply_coercion loc strict restr arg = Lprim(mod_field pos,[Lvar id], loc) in let lam = - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map (apply_coercion_field loc get_field) pos_cc_list, loc) in @@ -127,7 +127,7 @@ let rec apply_coercion loc strict restr arg = let carg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict arg [{name = param; layout = Lambda.layout_module; - attributes = Lambda.default_param_attribute; mode = alloc_heap}] + attributes = Lambda.default_param_attribute; mode = alloc_heap_aliased}] [carg] cc_res | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode; pc_poly_sort } -> Translprim.transl_primitive loc pc_desc pc_env pc_type @@ -151,7 +151,7 @@ and apply_coercion_result loc strict funct params args cc_res = ({ name = param; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; - mode = alloc_heap } :: params) + mode = alloc_heap_aliased } :: params) (arg :: args) cc_res | _ -> name_lambda strict funct Lambda.layout_functor @@ -167,7 +167,7 @@ and apply_coercion_result loc strict funct params args cc_res = may_fuse_arity = true; } ~loc ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~body:(apply_coercion loc Strict cc_res @@ -554,7 +554,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc = name = param'; layout = Lambda.layout_module; attributes = Lambda.default_param_attribute; - mode = alloc_heap + mode = alloc_heap_aliased } :: params in let body = Llet (Alias, Lambda.layout_module, param, arg, body) in params, body) @@ -581,7 +581,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc = } ~loc ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_heap_aliased ~region:true ~body @@ -638,7 +638,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let body, size = match cc with Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map (fun id -> Lvar id) (List.rev fields), loc), List.length fields | Tcoerce_structure(pos_cc_list, id_pos_list) -> @@ -654,7 +654,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function in let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in let lam = - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map (fun (pos, cc) -> match cc with @@ -862,7 +862,7 @@ and transl_include_functor ~generative modl params scopes loc = let modl = transl_module ~scopes Tcoerce_none None modl in let params = if generative then [params;[]] else [params] in let params = List.map (fun coercion -> - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map (fun (name, cc) -> apply_coercion loc Strict cc (Lvar name)) coercion, @@ -1197,7 +1197,7 @@ let transl_store_structure ~scopes glob map prims aliases str = Lsequence(lam, Llet(Strict, Lambda.layout_module, id, Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map (fun id -> Lvar id) (defined_idents str.str_items), loc)), Lsequence(store_ident loc id, @@ -1226,7 +1226,7 @@ let transl_store_structure ~scopes glob map prims aliases str = Lsequence(lam, Llet(Strict, Lambda.layout_module, id, Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map field map, loc)), Lsequence(store_ident loc id, transl_store ~scopes rootpath @@ -1575,7 +1575,7 @@ let stub_out_runtime_parameters compilation_unit code = Location.none, None))) in Lprim (Praise Raise_regular, - [Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [ slot; message ], loc)], + [Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), [ slot; message ], loc)], loc) let transl_implementation compilation_unit impl ~style = @@ -1791,7 +1791,7 @@ let transl_package_plain_block component_names coercion = in size, apply_coercion Loc_unknown Strict coercion - (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map get_component component_names, Loc_unknown)) @@ -1831,7 +1831,7 @@ let transl_package_set_fields component_names target_name coercion = 0 component_names) | Tcoerce_structure (pos_cc_list, _id_pos_list) -> let components = - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), List.map get_component component_names, Loc_unknown) in diff --git a/ocaml/lambda/translmode.ml b/ocaml/lambda/translmode.ml index c4ee3875738..bdf1729faba 100644 --- a/ocaml/lambda/translmode.ml +++ b/ocaml/lambda/translmode.ml @@ -27,13 +27,25 @@ let transl_locality_mode_r locality = to ceil and determined; here we push it again just to get the constant. *) Locality.zap_to_ceil locality |> transl_locality_mode +let transl_uniqueness_mode = function + | Uniqueness.Const.Unique -> alloc_unique + | Uniqueness.Const.Aliased -> alloc_aliased + +let transl_uniqueness_mode_l uniqueness = + Uniqueness.zap_to_floor uniqueness |> transl_uniqueness_mode + +let transl_uniqueness_mode_r uniqueness = + Uniqueness.zap_to_ceil uniqueness |> transl_uniqueness_mode + let transl_alloc_mode_l mode = - (* we only take the locality axis *) - Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_l + (* we only take the locality and uniqueness axis *) + ( Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_l, + Alloc.proj (Monadic Uniqueness) mode |> transl_uniqueness_mode_l ) let transl_alloc_mode_r mode = - (* we only take the locality axis *) - Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_r + (* we only take the locality and uniqueness axis *) + ( Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_r, + Alloc.proj (Monadic Uniqueness) mode |> transl_uniqueness_mode_r ) let transl_alloc_mode (mode : Typedtree.alloc_mode) = transl_alloc_mode_r mode.mode diff --git a/ocaml/lambda/translmode.mli b/ocaml/lambda/translmode.mli index de43e2a8b63..ce0ed82b19a 100644 --- a/ocaml/lambda/translmode.mli +++ b/ocaml/lambda/translmode.mli @@ -16,10 +16,10 @@ open Mode val transl_locality_mode_l : (allowed * 'r) Locality.t -> Lambda.locality_mode -val transl_alloc_mode_l : (allowed * 'r) Alloc.t -> Lambda.locality_mode +val transl_alloc_mode_l : (allowed * 'r) Alloc.t -> Lambda.alloc_mode -val transl_alloc_mode_r : ('l * allowed) Alloc.t -> Lambda.locality_mode +val transl_alloc_mode_r : ('l * allowed) Alloc.t -> Lambda.alloc_mode -val transl_alloc_mode : Typedtree.alloc_mode -> Lambda.locality_mode +val transl_alloc_mode : Typedtree.alloc_mode -> Lambda.alloc_mode val transl_modify_mode : (allowed * 'r) Locality.t -> Lambda.modify_mode diff --git a/ocaml/lambda/translobj.ml b/ocaml/lambda/translobj.ml index 348730fe9f4..96931d40e02 100644 --- a/ocaml/lambda/translobj.ml +++ b/ocaml/lambda/translobj.ml @@ -187,7 +187,7 @@ let oo_wrap_gen env req f x = List.fold_left (fun lambda id -> let cl = - Lprim(Pmakeblock(0, Mutable, None, alloc_heap), + Lprim(Pmakeblock(0, Mutable, None, alloc_heap_aliased), [lambda_unit; lambda_unit; lambda_unit], Loc_unknown) in diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index be555ae38b9..d0cb4020d5f 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -136,6 +136,10 @@ let to_locality ~poly = function | None -> assert false | Some locality -> transl_locality_mode_l locality +let to_alloc_mode ~poly mode = + (* CR: check the aliased mode *) + (to_locality ~poly mode, alloc_aliased) + let to_modify_mode ~poly = function | Prim_global, _ -> modify_heap | Prim_local, _ -> modify_maybe_stack @@ -321,7 +325,8 @@ let indexing_primitives = let lookup_primitive loc ~poly_mode ~poly_sort pos p = let runtime5 = Config.runtime5 in - let mode = to_locality ~poly:poly_mode p.prim_native_repr_res in + let alloc_mode = to_alloc_mode ~poly:poly_mode p.prim_native_repr_res in + let mode = fst alloc_mode in let arg_modes = List.map (to_modify_mode ~poly:poly_mode) p.prim_native_repr_args in @@ -370,8 +375,8 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%setfield1" -> let mode = get_first_arg_mode () in Primitive ((Psetfield(1, Pointer, Assignment mode)), 2); - | "%makeblock" -> Primitive ((Pmakeblock(0, Immutable, None, mode)), 1) - | "%makemutable" -> Primitive ((Pmakeblock(0, Mutable, None, mode)), 1) + | "%makeblock" -> Primitive ((Pmakeblock(0, Immutable, None, alloc_mode)), 1) + | "%makemutable" -> Primitive ((Pmakeblock(0, Mutable, None, alloc_mode)), 1) | "%raise" -> Raise Raise_regular | "%reraise" -> Raise Raise_reraise | "%raise_notrace" -> Raise Raise_notrace @@ -537,9 +542,9 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%nativeint_sub" -> Primitive ((Psubbint (Pnativeint, mode)), 2) | "%nativeint_mul" -> Primitive ((Pmulbint (Pnativeint, mode)), 2) | "%nativeint_div" -> - Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe; mode }), 2); + Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe; mode = mode }), 2); | "%nativeint_mod" -> - Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe; mode }), 2); + Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe; mode = mode }), 2); | "%nativeint_and" -> Primitive ((Pandbint (Pnativeint, mode)), 2) | "%nativeint_or" -> Primitive ( (Porbint (Pnativeint, mode)), 2) | "%nativeint_xor" -> Primitive ((Pxorbint (Pnativeint, mode)), 2) @@ -553,9 +558,9 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%int32_sub" -> Primitive ((Psubbint (Pint32, mode)), 2) | "%int32_mul" -> Primitive ((Pmulbint (Pint32, mode)), 2) | "%int32_div" -> - Primitive ((Pdivbint { size = Pint32; is_safe = Safe; mode }), 2) + Primitive ((Pdivbint { size = Pint32; is_safe = Safe; mode = mode }), 2) | "%int32_mod" -> - Primitive ((Pmodbint { size = Pint32; is_safe = Safe; mode }), 2) + Primitive ((Pmodbint { size = Pint32; is_safe = Safe; mode = mode }), 2) | "%int32_and" -> Primitive ((Pandbint (Pint32, mode)), 2) | "%int32_or" -> Primitive ( (Porbint (Pint32, mode)), 2) | "%int32_xor" -> Primitive ((Pxorbint (Pint32, mode)), 2) @@ -569,9 +574,9 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%int64_sub" -> Primitive ((Psubbint (Pint64, mode)), 2) | "%int64_mul" -> Primitive ((Pmulbint (Pint64, mode)), 2) | "%int64_div" -> - Primitive ((Pdivbint { size = Pint64; is_safe = Safe; mode }), 2) + Primitive ((Pdivbint { size = Pint64; is_safe = Safe; mode = mode }), 2) | "%int64_mod" -> - Primitive ((Pmodbint { size = Pint64; is_safe = Safe; mode }), 2) + Primitive ((Pmodbint { size = Pint64; is_safe = Safe; mode = mode }), 2) | "%int64_and" -> Primitive ((Pandbint (Pint64, mode)), 2) | "%int64_or" -> Primitive ( (Porbint (Pint64, mode)), 2) | "%int64_xor" -> Primitive ((Pxorbint (Pint64, mode)), 2) @@ -1311,7 +1316,7 @@ let lambda_of_prim prim_name prim loc args arg_exps = lambda_of_loc kind loc | Loc kind, [arg] -> let lam = lambda_of_loc kind loc in - Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [lam; arg], loc) + Lprim(Pmakeblock(0, Immutable, None, alloc_heap_aliased), [lam; arg], loc) | Send (pos, layout), [obj; meth] -> Lsend(Public, meth, obj, [], pos, alloc_heap, loc, layout) | Send_self (pos, layout), [obj; meth] -> @@ -1356,7 +1361,7 @@ let lambda_of_prim prim_name prim loc args arg_exps = Lprim ( Praise Raise_regular, [Lprim ( - Pmakeblock (0, Immutable, None, alloc_heap), + Pmakeblock (0, Immutable, None, alloc_heap_aliased), [exn; Lconst (Const_immstring msg)], loc)], loc) @@ -1414,7 +1419,6 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = | None -> prim | Some prim -> prim in - let to_locality = to_locality ~poly:poly_mode in let error_loc = to_location loc in let rec make_params ty repr_args repr_res = match repr_args, repr_res with @@ -1437,7 +1441,7 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = let arg_layout = Typeopt.layout env error_loc arg_sort arg_ty in - let arg_mode = to_locality arg in + let arg_mode = to_alloc_mode ~poly:poly_mode arg in let params, return = make_params ret_ty repr_args repr_res in { name = Ident.create_local "prim"; layout = arg_layout; @@ -1458,7 +1462,7 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = loc in let body = lambda_of_prim p.prim_name prim loc args None in - let locality_mode = to_locality p.prim_native_repr_res in + let locality_mode = to_locality ~poly:poly_mode p.prim_native_repr_res in let () = (* CR mshinwell: Write a version of [primitive_may_allocate] that works on the [prim] type. *) @@ -1503,7 +1507,8 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = | Alloc_heap :: args -> count_nlocal args | (Alloc_local :: _) as args -> List.length args in - let nlocal = count_nlocal (List.map to_locality p.prim_native_repr_args) + let nlocal = count_nlocal + (List.map (to_locality ~poly:poly_mode) p.prim_native_repr_args) in lfunction ~kind:(Curried {nlocal}) ~params @@ -1512,7 +1517,7 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = ~loc ~body ~mode:alloc_heap - ~ret_mode:(to_locality p.prim_native_repr_res) + ~ret_mode:(to_alloc_mode ~poly:poly_mode p.prim_native_repr_res) ~region let lambda_primitive_needs_event_after = function diff --git a/ocaml/lambda/value_rec_compiler.ml b/ocaml/lambda/value_rec_compiler.ml index 4ff0585b7dd..9a36817beb0 100644 --- a/ocaml/lambda/value_rec_compiler.ml +++ b/ocaml/lambda/value_rec_compiler.ml @@ -509,7 +509,7 @@ let rec split_static_function lfun block_var local_idents lam : ap_specialised = Default_specialise; ap_result_layout = lfun.return; ap_region_close = Rc_normal; - ap_mode = lfun.ret_mode; + ap_mode = fst lfun.ret_mode; ap_probe = None; } in @@ -527,7 +527,7 @@ let rec split_static_function lfun block_var local_idents lam : in let lifted = { lfun = wrapper; free_vars_block_size = 1 } in Reachable (lifted, - Lprim (Pmakeblock (0, lifted_block_mut, None, Lambda.alloc_heap), + Lprim (Pmakeblock (0, lifted_block_mut, None, Lambda.alloc_heap_aliased), [Lvar v], no_loc)) | Lfunction lfun -> let free_vars = Lambda.free_variables lfun.body in @@ -553,7 +553,7 @@ let rec split_static_function lfun block_var local_idents lam : in let lifted = { lfun = new_fun; free_vars_block_size } in let block = - Lprim (Pmakeblock (0, lifted_block_mut, None, Lambda.alloc_heap), + Lprim (Pmakeblock (0, lifted_block_mut, None, Lambda.alloc_heap_aliased), List.rev block_fields_rev, no_loc) in diff --git a/ocaml/typing/mode_intf.mli b/ocaml/typing/mode_intf.mli index 5af0c2e39f9..e5ecc977040 100644 --- a/ocaml/typing/mode_intf.mli +++ b/ocaml/typing/mode_intf.mli @@ -240,6 +240,10 @@ module type S = sig val aliased : lr val unique : lr + + val zap_to_floor : (allowed * 'r) t -> Const.t + + val zap_to_ceil : ('l * allowed) t -> Const.t end module Contention : sig