From 05c342433937f94ecc5d4b76d561cc63f1932d28 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 5 Nov 2024 22:13:52 -0500 Subject: [PATCH] Use const sorts in variant/record representations --- lambda/matching.ml | 63 ++++++--------- lambda/translcore.ml | 50 +++--------- ocamldoc/odoc_sig.ml | 2 +- toplevel/genprintval.ml | 28 +++---- typing/datarepr.ml | 24 +++--- typing/predef.ml | 73 +++++++++-------- typing/printtyped.ml | 14 ++-- typing/subst.ml | 58 +------------- typing/typedecl.ml | 170 +++++++++++++++++++++++----------------- typing/typedtree.ml | 7 +- typing/typeopt.ml | 4 +- typing/types.ml | 25 +++--- typing/types.mli | 13 ++- 13 files changed, 224 insertions(+), 307 deletions(-) diff --git a/lambda/matching.ml b/lambda/matching.ml index 2d854442327..4fec43277d4 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -104,17 +104,15 @@ exception Error of Location.t * error let dbg = false -let jkind_layout_default_to_value_and_check_not_void loc jkind = - let rec contains_void : Jkind.Layout.Const.t -> bool = function - | Any -> false +let sort_check_not_void loc sort = + let rec contains_void : Jkind.Sort.Const.t -> bool = function | Base Void -> true | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64 | Vec128) -> false | Product [] -> - Misc.fatal_error "nil in jkind_layout_default_to_value_and_check_not_void" - | Product ts -> List.exists contains_void ts + Misc.fatal_error "nil in sort_check_not_void" + | Product ss -> List.exists contains_void ss in - let layout = Jkind.get_layout_defaulting_to_value jkind in - if contains_void layout then + if contains_void sort then raise (Error (loc, Void_layout)) ;; @@ -1910,9 +1908,7 @@ let get_pat_args_constr p rem = match p with | { pat_desc = Tpat_construct (_, {cstr_args}, args, _) } -> List.iter2 - (fun { ca_jkind } arg -> - jkind_layout_default_to_value_and_check_not_void - arg.pat_loc ca_jkind) + (fun { ca_sort } arg -> sort_check_not_void arg.pat_loc ca_sort) cstr_args args; (* CR layouts v5: This sanity check will have to go (or be replaced with a void-specific check) when we have other non-value sorts *) @@ -1928,12 +1924,11 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = let loc = head_loc ~scopes head in (* CR layouts v5: This sanity check should be removed or changed to specifically check for void when we add other non-value sorts. *) - List.iter (fun { ca_jkind } -> - jkind_layout_default_to_value_and_check_not_void head.pat_loc ca_jkind) + List.iter (fun { ca_sort } -> sort_check_not_void head.pat_loc ca_sort) cstr.cstr_args; let ubr = Translmode.transl_unique_barrier (head.pat_unique_barrier) in let sem = add_barrier_to_read ubr Reads_agree in - let make_field_access binding_kind jkind ~field ~pos = + let make_field_access binding_kind sort ~field ~pos = let prim = match cstr.cstr_shape with | Constructor_uniform_value -> Pfield (pos, Pointer, sem) @@ -1955,8 +1950,6 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = let shape = Lambda.transl_mixed_product_shape shape in Pmixedfield (pos, read, shape, sem) in - let sort = Jkind.sort_of_jkind jkind in - let sort = Jkind.Sort.default_for_transl_and_get sort in let layout = Typeopt.layout_of_sort head.pat_loc sort in (Lprim (prim, [ arg ], loc), binding_kind, sort, layout) in @@ -1967,15 +1960,15 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = match cstr.cstr_repr with | Variant_boxed _ -> List.mapi - (fun i { ca_jkind } -> - make_field_access str ca_jkind ~field:i ~pos:i) + (fun i { ca_sort } -> + make_field_access str ca_sort ~field:i ~pos:i) cstr.cstr_args @ rem | Variant_unboxed -> (arg, str, sort, layout) :: rem | Variant_extensible -> List.mapi - (fun i { ca_jkind } -> - make_field_access str ca_jkind ~field:i ~pos:(i+1)) + (fun i { ca_sort } -> + make_field_access str ca_sort ~field:i ~pos:(i+1)) cstr.cstr_args @ rem @@ -2297,7 +2290,7 @@ let record_matching_line num_fields lbl_pat_list = List.iter (fun (_, lbl, pat) -> (* CR layouts v5: This void sanity check can be removed when we add proper void support (or whenever we remove `lbl_pos_void`) *) - jkind_layout_default_to_value_and_check_not_void pat.pat_loc lbl.lbl_jkind; + sort_check_not_void pat.pat_loc lbl.lbl_sort; patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -2331,12 +2324,9 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = rem else let lbl = all_labels.(pos) in - jkind_layout_default_to_value_and_check_not_void - head.pat_loc lbl.lbl_jkind; + sort_check_not_void head.pat_loc lbl.lbl_sort; let ptr = Typeopt.maybe_pointer_type head.pat_env lbl.lbl_arg in - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl_sort in + let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl.lbl_sort in let sem = if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree in @@ -2347,21 +2337,21 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = | Record_boxed _ | Record_inlined (_, Constructor_uniform_value, Variant_boxed _) -> Lprim (Pfield (lbl.lbl_pos, ptr, sem), [ arg ], loc), - lbl_sort, lbl_layout + lbl.lbl_sort, lbl_layout | Record_unboxed | Record_inlined (_, _, Variant_unboxed) -> arg, sort, layout | Record_float -> (* TODO: could optimise to Alloc_local sometimes *) Lprim (Pfloatfield (lbl.lbl_pos, sem, alloc_heap), [ arg ], loc), (* Here we are projecting a boxed float from a float record. *) - lbl_sort, lbl_layout + lbl.lbl_sort, lbl_layout | Record_ufloat -> Lprim (Pufloatfield (lbl.lbl_pos, sem), [ arg ], loc), (* Here we are projecting an unboxed float from a float record. *) - lbl_sort, lbl_layout + lbl.lbl_sort, lbl_layout | Record_inlined (_, Constructor_uniform_value, Variant_extensible) -> Lprim (Pfield (lbl.lbl_pos + 1, ptr, sem), [ arg ], loc), - lbl_sort, lbl_layout + lbl.lbl_sort, lbl_layout | Record_inlined (_, Constructor_mixed _, Variant_extensible) -> (* CR layouts v5.9: support this *) fatal_error @@ -2388,7 +2378,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = { value_prefix_len; flat_suffix } in Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [ arg ], loc), - lbl_sort, lbl_layout + lbl.lbl_sort, lbl_layout in let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in let str = add_barrier_to_let_kind ubr str in @@ -2410,9 +2400,7 @@ let get_expr_args_record_unboxed_product ~scopes head in let lbl_layouts = Array.map (fun lbl -> - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - Typeopt.layout_of_sort lbl.lbl_loc lbl_sort + Typeopt.layout_of_sort lbl.lbl_loc lbl.lbl_sort ) all_labels |> Array.to_list in @@ -2421,8 +2409,7 @@ let get_expr_args_record_unboxed_product ~scopes head rem else let lbl = all_labels.(pos) in - jkind_layout_default_to_value_and_check_not_void - head.pat_loc lbl.lbl_jkind; + sort_check_not_void head.pat_loc lbl.lbl_sort; let access = if Array.length all_labels = 1 then arg (* erase singleton unboxed records before lambda *) else @@ -2436,10 +2423,8 @@ let get_expr_args_record_unboxed_product ~scopes head else Alias in - let sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let sort = Jkind.Sort.default_for_transl_and_get sort in - let layout = Typeopt.layout_of_sort lbl.lbl_loc sort in - (access, str, sort, layout) :: make_args (pos + 1) + let layout = Typeopt.layout_of_sort lbl.lbl_loc lbl.lbl_sort in + (access, str, lbl.lbl_sort, layout) :: make_args (pos + 1) in make_args 0 diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 3b216c0765e..c27d89d16d4 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -527,11 +527,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = of_location ~scopes e.exp_loc) | Texp_construct(_, cstr, args, alloc_mode) -> let args_with_sorts = - List.map2 (fun { ca_jkind } e -> - let sort = Jkind.sort_of_jkind ca_jkind in - let sort = Jkind.Sort.default_for_transl_and_get sort in - e, sort) - cstr.cstr_args args + List.map2 (fun { ca_sort } e -> e, ca_sort) cstr.cstr_args args in let ll = List.map (fun (e, sort) -> transl_exp ~scopes sort e) args_with_sorts @@ -647,9 +643,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree in let sem = add_barrier_to_read (transl_unique_barrier ubr) sem in - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - check_record_field_sort id.loc lbl_sort; + check_record_field_sort id.loc lbl.lbl_sort; begin match lbl.lbl_repres with Record_boxed _ | Record_inlined (_, Constructor_uniform_value, Variant_boxed _) -> @@ -707,11 +701,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | Texp_unboxed_field(arg, arg_sort, _id, lbl, _) -> begin match lbl.lbl_repres with | Record_unboxed_product -> - let lbl_layout l = - let lbl_sort = Jkind.sort_of_jkind l.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - layout e.exp_env l.lbl_loc lbl_sort l.lbl_arg - in + let lbl_layout l = layout e.exp_env l.lbl_loc l.lbl_sort l.lbl_arg in let layouts = Array.to_list (Array.map lbl_layout lbl.lbl_all) in let arg_sort = Jkind.Sort.default_for_transl_and_get arg_sort in let targ = transl_exp ~scopes arg_sort arg in @@ -727,9 +717,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = representability on construction, [sort_of_jkind] will be unsafe here. Probably we should add a sort to `Texp_setfield` in the typed tree, then. *) - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - check_record_field_sort id.loc lbl_sort; + check_record_field_sort id.loc lbl.lbl_sort; let mode = Assignment (transl_modify_mode arg_mode) in @@ -767,7 +755,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = end in Lprim(access, [transl_exp ~scopes Jkind.Sort.Const.for_record arg; - transl_exp ~scopes lbl_sort newval], + transl_exp ~scopes lbl.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 @@ -1888,9 +1876,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let copy_id = Ident.create_local "newrecord" in let update_field cont (lbl, definition) = (* CR layouts v5: allow more unboxed types here. *) - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - check_record_field_sort lbl.lbl_loc lbl_sort; + check_record_field_sort lbl.lbl_loc lbl.lbl_sort; match definition with | Kept _ -> cont | Overridden (_lid, expr) -> @@ -1937,7 +1923,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = end in Lsequence(Lprim(upd, [Lvar copy_id; - transl_exp ~scopes lbl_sort expr], + transl_exp ~scopes lbl.lbl_sort expr], of_location ~scopes loc), cont) in @@ -1955,15 +1941,9 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let lv = Array.mapi (fun i (lbl, definition) -> - (* CR layouts v2.5: When we allow `any` in record fields and check - representability on construction, [sort_of_layout] will be unsafe - here. Probably we should add sorts to record construction in the - typed tree, then. *) - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in match definition with | Kept (typ, mut, _) -> - let field_layout = layout env lbl.lbl_loc lbl_sort typ in + let field_layout = layout env lbl.lbl_loc lbl.lbl_sort typ in let sem = if Types.is_mutable mut then Reads_vary else Reads_agree in @@ -2019,8 +1999,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = of_location ~scopes loc), field_layout | Overridden (_lid, expr) -> - let field_layout = layout_exp lbl_sort expr in - transl_exp ~scopes lbl_sort expr, field_layout) + let field_layout = layout_exp lbl.lbl_sort expr in + transl_exp ~scopes lbl.lbl_sort expr, field_layout) fields in let ll, shape = List.split (Array.to_list lv) in @@ -2115,11 +2095,9 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = let shape = Array.map (fun (lbl, definition) -> - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in match definition with - | Kept (typ, _mut, _) -> layout env lbl.lbl_loc lbl_sort typ - | Overridden (_lid, expr) -> layout_exp lbl_sort expr) + | Kept (typ, _mut, _) -> layout env lbl.lbl_loc lbl.lbl_sort typ + | Overridden (_lid, expr) -> layout_exp lbl.lbl_sort expr) fields |> Array.to_list in @@ -2131,9 +2109,7 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = let access = Punboxed_product_field (i, shape) in Lprim (access, [Lvar init_id], of_location ~scopes loc) | Overridden (_lid, expr) -> - let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in - let lbl_sort = Jkind.Sort.default_for_transl_and_get lbl_sort in - transl_exp ~scopes lbl_sort expr) + transl_exp ~scopes lbl.lbl_sort expr) fields |> Array.to_list in diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index b24c1ce2e9d..cc75da1715d 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -496,7 +496,7 @@ module Analyser = { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } = get_field env comments @@ {Types.ld_id; ld_mutable; ld_modalities = Mode.Modality.Value.Const.id; - ld_jkind=Jkind.Builtin.any ~why:Dummy_jkind (* ignored *); + ld_sort=Jkind.Sort.Const.void (* ignored *); ld_type=ld_type.Typedtree.ctyp_type; ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in let open Typedtree in diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 01e074df1e5..f2d9a9e646b 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -249,16 +249,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | Print_as_value (* can interpret as a value and print *) | Print_as of string (* can't print *) - let get_and_default_jkind_for_printing jkind = - let layout = Jkind.get_layout_defaulting_to_value jkind in - match layout with - (* CR layouts v3.0: [Value_or_null] should probably require special - printing to avoid descending into NULL. (This module uses - lots of unsafe Obj features.) - *) + let print_sort : Jkind.Sort.Const.t -> _ = function | Base Value -> Print_as_value | Base Void -> Print_as "" - | Any -> Print_as "" | Base (Float64 | Float32 | Bits32 | Bits64 | Vec128 | Word) -> Print_as "" | Product _ -> Print_as "" @@ -457,9 +450,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct instantiate_types env type_params ty_list l in let ty_args = List.map2 - (fun { ca_jkind } ty_arg -> - (ty_arg, - get_and_default_jkind_for_printing ca_jkind) + (fun { ca_sort } ty_arg -> + (ty_arg, print_sort ca_sort) ) l ty_args in tree_of_constr_with_args (tree_of_constr env path) @@ -574,12 +566,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct lbl_list pos obj rep = let rec tree_of_fields first pos = function | [] -> [] - | {ld_id; ld_type; ld_jkind} :: remainder -> + | {ld_id; ld_type; ld_sort} :: remainder -> let ty_arg = instantiate_type env type_params ty_list ld_type in let name = Ident.name ld_id in (* PR#5722: print full module path only for first record field *) - let is_void = Jkind.is_void_defaulting ld_jkind in + let is_void = Jkind.Sort.Const.(equal void ld_sort) in let lid = if first then tree_of_label env path (Out_name.create name) else Oide_ident (Out_name.create name) @@ -619,17 +611,17 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct ty_list lbl_list pos obj = let rec tree_of_fields first pos = function | [] -> [] - | {ld_id; ld_type; ld_jkind} :: remainder -> + | {ld_id; ld_type; ld_sort} :: remainder -> let ty_arg = instantiate_type env type_params ty_list ld_type in let name = Ident.name ld_id in (* PR#5722: print full module path only for first record field *) - let is_void = Jkind.is_void_defaulting ld_jkind in + let is_void = Jkind.Sort.Const.(equal void ld_sort) in let lid = if first then tree_of_label env path (Out_name.create name) else Oide_ident (Out_name.create name) and v = - match get_and_default_jkind_for_printing ld_jkind with + match print_sort ld_sort with | Print_as msg -> Oval_stuff msg | Print_as_value -> match lbl_list with @@ -737,8 +729,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | _ -> assert false in let args = instantiate_types env type_params ty_list cstr.cstr_args in - let args = List.map2 (fun { ca_jkind } arg -> - (arg, get_and_default_jkind_for_printing ca_jkind)) + let args = List.map2 (fun { ca_sort } arg -> + (arg, print_sort ca_sort)) cstr.cstr_args args in tree_of_constr_with_args diff --git a/typing/datarepr.ml b/typing/datarepr.ml index cb9daeac2d6..4d4ccb6ad01 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -70,7 +70,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep = in let type_params = TypeSet.elements arg_vars_set in let arity = List.length type_params in - let is_void_label lbl = Jkind.is_void_defaulting lbl.ld_jkind in + let is_void_label lbl = Jkind.Sort.Const.(equal void lbl.ld_sort) in let jkind = Jkind.for_boxed_record ~all_void:(List.for_all is_void_label lbls) in @@ -97,7 +97,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep = [ { ca_type = newgenconstr path type_params; - ca_jkind = jkind; + ca_sort = Jkind.Sort.Const.value; ca_modalities = Mode.Modality.Value.Const.id; ca_loc = Location.none } @@ -121,21 +121,21 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep = written here should be irrelevant, and so would like to understand this interaction better. *) begin match cd_args with - | Cstr_tuple [{ ca_jkind = jkind }] - | Cstr_record [{ ld_jkind = jkind }] -> - [| Constructor_uniform_value, [| jkind |] |] + | Cstr_tuple [{ ca_sort = sort }] + | Cstr_record [{ ld_sort = sort }] -> + [| Constructor_uniform_value, [| sort |] |] | Cstr_tuple ([] | _ :: _) | Cstr_record ([] | _ :: _) -> - Misc.fatal_error "Multiple or 0 arguments in [@@unboxed] variant" + Misc.fatal_error "Multiple arguments in [@@unboxed] variant" end | Variant_unboxed, ([] | _ :: _) -> Misc.fatal_error "Multiple or 0 constructors in [@@unboxed] variant" in - let all_void jkinds = Array.for_all Jkind.is_void_defaulting jkinds in + let all_void sorts = Array.for_all Jkind.Sort.Const.(equal void) sorts in let num_consts = ref 0 and num_nonconsts = ref 0 in let cstr_constant = Array.map - (fun (_, jkinds) -> - let all_void = all_void jkinds in + (fun (_, sorts) -> + let all_void = all_void sorts in if all_void then incr num_consts else incr num_nonconsts; all_void) cstr_shapes_and_arg_jkinds @@ -229,7 +229,7 @@ let dummy_label (type rep) (record_form : rep record_form) in { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_modalities = Mode.Modality.Value.Const.id; - lbl_jkind = Jkind.Builtin.any ~why:Dummy_jkind; + lbl_sort = Jkind.Sort.Const.void; lbl_num = -1; lbl_pos = -1; lbl_all = [||]; lbl_repres = repres; lbl_private = Public; @@ -243,14 +243,14 @@ let label_descrs record_form ty_res lbls repres priv = let rec describe_labels num pos = function [] -> [] | l :: rest -> - let is_void = Jkind.is_void_defaulting l.ld_jkind in + let is_void = Jkind.Sort.Const.(equal void l.ld_sort) in let lbl = { lbl_name = Ident.name l.ld_id; lbl_res = ty_res; lbl_arg = l.ld_type; lbl_mut = l.ld_mutable; lbl_modalities = l.ld_modalities; - lbl_jkind = l.ld_jkind; + lbl_sort = l.ld_sort; lbl_pos = if is_void then lbl_pos_void else pos; lbl_num = num; lbl_all = all_labels; diff --git a/typing/predef.ml b/typing/predef.ml index 80180379696..018e8c0a8a5 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -208,14 +208,17 @@ and ident_some = ident_create "Some" and ident_null = ident_create "Null" and ident_this = ident_create "This" +let option_argument_sort = Jkind.Sort.Const.value let option_argument_jkind = Jkind.Builtin.value ~why:( Type_argument {parent_path = path_option; position = 1; arity = 1}) +let list_jkind = Jkind.Builtin.value ~why:Boxed_variant +let list_sort = Jkind.Sort.Const.value +let list_argument_sort = Jkind.Sort.Const.value let list_argument_jkind = Jkind.Builtin.value ~why:( Type_argument {parent_path = path_list; position = 1; arity = 1}) -let or_null_argument_jkind = Jkind.Builtin.value ~why:( - Type_argument {parent_path = path_or_null; position = 1; arity = 1}) +let or_null_argument_sort = Jkind.Sort.Const.value let mk_add_type add_type ?manifest type_ident @@ -278,16 +281,14 @@ let mk_add_type1 add_type type_ident add_type type_ident decl env let mk_add_extension add_extension id args = - List.iter (fun (_, jkind) -> + List.iter (fun (_, sort) -> let raise_error () = Misc.fatal_error "sanity check failed: non-value jkind in predef extension \ constructor; should this have Constructor_mixed shape?" in - match Jkind.get_layout jkind with - | Some (Base Value) -> () - | Some (Any - | Base (Void | Float32 | Float64 | Word | Bits32 | Bits64 | Vec128) - | Product _) - | None -> raise_error ()) + match (sort : Jkind.Sort.Const.t) with + | Base Value -> () + | Base (Void | Float32 | Float64 | Word | Bits32 | Bits64 | Vec128) + | Product _ -> raise_error ()) args; add_extension id { ext_type_path = path_exn; @@ -295,10 +296,10 @@ let mk_add_extension add_extension id args = ext_args = Cstr_tuple (List.map - (fun (ca_type, ca_jkind) -> + (fun (ca_type, ca_sort) -> { ca_type; - ca_jkind; + ca_sort; ca_modalities=Mode.Modality.Value.Const.id; ca_loc=Location.none }) @@ -316,20 +317,20 @@ let mk_add_extension add_extension id args = let variant constrs = let mk_elt { cd_args } = - let jkinds = match cd_args with + let sorts = match cd_args with | Cstr_tuple args -> - Misc.Stdlib.Array.of_list_map (fun { ca_jkind } -> ca_jkind) args + Misc.Stdlib.Array.of_list_map (fun { ca_sort } -> ca_sort) args | Cstr_record lbls -> - Misc.Stdlib.Array.of_list_map (fun { ld_jkind } -> ld_jkind) lbls + Misc.Stdlib.Array.of_list_map (fun { ld_sort } -> ld_sort) lbls in - Constructor_uniform_value, jkinds + Constructor_uniform_value, sorts in Type_variant (constrs, Variant_boxed (Misc.Stdlib.Array.of_list_map mk_elt constrs)) -let unrestricted tvar jkind = +let unrestricted tvar ca_sort = {ca_type=tvar; - ca_jkind=jkind; + ca_sort; ca_modalities=Mode.Modality.Value.Const.id; ca_loc=Location.none} @@ -339,7 +340,6 @@ let build_initial_env add_type add_extension empty_env = let add_type = mk_add_type add_type and add_type1 = mk_add_type1 add_type and add_extension = mk_add_extension add_extension in - let list_jkind = Jkind.Builtin.value ~why:Boxed_variant in empty_env (* Predefined types *) |> add_type1 ident_array @@ -371,8 +371,8 @@ let build_initial_env add_type add_extension empty_env = ~separability:Separability.Ind ~kind:(fun tvar -> variant [cstr ident_nil []; - cstr ident_cons [unrestricted tvar list_argument_jkind; - unrestricted (type_list tvar) list_jkind]]) + cstr ident_cons [unrestricted tvar list_argument_sort; + unrestricted (type_list tvar) list_sort]]) ~jkind:list_jkind |> add_type ident_nativeint ~jkind:Jkind.Const.Builtin.immutable_data @@ -381,35 +381,32 @@ let build_initial_env add_type add_extension empty_env = ~separability:Separability.Ind ~kind:(fun tvar -> variant [cstr ident_none []; - cstr ident_some [unrestricted tvar option_argument_jkind]]) + cstr ident_some [unrestricted tvar option_argument_sort]]) ~jkind:(Jkind.Builtin.value ~why:Boxed_variant) |> add_type ident_lexing_position ~kind:( - let lbl (field, field_type, jkind) = + let lbl (field, field_type) = let id = Ident.create_predef field in { ld_id=id; ld_mutable=Immutable; ld_modalities=Mode.Modality.Value.Const.id; ld_type=field_type; - ld_jkind=jkind; + ld_sort=Jkind.Sort.Const.value; ld_loc=Location.none; ld_attributes=[]; ld_uid=Uid.of_predef_id id; } in - let immediate = Jkind.Builtin.immediate ~why:(Primitive ident_int) in let labels = List.map lbl [ - ("pos_fname", type_string, - Jkind.of_builtin ~why:(Primitive ident_string) - Jkind.Const.Builtin.immutable_data); - ("pos_lnum", type_int, immediate); - ("pos_bol", type_int, immediate); - ("pos_cnum", type_int, immediate) ] + ("pos_fname", type_string); + ("pos_lnum", type_int); + ("pos_bol", type_int); + ("pos_cnum", type_int) ] in Type_record ( labels, - (Record_boxed (List.map (fun label -> label.ld_jkind) labels |> Array.of_list)) + (Record_boxed (List.map (fun label -> label.ld_sort) labels |> Array.of_list)) ) ) ~jkind:Jkind.Const.Builtin.immutable_data @@ -425,25 +422,25 @@ let build_initial_env add_type add_extension empty_env = (* Predefined exceptions - alphabetical order *) |> add_extension ident_assert_failure [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), - Jkind.Builtin.value ~why:Tuple] + Jkind.Sort.Const.value] |> add_extension ident_division_by_zero [] |> add_extension ident_end_of_file [] |> add_extension ident_failure [type_string, - Jkind.Builtin.value ~why:(Primitive ident_string)] + Jkind.Sort.Const.value] |> add_extension ident_invalid_argument [type_string, - Jkind.Builtin.value ~why:(Primitive ident_string)] + Jkind.Sort.Const.value] |> add_extension ident_match_failure [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), - Jkind.Builtin.value ~why:Tuple] + Jkind.Sort.Const.value] |> add_extension ident_not_found [] |> add_extension ident_out_of_memory [] |> add_extension ident_stack_overflow [] |> add_extension ident_sys_blocked_io [] |> add_extension ident_sys_error [type_string, - Jkind.Builtin.value ~why:(Primitive ident_string)] + Jkind.Sort.Const.value] |> add_extension ident_undefined_recursive_module [newgenty (Ttuple[None, type_string; None, type_int; None, type_int]), - Jkind.Builtin.value ~why:Tuple] + Jkind.Sort.Const.value] let add_simd_stable_extension_types add_type env = let add_type = mk_add_type add_type in @@ -469,7 +466,7 @@ let add_small_number_extension_types add_type env = let or_null_kind tvar = variant [cstr ident_null []; - cstr ident_this [unrestricted tvar or_null_argument_jkind]] + cstr ident_this [unrestricted tvar or_null_argument_sort]] let add_or_null add_type env = let add_type1 = mk_add_type1 add_type in diff --git a/typing/printtyped.ml b/typing/printtyped.ml index af6d9915b4e..153dd95a48f 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -180,9 +180,9 @@ let tuple_component_label i ppf = function let typevars ppf vs = List.iter (typevar_jkind ~print_quote:true ppf) vs -let jkind_array i ppf jkinds = - array (i+1) (fun _ ppf l -> fprintf ppf "%a;@ " Jkind.format l) - ppf jkinds +let sort_array i ppf sorts = + array (i+1) (fun _ ppf l -> fprintf ppf "%a;@ " Jkind.Sort.Const.format l) + ppf sorts let tag ppf = let open Types in function | Ordinary {src_index;runtime_tag} -> @@ -194,8 +194,8 @@ let variant_representation i ppf = let open Types in function line i ppf "Variant_unboxed\n" | Variant_boxed cstrs -> line i ppf "Variant_boxed %a\n" - (array (i+1) (fun _ ppf (_cstr, jkinds) -> - jkind_array (i+1) ppf jkinds)) + (array (i+1) (fun _ ppf (_cstr, sorts) -> + sort_array (i+1) ppf sorts)) cstrs | Variant_extensible -> line i ppf "Variant_inlined\n" @@ -205,8 +205,8 @@ let flat_element i ppf flat_element = let record_representation i ppf = let open Types in function | Record_unboxed -> line i ppf "Record_unboxed\n" - | Record_boxed jkinds -> - line i ppf "Record_boxed %a\n" (jkind_array i) jkinds + | Record_boxed sorts -> + line i ppf "Record_boxed %a\n" (sort_array i) sorts | Record_inlined (t, _c, v) -> line i ppf "Record_inlined (%a, %a)\n" tag t (variant_representation i) v | Record_float -> line i ppf "Record_float\n" diff --git a/typing/subst.ml b/typing/subst.ml index aba4f23965c..d063669535e 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -124,11 +124,6 @@ let with_additional_action = in { s with additional_action; last_compose = None } -let apply_prepare_jkind s lay loc = - match s.additional_action with - | Prepare_for_saving { prepare_jkind } -> prepare_jkind loc lay - | Duplicate_variables | No_action -> lay - let change_locs s loc = { s with loc = Some loc; last_compose = None } let loc s x = @@ -467,7 +462,7 @@ let label_declaration copy_scope s l = ld_id = l.ld_id; ld_mutable = l.ld_mutable; ld_modalities = l.ld_modalities; - ld_jkind = apply_prepare_jkind s l.ld_jkind l.ld_loc; + ld_sort = l.ld_sort; ld_type = typexp copy_scope s l.ld_loc l.ld_type; ld_loc = loc s l.ld_loc; ld_attributes = attrs s l.ld_attributes; @@ -477,13 +472,7 @@ let label_declaration copy_scope s l = let constructor_argument copy_scope s ca = { ca_type = typexp copy_scope s ca.ca_loc ca.ca_type; - ca_jkind = begin match s.additional_action with - | Prepare_for_saving { prepare_jkind } -> - prepare_jkind ca.ca_loc ca.ca_jkind - (* CR layouts v2.8: This will have to be copied once we - have with-types. *) - | Duplicate_variables | No_action -> ca.ca_jkind - end; + ca_sort = ca.ca_sort; ca_loc = loc s ca.ca_loc; ca_modalities = ca.ca_modalities; } @@ -504,30 +493,6 @@ let constructor_declaration copy_scope s c = cd_uid = c.cd_uid; } -(* called only when additional_action is [Prepare_for_saving] *) -let variant_representation ~prepare_jkind loc = function - | Variant_unboxed -> Variant_unboxed - | Variant_boxed cstrs_and_jkinds -> - Variant_boxed - (Array.map - (fun (cstr, jkinds) -> cstr, Array.map (prepare_jkind loc) jkinds) - cstrs_and_jkinds) - | Variant_extensible -> Variant_extensible - -(* called only when additional_action is [Prepare_for_saving] *) -let record_representation ~prepare_jkind loc = function - | Record_unboxed -> Record_unboxed - | Record_inlined (tag, constructor_rep, variant_rep) -> - Record_inlined (tag, - constructor_rep, - variant_representation ~prepare_jkind loc variant_rep) - | Record_boxed lays -> - Record_boxed (Array.map (prepare_jkind loc) lays) - | (Record_float | Record_ufloat | Record_mixed _) as rep -> rep - -let record_unboxed_product_representation ~prepare_jkind:_ _loc = function - | Record_unboxed_product -> Record_unboxed_product - let type_declaration' copy_scope s decl = { type_params = List.map (typexp copy_scope s decl.type_loc) decl.type_params; type_arity = decl.type_arity; @@ -535,30 +500,11 @@ let type_declaration' copy_scope s decl = begin match decl.type_kind with Type_abstract r -> Type_abstract r | Type_variant (cstrs, rep) -> - let rep = - match s.additional_action with - | No_action | Duplicate_variables -> rep - | Prepare_for_saving { prepare_jkind } -> - variant_representation ~prepare_jkind decl.type_loc rep - in Type_variant (List.map (constructor_declaration copy_scope s) cstrs, rep) | Type_record(lbls, rep) -> - let rep = - match s.additional_action with - | No_action | Duplicate_variables -> rep - | Prepare_for_saving { prepare_jkind } -> - record_representation ~prepare_jkind decl.type_loc rep - in Type_record (List.map (label_declaration copy_scope s) lbls, rep) | Type_record_unboxed_product(lbls, rep) -> - let rep = - match s.additional_action with - | No_action | Duplicate_variables -> rep - | Prepare_for_saving { prepare_jkind } -> - record_unboxed_product_representation - ~prepare_jkind decl.type_loc rep - in Type_record_unboxed_product (List.map (label_declaration copy_scope s) lbls, rep) | Type_open -> Type_open diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 2641c8cd8b0..137703388e4 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -484,8 +484,8 @@ let transl_labels (type rep) ~(record_form : rep record_form) ~new_var_jkind {Types.ld_id = ld.ld_id; ld_mutable = ld.ld_mutable; ld_modalities = ld.ld_modalities; - ld_jkind = Jkind.Builtin.any ~why:Dummy_jkind; - (* Updated by [update_label_jkinds] *) + ld_sort = Jkind.Sort.Const.void; + (* Updated by [update_label_sorts] *) ld_type = ty; ld_loc = ld.ld_loc; ld_attributes = ld.ld_attributes; @@ -516,8 +516,8 @@ let transl_types_gf ~new_var_jkind ~allow_unboxed Types.ca_modalities = ca.ca_modalities; ca_loc = ca.ca_loc; ca_type = ca.ca_type.ctyp_type; - ca_jkind = Jkind.Builtin.any ~why:Dummy_jkind; - (* Updated by [update_constructor_arguments_jkinds] *) + ca_sort = Jkind.Sort.Const.void; + (* Updated by [update_constructor_arguments_sorts] *) }) tyl_gfl in tyl_gfl, tyl_gfl' @@ -546,7 +546,7 @@ let transl_constructor_arguments ~new_var_jkind ~unboxed (* Note that [make_constructor] does not fill in the [ld_jkind] field of any computed record types, because it's called too early in the translation of a type declaration to compute accurate jkinds in the presence of recursively - defined types. It is updated later by [update_constructor_arguments_jkinds] + defined types. It is updated later by [update_constructor_arguments_sorts] *) let make_constructor env loc ~cstr_path ~type_path ~unboxed type_params svars @@ -797,7 +797,6 @@ let transl_declaration env sdecl (id, uid) = let cty = transl_simple_type ~new_var_jkind:Any env ~closed:no_row Mode.Alloc.Const.legacy sty in Some cty, Some cty.ctyp_type in - let any = Jkind.Builtin.any ~why:Initial_typedecl_env in (* jkind_default is the jkind to use for now as the type_jkind when there is no annotation and no manifest. See Note [Default jkinds in transl_declaration]. @@ -891,21 +890,21 @@ let transl_declaration env sdecl (id, uid) = Variant_unboxed, Jkind.of_new_legacy_sort ~why:Old_style_unboxed_type else - (* We mark all arg jkinds "any" here. They are updated later, - after the circular type checks make it safe to check jkinds. + (* We mark all arg sorts "void" here. They are updated later, + after the circular type checks make it safe to check sorts. Likewise, [Constructor_uniform_value] is potentially wrong and will be updated later. *) Variant_boxed ( Array.map (fun cstr -> - let jkinds = + let sorts = match Types.(cstr.cd_args) with | Cstr_tuple args -> - Array.make (List.length args) any - | Cstr_record _ -> [| any |] + Array.make (List.length args) Jkind.Sort.Const.void + | Cstr_record _ -> [| Jkind.Sort.Const.value |] in - Constructor_uniform_value, jkinds) + Constructor_uniform_value, sorts) (Array.of_list cstrs) ), Jkind.Builtin.value ~why:Boxed_variant @@ -927,8 +926,8 @@ let transl_declaration env sdecl (id, uid) = (* Note this is inaccurate, using `Record_boxed` in cases where the correct representation is [Record_float], [Record_ufloat], or [Record_mixed]. Those cases are fixed up after we can get - accurate jkinds for the fields, in [update_decl_jkind]. *) - Record_boxed (Array.make (List.length lbls) any), + accurate sorts for the fields, in [update_decl_jkind]. *) + Record_boxed (Array.make (List.length lbls) Jkind.Sort.Const.void), Jkind.Builtin.value ~why:Boxed_record in Ttype_record lbls, Type_record(lbls', rep), jkind @@ -942,7 +941,9 @@ let transl_declaration env sdecl (id, uid) = (* The jkinds below, and the ones in [lbls], are dummy jkinds which are replaced and made to correspond to each other in [update_decl_jkind]. *) - let jkind_ls = List.map (fun _ -> any) lbls in + let jkind_ls = + List.map (fun _ -> Jkind.Builtin.any ~why:Initial_typedecl_env) lbls + in let jkind = Jkind.Builtin.product ~why:Unboxed_record jkind_ls in Ttype_record_unboxed_product lbls, Type_record_unboxed_product(lbls', Record_unboxed_product), jkind @@ -1237,59 +1238,70 @@ let check_coherence env loc dpath decl = let check_abbrev env sdecl (id, decl) = (id, check_coherence env sdecl.ptype_loc (Path.Pident id) decl) -(* The [update_x_jkinds] functions infer more precise jkinds in the type kind, +(* The [update_x_sorts] functions infer more precise jkinds in the type kind, including which fields of a record are void. This would be hard to do during [transl_declaration] due to mutually recursive types. *) -(* [update_label_jkinds] additionally returns whether all the jkinds - were void *) -let update_label_jkinds env loc lbls named = - (* [named] is [Some jkinds] for top-level records (we will update the - jkinds) and [None] for inlined records. *) +(* [update_label_sorts] additionally returns whether all the jkinds + were void, and the jkinds of the labels *) +let update_label_sorts env loc lbls named = + (* [named] is [Some sorts] for top-level records (we will update the + sorts) and [None] for inlined records. *) (* CR layouts v5: it wouldn't be too hard to support records that are all void. just needs a bit of refactoring in translcore *) let update = match named with | None -> fun _ _ -> () - | Some jkinds -> fun idx jkind -> jkinds.(idx) <- jkind + | Some sorts -> fun idx sort -> sorts.(idx) <- sort in - let lbls = + let lbls_and_jkinds = List.mapi (fun idx (Types.{ld_type} as lbl) -> - let ld_jkind = Ctype.type_jkind env ld_type in - update idx ld_jkind; - {lbl with ld_jkind} + let jkind = Ctype.type_jkind env ld_type in + (* Next line guaranteed to be safe because of [check_representable] *) + let sort = Jkind.sort_of_jkind jkind in + let ld_sort = Jkind.Sort.default_to_value_and_get sort in + update idx ld_sort; + {lbl with ld_sort}, jkind ) lbls in - if List.for_all (fun l -> Jkind.is_void_defaulting l.ld_jkind) lbls then + let lbls, jkinds = List.split lbls_and_jkinds in + if List.for_all (fun l -> Jkind.Sort.Const.(equal void l.ld_sort)) lbls then raise (Error (loc, Jkind_empty_record)) - else lbls, false + else lbls, false, jkinds (* CR layouts v5: return true for a record with all voids *) (* In addition to updated constructor arguments, returns whether all arguments are void, useful for detecting enumerations that can be [immediate]. *) -let update_constructor_arguments_jkinds env loc cd_args jkinds = +let update_constructor_arguments_sorts env loc cd_args sorts = let update = - match jkinds with + match sorts with | None -> fun _ _ -> () - | Some jkinds -> fun idx jkind -> jkinds.(idx) <- jkind + | Some sorts -> fun idx sort -> sorts.(idx) <- sort in match cd_args with | Types.Cstr_tuple args -> - let args = + let args_and_jkinds = List.mapi (fun idx ({Types.ca_type; _} as arg) -> - let ca_jkind = Ctype.type_jkind env ca_type in - update idx ca_jkind; - {arg with ca_jkind}) args + let jkind = Ctype.type_jkind env ca_type in + (* Next line guaranteed to be safe because of [check_representable] *) + let sort = Jkind.sort_of_jkind jkind in + let ca_sort = Jkind.Sort.default_to_value_and_get sort in + update idx ca_sort; + {arg with ca_sort}, jkind) + args in + let args, jkinds = List.split args_and_jkinds in Types.Cstr_tuple args, - List.for_all (fun { ca_jkind } -> Jkind.is_void_defaulting ca_jkind) args + List.for_all + (fun { ca_sort } -> Jkind_types.Sort.Const.(equal void ca_sort)) args, + jkinds | Types.Cstr_record lbls -> - let lbls, all_void = - update_label_jkinds env loc lbls None + let lbls, all_void, jkinds = + update_label_sorts env loc lbls None in - update 0 (Jkind.Builtin.value ~why:Boxed_record); - Types.Cstr_record lbls, all_void + update 0 Jkind.Sort.Const.value; + Types.Cstr_record lbls, all_void, jkinds let assert_mixed_product_support = let required_reserved_header_bits = 8 in @@ -1443,17 +1455,17 @@ module Element_repr = struct end let update_constructor_representation - env (cd_args : Types.constructor_arguments) ~loc + env (cd_args : Types.constructor_arguments) arg_jkinds ~loc ~is_extension_constructor = let flat_suffix = match cd_args with | Cstr_tuple arg_types_and_modes -> let arg_reprs = - List.map (fun {Types.ca_type=arg_type; ca_jkind=arg_jkind; _} -> + List.map2 (fun {Types.ca_type=arg_type; _} arg_jkind -> let kloc : jkind_sort_loc = Cstr_tuple { unboxed = false } in Element_repr.classify env loc kloc arg_type arg_jkind, arg_type) - arg_types_and_modes + arg_types_and_modes arg_jkinds in Element_repr.mixed_product_shape loc arg_reprs Cstr_tuple ~on_flat_field_expected:(fun ~non_value ~boxed -> @@ -1466,11 +1478,11 @@ let update_constructor_representation raise (Error (loc, Illegal_mixed_product violation))) | Cstr_record fields -> let arg_reprs = - List.map (fun ld -> + List.map2 (fun ld arg_jkind -> let kloc = Inlined_record { unboxed = false } in - Element_repr.classify env loc kloc ld.Types.ld_type ld.ld_jkind, + Element_repr.classify env loc kloc ld.Types.ld_type arg_jkind, ld) - fields + fields arg_jkinds in Element_repr.mixed_product_shape loc arg_reprs Cstr_record ~on_flat_field_expected:(fun ~non_value ~boxed -> @@ -1522,20 +1534,24 @@ let update_decl_jkind env dpath decl = let update_record_kind loc lbls rep = match lbls, rep with | [Types.{ld_type} as lbl], Record_unboxed -> - let ld_jkind = Ctype.type_jkind env ld_type in - [{lbl with ld_jkind}], Record_unboxed, ld_jkind - | _, Record_boxed jkinds -> - let lbls, all_void = - update_label_jkinds env loc lbls (Some jkinds) + let jkind = Ctype.type_jkind env ld_type in + (* This next line is guaranteed to be OK because of a call to + [check_representable] *) + let sort = Jkind.sort_of_jkind jkind in + let ld_sort = Jkind.Sort.default_to_value_and_get sort in + [{lbl with ld_sort}], Record_unboxed, jkind + | _, Record_boxed sorts -> + let lbls, all_void, jkinds = + update_label_sorts env loc lbls (Some sorts) in let jkind = Jkind.for_boxed_record ~all_void in let reprs = - List.mapi - (fun i lbl -> + List.map2 + (fun lbl jkind -> let kloc = Record { unboxed = false } in - Element_repr.classify env loc kloc lbl.Types.ld_type jkinds.(i), + Element_repr.classify env loc kloc lbl.Types.ld_type jkind, lbl) - lbls + lbls jkinds in let repr_summary = { values = false; imms = false; floats = false; float64s = false; @@ -1635,16 +1651,20 @@ let update_decl_jkind env dpath decl = | [{Types.cd_args} as cstr], Variant_unboxed -> begin match cd_args with | Cstr_tuple [{ca_type=ty; _} as arg] -> begin - let ca_jkind = Ctype.type_jkind env ty in + let jkind = Ctype.type_jkind env ty in + let sort = Jkind.sort_of_jkind jkind in + let ca_sort = Jkind.Sort.default_to_value_and_get sort in [{ cstr with Types.cd_args = - Cstr_tuple [{ arg with ca_jkind }] }], - Variant_unboxed, ca_jkind + Cstr_tuple [{ arg with ca_sort }] }], + Variant_unboxed, jkind end | Cstr_record [{ld_type} as lbl] -> begin - let ld_jkind = Ctype.type_jkind env ld_type in + let jkind = Ctype.type_jkind env ld_type in + let sort = Jkind.sort_of_jkind jkind in + let ld_sort = Jkind.Sort.default_to_value_and_get sort in [{ cstr with Types.cd_args = - Cstr_record [{ lbl with ld_jkind }] }], - Variant_unboxed, ld_jkind + Cstr_record [{ lbl with ld_sort }] }], + Variant_unboxed, jkind end | (Cstr_tuple ([] | _ :: _ :: _) | Cstr_record ([] | _ :: _ :: _)) -> assert false @@ -1652,27 +1672,27 @@ let update_decl_jkind env dpath decl = | cstrs, Variant_boxed cstr_shapes -> let (_,cstrs,all_voids) = List.fold_left (fun (idx,cstrs,all_voids) cstr -> - let arg_jkinds = + let arg_sorts = match cstr_shapes.(idx) with - | Constructor_uniform_value, arg_jkinds -> arg_jkinds + | Constructor_uniform_value, arg_sorts -> arg_sorts | Constructor_mixed _, _ -> fatal_error "Typedecl.update_variant_kind doesn't expect mixed \ constructor as input" in - let cd_args, all_void = - update_constructor_arguments_jkinds env cstr.Types.cd_loc - cstr.Types.cd_args (Some arg_jkinds) + let cd_args, all_void, jkinds = + update_constructor_arguments_sorts env cstr.Types.cd_loc + cstr.Types.cd_args (Some arg_sorts) in let cstr_repr = - update_constructor_representation env cd_args + update_constructor_representation env cd_args jkinds ~is_extension_constructor:false ~loc:cstr.Types.cd_loc in let () = match cstr_repr with | Constructor_uniform_value -> () - | Constructor_mixed _ -> cstr_shapes.(idx) <- cstr_repr, arg_jkinds + | Constructor_mixed _ -> cstr_shapes.(idx) <- cstr_repr, arg_sorts in let cstr = { cstr with Types.cd_args } in (idx+1,cstr::cstrs,all_voids && all_void) @@ -1713,8 +1733,12 @@ let update_decl_jkind env dpath decl = | Record_unboxed_product -> let lbls, jkinds = List.map (fun (Types.{ld_type} as lbl) -> - let ld_jkind = Ctype.type_jkind env ld_type in - {lbl with ld_jkind}, ld_jkind + let jkind = Ctype.type_jkind env ld_type in + (* This next line is guaranteed to be OK because of a call to + [check_representable] *) + let sort = Jkind.sort_of_jkind jkind in + let ld_sort = Jkind.Sort.default_to_value_and_get sort in + {lbl with ld_sort}, jkind ) lbls |> List.split in @@ -2395,11 +2419,11 @@ let transl_extension_constructor_decl ~cstr_path:(Pident id) ~type_path ~unboxed:false typext_params svars sargs sret_type in - let args, constant = - update_constructor_arguments_jkinds env loc args None + let args, constant, jkinds = + update_constructor_arguments_sorts env loc args None in let constructor_shape = - update_constructor_representation env args ~loc + update_constructor_representation env args jkinds ~loc ~is_extension_constructor:true in args, constructor_shape, constant, ret_type, diff --git a/typing/typedtree.ml b/typing/typedtree.ml index dd0d5d0bdd6..c78b97000c9 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -1125,18 +1125,17 @@ let iter_pattern_full ~of_sort ~of_const_sort ~both_sides_of_or f sort pat = match cstr.cstr_repr with | Variant_unboxed -> [ sort ] | Variant_boxed _ | Variant_extensible -> - (List.map (fun { ca_jkind } -> - of_sort (Jkind.sort_of_jkind ca_jkind) ) + (List.map (fun { ca_sort } -> of_const_sort ca_sort ) cstr.cstr_args) in List.iter2 (loop f) sorts patl | Tpat_record (lbl_pat_list, _) -> List.iter (fun (_, lbl, pat) -> - (loop f) (of_sort (Jkind.sort_of_jkind lbl.lbl_jkind)) pat) + (loop f) (of_const_sort lbl.lbl_sort) pat) lbl_pat_list | Tpat_record_unboxed_product (lbl_pat_list, _) -> List.iter (fun (_, lbl, pat) -> - (loop f) (of_sort (Jkind.sort_of_jkind lbl.lbl_jkind)) pat) + (loop f) (of_const_sort lbl.lbl_sort) pat) lbl_pat_list (* Cases where the inner things must be value: *) | Tpat_variant (_, pat, _) -> Option.iter (loop f value) pat diff --git a/typing/typeopt.ml b/typing/typeopt.ml index bccba3937b8..e8b29174ef0 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -566,7 +566,7 @@ and value_kind_variant env ~loc ~visited ~depth ~num_nodes_visited value_kind env ~loc ~visited ~depth ~num_nodes_visited ty | _ -> assert false end - | Variant_boxed cstrs_and_jkinds -> + | Variant_boxed cstrs_and_sorts -> let depth = depth + 1 in let for_constructor_fields fields ~depth ~num_nodes_visited ~field_to_type = List.fold_left_map @@ -654,7 +654,7 @@ and value_kind_variant env ~loc ~visited ~depth ~num_nodes_visited | None -> None | Some (num_nodes_visited, next_const, consts, next_tag, non_consts) -> - let cstr_shape, _ = cstrs_and_jkinds.(idx) in + let cstr_shape, _ = cstrs_and_sorts.(idx) in let (is_mutable, num_nodes_visited), fields = for_one_constructor constructor ~depth ~num_nodes_visited ~cstr_shape diff --git a/typing/types.ml b/typing/types.ml index 4f4337d67f5..a745ae47150 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -311,7 +311,7 @@ and mixed_product_shape = and record_representation = | Record_unboxed | Record_inlined of tag * constructor_representation * variant_representation - | Record_boxed of (allowed * disallowed) jkind array + | Record_boxed of Jkind_types.Sort.Const.t array | Record_float | Record_ufloat | Record_mixed of mixed_product_shape @@ -322,7 +322,7 @@ and record_unboxed_product_representation = and variant_representation = | Variant_unboxed | Variant_boxed of (constructor_representation * - (allowed * disallowed) jkind array) array + Jkind_types.Sort.Const.t array) array | Variant_extensible and constructor_representation = @@ -335,7 +335,7 @@ and label_declaration = ld_mutable: mutability; ld_modalities: Mode.Modality.Value.Const.t; ld_type: type_expr; - ld_jkind : jkind_l; + ld_sort: Jkind_types.Sort.Const.t; ld_loc: Location.t; ld_attributes: Parsetree.attributes; ld_uid: Uid.t; @@ -355,7 +355,7 @@ and constructor_argument = { ca_modalities: Mode.Modality.Value.Const.t; ca_type: type_expr; - ca_jkind: jkind_l; + ca_sort: Jkind_types.Sort.Const.t; ca_loc: Location.t; } @@ -660,12 +660,13 @@ let equal_constructor_representation r1 r2 = r1 == r2 || match r1, r2 with let equal_variant_representation r1 r2 = r1 == r2 || match r1, r2 with | Variant_unboxed, Variant_unboxed -> true - | Variant_boxed cstrs_and_jkinds1, Variant_boxed cstrs_and_jkinds2 -> - Misc.Stdlib.Array.equal (fun (cstr1, jkinds1) (cstr2, jkinds2) -> + | Variant_boxed cstrs_and_sorts1, Variant_boxed cstrs_and_sorts2 -> + Misc.Stdlib.Array.equal (fun (cstr1, sorts1) (cstr2, sorts2) -> equal_constructor_representation cstr1 cstr2 - && Misc.Stdlib.Array.equal !jkind_equal jkinds1 jkinds2) - cstrs_and_jkinds1 - cstrs_and_jkinds2 + && Misc.Stdlib.Array.equal Jkind_types.Sort.Const.equal + sorts1 sorts2) + cstrs_and_sorts1 + cstrs_and_sorts2 | Variant_extensible, Variant_extensible -> true | (Variant_unboxed | Variant_boxed _ | Variant_extensible), _ -> @@ -680,8 +681,8 @@ let equal_record_representation r1 r2 = match r1, r2 with ignore (cr1 : constructor_representation); ignore (cr2 : constructor_representation); equal_tag tag1 tag2 && equal_variant_representation vr1 vr2 - | Record_boxed lays1, Record_boxed lays2 -> - Misc.Stdlib.Array.equal !jkind_equal lays1 lays2 + | Record_boxed sorts1, Record_boxed sorts2 -> + Misc.Stdlib.Array.equal Jkind_types.Sort.Const.equal sorts1 sorts2 | Record_float, Record_float -> true | Record_ufloat, Record_ufloat -> @@ -709,7 +710,7 @@ type 'a gen_label_description = lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutability; (* Is this a mutable field? *) lbl_modalities: Mode.Modality.Value.Const.t;(* Modalities on the field *) - lbl_jkind : jkind_l; (* Jkind of the argument *) + lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) lbl_pos: int; (* Position in block *) lbl_num: int; (* Position in type *) lbl_all: 'a gen_label_description array; (* All the labels in this type *) diff --git a/typing/types.mli b/typing/types.mli index 3ae4afb2ae5..c8613d7e262 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -603,7 +603,7 @@ and record_representation = (* For an inlined record, we record the representation of the variant that contains it and the tag/representation of the relevant constructor of that variant. *) - | Record_boxed of jkind_l array + | Record_boxed of Jkind_types.Sort.Const.t array | Record_float (* All fields are floats *) | Record_ufloat (* All fields are [float#]s. Same runtime representation as [Record_float], @@ -623,7 +623,7 @@ and record_unboxed_product_representation = and variant_representation = | Variant_unboxed | Variant_boxed of (constructor_representation * - jkind_l array) array + Jkind_types.Sort.Const.t array) array (* The outer array has an element for each constructor. Each inner array has a jkind for each argument of the corresponding constructor. @@ -650,7 +650,7 @@ and label_declaration = ld_mutable: mutability; ld_modalities: Mode.Modality.Value.Const.t; ld_type: type_expr; - ld_jkind : jkind_l; + ld_sort: Jkind_types.Sort.Const.t; ld_loc: Location.t; ld_attributes: Parsetree.attributes; ld_uid: Uid.t; @@ -670,7 +670,7 @@ and constructor_argument = { ca_modalities: Mode.Modality.Value.Const.t; ca_type: type_expr; - ca_jkind: jkind_l; + ca_sort: Jkind_types.Sort.Const.t; ca_loc: Location.t; } @@ -896,7 +896,7 @@ type 'a gen_label_description = lbl_mut: mutability; (* Is this a mutable field? *) lbl_modalities: Mode.Modality.Value.Const.t; (* Modalities on the field *) - lbl_jkind : jkind_l; (* Jkind of the argument *) + lbl_sort: Jkind_types.Sort.Const.t; (* Sort of the argument *) lbl_pos: int; (* Position in block *) lbl_num: int; (* Position in the type *) lbl_all: 'a gen_label_description array; (* All the labels in this type *) @@ -906,9 +906,6 @@ type 'a gen_label_description = lbl_attributes: Parsetree.attributes; lbl_uid: Uid.t; } -(* CR layouts v5: once we allow [any] in record fields, change [lbl_jkind] to - be a [sort option]. This will allow a fast path for representability checks - at record construction, and currently only the sort is used anyway. *) type label_description = record_representation gen_label_description