From c1241b315085c1c06f39fd0bb5aa24eb148d9c4e Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Thu, 24 Oct 2024 16:24:26 -0400 Subject: [PATCH 01/19] Basic unboxed records (rebased) --- chamelon/minimizer/flatteningmodules.ml | 6 + chamelon/minimizer/removedeadcode.ml | 13 + chamelon/minimizer/simplifytypes.ml | 43 + file_formats/cmt_format.ml | 70 +- lambda/matching.ml | 103 +- lambda/translcore.ml | 84 ++ .../parser/flambda_parser.new-messages | 653 ++++++----- ocamldoc/odoc_sig.ml | 3 + parsing/ast_helper.ml | 5 + parsing/ast_helper.mli | 5 + parsing/ast_iterator.ml | 12 +- parsing/ast_mapper.ml | 10 + parsing/depend.ml | 9 +- parsing/lexer.mll | 2 + parsing/parser.mly | 22 +- parsing/parsetree.mli | 18 + parsing/pprintast.ml | 67 +- parsing/printast.ml | 14 + printer/printast_with_mappings.ml | 14 + .../tests/parsetree/source_jane_street.ml | 12 + .../tool-toplevel/pr6468.compilers.reference | 40 + .../tests/typing-layouts-bits32/basics.ml | 4 +- .../typing-layouts-bits32/basics_alpha.ml | 2 +- .../tests/typing-layouts-bits64/basics.ml | 4 +- .../typing-layouts-bits64/basics_alpha.ml | 2 +- .../tests/typing-layouts-float32/basics.ml | 4 +- .../tests/typing-layouts-float64/basics.ml | 4 +- .../tests/typing-layouts-products/basics.ml | 4 +- .../typing-layouts-unboxed-records/basics.ml | 493 ++++++++ .../basics_alpha.ml | 125 ++ .../basics_from_typing_atat_unboxed.ml | 128 +++ .../basics_from_unboxed_tuples_tests.ml | 1019 +++++++++++++++++ .../disabled.ml | 39 + .../typing-layouts-unboxed-records/dlambda.ml | 128 +++ .../typing-layouts-unboxed-records/letrec.ml | 85 ++ ..._inline_unboxed_record.compilers.reference | 4 + .../parsing_inline_unboxed_record.ml | 11 + .../recursive.ml | 228 ++++ .../separability.ml | 58 + .../typing-warnings.ml | 827 +++++++++++++ .../typing_misc_unboxed_records.ml | 318 +++++ .../unboxed_records.ml | 104 ++ .../unboxed_records.reference | 7 + ...boxed_records_disabled.compilers.reference | 4 + ...unboxed_records_stable.compilers.reference | 4 + .../typing-layouts-unboxed-records/unique.ml | 92 ++ .../typing-layouts-unboxed-records/unused.ml | 140 +++ .../tests/typing-layouts-vec128/basics.ml | 4 +- .../typing-layouts-vec128/basics_alpha.ml | 4 +- testsuite/tests/typing-layouts-word/basics.ml | 4 +- .../tests/typing-layouts-word/basics_alpha.ml | 2 +- .../tests/typing-layouts/basics_alpha.ml | 11 +- toplevel/genprintval.ml | 49 +- typing/btype.ml | 5 +- typing/ctype.ml | 145 ++- typing/ctype.mli | 2 +- typing/datarepr.ml | 25 +- typing/datarepr.mli | 3 + typing/env.ml | 203 +++- typing/env.mli | 24 +- typing/includecore.ml | 120 +- typing/includecore.mli | 2 + typing/jkind.ml | 12 + typing/jkind_intf.ml | 4 +- typing/mtype.ml | 9 +- typing/oprint.ml | 10 + typing/outcometree.mli | 2 + typing/parmatch.ml | 49 +- typing/patterns.ml | 21 + typing/patterns.mli | 3 + typing/predef.mli | 2 +- typing/printpat.ml | 42 +- typing/printtyp.ml | 16 +- typing/printtyped.ml | 35 +- typing/shape.ml | 11 + typing/shape.mli | 5 + typing/subst.ml | 11 + typing/tast_iterator.ml | 12 + typing/tast_mapper.ml | 27 +- typing/typecore.ml | 766 ++++++++----- typing/typecore.mli | 9 +- typing/typedecl.ml | 87 +- typing/typedecl.mli | 1 + typing/typedecl_separability.ml | 41 +- typing/typedecl_variance.ml | 4 + typing/typedtree.ml | 22 + typing/typedtree.mli | 28 + typing/typemod.ml | 2 +- typing/typemod.mli | 1 + typing/typeopt.ml | 8 + typing/types.ml | 64 +- typing/types.mli | 33 +- typing/uniqueness_analysis.ml | 88 +- typing/untypeast.ml | 14 + typing/value_rec_check.ml | 27 + utils/warnings.ml | 41 +- utils/warnings.mli | 12 +- 97 files changed, 6199 insertions(+), 966 deletions(-) create mode 100644 testsuite/tests/typing-layouts-unboxed-records/basics.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/disabled.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/dlambda.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/letrec.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference create mode 100644 testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/recursive.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/separability.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference create mode 100644 testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference create mode 100644 testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference create mode 100644 testsuite/tests/typing-layouts-unboxed-records/unique.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/unused.ml diff --git a/chamelon/minimizer/flatteningmodules.ml b/chamelon/minimizer/flatteningmodules.ml index 7500805f0e5..2b8e698b5e8 100644 --- a/chamelon/minimizer/flatteningmodules.ml +++ b/chamelon/minimizer/flatteningmodules.ml @@ -102,6 +102,12 @@ let rec replace_in_pat : type k. _ -> k general_pattern -> k general_pattern = (fun (e1, e2, pat) -> (e1, e2, replace_in_pat mod_name pat)) r, a1 ) + | O (Tpat_record_unboxed_product (r, a1)) -> + Tpat_record_unboxed_product + ( List.map + (fun (e1, e2, pat) -> (e1, e2, replace_in_pat mod_name pat)) + r, + a1 ) | O (Tpat_or (p1, p2, a1)) -> Tpat_or (replace_in_pat mod_name p1, replace_in_pat mod_name p2, a1) | O (Tpat_lazy pat) -> Tpat_lazy (replace_in_pat mod_name pat) diff --git a/chamelon/minimizer/removedeadcode.ml b/chamelon/minimizer/removedeadcode.ml index 676f4c0c6d4..1a81f504087 100644 --- a/chamelon/minimizer/removedeadcode.ml +++ b/chamelon/minimizer/removedeadcode.ml @@ -85,6 +85,8 @@ let rec var_from_pat pat_desc acc = (List.map (fun (_, pat, _) -> pat) fields) | O (Tpat_record (r, _)) -> List.fold_left (fun l (_, _, pat) -> var_from_pat pat.pat_desc l) acc r + | O (Tpat_record_unboxed_product (r, _)) -> + List.fold_left (fun l (_, _, pat) -> var_from_pat pat.pat_desc l) acc r | O (Tpat_or (p1, p2, _)) -> var_from_pat p1.pat_desc (var_from_pat p2.pat_desc acc) | O (Tpat_lazy pat) -> var_from_pat pat.pat_desc acc @@ -150,6 +152,17 @@ let rec rem_in_pat str pat should_remove = r, a1 ); } + | O (Tpat_record_unboxed_product (r, a1)) -> + { + pat with + pat_desc = + Tpat_record_unboxed_product + ( List.map + (fun (e1, e2, pat) -> + (e1, e2, rem_in_pat str pat should_remove)) + r, + a1 ); + } | O (Tpat_or (p1, p2, a1)) -> let p1 = rem_in_pat str p1 should_remove in let p2 = rem_in_pat str p2 should_remove in diff --git a/chamelon/minimizer/simplifytypes.ml b/chamelon/minimizer/simplifytypes.ml index 59513746dd3..35ef9b9ac87 100644 --- a/chamelon/minimizer/simplifytypes.ml +++ b/chamelon/minimizer/simplifytypes.ml @@ -80,6 +80,27 @@ let remove_cons_mapper (cons_to_rem, cons_typ) = }; } :: l + | Tpat_record_unboxed_product (lab_list, flag) + -> + let nlab_list = + List.filter + (fun (_, ld, _) -> + ld.lbl_name = cons_to_rem) + lab_list + in + if nlab_list = [] then l + else + { + val_case with + c_lhs = + { + val_case.c_lhs with + pat_desc = + Tpat_record_unboxed_product + (nlab_list, flag); + }; + } + :: l | _ -> Tast_mapper.default.case mapper val_case :: l) @@ -127,6 +148,28 @@ let remove_cons_mapper (cons_to_rem, cons_typ) = }; } :: l + | Tpat_record_unboxed_product (lab_list, flag) + -> + let nlab_list = + List.filter + (fun (_, ld, _) -> + ld.lbl_name = cons_to_rem) + lab_list + in + if nlab_list = [] then l + else + { + comp_case with + c_lhs = + as_computation_pattern + { + comp_case.c_lhs with + pat_desc = + Tpat_record_unboxed_product + (nlab_list, flag); + }; + } + :: l | _ -> Tast_mapper.default.case mapper comp_case :: l) diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml index 3e220fa7ab0..b1db2dfd632 100644 --- a/file_formats/cmt_format.ml +++ b/file_formats/cmt_format.ml @@ -167,9 +167,38 @@ let iter_on_occurrences let path = path_in_type cstr_res cstr_name in Option.iter (fun path -> f ~namespace:Constructor env path lid) path in - let add_label env lid { Types.lbl_name; lbl_res; _ } = + let add_label ~namespace env lid { Types.lbl_name; lbl_res; _ } = let path = path_in_type lbl_res lbl_name in - Option.iter (fun path -> f ~namespace:Label env path lid) path + Option.iter (fun path -> f ~namespace env path lid) path + in + let iter_field_exps ~namespace exp_env fields = + Array.iter (fun (label_descr, record_label_definition) -> + match record_label_definition with + | Overridden ({ Location.txt; loc}, {exp_loc; _}) + when not exp_loc.loc_ghost + && loc.loc_start = exp_loc.loc_start + && loc.loc_end = exp_loc.loc_end -> + (* In the presence of punning we want to index the label + even if it is ghosted *) + let lid = { Location.txt; loc = {loc with loc_ghost = false} } in + add_label ~namespace exp_env lid label_descr + | Overridden (lid, _) -> add_label ~namespace exp_env lid label_descr + | Kept _ -> ()) fields + in + let iter_field_pats ~namespace pat_env fields = + List.iter (fun (lid, label_descr, pat) -> + let lid = + let open Location in + (* In the presence of punning we want to index the label + even if it is ghosted *) + if (not pat.pat_loc.loc_ghost + && lid.loc.loc_start = pat.pat_loc.loc_start + && lid.loc.loc_end = pat.pat_loc.loc_end) + then {lid with loc = {lid.loc with loc_ghost = false}} + else lid + in + add_label ~namespace pat_env lid label_descr) + fields in let with_constraint ~env (_path, _lid, with_constraint) = match with_constraint with @@ -187,24 +216,15 @@ let iter_on_occurrences add_constructor_description exp_env lid constr_desc | Texp_field (_, lid, label_desc, _, _) | Texp_setfield (_, _, lid, label_desc, _) -> - add_label exp_env lid label_desc + add_label ~namespace:Label exp_env lid label_desc + | Texp_unboxed_field (_, lid, label_desc, _) -> + add_label ~namespace:Unboxed_label exp_env lid label_desc | Texp_new (path, lid, _, _) -> f ~namespace:Class exp_env path lid | Texp_record { fields; _ } -> - Array.iter (fun (label_descr, record_label_definition) -> - match record_label_definition with - | Overridden ( - { Location.txt; loc}, - {exp_loc; _}) - when not exp_loc.loc_ghost - && loc.loc_start = exp_loc.loc_start - && loc.loc_end = exp_loc.loc_end -> - (* In the presence of punning we want to index the label - even if it is ghosted *) - let lid = { Location.txt; loc = {loc with loc_ghost = false} } in - add_label exp_env lid label_descr - | Overridden (lid, _) -> add_label exp_env lid label_descr - | Kept _ -> ()) fields + iter_field_exps ~namespace:Label exp_env fields + | Texp_record_unboxed_product { fields ; _ } -> + iter_field_exps ~namespace:Unboxed_label exp_env fields | Texp_instvar (_self_path, path, name) -> let lid = { name with txt = Longident.Lident name.txt } in f ~namespace:Value exp_env path lid @@ -257,19 +277,9 @@ let iter_on_occurrences | Tpat_construct (lid, constr_desc, _, _) -> add_constructor_description pat_env lid constr_desc | Tpat_record (fields, _) -> - List.iter (fun (lid, label_descr, pat) -> - let lid = - let open Location in - (* In the presence of punning we want to index the label - even if it is ghosted *) - if (not pat.pat_loc.loc_ghost - && lid.loc.loc_start = pat.pat_loc.loc_start - && lid.loc.loc_end = pat.pat_loc.loc_end) - then {lid with loc = {lid.loc with loc_ghost = false}} - else lid - in - add_label pat_env lid label_descr) - fields + iter_field_pats ~namespace:Label pat_env fields + | Tpat_record_unboxed_product (fields, _) -> + iter_field_pats ~namespace:Unboxed_label pat_env fields | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ | Tpat_unboxed_tuple _ | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ diff --git a/lambda/matching.ml b/lambda/matching.ml index 6645a1e0dc3..8223e03f31e 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -174,6 +174,14 @@ let expand_record_head h = { h with pat_desc = Record (Array.to_list lbl_all) } | _ -> h +let expand_record_unboxed_product_head h = + let open Patterns.Head in + match h.pat_desc with + | Record_unboxed_product [] -> fatal_error "Matching.expand_record_unboxed_product_head" + | Record_unboxed_product ({ lbl_all } :: _) -> + { h with pat_desc = Record_unboxed_product (Array.to_list lbl_all) } + | _ -> h + let bind_alias p id ~arg ~arg_sort ~action = let k = Typeopt.layout p.pat_env p.pat_loc arg_sort p.pat_type in bind_with_layout Alias (id, k) arg action @@ -243,6 +251,9 @@ end = struct | Tpat_record (lbls, closed) -> let all_lbls = all_record_args lbls in { p with pat_desc = Tpat_record (all_lbls, closed) } + | Tpat_record_unboxed_product (lbls, closed) -> + let all_lbls = all_record_args lbls in + { p with pat_desc = Tpat_record_unboxed_product (all_lbls, closed) } | _ -> p (* Explode or-patterns and turn aliases into bindings in actions *) @@ -266,6 +277,10 @@ end = struct | `Record (lbls, closed) -> let full_view = `Record (all_record_args lbls, closed) in stop p full_view + | `Record_unboxed_product ([], _) as view -> stop p view + | `Record_unboxed_product (lbls, closed) -> + let full_view = `Record_unboxed_product (all_record_args lbls, closed) in + stop p full_view | `Or _ -> ( let orpat = General.view (simpl_under_orpat (General.erase p)) in match orpat.pat_desc with @@ -320,6 +335,9 @@ end = struct | `Record (fields, closed) -> let alpha_field env (lid, l, p) = (lid, l, alpha_pat env p) in `Record (List.map (alpha_field env) fields, closed) + | `Record_unboxed_product (fields, closed) -> + let alpha_field env (lid, l, p) = (lid, l, alpha_pat env p) in + `Record_unboxed_product (List.map (alpha_field env) fields, closed) | `Array (am, arg_sort, ps) -> `Array (am, arg_sort, List.map (alpha_pat env) ps) | `Lazy p -> `Lazy (alpha_pat env p) in @@ -416,6 +434,13 @@ let expand_record_simple : Simple.pattern -> Simple.pattern = | `Record (l, _) -> { p with pat_desc = `Record (all_record_args l, Closed) } | _ -> p +let expand_record_unboxed_product_simple : Simple.pattern -> Simple.pattern = + fun p -> + match p.pat_desc with + | `Record_unboxed_product (l, _) -> + { p with pat_desc = `Record_unboxed_product (all_record_args l, Closed) } + | _ -> p + type initial_clause = pattern list clause type matrix = pattern list list @@ -436,7 +461,9 @@ exception NoMatch let matcher discr (p : Simple.pattern) rem = let discr = expand_record_head discr in + let discr = expand_record_unboxed_product_head discr in let p = expand_record_simple p in + let p = expand_record_unboxed_product_simple p in let omegas = Patterns.(omegas (Head.arity discr)) in let ph, args = Patterns.Head.deconstruct p in let yes () = args @ rem in @@ -451,7 +478,7 @@ let matcher discr (p : Simple.pattern) rem = match (discr.pat_desc, ph.pat_desc) with | Any, _ -> rem | ( ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _ - | Tuple _ | Unboxed_tuple _ ), + | Record_unboxed_product _ | Tuple _ | Unboxed_tuple _ ), Any ) -> omegas @ rem | Constant cst, Constant cst' -> yesif (const_compare cst cst' = 0) @@ -469,9 +496,12 @@ let matcher discr (p : Simple.pattern) rem = | Record l, Record l' -> (* we already expanded the record fully *) yesif (List.length l = List.length l') + | Record_unboxed_product l, Record_unboxed_product l' -> + (* we already expanded the record fully *) + yesif (List.length l = List.length l') | Lazy, Lazy -> yes () - | ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _ | Tuple _ - | Unboxed_tuple _), _ + | ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _ + | Record_unboxed_product _ | Tuple _ | Unboxed_tuple _), _ -> no () @@ -1247,6 +1277,7 @@ let can_group discr pat = | Tuple _, (Tuple _ | Any) | Unboxed_tuple _, (Unboxed_tuple _ | Any) | Record _, (Record _ | Any) + | Record_unboxed_product _, (Record_unboxed_product _ | Any) | Array _, Array _ | Variant _, Variant _ | Lazy, Lazy -> @@ -1259,8 +1290,8 @@ let can_group discr pat = | Const_int32 _ | Const_int64 _ | Const_nativeint _ | Const_unboxed_int32 _ | Const_unboxed_int64 _ | Const_unboxed_nativeint _ ) - | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ | Array _ - | Variant _ | Lazy ) ) -> + | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ | Record_unboxed_product _ + | Array _ | Variant _ | Lazy ) ) -> false let is_or p = @@ -2274,6 +2305,13 @@ let get_pat_args_record num_fields p rem = record_matching_line num_fields lbl_pat_list @ rem | _ -> assert false +let get_pat_args_record_unboxed_product num_fields p rem = + match p with + | { pat_desc = Tpat_any } -> record_matching_line num_fields [] @ rem + | { pat_desc = Tpat_record_unboxed_product (lbl_pat_list, _) } -> + record_matching_line num_fields lbl_pat_list @ rem + | _ -> assert false + let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = let loc = head_loc ~scopes head in let all_labels = @@ -2353,6 +2391,37 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = in make_args 0 +let get_expr_args_record_unboxed_product ~scopes head (arg, _mut, _sort, _layout) rem = + let loc = head_loc ~scopes head in + let all_labels = + let open Patterns.Head in + match head.pat_desc with + | Record_unboxed_product ({ lbl_all ; lbl_repres = Record_unboxed_product} :: _) -> + lbl_all + | _ -> + assert false + in + let rec make_args pos = + if pos >= Array.length all_labels then + rem + else + let lbl = all_labels.(pos) in + jkind_layout_default_to_value_and_check_not_void head.pat_loc lbl.lbl_jkind; + let lbl_layouts = Array.map (fun lbl -> + Typeopt.layout_of_sort lbl.lbl_loc (Jkind.sort_of_jkind lbl.lbl_jkind) + ) lbl.lbl_all |> Array.to_list in + let access = if Array.length all_labels = 1 then + arg (* erase singleton unboxed records before lambda *) + else + Lprim (Punboxed_product_field (pos, lbl_layouts), [ arg ], loc) + in + let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in + let sort = Jkind.sort_of_jkind lbl.lbl_jkind in + let layout = Typeopt.layout_of_sort lbl.lbl_loc sort in + (access, str, sort, layout) :: make_args (pos + 1) + in + make_args 0 + let divide_record all_labels ~scopes head ctx pm = (* There is some redundancy in the expansions here, [head] is expanded here and again in the matcher. It would be @@ -2365,6 +2434,13 @@ let divide_record all_labels ~scopes head ctx pm = (get_pat_args_record (Array.length all_labels)) head ctx pm +let divide_record_unboxed_product all_labels ~scopes head ctx pm = + let head = expand_record_unboxed_product_head head in + divide_line (Context.specialize head) + (get_expr_args_record_unboxed_product ~scopes) + (get_pat_args_record_unboxed_product (Array.length all_labels)) + head ctx pm + (* Matching against an array pattern *) let get_key_array = function @@ -3764,11 +3840,15 @@ and do_compile_matching ~scopes value_kind repr partial ctx pmh = compile_no_test ~scopes value_kind (divide_unboxed_tuple ~scopes ph shape) Context.combine repr partial ctx pm - | Record [] -> assert false + | Record [] | Record_unboxed_product [] -> assert false | Record (lbl :: _) -> compile_no_test ~scopes value_kind (divide_record ~scopes lbl.lbl_all ph) Context.combine repr partial ctx pm + | Record_unboxed_product (lbl :: _) -> + compile_no_test ~scopes value_kind + (divide_record_unboxed_product ~scopes lbl.lbl_all ph) + Context.combine repr partial ctx pm | Constant (Const_float32 _ | Const_unboxed_float32 _) -> Parmatch.raise_matched_float32 () | Constant cst -> @@ -3844,6 +3924,7 @@ let is_lazy_pat p = | Tpat_alias _ | Tpat_variant _ | Tpat_record _ + | Tpat_record_unboxed_product _ | Tpat_tuple _ | Tpat_unboxed_tuple _ | Tpat_construct _ @@ -3857,11 +3938,12 @@ let is_lazy_pat p = let has_lazy p = Typedtree.exists_pattern is_lazy_pat p let is_record_with_mutable_field p = + let fields_have_mutable_type lps = + List.exists (fun (_, lbl, _) -> Types.is_mutable lbl.lbl_mut) lps + in match p.pat_desc with - | Tpat_record (lps, _) -> - List.exists - (fun (_, lbl, _) -> Types.is_mutable lbl.lbl_mut) - lps + | Tpat_record (lps, _) -> fields_have_mutable_type lps + | Tpat_record_unboxed_product (lps, _) -> fields_have_mutable_type lps | Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ @@ -4220,6 +4302,7 @@ let flatten_simple_pattern size (p : Simple.pattern) = | `Array _ | `Variant _ | `Record _ + | `Record_unboxed_product _ | `Lazy _ | `Construct _ | `Constant _ diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 5d5c9abff3e..902668d671a 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -386,6 +386,23 @@ let zero_alloc_of_application end | None, _ -> Zero_alloc_utils.Assume_info.none +(* CR layouts v5: [Punboxed_product_field] does not use special indexing for void, whereas + [lbl.lbl_pos] does, so we need to find the "normal" index. This function should be + removed, and we should just use [lbl.lbl_pos], once we remove [lbl_pos_void]. + + Asserts that this lbl is not void. *) +let lbl_idx lbl = + (* Reimplementation of OCaml 5's [Array.find_index] *) + let find_index f array = + let i = ref 0 in + while !i < (Array.length array) && not (f (Array.get array !i)) do + incr i + done; + if !i == Array.length array then None else Some !i + in + assert (lbl.lbl_pos <> lbl_pos_void); + find_index (fun { lbl_pos } -> lbl_pos = lbl.lbl_pos ) lbl.lbl_all |> Option.get + let rec transl_exp ~scopes sort e = transl_exp1 ~scopes ~in_new_scope:false sort e @@ -631,6 +648,9 @@ and transl_exp0 ~in_new_scope ~scopes sort e = transl_record ~scopes e.exp_loc e.exp_env (Option.map transl_alloc_mode alloc_mode) fields representation extended_expression + | Texp_record_unboxed_product {fields; representation; extended_expression } -> + transl_record_unboxed_product ~scopes e.exp_loc e.exp_env + fields representation extended_expression | Texp_field(arg, id, lbl, float, ubr) -> let targ = transl_exp ~scopes Jkind.Sort.for_record arg in let sem = @@ -693,6 +713,25 @@ and transl_exp0 ~in_new_scope ~scopes sort e = Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [targ], of_location ~scopes e.exp_loc) end + | Texp_unboxed_field(arg, _id, lbl, _) -> + begin match lbl.lbl_repres with + | Record_unboxed_product -> + let layouts, jkinds = + Array.map (fun lbl -> + layout e.exp_env lbl.lbl_loc (Jkind.sort_of_jkind lbl.lbl_jkind) lbl.lbl_arg, + lbl.lbl_jkind + ) lbl.lbl_all + |> Array.to_list |> List.split + in + let arg_jkind = Jkind.Builtin.product ~why:Unboxed_record jkinds in + let targ = transl_exp ~scopes (Jkind.sort_of_jkind arg_jkind) arg in + if Array.length lbl.lbl_all == 1 then + (* erase singleton unboxed records before lambda *) + targ + else + Lprim (Punboxed_product_field (lbl_idx lbl, layouts), [targ], + of_location ~scopes e.exp_loc) + end | Texp_setfield(arg, arg_mode, id, lbl, newval) -> (* CR layouts v2.5: When we allow `any` in record fields and check representability on construction, [sort_of_jkind] will be unsafe here. @@ -2056,6 +2095,51 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = transl_exp ~scopes Jkind.Sort.for_record init_expr, lam) end +and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = + match repres with + | Record_unboxed_product -> + let init_id = Ident.create_local "init" in + let shape = + Array.map + (fun (lbl, definition) -> + let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in + match definition with + | Kept (typ, _mut, _) -> layout env lbl.lbl_loc lbl_sort typ + | Overridden (_lid, expr) -> layout_exp lbl_sort expr) + fields + |> Array.to_list + in + let ll = + Array.mapi + (fun i (lbl, definition) -> + match definition with + | Kept (_typ, _mut, _) -> + 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 + transl_exp ~scopes lbl_sort expr) + fields + |> Array.to_list + in + begin match ll with + | [l] -> l (* erase singleton unboxed records before lambda *) + | _ -> + let lam = Lprim(Pmake_unboxed_product shape, ll, of_location ~scopes loc) in + begin match opt_init_expr with + | None -> lam + | Some init_expr -> + (* CR layouts v11: if a functional update can change the kind, then + the resulting kind may be different than [init_expr_jkind] *) + let init_expr_jkind = + Jkind.Builtin.product ~why:Unboxed_record + (Array.map (fun (lbl,_) -> lbl.lbl_jkind) fields |> Array.to_list) in + let init_expr_sort = Jkind.sort_of_jkind init_expr_jkind in + let layout = layout_exp init_expr_sort init_expr in + Llet(Strict, layout, init_id, transl_exp ~scopes init_expr_sort init_expr, lam) + end + end + and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = let return_layout = layout_exp return_sort e in let rewrite_case (val_cases, exn_cases, static_handlers as acc) diff --git a/middle_end/flambda2/parser/flambda_parser.new-messages b/middle_end/flambda2/parser/flambda_parser.new-messages index c4034c79c6b..636c4ba34ed 100644 --- a/middle_end/flambda2/parser/flambda_parser.new-messages +++ b/middle_end/flambda2/parser/flambda_parser.new-messages @@ -459,11 +459,11 @@ expect_test_spec: KWD_LET SYMBOL EQUAL KWD_CLOSURE IDENT AT IDENT TILDEMINUS -expect_test_spec: KWD_APPLY AMP TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_FLOAT AMP TILDEMINUS ## ## Ends in an error in state: 84. ## -## alloc_mode_for_allocations_opt -> AMP . region [ SYMBOL RPAREN LPAREN KWD_WITH KWD_UNROLL KWD_INLINING_STATE KWD_INLINED KWD_IN KWD_END KWD_AND INT IDENT FLOAT ] +## alloc_mode_for_allocations_opt -> AMP . region [ SYMBOL LPAREN KWD_WITH KWD_IN KWD_END KWD_AND INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## AMP @@ -505,7 +505,7 @@ expect_test_spec: KWD_LET KWD_SET_OF_CLOSURES SYMBOL EQUAL KWD_CLOSURE IDENT KWD -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH TILDEMINUS ## ## Ends in an error in state: 94. ## @@ -517,7 +517,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE TILDEMINUS ## ## Ends in an error in state: 95. ## @@ -529,7 +529,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE TILDEMIN -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT TILDEMINUS ## ## Ends in an error in state: 97. ## @@ -541,7 +541,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT TI -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQUAL TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT EQUAL TILDEMINUS ## ## Ends in an error in state: 98. ## @@ -553,7 +553,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQ -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT TILDEMINUS ## ## Ends in an error in state: 99. ## @@ -566,7 +566,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQ -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT SEMICOLON TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT SEMICOLON TILDEMINUS ## ## Ends in an error in state: 101. ## @@ -1329,7 +1329,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_INT_ARITH FLOAT KWD_LAND FLOAT TILDEM expect_test_spec: KWD_LET IDENT EQUAL PRIM_BYTES_LOAD TILDEMINUS ## -## Ends in an error in state: 239. +## Ends in an error in state: 241. ## ## prefix_binop -> PRIM_BYTES_LOAD . string_accessor_width [ LPAREN ] ## @@ -1341,7 +1341,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BYTES_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_NATIVEINT TILDEMINUS ## -## Ends in an error in state: 242. +## Ends in an error in state: 244. ## ## unop -> PRIM_BOX_NATIVEINT . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1353,7 +1353,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_NATIVEINT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT64 TILDEMINUS ## -## Ends in an error in state: 244. +## Ends in an error in state: 246. ## ## unop -> PRIM_BOX_INT64 . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1365,7 +1365,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT64 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT32 TILDEMINUS ## -## Ends in an error in state: 246. +## Ends in an error in state: 248. ## ## unop -> PRIM_BOX_INT32 . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1377,7 +1377,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT32 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_FLOAT TILDEMINUS ## -## Ends in an error in state: 248. +## Ends in an error in state: 250. ## ## unop -> PRIM_BOX_FLOAT . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1389,9 +1389,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET TILDEMINUS ## -## Ends in an error in state: 251. +## Ends in an error in state: 253. ## -## ternop_app -> PRIM_BLOCK_SET . block_access_kind simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET . block_access_kind simple DOT LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET @@ -1401,7 +1401,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 253. +## Ends in an error in state: 255. ## ## block_access_kind -> KWD_FLOAT . size_opt [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1413,7 +1413,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE TILDEMINUS ## -## Ends in an error in state: 254. +## Ends in an error in state: 256. ## ## size_opt -> KWD_SIZE . LPAREN targetint RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1425,7 +1425,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN TILDEMINUS ## -## Ends in an error in state: 255. +## Ends in an error in state: 257. ## ## size_opt -> KWD_SIZE LPAREN . targetint RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1437,7 +1437,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN INT TILDEMINUS ## -## Ends in an error in state: 257. +## Ends in an error in state: 259. ## ## size_opt -> KWD_SIZE LPAREN targetint . RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1449,9 +1449,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN INT TILDEMI expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM LPAREN ## -## Ends in an error in state: 260. +## Ends in an error in state: 262. ## -## ternop_app -> PRIM_BLOCK_SET block_access_kind . simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET block_access_kind . simple DOT LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind @@ -1460,19 +1460,19 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM LPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 271, spurious reduction of production tag_opt -> -## In state 276, spurious reduction of production size_opt -> -## In state 277, spurious reduction of production block_access_kind -> block_access_field_kind tag_opt size_opt +## In state 273, spurious reduction of production tag_opt -> +## In state 278, spurious reduction of production size_opt -> +## In state 279, spurious reduction of production block_access_kind -> block_access_field_kind tag_opt size_opt ## expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT TILDEMINUS ## -## Ends in an error in state: 261. +## Ends in an error in state: 263. ## +## binop_app -> PRIM_BLOCK_SET block_access_kind simple . DOT LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE DOT ] -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple . DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind simple @@ -1482,9 +1482,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 262. +## Ends in an error in state: 264. ## -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT . LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT . LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind simple DOT @@ -1494,9 +1494,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 263. +## Ends in an error in state: 265. ## -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN . simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN . tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN @@ -1504,34 +1504,33 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT TILDEMINUS ## -## Ends in an error in state: 264. +## Ends in an error in state: 266. ## -## simple -> simple . TILDE coercion [ TILDE RPAREN ] -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple . RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag . RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag ## -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN TILDEMINUS ## -## Ends in an error in state: 265. +## Ends in an error in state: 267. ## -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN . init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN . init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN ## -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN LESSMINUS TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN LESSMINUS TILDEMINUS ## -## Ends in an error in state: 266. +## Ends in an error in state: 268. ## ## init_or_assign -> LESSMINUS . [ SYMBOL INT IDENT FLOAT ] ## init_or_assign -> LESSMINUS . AMP [ SYMBOL INT IDENT FLOAT ] @@ -1542,34 +1541,34 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAR -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN EQUAL TILDEMINUS ## -## Ends in an error in state: 269. +## Ends in an error in state: 271. ## -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign . simple [ KWD_WITH KWD_IN KWD_AND ] +## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign . simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign ## -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN EQUAL FLOAT TILDEMINUS ## -## Ends in an error in state: 270. +## Ends in an error in state: 272. ## +## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign simple . [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] -## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign simple . [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign simple +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign simple ## expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM TILDEMINUS ## -## Ends in an error in state: 271. +## Ends in an error in state: 273. ## ## block_access_kind -> block_access_field_kind . tag_opt size_opt [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1581,7 +1580,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG TILDEMINUS ## -## Ends in an error in state: 272. +## Ends in an error in state: 274. ## ## tag_opt -> KWD_TAG . LPAREN tag RPAREN [ SYMBOL LPAREN KWD_SIZE INT IDENT FLOAT ] ## @@ -1593,7 +1592,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN TILDEMINUS ## -## Ends in an error in state: 273. +## Ends in an error in state: 275. ## ## tag_opt -> KWD_TAG LPAREN . tag RPAREN [ SYMBOL LPAREN KWD_SIZE INT IDENT FLOAT ] ## @@ -1605,7 +1604,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT TILDEMINUS ## -## Ends in an error in state: 274. +## Ends in an error in state: 276. ## ## tag_opt -> KWD_TAG LPAREN tag . RPAREN [ SYMBOL LPAREN KWD_SIZE INT IDENT FLOAT ] ## @@ -1617,7 +1616,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT TILDEMIN expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT RPAREN TILDEMINUS ## -## Ends in an error in state: 276. +## Ends in an error in state: 278. ## ## block_access_kind -> block_access_field_kind tag_opt . size_opt [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1629,9 +1628,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT RPAREN T expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD TILDEMINUS ## -## Ends in an error in state: 278. +## Ends in an error in state: 280. ## -## prefix_binop -> PRIM_BLOCK_LOAD . mutability block_access_kind [ LPAREN ] +## unop -> PRIM_BLOCK_LOAD . mutability block_access_kind LPAREN tag RPAREN [ SYMBOL INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_LOAD @@ -1641,9 +1640,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 281. +## Ends in an error in state: 283. ## -## prefix_binop -> PRIM_BLOCK_LOAD mutability . block_access_kind [ LPAREN ] +## unop -> PRIM_BLOCK_LOAD mutability . block_access_kind LPAREN tag RPAREN [ SYMBOL INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_LOAD mutability @@ -1651,9 +1650,53 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD KWD_IMMUTABLE_UNIQUE TILDE +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD KWD_IMM SYMBOL +## +## Ends in an error in state: 284. +## +## unop -> PRIM_BLOCK_LOAD mutability block_access_kind . LPAREN tag RPAREN [ SYMBOL INT IDENT FLOAT ] +## +## The known suffix of the stack is as follows: +## PRIM_BLOCK_LOAD mutability block_access_kind +## +## WARNING: This example involves spurious reductions. +## This implies that, although the LR(1) items shown above provide an +## accurate view of the past (what has been recognized so far), they +## may provide an INCOMPLETE view of the future (what was expected next). +## In state 273, spurious reduction of production tag_opt -> +## In state 278, spurious reduction of production size_opt -> +## In state 279, spurious reduction of production block_access_kind -> block_access_field_kind tag_opt size_opt +## + + + +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN TILDEMINUS +## +## Ends in an error in state: 285. +## +## unop -> PRIM_BLOCK_LOAD mutability block_access_kind LPAREN . tag RPAREN [ SYMBOL INT IDENT FLOAT ] +## +## The known suffix of the stack is as follows: +## PRIM_BLOCK_LOAD mutability block_access_kind LPAREN +## + + + +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN INT TILDEMINUS +## +## Ends in an error in state: 286. +## +## unop -> PRIM_BLOCK_LOAD mutability block_access_kind LPAREN tag . RPAREN [ SYMBOL INT IDENT FLOAT ] +## +## The known suffix of the stack is as follows: +## PRIM_BLOCK_LOAD mutability block_access_kind LPAREN tag +## + + + expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK TILDEMINUS ## -## Ends in an error in state: 283. +## Ends in an error in state: 288. ## ## block -> PRIM_BLOCK . mutability tag alloc_mode_for_allocations_opt LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1665,7 +1708,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 284. +## Ends in an error in state: 289. ## ## block -> PRIM_BLOCK mutability . tag alloc_mode_for_allocations_opt LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1677,7 +1720,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK KWD_IMMUTABLE_UNIQUE TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT TILDEMINUS ## -## Ends in an error in state: 285. +## Ends in an error in state: 290. ## ## block -> PRIM_BLOCK mutability tag . alloc_mode_for_allocations_opt LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1689,7 +1732,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT AMP IDENT TILDEMINUS ## -## Ends in an error in state: 286. +## Ends in an error in state: 291. ## ## block -> PRIM_BLOCK mutability tag alloc_mode_for_allocations_opt . LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1701,7 +1744,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT AMP IDENT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT LPAREN TILDEMINUS ## -## Ends in an error in state: 287. +## Ends in an error in state: 292. ## ## block -> PRIM_BLOCK mutability tag alloc_mode_for_allocations_opt LPAREN . loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1713,7 +1756,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_LOAD TILDEMINUS ## -## Ends in an error in state: 292. +## Ends in an error in state: 297. ## ## prefix_binop -> PRIM_BIGSTRING_LOAD . string_accessor_width [ LPAREN ] ## @@ -1725,7 +1768,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET TILDEMINUS ## -## Ends in an error in state: 296. +## Ends in an error in state: 303. ## ## ternop_app -> PRIM_ARRAY_SET . array_kind array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1737,7 +1780,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 299. +## Ends in an error in state: 306. ## ## ternop_app -> PRIM_ARRAY_SET array_kind . array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1749,7 +1792,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_VEC128 TILDEMINUS ## -## Ends in an error in state: 301. +## Ends in an error in state: 308. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width . simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1761,7 +1804,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_VEC128 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT TILDEMINUS ## -## Ends in an error in state: 302. +## Ends in an error in state: 309. ## ## simple -> simple . TILDE coercion [ TILDE DOT ] ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple . DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] @@ -1774,7 +1817,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 303. +## Ends in an error in state: 310. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT . LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1786,7 +1829,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 304. +## Ends in an error in state: 311. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN . simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1798,7 +1841,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 305. +## Ends in an error in state: 312. ## ## simple -> simple . TILDE coercion [ TILDE RPAREN ] ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple . RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] @@ -1811,7 +1854,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT TILD expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 306. +## Ends in an error in state: 313. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple RPAREN . init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1823,7 +1866,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAR expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL TILDEMINUS ## -## Ends in an error in state: 307. +## Ends in an error in state: 314. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1835,7 +1878,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAR expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL FLOAT TILDEMINUS ## -## Ends in an error in state: 308. +## Ends in an error in state: 315. ## ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign simple . [ KWD_WITH KWD_IN KWD_AND ] @@ -1848,7 +1891,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAR expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD TILDEMINUS ## -## Ends in an error in state: 309. +## Ends in an error in state: 316. ## ## binop_app -> PRIM_ARRAY_LOAD . array_kind mutability array_accessor_width simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1860,7 +1903,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 310. +## Ends in an error in state: 317. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind . mutability array_accessor_width simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1872,7 +1915,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 311. +## Ends in an error in state: 318. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability . array_accessor_width simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1884,7 +1927,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_IMMUTABLE_UNIQUE TILDE expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_VEC128 TILDEMINUS ## -## Ends in an error in state: 312. +## Ends in an error in state: 319. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width . simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1896,7 +1939,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_VEC128 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT TILDEMINUS ## -## Ends in an error in state: 313. +## Ends in an error in state: 320. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple . DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE DOT ] @@ -1909,7 +1952,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 314. +## Ends in an error in state: 321. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple DOT . LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1921,7 +1964,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 315. +## Ends in an error in state: 322. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple DOT LPAREN . simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1933,7 +1976,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN TILDEMINU expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 316. +## Ends in an error in state: 323. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple DOT LPAREN simple . RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE RPAREN ] @@ -1946,7 +1989,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN FLOAT TIL expect_test_spec: KWD_LET IDENT EQUAL KWD_REC_INFO TILDEMINUS ## -## Ends in an error in state: 319. +## Ends in an error in state: 326. ## ## named -> KWD_REC_INFO . rec_info_atom [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1958,7 +2001,7 @@ expect_test_spec: KWD_LET IDENT EQUAL KWD_REC_INFO TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH TILDEMINUS ## -## Ends in an error in state: 321. +## Ends in an error in state: 328. ## ## named -> unop . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1970,7 +2013,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH FLOAT TILDEMINUS ## -## Ends in an error in state: 322. +## Ends in an error in state: 329. ## ## named -> unop simple . [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] @@ -1983,7 +2026,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL FLOAT TILDEMINUS ## -## Ends in an error in state: 324. +## Ends in an error in state: 331. ## ## binop_app -> simple . infix_binop simple [ KWD_WITH KWD_IN KWD_AND ] ## named -> simple . [ KWD_WITH KWD_IN KWD_AND ] @@ -1997,7 +2040,7 @@ expect_test_spec: KWD_LET IDENT EQUAL FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT TILDEMINUS ## -## Ends in an error in state: 338. +## Ends in an error in state: 345. ## ## binop_app -> simple infix_binop . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2009,7 +2052,7 @@ expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT FLOAT TILDEMINUS ## -## Ends in an error in state: 339. +## Ends in an error in state: 346. ## ## binop_app -> simple infix_binop simple . [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] @@ -2022,7 +2065,7 @@ expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ TILDEMINUS ## -## Ends in an error in state: 343. +## Ends in an error in state: 350. ## ## binop_app -> prefix_binop . LPAREN simple COMMA simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2032,9 +2075,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN TILDEMINUS ## -## Ends in an error in state: 344. +## Ends in an error in state: 351. ## ## binop_app -> prefix_binop LPAREN . simple COMMA simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2044,9 +2087,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 345. +## Ends in an error in state: 352. ## ## binop_app -> prefix_binop LPAREN simple . COMMA simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE COMMA ] @@ -2057,9 +2100,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT COMMA TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT COMMA TILDEMINUS ## -## Ends in an error in state: 346. +## Ends in an error in state: 353. ## ## binop_app -> prefix_binop LPAREN simple COMMA . simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2069,9 +2112,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT COMMA TILDEMI -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT COMMA FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT COMMA FLOAT TILDEMINUS ## -## Ends in an error in state: 347. +## Ends in an error in state: 354. ## ## binop_app -> prefix_binop LPAREN simple COMMA simple . RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE RPAREN ] @@ -2084,7 +2127,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT COMMA FLOAT T expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET TILDEMINUS ## -## Ends in an error in state: 352. +## Ends in an error in state: 359. ## ## ternop_app -> bytes_or_bigstring_set . string_accessor_width simple DOT LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2096,7 +2139,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT TILDEMINUS ## -## Ends in an error in state: 353. +## Ends in an error in state: 360. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width . simple DOT LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2108,7 +2151,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT TILDEMINUS ## -## Ends in an error in state: 354. +## Ends in an error in state: 361. ## ## simple -> simple . TILDE coercion [ TILDE DOT ] ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple . DOT LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] @@ -2121,7 +2164,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 355. +## Ends in an error in state: 362. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT . LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2133,7 +2176,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT TILDEMINU expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 356. +## Ends in an error in state: 363. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN . simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2145,7 +2188,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN TI expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 357. +## Ends in an error in state: 364. ## ## simple -> simple . TILDE coercion [ TILDE RPAREN ] ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN simple . RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] @@ -2158,7 +2201,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FL expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 358. +## Ends in an error in state: 365. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN simple RPAREN . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2170,7 +2213,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FL expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FLOAT RPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 359. +## Ends in an error in state: 366. ## ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN simple RPAREN simple . [ KWD_WITH KWD_IN KWD_AND ] @@ -2183,7 +2226,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FL expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED TILDEMINUS ## -## Ends in an error in state: 362. +## Ends in an error in state: 369. ## ## separated_nonempty_list(KWD_AND,symbol_binding) -> symbol_binding . [ KWD_WITH KWD_IN ] ## separated_nonempty_list(KWD_AND,symbol_binding) -> symbol_binding . KWD_AND separated_nonempty_list(KWD_AND,symbol_binding) [ KWD_WITH KWD_IN ] @@ -2196,7 +2239,7 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED TILDEMINUS expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_AND TILDEMINUS ## -## Ends in an error in state: 363. +## Ends in an error in state: 370. ## ## separated_nonempty_list(KWD_AND,symbol_binding) -> symbol_binding KWD_AND . separated_nonempty_list(KWD_AND,symbol_binding) [ KWD_WITH KWD_IN ] ## @@ -2208,7 +2251,7 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_AND TILDEMINUS expect_test_spec: KWD_LET SYMBOL TILDEMINUS ## -## Ends in an error in state: 364. +## Ends in an error in state: 371. ## ## static_closure_binding -> symbol . EQUAL fun_decl [ KWD_WITH KWD_IN KWD_AND ] ## static_data_binding -> symbol . EQUAL static_data [ KWD_WITH KWD_IN KWD_AND ] @@ -2221,7 +2264,7 @@ expect_test_spec: KWD_LET SYMBOL TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL TILDEMINUS ## -## Ends in an error in state: 365. +## Ends in an error in state: 372. ## ## static_closure_binding -> symbol EQUAL . fun_decl [ KWD_WITH KWD_IN KWD_AND ] ## static_data_binding -> symbol EQUAL . static_data [ KWD_WITH KWD_IN KWD_AND ] @@ -2234,7 +2277,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK TILDEMINUS ## -## Ends in an error in state: 367. +## Ends in an error in state: 374. ## ## static_data -> STATIC_CONST_FLOAT_BLOCK . LPAREN loption(separated_nonempty_list(COMMA,float_or_variable)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2246,7 +2289,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN TILDEMINUS ## -## Ends in an error in state: 368. +## Ends in an error in state: 375. ## ## static_data -> STATIC_CONST_FLOAT_BLOCK LPAREN . loption(separated_nonempty_list(COMMA,float_or_variable)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2258,7 +2301,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN TILDEMINU expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 374. +## Ends in an error in state: 381. ## ## separated_nonempty_list(COMMA,float_or_variable) -> float_or_variable . [ RPAREN ] ## separated_nonempty_list(COMMA,float_or_variable) -> float_or_variable . COMMA separated_nonempty_list(COMMA,float_or_variable) [ RPAREN ] @@ -2271,7 +2314,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT TIL expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT COMMA TILDEMINUS ## -## Ends in an error in state: 375. +## Ends in an error in state: 382. ## ## separated_nonempty_list(COMMA,float_or_variable) -> float_or_variable COMMA . separated_nonempty_list(COMMA,float_or_variable) [ RPAREN ] ## @@ -2283,7 +2326,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT COM expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY TILDEMINUS ## -## Ends in an error in state: 377. +## Ends in an error in state: 384. ## ## static_data -> STATIC_CONST_FLOAT_ARRAY . LBRACKPIPE loption(separated_nonempty_list(SEMICOLON,float_or_variable)) RBRACKPIPE [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2295,7 +2338,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE TILDEMINUS ## -## Ends in an error in state: 378. +## Ends in an error in state: 385. ## ## static_data -> STATIC_CONST_FLOAT_ARRAY LBRACKPIPE . loption(separated_nonempty_list(SEMICOLON,float_or_variable)) RBRACKPIPE [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2307,7 +2350,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE TILDE expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT TILDEMINUS ## -## Ends in an error in state: 382. +## Ends in an error in state: 389. ## ## separated_nonempty_list(SEMICOLON,float_or_variable) -> float_or_variable . [ RBRACKPIPE ] ## separated_nonempty_list(SEMICOLON,float_or_variable) -> float_or_variable . SEMICOLON separated_nonempty_list(SEMICOLON,float_or_variable) [ RBRACKPIPE ] @@ -2320,7 +2363,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT SEMICOLON TILDEMINUS ## -## Ends in an error in state: 383. +## Ends in an error in state: 390. ## ## separated_nonempty_list(SEMICOLON,float_or_variable) -> float_or_variable SEMICOLON . separated_nonempty_list(SEMICOLON,float_or_variable) [ RBRACKPIPE ] ## @@ -2332,7 +2375,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK TILDEMINUS ## -## Ends in an error in state: 387. +## Ends in an error in state: 394. ## ## static_data -> STATIC_CONST_BLOCK . mutability tag LPAREN loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2344,7 +2387,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 388. +## Ends in an error in state: 395. ## ## static_data -> STATIC_CONST_BLOCK mutability . tag LPAREN loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2356,7 +2399,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK KWD_IMMUTABLE_UNIQUE T expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT TILDEMINUS ## -## Ends in an error in state: 389. +## Ends in an error in state: 396. ## ## static_data -> STATIC_CONST_BLOCK mutability tag . LPAREN loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2368,7 +2411,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN TILDEMINUS ## -## Ends in an error in state: 390. +## Ends in an error in state: 397. ## ## static_data -> STATIC_CONST_BLOCK mutability tag LPAREN . loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2380,7 +2423,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL TILDEMINUS ## -## Ends in an error in state: 397. +## Ends in an error in state: 404. ## ## separated_nonempty_list(COMMA,field_of_block) -> field_of_block . [ RPAREN ] ## separated_nonempty_list(COMMA,field_of_block) -> field_of_block . COMMA separated_nonempty_list(COMMA,field_of_block) [ RPAREN ] @@ -2393,7 +2436,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL TILD expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL COMMA TILDEMINUS ## -## Ends in an error in state: 398. +## Ends in an error in state: 405. ## ## separated_nonempty_list(COMMA,field_of_block) -> field_of_block COMMA . separated_nonempty_list(COMMA,field_of_block) [ RPAREN ] ## @@ -2405,7 +2448,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL COMM expect_test_spec: KWD_LET SYMBOL EQUAL KWD_MUTABLE TILDEMINUS ## -## Ends in an error in state: 400. +## Ends in an error in state: 407. ## ## static_data -> KWD_MUTABLE . STRING [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2417,7 +2460,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL KWD_MUTABLE TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT TILDEMINUS ## -## Ends in an error in state: 404. +## Ends in an error in state: 411. ## ## static_data -> variable . COLON static_data_kind [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2429,7 +2472,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON TILDEMINUS ## -## Ends in an error in state: 405. +## Ends in an error in state: 412. ## ## static_data -> variable COLON . static_data_kind [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2441,7 +2484,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_NATIVEINT TILDEMINUS ## -## Ends in an error in state: 406. +## Ends in an error in state: 413. ## ## static_data_kind -> KWD_NATIVEINT . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2453,7 +2496,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_NATIVEINT TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT64 TILDEMINUS ## -## Ends in an error in state: 408. +## Ends in an error in state: 415. ## ## static_data_kind -> KWD_INT64 . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2465,7 +2508,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT64 TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT32 TILDEMINUS ## -## Ends in an error in state: 410. +## Ends in an error in state: 417. ## ## static_data_kind -> KWD_INT32 . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2477,7 +2520,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT32 TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 412. +## Ends in an error in state: 419. ## ## static_data_kind -> KWD_FLOAT . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2489,9 +2532,9 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 421. +## Ends in an error in state: 428. ## -## code -> code_header . kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header . kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header @@ -2501,7 +2544,7 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN TILDEMINUS ## -## Ends in an error in state: 422. +## Ends in an error in state: 429. ## ## kinded_args -> LPAREN . separated_nonempty_list(COMMA,kinded_variable) RPAREN [ IDENT EQUAL ] ## @@ -2513,7 +2556,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 423. +## Ends in an error in state: 430. ## ## kinded_variable -> variable . kind_with_subkind_opt [ RPAREN COMMA ] ## @@ -2525,7 +2568,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON TILDEMINUS ## -## Ends in an error in state: 424. +## Ends in an error in state: 431. ## ## kind_with_subkind_opt -> COLON . kind_with_subkind [ RPAREN COMMA ] ## @@ -2537,7 +2580,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK TILDEMINUS ## -## Ends in an error in state: 425. +## Ends in an error in state: 432. ## ## subkind -> LBRACK . ctors RBRACK [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## @@ -2549,7 +2592,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT TILDEMINUS ## -## Ends in an error in state: 426. +## Ends in an error in state: 433. ## ## tag -> INT . [ KWD_OF ] ## targetint -> INT . [ RBRACK PIPE ] @@ -2562,7 +2605,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT PIPE TILDEMINUS ## -## Ends in an error in state: 428. +## Ends in an error in state: 435. ## ## ctors_nonempty -> targetint PIPE . ctors_nonempty [ RBRACK ] ## @@ -2574,7 +2617,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT PIPE TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE INT TILDEMINUS ## -## Ends in an error in state: 429. +## Ends in an error in state: 436. ## ## nonconst_ctor -> tag . KWD_OF kinds_with_subkinds_nonempty [ RBRACK PIPE ] ## @@ -2586,7 +2629,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF TILDEMINUS ## -## Ends in an error in state: 430. +## Ends in an error in state: 437. ## ## nonconst_ctor -> tag KWD_OF . kinds_with_subkinds_nonempty [ RBRACK PIPE ] ## @@ -2598,7 +2641,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_VAL TILDEMINUS ## -## Ends in an error in state: 431. +## Ends in an error in state: 438. ## ## subkind -> KWD_VAL . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_VAL . KWD_ARRAY [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2611,7 +2654,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_VAL TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_NATIVEINT TILDEMINUS ## -## Ends in an error in state: 435. +## Ends in an error in state: 442. ## ## naked_number_kind -> KWD_NATIVEINT . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_NATIVEINT . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2624,7 +2667,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_NATIVEINT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT64 TILDEMINUS ## -## Ends in an error in state: 437. +## Ends in an error in state: 444. ## ## naked_number_kind -> KWD_INT64 . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_INT64 . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2637,7 +2680,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT64 TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT32 TILDEMINUS ## -## Ends in an error in state: 439. +## Ends in an error in state: 446. ## ## naked_number_kind -> KWD_INT32 . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_INT32 . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2650,7 +2693,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT32 TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_IMM TILDEMINUS ## -## Ends in an error in state: 441. +## Ends in an error in state: 448. ## ## naked_number_kind -> KWD_IMM . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_IMM . KWD_TAGGED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2664,7 +2707,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_IMM TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 444. +## Ends in an error in state: 451. ## ## naked_number_kind -> KWD_FLOAT . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_FLOAT . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2679,7 +2722,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT CARET TILDEMINUS ## -## Ends in an error in state: 447. +## Ends in an error in state: 454. ## ## subkind -> KWD_FLOAT CARET . plain_int [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## @@ -2691,7 +2734,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT CARET TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_ANY TILDEMINUS ## -## Ends in an error in state: 449. +## Ends in an error in state: 456. ## ## subkind -> KWD_ANY . KWD_ARRAY [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## @@ -2703,7 +2746,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_ANY TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_REC_INFO TILDEMINUS ## -## Ends in an error in state: 455. +## Ends in an error in state: 462. ## ## separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind . [ RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL ] ## separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind . STAR separated_nonempty_list(STAR,kind_with_subkind) [ RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL ] @@ -2716,7 +2759,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_REC_INFO TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT STAR TILDEMINUS ## -## Ends in an error in state: 456. +## Ends in an error in state: 463. ## ## separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind STAR . separated_nonempty_list(STAR,kind_with_subkind) [ RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL ] ## @@ -2728,7 +2771,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT STAR TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT RPAREN ## -## Ends in an error in state: 460. +## Ends in an error in state: 467. ## ## separated_nonempty_list(PIPE,nonconst_ctor) -> nonconst_ctor . [ RBRACK ] ## separated_nonempty_list(PIPE,nonconst_ctor) -> nonconst_ctor . PIPE separated_nonempty_list(PIPE,nonconst_ctor) [ RBRACK ] @@ -2740,18 +2783,18 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT RPARE ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 444, spurious reduction of production naked_number_kind -> KWD_FLOAT -## In state 453, spurious reduction of production kind_with_subkind -> naked_number_kind -## In state 455, spurious reduction of production separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind -## In state 452, spurious reduction of production kinds_with_subkinds_nonempty -> separated_nonempty_list(STAR,kind_with_subkind) -## In state 454, spurious reduction of production nonconst_ctor -> tag KWD_OF kinds_with_subkinds_nonempty +## In state 451, spurious reduction of production naked_number_kind -> KWD_FLOAT +## In state 460, spurious reduction of production kind_with_subkind -> naked_number_kind +## In state 462, spurious reduction of production separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind +## In state 459, spurious reduction of production kinds_with_subkinds_nonempty -> separated_nonempty_list(STAR,kind_with_subkind) +## In state 461, spurious reduction of production nonconst_ctor -> tag KWD_OF kinds_with_subkinds_nonempty ## expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE TILDEMINUS ## -## Ends in an error in state: 461. +## Ends in an error in state: 468. ## ## separated_nonempty_list(PIPE,nonconst_ctor) -> nonconst_ctor PIPE . separated_nonempty_list(PIPE,nonconst_ctor) [ RBRACK ] ## @@ -2763,7 +2806,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON KWD_REC_INFO TILDEMINUS ## -## Ends in an error in state: 471. +## Ends in an error in state: 478. ## ## separated_nonempty_list(COMMA,kinded_variable) -> kinded_variable . [ RPAREN ] ## separated_nonempty_list(COMMA,kinded_variable) -> kinded_variable . COMMA separated_nonempty_list(COMMA,kinded_variable) [ RPAREN ] @@ -2776,7 +2819,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON KWD_REC_INFO TILDEM expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COMMA TILDEMINUS ## -## Ends in an error in state: 472. +## Ends in an error in state: 479. ## ## separated_nonempty_list(COMMA,kinded_variable) -> kinded_variable COMMA . separated_nonempty_list(COMMA,kinded_variable) [ RPAREN ] ## @@ -2788,9 +2831,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COMMA TILDEMINUS expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT LPAREN IDENT RPAREN TILDEMINUS ## -## Ends in an error in state: 474. +## Ends in an error in state: 481. ## -## code -> code_header kinded_args . variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args . variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args @@ -2800,9 +2843,9 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT LPAREN IDENT expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 475. +## Ends in an error in state: 482. ## -## code -> code_header kinded_args variable . variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable . variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args variable @@ -2812,9 +2855,9 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT TILDEM expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 476. +## Ends in an error in state: 483. ## -## code -> code_header kinded_args variable variable . variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable . variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args variable variable @@ -2824,9 +2867,9 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 477. +## Ends in an error in state: 484. ## -## code -> code_header kinded_args variable variable variable . MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable . variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args variable variable variable @@ -2834,33 +2877,45 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 478. +## Ends in an error in state: 485. ## -## code -> code_header kinded_args variable variable variable MINUSGREATER . continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable variable . MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable MINUSGREATER +## code_header kinded_args variable variable variable variable ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER TILDEMINUS ## -## Ends in an error in state: 479. +## Ends in an error in state: 486. ## -## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id . exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable variable MINUSGREATER . continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable MINUSGREATER continuation_id +## code_header kinded_args variable variable variable variable MINUSGREATER ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT TILDEMINUS +## +## Ends in an error in state: 487. ## -## Ends in an error in state: 480. +## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id . exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## +## The known suffix of the stack is as follows: +## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id +## + + + +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR TILDEMINUS +## +## Ends in an error in state: 488. ## ## exn_continuation_id -> STAR . continuation_id [ KWD_LOCAL EQUAL COLON ] ## @@ -2870,21 +2925,21 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT TILDEMINUS ## -## Ends in an error in state: 482. +## Ends in an error in state: 490. ## -## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id . return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id . return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id +## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON TILDEMINUS ## -## Ends in an error in state: 483. +## Ends in an error in state: 491. ## ## return_arity -> COLON . kinds_with_subkinds [ KWD_LOCAL EQUAL ] ## @@ -2894,45 +2949,45 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON KWD_UNIT TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON KWD_UNIT TILDEMINUS ## -## Ends in an error in state: 487. +## Ends in an error in state: 495. ## -## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity . boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity . boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity +## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT KWD_LOCAL TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT KWD_LOCAL TILDEMINUS ## -## Ends in an error in state: 489. +## Ends in an error in state: 497. ## -## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) . EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) . EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) +## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT EQUAL TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT EQUAL TILDEMINUS ## -## Ends in an error in state: 490. +## Ends in an error in state: 498. ## -## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL . expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL . expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL +## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL ## expect_test_spec: KWD_INVALID TILDEMINUS ## -## Ends in an error in state: 491. +## Ends in an error in state: 499. ## ## atomic_expr -> KWD_INVALID . STRING [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -2944,7 +2999,7 @@ expect_test_spec: KWD_INVALID TILDEMINUS expect_test_spec: KWD_CONT TILDEMINUS ## -## Ends in an error in state: 494. +## Ends in an error in state: 502. ## ## atomic_expr -> KWD_CONT . apply_cont_expr [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -2956,7 +3011,7 @@ expect_test_spec: KWD_CONT TILDEMINUS expect_test_spec: KWD_APPLY TILDEMINUS ## -## Ends in an error in state: 496. +## Ends in an error in state: 504. ## ## atomic_expr -> KWD_APPLY . apply_expr [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -2968,9 +3023,9 @@ expect_test_spec: KWD_APPLY TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT TILDEMINUS ## -## Ends in an error in state: 497. +## Ends in an error in state: 505. ## -## call_kind -> KWD_DIRECT . LPAREN code_id function_slot_opt alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT . LPAREN code_id function_slot_opt alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT @@ -2980,9 +3035,9 @@ expect_test_spec: KWD_APPLY KWD_DIRECT TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN TILDEMINUS ## -## Ends in an error in state: 498. +## Ends in an error in state: 506. ## -## call_kind -> KWD_DIRECT LPAREN . code_id function_slot_opt alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN . code_id function_slot_opt alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT LPAREN @@ -2992,9 +3047,9 @@ expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 499. +## Ends in an error in state: 507. ## -## call_kind -> KWD_DIRECT LPAREN code_id . function_slot_opt alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN code_id . function_slot_opt alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT LPAREN code_id @@ -3004,9 +3059,9 @@ expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AT IDENT TILDEMINUS ## -## Ends in an error in state: 500. +## Ends in an error in state: 508. ## -## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt . alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt . alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT LPAREN code_id function_slot_opt @@ -3014,21 +3069,57 @@ expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AT IDENT TILDEMINUS -expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AMP IDENT TILDEMINUS +expect_test_spec: KWD_APPLY AMP TILDEMINUS +## +## Ends in an error in state: 509. +## +## alloc_mode_for_applications_opt -> AMP . region AMP region [ SYMBOL RPAREN LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## +## The known suffix of the stack is as follows: +## AMP +## + + + +expect_test_spec: KWD_APPLY AMP IDENT TILDEMINUS +## +## Ends in an error in state: 510. +## +## alloc_mode_for_applications_opt -> AMP region . AMP region [ SYMBOL RPAREN LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## +## The known suffix of the stack is as follows: +## AMP region +## + + + +expect_test_spec: KWD_APPLY AMP IDENT AMP TILDEMINUS +## +## Ends in an error in state: 511. +## +## alloc_mode_for_applications_opt -> AMP region AMP . region [ SYMBOL RPAREN LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## +## The known suffix of the stack is as follows: +## AMP region AMP +## + + + +expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AMP IDENT AMP IDENT TILDEMINUS ## -## Ends in an error in state: 501. +## Ends in an error in state: 513. ## -## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_allocations_opt . RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_applications_opt . RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: -## KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_allocations_opt +## KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_applications_opt ## expect_test_spec: KWD_APPLY KWD_CCALL TILDEMINUS ## -## Ends in an error in state: 503. +## Ends in an error in state: 515. ## ## call_kind -> KWD_CCALL . boption(KWD_NOALLOC) [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## @@ -3038,9 +3129,9 @@ expect_test_spec: KWD_APPLY KWD_CCALL TILDEMINUS -expect_test_spec: KWD_APPLY AMP IDENT TILDEMINUS +expect_test_spec: KWD_APPLY KWD_CCALL KWD_NOALLOC TILDEMINUS ## -## Ends in an error in state: 506. +## Ends in an error in state: 518. ## ## apply_expr -> call_kind . option(inlined) option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3052,7 +3143,7 @@ expect_test_spec: KWD_APPLY AMP IDENT TILDEMINUS expect_test_spec: KWD_APPLY KWD_UNROLL TILDEMINUS ## -## Ends in an error in state: 507. +## Ends in an error in state: 519. ## ## inlined -> KWD_UNROLL . LPAREN plain_int RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3064,7 +3155,7 @@ expect_test_spec: KWD_APPLY KWD_UNROLL TILDEMINUS expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN TILDEMINUS ## -## Ends in an error in state: 508. +## Ends in an error in state: 520. ## ## inlined -> KWD_UNROLL LPAREN . plain_int RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3076,7 +3167,7 @@ expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN INT TILDEMINUS ## -## Ends in an error in state: 509. +## Ends in an error in state: 521. ## ## inlined -> KWD_UNROLL LPAREN plain_int . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3088,7 +3179,7 @@ expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN INT TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED TILDEMINUS ## -## Ends in an error in state: 511. +## Ends in an error in state: 523. ## ## inlined -> KWD_INLINED . LPAREN KWD_ALWAYS RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## inlined -> KWD_INLINED . LPAREN KWD_HINT RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] @@ -3103,7 +3194,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN TILDEMINUS ## -## Ends in an error in state: 512. +## Ends in an error in state: 524. ## ## inlined -> KWD_INLINED LPAREN . KWD_ALWAYS RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## inlined -> KWD_INLINED LPAREN . KWD_HINT RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] @@ -3118,7 +3209,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_NEVER TILDEMINUS ## -## Ends in an error in state: 513. +## Ends in an error in state: 525. ## ## inlined -> KWD_INLINED LPAREN KWD_NEVER . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3130,7 +3221,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_NEVER TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_HINT TILDEMINUS ## -## Ends in an error in state: 515. +## Ends in an error in state: 527. ## ## inlined -> KWD_INLINED LPAREN KWD_HINT . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3142,7 +3233,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_HINT TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_DEFAULT TILDEMINUS ## -## Ends in an error in state: 517. +## Ends in an error in state: 529. ## ## inlined -> KWD_INLINED LPAREN KWD_DEFAULT . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3154,7 +3245,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_DEFAULT TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS TILDEMINUS ## -## Ends in an error in state: 519. +## Ends in an error in state: 531. ## ## inlined -> KWD_INLINED LPAREN KWD_ALWAYS . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3166,7 +3257,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS RPAREN TILDEMINUS ## -## Ends in an error in state: 521. +## Ends in an error in state: 533. ## ## apply_expr -> call_kind option(inlined) . option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3178,7 +3269,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS RPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE TILDEMINUS ## -## Ends in an error in state: 522. +## Ends in an error in state: 534. ## ## inlining_state -> KWD_INLINING_STATE . LPAREN inlining_state_depth RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -3190,7 +3281,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN TILDEMINUS ## -## Ends in an error in state: 523. +## Ends in an error in state: 535. ## ## inlining_state -> KWD_INLINING_STATE LPAREN . inlining_state_depth RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -3202,7 +3293,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH TILDEMINUS ## -## Ends in an error in state: 524. +## Ends in an error in state: 536. ## ## inlining_state_depth -> KWD_DEPTH . LPAREN plain_int RPAREN [ RPAREN ] ## @@ -3214,7 +3305,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN TILDEMINUS ## -## Ends in an error in state: 525. +## Ends in an error in state: 537. ## ## inlining_state_depth -> KWD_DEPTH LPAREN . plain_int RPAREN [ RPAREN ] ## @@ -3226,7 +3317,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN TILDEMINU expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT TILDEMINUS ## -## Ends in an error in state: 526. +## Ends in an error in state: 538. ## ## inlining_state_depth -> KWD_DEPTH LPAREN plain_int . RPAREN [ RPAREN ] ## @@ -3238,7 +3329,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT TILDE expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPAREN TILDEMINUS ## -## Ends in an error in state: 528. +## Ends in an error in state: 540. ## ## inlining_state -> KWD_INLINING_STATE LPAREN inlining_state_depth . RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -3250,7 +3341,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPARE expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPAREN RPAREN TILDEMINUS ## -## Ends in an error in state: 530. +## Ends in an error in state: 542. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) . func_name_with_optional_arities simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3262,7 +3353,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPARE expect_test_spec: KWD_APPLY LPAREN TILDEMINUS ## -## Ends in an error in state: 531. +## Ends in an error in state: 543. ## ## func_name_with_optional_arities -> LPAREN . simple COLON blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3274,7 +3365,7 @@ expect_test_spec: KWD_APPLY LPAREN TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 532. +## Ends in an error in state: 544. ## ## func_name_with_optional_arities -> LPAREN simple . COLON blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## simple -> simple . TILDE coercion [ TILDE COLON ] @@ -3287,7 +3378,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON TILDEMINUS ## -## Ends in an error in state: 533. +## Ends in an error in state: 545. ## ## func_name_with_optional_arities -> LPAREN simple COLON . blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3299,7 +3390,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_UNIT TILDEMINUS ## -## Ends in an error in state: 536. +## Ends in an error in state: 548. ## ## func_name_with_optional_arities -> LPAREN simple COLON blank_or(kinds_with_subkinds) . MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3311,7 +3402,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_UNIT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER TILDEMINUS ## -## Ends in an error in state: 537. +## Ends in an error in state: 549. ## ## func_name_with_optional_arities -> LPAREN simple COLON blank_or(kinds_with_subkinds) MINUSGREATER . kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3323,7 +3414,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_UNIT TILDEMINUS ## -## Ends in an error in state: 538. +## Ends in an error in state: 550. ## ## func_name_with_optional_arities -> LPAREN simple COLON blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds . RPAREN [ MINUSGREATER LPAREN ] ## @@ -3335,7 +3426,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_UNIT T expect_test_spec: KWD_APPLY FLOAT TILDEMINUS ## -## Ends in an error in state: 540. +## Ends in an error in state: 552. ## ## func_name_with_optional_arities -> simple . [ MINUSGREATER LPAREN ] ## simple -> simple . TILDE coercion [ TILDE MINUSGREATER LPAREN ] @@ -3348,7 +3439,7 @@ expect_test_spec: KWD_APPLY FLOAT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 541. +## Ends in an error in state: 553. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities . simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3360,7 +3451,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_FLOAT expect_test_spec: KWD_APPLY FLOAT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 542. +## Ends in an error in state: 554. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities simple_args . MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3372,7 +3463,7 @@ expect_test_spec: KWD_APPLY FLOAT LPAREN FLOAT RPAREN TILDEMINUS expect_test_spec: KWD_APPLY FLOAT MINUSGREATER TILDEMINUS ## -## Ends in an error in state: 543. +## Ends in an error in state: 555. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER . result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3384,7 +3475,7 @@ expect_test_spec: KWD_APPLY FLOAT MINUSGREATER TILDEMINUS expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT TILDEMINUS ## -## Ends in an error in state: 545. +## Ends in an error in state: 557. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER result_continuation . exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3396,7 +3487,7 @@ expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT TILDEMINUS expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT STAR TILDEMINUS ## -## Ends in an error in state: 546. +## Ends in an error in state: 558. ## ## exn_continuation -> STAR . continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3408,7 +3499,7 @@ expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT STAR TILDEMINUS expect_test_spec: KWD_HCF TILDEMINUS ## -## Ends in an error in state: 557. +## Ends in an error in state: 569. ## ## expr -> inner_expr . [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## where_expr -> inner_expr . KWD_WHERE recursive loption(separated_nonempty_list(KWD_ANDWHERE,continuation_binding)) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] @@ -3421,7 +3512,7 @@ expect_test_spec: KWD_HCF TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE TILDEMINUS ## -## Ends in an error in state: 558. +## Ends in an error in state: 570. ## ## where_expr -> inner_expr KWD_WHERE . recursive loption(separated_nonempty_list(KWD_ANDWHERE,continuation_binding)) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3433,7 +3524,7 @@ expect_test_spec: KWD_HCF KWD_WHERE TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE KWD_REC TILDEMINUS ## -## Ends in an error in state: 559. +## Ends in an error in state: 571. ## ## where_expr -> inner_expr KWD_WHERE recursive . loption(separated_nonempty_list(KWD_ANDWHERE,continuation_binding)) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3445,7 +3536,7 @@ expect_test_spec: KWD_HCF KWD_WHERE KWD_REC TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT TILDEMINUS ## -## Ends in an error in state: 562. +## Ends in an error in state: 574. ## ## continuation_binding -> continuation_id . continuation_sort kinded_args EQUAL continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3457,7 +3548,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT KWD_DEFINE_ROOT_SYMBOL TILDEMINUS ## -## Ends in an error in state: 565. +## Ends in an error in state: 577. ## ## continuation_binding -> continuation_id continuation_sort . kinded_args EQUAL continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3469,7 +3560,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT KWD_DEFINE_ROOT_SYMBOL TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT RPAREN TILDEMINUS ## -## Ends in an error in state: 566. +## Ends in an error in state: 578. ## ## continuation_binding -> continuation_id continuation_sort kinded_args . EQUAL continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3481,7 +3572,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT RPAREN TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL TILDEMINUS ## -## Ends in an error in state: 567. +## Ends in an error in state: 579. ## ## continuation_binding -> continuation_id continuation_sort kinded_args EQUAL . continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3493,7 +3584,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET TILDEMINUS ## -## Ends in an error in state: 568. +## Ends in an error in state: 580. ## ## let_expr(continuation_body) -> KWD_LET . let_(continuation_body) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## let_symbol(continuation_body) -> KWD_LET . separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt KWD_IN continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] @@ -3506,7 +3597,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELETED KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 570. +## Ends in an error in state: 582. ## ## let_symbol(continuation_body) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt . KWD_IN continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3518,7 +3609,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELET expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELETED KWD_IN TILDEMINUS ## -## Ends in an error in state: 571. +## Ends in an error in state: 583. ## ## let_symbol(continuation_body) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt KWD_IN . continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3528,9 +3619,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELET -expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE RBRACE TILDEMINUS +expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 577. +## Ends in an error in state: 589. ## ## let_(continuation_body) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt . KWD_IN continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3540,9 +3631,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_R -expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_IN TILDEMINUS +expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_IN TILDEMINUS ## -## Ends in an error in state: 578. +## Ends in an error in state: 590. ## ## let_(continuation_body) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt KWD_IN . continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3552,9 +3643,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_R -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION TILDEMINUS ## -## Ends in an error in state: 580. +## Ends in an error in state: 592. ## ## separated_nonempty_list(KWD_AND,let_binding) -> let_binding . [ KWD_WITH KWD_IN ] ## separated_nonempty_list(KWD_AND,let_binding) -> let_binding . KWD_AND separated_nonempty_list(KWD_AND,let_binding) [ KWD_WITH KWD_IN ] @@ -3565,9 +3656,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_AND TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_AND TILDEMINUS ## -## Ends in an error in state: 581. +## Ends in an error in state: 593. ## ## separated_nonempty_list(KWD_AND,let_binding) -> let_binding KWD_AND . separated_nonempty_list(KWD_AND,let_binding) [ KWD_WITH KWD_IN ] ## @@ -3579,7 +3670,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_AND TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF TILDEMINUS ## -## Ends in an error in state: 586. +## Ends in an error in state: 598. ## ## separated_nonempty_list(KWD_ANDWHERE,continuation_binding) -> continuation_binding . [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## separated_nonempty_list(KWD_ANDWHERE,continuation_binding) -> continuation_binding . KWD_ANDWHERE separated_nonempty_list(KWD_ANDWHERE,continuation_binding) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] @@ -3592,7 +3683,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF KWD_ANDWHERE TILDEMINUS ## -## Ends in an error in state: 587. +## Ends in an error in state: 599. ## ## separated_nonempty_list(KWD_ANDWHERE,continuation_binding) -> continuation_binding KWD_ANDWHERE . separated_nonempty_list(KWD_ANDWHERE,continuation_binding) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3604,7 +3695,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF KWD_ANDWHERE TILDEMINUS expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 592. +## Ends in an error in state: 604. ## ## let_symbol(expr) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt . KWD_IN expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3616,7 +3707,7 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_WITH LBRACE RBRACE TILD expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_IN TILDEMINUS ## -## Ends in an error in state: 593. +## Ends in an error in state: 605. ## ## let_symbol(expr) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt KWD_IN . expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3626,9 +3717,9 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_IN TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE RBRACE TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 596. +## Ends in an error in state: 608. ## ## let_(expr) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt . KWD_IN expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3638,9 +3729,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE RBRACE T -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_IN TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_IN TILDEMINUS ## -## Ends in an error in state: 597. +## Ends in an error in state: 609. ## ## let_(expr) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt KWD_IN . expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3652,7 +3743,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_IN TILDEMINUS expect_test_spec: LPAREN KWD_HCF KWD_WITH ## -## Ends in an error in state: 600. +## Ends in an error in state: 612. ## ## atomic_expr -> LPAREN expr . RPAREN [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3663,14 +3754,14 @@ expect_test_spec: LPAREN KWD_HCF KWD_WITH ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 557, spurious reduction of production expr -> inner_expr +## In state 569, spurious reduction of production expr -> inner_expr ## expect_test_spec: KWD_HCF RPAREN ## -## Ends in an error in state: 602. +## Ends in an error in state: 614. ## ## expect_test_spec -> module_ . BIGARROW module_ EOF [ # ] ## @@ -3681,15 +3772,15 @@ expect_test_spec: KWD_HCF RPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 557, spurious reduction of production expr -> inner_expr -## In state 606, spurious reduction of production module_ -> expr +## In state 569, spurious reduction of production expr -> inner_expr +## In state 618, spurious reduction of production module_ -> expr ## expect_test_spec: KWD_HCF BIGARROW TILDEMINUS ## -## Ends in an error in state: 603. +## Ends in an error in state: 615. ## ## expect_test_spec -> module_ BIGARROW . module_ EOF [ # ] ## @@ -3701,7 +3792,7 @@ expect_test_spec: KWD_HCF BIGARROW TILDEMINUS expect_test_spec: KWD_HCF BIGARROW KWD_HCF RPAREN ## -## Ends in an error in state: 604. +## Ends in an error in state: 616. ## ## expect_test_spec -> module_ BIGARROW module_ . EOF [ # ] ## @@ -3712,15 +3803,15 @@ expect_test_spec: KWD_HCF BIGARROW KWD_HCF RPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 557, spurious reduction of production expr -> inner_expr -## In state 606, spurious reduction of production module_ -> expr +## In state 569, spurious reduction of production expr -> inner_expr +## In state 618, spurious reduction of production module_ -> expr ## flambda_unit: TILDEMINUS ## -## Ends in an error in state: 608. +## Ends in an error in state: 620. ## ## flambda_unit' -> . flambda_unit [ # ] ## @@ -3732,7 +3823,7 @@ flambda_unit: TILDEMINUS flambda_unit: KWD_HCF RPAREN ## -## Ends in an error in state: 609. +## Ends in an error in state: 621. ## ## flambda_unit -> module_ . EOF [ # ] ## @@ -3743,8 +3834,8 @@ flambda_unit: KWD_HCF RPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 557, spurious reduction of production expr -> inner_expr -## In state 606, spurious reduction of production module_ -> expr +## In state 569, spurious reduction of production expr -> inner_expr +## In state 618, spurious reduction of production module_ -> expr ## diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index b7e1f5289da..b24c1ce2e9d 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -411,6 +411,7 @@ module Analyser = | Parsetree.Ptype_record label_declaration_list -> (0, Record.(doc parsetree) pos_end label_declaration_list) + | Parsetree.Ptype_record_unboxed_product _ -> assert false | Parsetree.Ptype_open -> (0, []) @@ -483,6 +484,8 @@ module Analyser = | Types.Type_record (l, _) -> Odoc_type.Type_record (List.map (get_field env name_comment_list) l) + | Types.Type_record_unboxed_product (_, _) -> assert false + | Types.Type_open -> Odoc_type.Type_open diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index e60591aef5d..d92d3835a1e 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -186,6 +186,8 @@ module Pat = struct let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let record_unboxed_product ?loc ?attrs a b = + mk ?loc ?attrs (Ppat_record_unboxed_product (a, b)) let array ?loc ?attrs a b = mk ?loc ?attrs (Ppat_array (a, b)) let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) let constraint_ ?loc ?attrs a b c = mk ?loc ?attrs (Ppat_constraint (a, b, c)) @@ -217,7 +219,10 @@ module Exp = struct let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let record_unboxed_product ?loc ?attrs a b = + mk ?loc ?attrs (Pexp_record_unboxed_product (a, b)) let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let unboxed_field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_unboxed_field (a, b)) let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) let array ?loc ?attrs a b = mk ?loc ?attrs (Pexp_array (a, b)) let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index d77365c0dfd..b660b633101 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -126,6 +126,8 @@ module Pat: val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern + val record_unboxed_product: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list + -> closed_flag -> pattern val array: ?loc:loc -> ?attrs:attrs -> mutable_flag -> pattern list -> pattern val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern @@ -166,7 +168,10 @@ module Exp: -> expression val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list -> expression option -> expression + val record_unboxed_product: ?loc:loc -> ?attrs:attrs -> (lid * expression) list + -> expression option -> expression val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + val unboxed_field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression -> expression val array: ?loc:loc -> ?attrs:attrs -> mutable_flag -> expression list -> diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 44dbd0fa6ed..1752b365fec 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -178,7 +178,8 @@ module T = struct | Ptype_abstract -> () | Ptype_variant l -> List.iter (sub.constructor_declaration sub) l - | Ptype_record l -> List.iter (sub.label_declaration sub) l + | Ptype_record l | Ptype_record_unboxed_product l -> + List.iter (sub.label_declaration sub) l | Ptype_open -> () let iter_constructor_argument sub {pca_type; pca_loc; pca_modalities} = @@ -474,10 +475,12 @@ module E = struct iter_loc sub lid; iter_opt (sub.expr sub) arg | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo - | Pexp_record (l, eo) -> + | Pexp_record (l, eo) + | Pexp_record_unboxed_product (l, eo) -> List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; iter_opt (sub.expr sub) eo - | Pexp_field (e, lid) -> + | Pexp_field (e, lid) + | Pexp_unboxed_field (e, lid) -> sub.expr sub e; iter_loc sub lid | Pexp_setfield (e1, lid, e2) -> sub.expr sub e1; iter_loc sub lid; @@ -565,7 +568,8 @@ module P = struct sub.pat sub p) p | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p - | Ppat_record (lpl, _cf) -> + | Ppat_record (lpl, _cf) + | Ppat_record_unboxed_product (lpl, _cf) -> List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl | Ppat_array (_mut, pl) -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 2d5e9f9b97a..6c4a28d9649 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -223,6 +223,8 @@ module T = struct | Ptype_variant l -> Ptype_variant (List.map (sub.constructor_declaration sub) l) | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_record_unboxed_product l -> + Ptype_record_unboxed_product (List.map (sub.label_declaration sub) l) | Ptype_open -> Ptype_open let map_constructor_argument sub x = @@ -550,8 +552,13 @@ module E = struct | Pexp_record (l, eo) -> record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) (map_opt (sub.expr sub) eo) + | Pexp_record_unboxed_product (l, eo) -> + record_unboxed_product ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_unboxed_field (e, lid) -> + unboxed_field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) | Pexp_setfield (e1, lid, e2) -> setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) @@ -644,6 +651,9 @@ module P = struct | Ppat_record (lpl, cf) -> record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf + | Ppat_record_unboxed_product (lpl, cf) -> + record_unboxed_product ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf | Ppat_array (mut, pl) -> array ~loc ~attrs mut (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t, m) -> diff --git a/parsing/depend.ml b/parsing/depend.ml index 000d6f272cc..69fba756745 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -174,6 +174,8 @@ let add_type_declaration bv td = List.iter (add_constructor_decl bv) cstrs | Ptype_record lbls -> List.iter (fun pld -> add_type bv pld.pld_type) lbls + | Ptype_record_unboxed_product lbls -> + List.iter (fun pld -> add_type bv pld.pld_type) lbls | Ptype_open -> () in add_tkind td.ptype_kind @@ -208,7 +210,7 @@ let rec add_pattern bv pat = add_opt (fun bv (_,p) -> add_pattern bv p) bv opt - | Ppat_record(pl, _) -> + | Ppat_record(pl, _) | Ppat_record_unboxed_product(pl, _) -> List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl | Ppat_array (_, pl) -> List.iter (add_pattern bv) pl | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 @@ -251,10 +253,11 @@ let rec add_expr bv exp = | Pexp_unboxed_tuple el -> add_labeled_tuple_expr bv el | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte | Pexp_variant(_, opte) -> add_opt add_expr bv opte - | Pexp_record(lblel, opte) -> + | Pexp_record(lblel, opte) + | Pexp_record_unboxed_product(lblel, opte) -> List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; add_opt add_expr bv opte - | Pexp_field(e, fld) -> add_expr bv e; add bv fld + | Pexp_field(e, fld) | Pexp_unboxed_field(e, fld) -> add_expr bv e; add bv fld | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 | Pexp_array (_, el) -> List.iter (add_expr bv) el | Pexp_ifthenelse(e1, e2, opte3) -> diff --git a/parsing/lexer.mll b/parsing/lexer.mll index ecf55bdf68c..0252e0c33dd 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -740,11 +740,13 @@ rule token = parse | "(" { LPAREN } | ")" { RPAREN } | "#(" { HASHLPAREN } + | "#{" { HASHLBRACE } | "*" { STAR } | "," { COMMA } | "->" { MINUSGREATER } | "." { DOT } | ".." { DOTDOT } + | ".#" { DOTHASH } | "." (dotsymbolchar symbolchar* as op) { DOTOP op } | ":" { COLON } | "::" { COLONCOLON } diff --git a/parsing/parser.mly b/parsing/parser.mly index c56ca13edea..24a1ea39339 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -939,6 +939,7 @@ let maybe_pmod_constraint mode expr = %token DONE "done" %token DOT "." %token DOTDOT ".." +%token DOTHASH ".#" %token DOWNTO "downto" %token ELSE "else" %token END "end" @@ -959,6 +960,7 @@ let maybe_pmod_constraint mode expr = %token GREATERRBRACE ">}" %token GREATERRBRACKET ">]" %token HASHLPAREN "#(" +%token HASHLBRACE "#{" %token IF "if" %token IN "in" %token INCLUDE "include" @@ -1122,12 +1124,12 @@ The precedences must be listed from low to high. %nonassoc HASH HASH_SUFFIX /* simple_expr/toplevel_directive */ %left HASHOP %nonassoc below_DOT -%nonassoc DOT DOTOP +%nonassoc DOT DOTHASH DOTOP /* Finally, the first tokens of simple_expr are above everything else. */ %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT HASH_FLOAT INT HASH_INT OBJECT LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCOLON LIDENT LPAREN NEW PREFIXOP STRING TRUE UIDENT - LBRACKETPERCENT QUOTED_STRING_EXPR STACK HASHLPAREN + LBRACKETPERCENT QUOTED_STRING_EXPR STACK HASHLBRACE HASHLPAREN /* Entry points */ @@ -3046,6 +3048,8 @@ comprehension_clause: { Pexp_override [] } | simple_expr DOT mkrhs(label_longident) { Pexp_field($1, $3) } + | simple_expr DOTHASH mkrhs(label_longident) + { Pexp_unboxed_field($1, $3) } | od=open_dot_declaration DOT LPAREN seq_expr RPAREN { Pexp_open(od, $4) } | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE @@ -3066,12 +3070,19 @@ comprehension_clause: | LBRACE record_expr_content RBRACE { let (exten, fields) = $2 in Pexp_record(fields, exten) } + | HASHLBRACE record_expr_content RBRACE + { let (exten, fields) = $2 in + Pexp_record_unboxed_product(fields, exten) } | LBRACE record_expr_content error { unclosed "{" $loc($1) "}" $loc($3) } | od=open_dot_declaration DOT LBRACE record_expr_content RBRACE { let (exten, fields) = $4 in Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_record(fields, exten))) } + | od=open_dot_declaration DOT HASHLBRACE record_expr_content RBRACE + { let (exten, fields) = $4 in + Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) + (Pexp_record_unboxed_product(fields, exten))) } | mod_longident DOT LBRACE record_expr_content error { unclosed "{" $loc($3) "}" $loc($5) } | array_exprs(LBRACKETBAR, BARRBRACKET) @@ -3715,6 +3726,9 @@ simple_delimited_pattern: LBRACE record_pat_content RBRACE { let (fields, closed) = $2 in Ppat_record(fields, closed) } + | HASHLBRACE record_pat_content RBRACE + { let (fields, closed) = $2 in + Ppat_record_unboxed_product(fields, closed) } | LBRACE record_pat_content error { unclosed "{" $loc($1) "}" $loc($3) } | LBRACKET pattern_semi_list RBRACKET @@ -3907,6 +3921,10 @@ nonempty_type_kind: priv = inline_private_flag LBRACE ls = label_declarations RBRACE { (Ptype_record ls, priv, oty) } + | oty = type_synonym + priv = inline_private_flag + HASHLBRACE ls = label_declarations RBRACE + { (Ptype_record_unboxed_product ls, priv, oty) } ; %inline type_synonym: ioption(terminated(core_type, EQUAL)) diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 7495d3acace..53e2809ce61 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -310,6 +310,15 @@ and pattern_desc = - [{ l1=P1; ...; ln=Pn; _}] when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + Invariant: [n > 0] + *) + | Ppat_record_unboxed_product of (Longident.t loc * pattern) list * closed_flag + (** [Ppat_record_unboxed_product([(l1, P1) ; ... ; (ln, Pn)], flag)] represents: + - [#{ l1=P1; ...; ln=Pn }] + when [flag] is {{!Asttypes.closed_flag.Closed}[Closed]} + - [#{ l1=P1; ...; ln=Pn; _}] + when [flag] is {{!Asttypes.closed_flag.Open}[Open]} + Invariant: [n > 0] *) | Ppat_array of mutable_flag * pattern list @@ -421,9 +430,17 @@ and expression_desc = - [{ l1=P1; ...; ln=Pn }] when [exp0] is [None] - [{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + Invariant: [n > 0] + *) + | Pexp_record_unboxed_product of (Longident.t loc * expression) list * expression option + (** [Pexp_record_unboxed_product([(l1,P1) ; ... ; (ln,Pn)], exp0)] represents + - [#{ l1=P1; ...; ln=Pn }] when [exp0] is [None] + - [#{ E0 with l1=P1; ...; ln=Pn }] when [exp0] is [Some E0] + Invariant: [n > 0] *) | Pexp_field of expression * Longident.t loc (** [E.l] *) + | Pexp_unboxed_field of expression * Longident.t loc (** [E.#l] *) | Pexp_setfield of expression * Longident.t loc * expression (** [E1.l <- E2] *) | Pexp_array of mutable_flag * expression list @@ -685,6 +702,7 @@ and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list | Ptype_record of label_declaration list (** Invariant: non-empty list *) + | Ptype_record_unboxed_product of label_declaration list (** Invariant: non-empty list *) | Ptype_open and label_declaration = diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 4d29bfd07d4..a1bd72e467a 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -704,6 +704,16 @@ and labeled_pattern1 ctxt (f:Format.formatter) (label, x) : unit = pattern1 ctxt f x and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false" as x);_}), None) -> @@ -727,22 +737,19 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_type li -> pp f "#%a" longident_loc li | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in begin match closed with | Closed -> pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l | _ -> pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l end + | Ppat_record_unboxed_product (l, closed) -> + begin match closed with + | Closed -> + pp f "@[<2>#{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>#{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end | Ppat_tuple (l, closed) -> labeled_tuple_pattern ctxt f ~unboxed:false l closed | Ppat_unboxed_tuple (l, closed) -> @@ -779,7 +786,7 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_open (lid, p) -> let with_paren = match p.ppat_desc with - | Ppat_array _ | Ppat_record _ + | Ppat_array _ | Ppat_record _ | Ppat_record_unboxed_product _ | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false");_}), None) -> false | _ -> true in @@ -1104,12 +1111,22 @@ and expression2 ctxt f x = else match x.pexp_desc with | Pexp_field (e, li) -> pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_unboxed_field (e, li) -> + pp f "@[%a.#%a@]" (simple_expr ctxt) e longident_loc li | Pexp_send (e, s) -> pp f "@[%a#%a@]" (simple_expr ctxt) e ident_of_name s.txt | _ -> simple_expr ctxt f x and simple_expr ctxt f x = + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in if x.pexp_attributes <> [] then expression ctxt f x else match x.pexp_desc with | Pexp_construct _ when is_simple_construct (view_expr x) -> @@ -1152,17 +1169,13 @@ and simple_expr ctxt f x = (core_type ctxt) ct | Pexp_variant (l, None) -> pp f "`%a" ident_of_name l | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) (option ~last:" with@;" (simple_expr ctxt)) eo (list longident_x_expression ~sep:";@;") l + | Pexp_record_unboxed_product (l, eo) -> + pp f "@[@[#{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l | Pexp_array (mut, l) -> let punct = match mut with | Immutable -> ':' @@ -2007,6 +2020,20 @@ and record_declaration ctxt f lbls = pp f "{@\n%a}" (list type_record_field ~sep:";@\n" ) lbls +and record_unboxed_product_declaration ctxt f lbls = + let type_record_field f pld = + let legacy, m = split_out_legacy_modalities pld.pld_modalities in + pp f "@[<2>%a%a%a:@;%a%a@;%a@]" + mutable_flag pld.pld_mutable + optional_legacy_modalities legacy + ident_of_name pld.pld_name.txt + (core_type ctxt) pld.pld_type + optional_space_atat_modalities m + (attributes ctxt) pld.pld_attributes + in + pp f "#{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + and type_declaration ctxt f x = (* type_declaration has an attribute field, but it's been printed by the caller of this method *) @@ -2044,6 +2071,8 @@ and type_declaration ctxt f x = | Ptype_abstract -> () | Ptype_record l -> pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_record_unboxed_product l -> + pp f "%t%t@;%a" intro priv (record_unboxed_product_declaration ctxt) l | Ptype_open -> pp f "%t%t@;.." intro priv in let constraints f = diff --git a/parsing/printast.ml b/parsing/printast.ml index 5006d84f8ee..68c496854e3 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -264,6 +264,9 @@ and pattern i ppf x = | Ppat_record (l, c) -> line i ppf "Ppat_record %a\n" fmt_closed_flag c; list i longident_x_pattern ppf l; + | Ppat_record_unboxed_product (l, c) -> + line i ppf "Ppat_record_unboxed_product %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l; | Ppat_array (mut, l) -> line i ppf "Ppat_array %a\n" fmt_mutable_flag mut; list i pattern ppf l; @@ -338,10 +341,18 @@ and expression i ppf x = line i ppf "Pexp_record\n"; list i longident_x_expression ppf l; option i expression ppf eo; + | Pexp_record_unboxed_product (l, eo) -> + line i ppf "Pexp_record_unboxed_product\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; | Pexp_field (e, li) -> line i ppf "Pexp_field\n"; expression i ppf e; longident_loc i ppf li; + | Pexp_unboxed_field (e, li) -> + line i ppf "Pexp_unboxed_field\n"; + expression i ppf e; + longident_loc i ppf li; | Pexp_setfield (e1, li, e2) -> line i ppf "Pexp_setfield\n"; expression i ppf e1; @@ -592,6 +603,9 @@ and type_kind i ppf x = | Ptype_record l -> line i ppf "Ptype_record\n"; list (i+1) label_decl ppf l; + | Ptype_record_unboxed_product l -> + line i ppf "Ptype_record_unboxed_product\n"; + list (i+1) label_decl ppf l; | Ptype_open -> line i ppf "Ptype_open\n"; diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index 5283f0f2bcb..8fd16dfcc82 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -286,6 +286,9 @@ and pattern i ppf x = | Ppat_record (l, c) -> line i ppf "Ppat_record %a\n" fmt_closed_flag c; list i longident_x_pattern ppf l; + | Ppat_record_unboxed_product (l, c) -> + line i ppf "Ppat_record_unboxed_product %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l; | Ppat_array (mut, l) -> line i ppf "Ppat_array %a\n" fmt_mutable_flag mut; list i pattern ppf l; @@ -362,10 +365,18 @@ and expression i ppf x = line i ppf "Pexp_record\n"; list i longident_x_expression ppf l; option i expression ppf eo; + | Pexp_record_unboxed_product (l, eo) -> + line i ppf "Pexp_record_unboxed_product\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; | Pexp_field (e, li) -> line i ppf "Pexp_field\n"; expression i ppf e; longident_loc i ppf li; + | Pexp_unboxed_field (e, li) -> + line i ppf "Pexp_unboxed_field\n"; + expression i ppf e; + longident_loc i ppf li; | Pexp_setfield (e1, li, e2) -> line i ppf "Pexp_setfield\n"; expression i ppf e1; @@ -622,6 +633,9 @@ and type_kind i ppf x = | Ptype_record l -> line i ppf "Ptype_record\n"; list (i+1) label_decl ppf l; + | Ptype_record_unboxed_product l -> + line i ppf "Ptype_record_unboxed_product\n"; + list (i+1) label_decl ppf l; | Ptype_open -> line i ppf "Ptype_open\n"; diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index 6c9314ee7ac..cec9dab8715 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -845,6 +845,18 @@ result: 7 - : unit = () |}] +(*******************) +(* Unboxed records *) + +type 'a with_idx : value & immediate = #{ data : 'a ; i : int } +let idx #{ data = _ ; i } = i +let inc r = #{ r with i = r.#i + 1 } +[%%expect{| +type 'a with_idx = #{ data : 'a; i : int; } +val idx : 'a with_idx -> int @@ global many = +val inc : 'a with_idx -> 'a with_idx @@ global many = +|}] + (***************) (* Modal kinds *) diff --git a/testsuite/tests/tool-toplevel/pr6468.compilers.reference b/testsuite/tests/tool-toplevel/pr6468.compilers.reference index 4fd188a76ff..17186e5619e 100644 --- a/testsuite/tests/tool-toplevel/pr6468.compilers.reference +++ b/testsuite/tests/tool-toplevel/pr6468.compilers.reference @@ -7,8 +7,48 @@ Line 1, characters 11-15: Warning 21 [nonreturning-statement]: this statement never returns (or has an unsound type.) val g : unit -> int = +<<<<<<< HEAD Exception: E. Raised at f in file "//toplevel//", line 4, characters 11-18 +||||||| parent of 80bf6fd31d (Basic unboxed records) +Exception: Not_found. +Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 +Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 +Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 +Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 +Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 +Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Translmod.toplevel_name in file "lambda/translmod.ml", line 1599, characters 6-40 +Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 547, characters 13-28 +Called from Simplif.simplify_lets.simplif in file "lambda/simplif.ml", line 571, characters 8-28 +Re-raised at f in file "//toplevel//", line 2, characters 11-26 +======= +Exception: Not_found. +Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 +Called from Env.find_type_data in file "typing/env.ml", line 1335, characters 8-48 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 435, characters 10-40 +Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 +Called from Env.find_type_data in file "typing/env.ml", line 1335, characters 8-48 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 435, characters 10-40 +Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 +Called from Env.find_type_data in file "typing/env.ml", line 1335, characters 8-48 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 435, characters 10-40 +Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 +Called from Translmod.toplevel_name in file "lambda/translmod.ml", line 1599, characters 6-40 +Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 547, characters 13-28 +Called from Simplif.simplify_lets.simplif in file "lambda/simplif.ml", line 571, characters 8-28 +Re-raised at f in file "//toplevel//", line 2, characters 11-26 +>>>>>>> 80bf6fd31d (Basic unboxed records) Called from g in file "//toplevel//", line 1, characters 11-15 Called from in file "//toplevel//", line 1, characters 0-4 Called from Topeval.load_lambda in file "toplevel/byte/topeval.ml", line 87, characters 4-14 diff --git a/testsuite/tests/typing-layouts-bits32/basics.ml b/testsuite/tests/typing-layouts-bits32/basics.ml index 2b1b6289893..8727387a5ad 100644 --- a/testsuite/tests/typing-layouts-bits32/basics.ml +++ b/testsuite/tests/typing-layouts-bits32/basics.ml @@ -221,7 +221,7 @@ Line 1, characters 14-26: 1 | type t5_3 = { x : t_bits32 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_bits32" has layout "bits32". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; @@ -268,7 +268,7 @@ Line 1, characters 21-33: 1 | type t5_6_1 = A of { x : t_bits32 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_bits32" has layout "bits32". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; (****************************************************) diff --git a/testsuite/tests/typing-layouts-bits32/basics_alpha.ml b/testsuite/tests/typing-layouts-bits32/basics_alpha.ml index e47fe2f0f33..25fc86b47c6 100644 --- a/testsuite/tests/typing-layouts-bits32/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-bits32/basics_alpha.ml @@ -219,7 +219,7 @@ Line 1, characters 14-26: 1 | type t5_3 = { x : t_bits32 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_bits32" has layout "bits32". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; diff --git a/testsuite/tests/typing-layouts-bits64/basics.ml b/testsuite/tests/typing-layouts-bits64/basics.ml index c36247c45ed..93ccf5f5117 100644 --- a/testsuite/tests/typing-layouts-bits64/basics.ml +++ b/testsuite/tests/typing-layouts-bits64/basics.ml @@ -221,7 +221,7 @@ Line 1, characters 14-26: 1 | type t5_3 = { x : t_bits64 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_bits64" has layout "bits64". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_bits64;; @@ -268,7 +268,7 @@ Line 1, characters 21-33: 1 | type t5_6_1 = A of { x : t_bits64 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_bits64" has layout "bits64". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; (****************************************************) diff --git a/testsuite/tests/typing-layouts-bits64/basics_alpha.ml b/testsuite/tests/typing-layouts-bits64/basics_alpha.ml index 51b5eca3def..4149d8fe252 100644 --- a/testsuite/tests/typing-layouts-bits64/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-bits64/basics_alpha.ml @@ -219,7 +219,7 @@ Line 1, characters 14-26: 1 | type t5_3 = { x : t_bits64 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_bits64" has layout "bits64". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_bits64;; diff --git a/testsuite/tests/typing-layouts-float32/basics.ml b/testsuite/tests/typing-layouts-float32/basics.ml index b19d79b0dc6..f9d9b009535 100644 --- a/testsuite/tests/typing-layouts-float32/basics.ml +++ b/testsuite/tests/typing-layouts-float32/basics.ml @@ -212,7 +212,7 @@ Line 1, characters 14-27: 1 | type t5_3 = { x : t_float32 } [@@unboxed];; ^^^^^^^^^^^^^ Error: Type "t_float32" has layout "float32". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_float32;; @@ -240,7 +240,7 @@ Line 1, characters 21-34: 1 | type t5_6_1 = A of { x : t_float32 } [@@unboxed];; ^^^^^^^^^^^^^ Error: Type "t_float32" has layout "float32". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; type ('a : float32) t5_7 = A of int diff --git a/testsuite/tests/typing-layouts-float64/basics.ml b/testsuite/tests/typing-layouts-float64/basics.ml index 573ecce486b..2a362033ed3 100644 --- a/testsuite/tests/typing-layouts-float64/basics.ml +++ b/testsuite/tests/typing-layouts-float64/basics.ml @@ -213,7 +213,7 @@ Line 1, characters 14-27: 1 | type t5_3 = { x : t_float64 } [@@unboxed];; ^^^^^^^^^^^^^ Error: Type "t_float64" has layout "float64". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; (* all-float64 constructor args are also allowed, as are some constructors that @@ -245,7 +245,7 @@ Line 1, characters 21-34: 1 | type t5_6_1 = A of { x : t_float64 } [@@unboxed];; ^^^^^^^^^^^^^ Error: Type "t_float64" has layout "float64". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; type ('a : float64) t5_7 = A of int diff --git a/testsuite/tests/typing-layouts-products/basics.ml b/testsuite/tests/typing-layouts-products/basics.ml index 786f99b7b90..f9a16f0396f 100644 --- a/testsuite/tests/typing-layouts-products/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics.ml @@ -754,7 +754,7 @@ Line 1, characters 37-43: 1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] ^^^^^^ Error: Type "'a" has layout "value & value". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}] type t = A of { x : #(int * int) } [@@unboxed] @@ -763,7 +763,7 @@ Line 1, characters 16-32: 1 | type t = A of { x : #(int * int) } [@@unboxed] ^^^^^^^^^^^^^^^^ Error: Type "#(int * int)" has layout "value & value". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}] (**************************************) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml new file mode 100644 index 00000000000..de091ba0be0 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -0,0 +1,493 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +open Stdlib_upstream_compatible + +(**************************************************************************) +(* Basic examples: construction, functional updates, projection, matching *) + +module With_index : sig + type 'a t : value & immediate + type 'a t_boxed : value + + val unbox_t : 'a t_boxed -> 'a t + val box_t : 'a t -> 'a t_boxed + val inc : 'a t -> 'a t +end = struct + type 'a t = #{ data : 'a ; i : int } + type 'a t_boxed = { data : 'a ; i : int } + + let unbox_t { data ; i = idx } = #{ data ; i = idx } + let box_t #{ data ; i = idx } = { data ; i = idx } + let inc t = #{ t with i = t.#i + 1 } +end +[%%expect{| +module With_index : + sig + type 'a t : value & immediate + type 'a t_boxed + val unbox_t : 'a t_boxed -> 'a t + val box_t : 'a t -> 'a t_boxed + val inc : 'a t -> 'a t + end +|}] + +(* We can change the type of an unboxed record with a functional update. *) + +type ('a : value & value) t = #{ x : 'a ; y : string } +let f : #(int * string) t -> #(string * int) t = + fun (#{ x = #(i, s); y } as r) -> #{ r with x = #(s, i) } +[%%expect{| +type ('a : value & value) t = #{ x : 'a; y : string; } +val f : #(int * string) t -> #(string * int) t = +|}] + +(* As-patterns, partial patterns *) + +type t = #{ i: int; j : int } +let add (#{ i; _} as r) = i + r.#j +[%%expect{| +type t = #{ i : int; j : int; } +val add : t -> int = +|}] + + +(* Unboxed records are not subject to the mixed-block restriction *) + +type t = #{ f : float# ; i : int } +[%%expect{| +type t = #{ f : float#; i : int; } +|}] + +let mk_t () = + #{ f = #3.14; i = 0 } +[%%expect{| +val mk_t : unit -> t = +|}] + +let take_t #{ f; i } = + #{ f; i } +[%%expect{| +val take_t : t -> t = +|}] + +let combine_ts #{ f = _f1; i = i1 } #{ f = f2; i = _i2 } = + #{ f = f2 ; i = i1 } +[%%expect{| +val combine_ts : t -> t -> t = +|}] + +(* We still cannot have top-level products *) + +let disallowed = #{ f = #3.14; i = 0 } +[%%expect{| +Line 1, characters 4-14: +1 | let disallowed = #{ f = #3.14; i = 0 } + ^^^^^^^^^^ +Error: Types of top-level module bindings must have layout "value", but + the type of "disallowed" has layout "float64 & value". +|}] + +(* However, we can have a top-level unboxed record if its kind is value *) + +type wrap_int = #{ i : int } +type wrap_wrap_int = #{ wi : wrap_int} +let w5 = #{ i = 5 } +let ww5 = #{ wi = #{ i = 5 }} +[%%expect{| +type wrap_int = #{ i : int; } +type wrap_wrap_int = #{ wi : wrap_int; } +val w5 : wrap_int = #{i = 5} +val ww5 : wrap_wrap_int = #{wi = #{i = 5}} +|}] + +type t = #{ s : string } +let s = #{ s = "hi" } +[%%expect{| +type t = #{ s : string; } +val s : t = #{s = "hi"} +|}] + +(* Accessing inner products *) + +type t = #{ is: #(int * int) } + +let add t = + let #(x, y) = t.#is in + x + y +[%%expect{| +type t = #{ is : #(int * int); } +val add : t -> int = +|}] + +(******************************) +(* Basic unboxed record types *) + +type t1 = #{ i1 : int } +type t2 = #{ f2: float# ; i2: int ; s2 : string} +type t3 = #{ f3: float# } +[%%expect{| +type t1 = #{ i1 : int; } +type t2 = #{ f2 : float#; i2 : int; s2 : string; } +type t3 = #{ f3 : float#; } +|}] + +(* You can put unboxed and normal products inside unboxed products *) + +type t4 = #(string * t2) +type t5 = #{ r5 : t1 ; r5_ : t2 ; s5 : string} +[%%expect{| +type t4 = #(string * t2) +type t5 = #{ r5 : t1; r5_ : t2; s5 : string; } +|}] + +(* But you can't put unboxed products into normal tuples and records (yet) *) + +type bad = { r : t2 } +[%%expect{| +Line 1, characters 0-21: +1 | type bad = { r : t2 } + ^^^^^^^^^^^^^^^^^^^^^ +Error: Type "t2" has layout "float64 & value & value". + Records may not yet contain types of this layout. +|}] + +type bad = t2 * t2 +[%%expect{| +Line 1, characters 11-13: +1 | type bad = t2 * t2 + ^^ +Error: Tuple element types must have layout value. + The layout of "t2" is float64 & value & value + because of the definition of t2 at line 2, characters 0-48. + But the layout of "t2" must be a sublayout of value + because it's the type of a tuple element. +|}] + +(*********************************) +(* Parameterized unboxed records *) + +type 'a t = #{ x : 'a } +let convert (r : int t) : int t = + { r with x = string } +[%%expect{| +type 'a t = #{ x : 'a; } +Line 3, characters 2-23: +3 | { r with x = string } + ^^^^^^^^^^^^^^^^^^^^^ +Error: This expression should not be a record, the expected type is "int t" +|}] + +(* Checks of constrain_type_jkind *) + +type 'a r = #{ i: 'a } +type int_r : immediate = int r +[%%expect{| +type 'a r = #{ i : 'a; } +type int_r = int r +|}] + +type ('a : float64) t = #{ i: 'a } +type floatu_t : float64 = float# t +[%%expect{| +type ('a : float64) t = #{ i : 'a; } +type floatu_t = float# t +|}] + +type 'a t = #{ i : 'a ; j : 'a } +type int_t : immediate & immediate = int t +[%%expect{| +type 'a t = #{ i : 'a; j : 'a; } +type int_t = int t +|}] + +type ('a : float64) t = #{ i : 'a ; j : 'a } +type floatu_t : float64 & float64 = float# t +[%%expect{| +type ('a : float64) t = #{ i : 'a; j : 'a; } +type floatu_t = float# t +|}] + +type 'a t = 'a list +type s = #{ lbl : s t } +[%%expect{| +type 'a t = 'a list +type s = #{ lbl : s t; } +|}] + +type ('a : float64) t = #{ x : string; y : 'a } +[%%expect{| +type ('a : float64) t = #{ x : string; y : 'a; } +|}];; + +type ('a : float64, 'b : immediate) t = #{ x : string; y : 'a; z : 'b } +[%%expect{| +type ('a : float64, 'b : immediate) t = #{ x : string; y : 'a; z : 'b; } +|}];; + +(***************************************************) +(* Simple kind annotations on unboxed record types *) + +type t1 : immediate = #{ i1 : int } +type t2 : float64 & immediate & value = #{ f2: float# ; i2: int ; s2 : string} +type t3 : float64 = #{ f3: float# } +type t5 : immediate & (float64 & immediate & value) & value = #{ r5 : t1 ; r5_ : t2 ; s5 : string} +[%%expect{| +type t1 = #{ i1 : int; } +type t2 = #{ f2 : float#; i2 : int; s2 : string; } +type t3 = #{ f3 : float#; } +type t5 = #{ r5 : t1; r5_ : t2; s5 : string; } +|}] + +type t5_bad : immediate & float64 & immediate & value & value = #{ r5 : t1 ; r5_ : t2 ; s5 : string} +[%%expect{| +Line 1, characters 0-100: +1 | type t5_bad : immediate & float64 & immediate & value & value = #{ r5 : t1 ; r5_ : t2 ; s5 : string} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The layout of type "t5_bad" is value & (float64 & value & value) & value + because it is an unboxed record. + But the layout of type "t5_bad" must be a sublayout of value & float64 & value & value & value + because of the annotation on the declaration of the type t5_bad. +|}] + +(**********************) +(* Signature checking *) + +(* Must expose non-value kind *) +module M : sig + type t +end = struct + type t = #{ s: string; r: string } +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ s: string; r: string } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = #{ s : string; r : string; } end + is not included in + sig type t end + Type declarations do not match: + type t = #{ s : string; r : string; } + is not included in + type t + The layout of the first is value & value + because of the definition of t at line 4, characters 2-36. + But the layout of the first must be a sublayout of value + because of the definition of t at line 2, characters 2-8. +|}] + +module M : sig + type t = #{ f : float# ; s : string } +end = struct + type t = #{ f : float# ; s : string } +end +[%%expect{| +module M : sig type t = #{ f : float#; s : string; } end +|}] + +module M2 : sig + type t : float64 & value +end = struct + include M +end +[%%expect{| +module M2 : sig type t : float64 & value end +|}] + +module M : sig + type t : float64 & value +end = struct + type t = #{ i : float# ; s : string } +end +[%%expect{| +module M : sig type t : float64 & value end +|}] + +module M : sig + type t : float64 & value +end = struct + type t = #{ i : float# ; s : string } +end +[%%expect{| +module M : sig type t : float64 & value end +|}] + +module M : sig + type t + type tup = t * t +end = struct + type t = #{ s : string } + type tup = t * t +end +[%%expect{| +module M : sig type t type tup = t * t end +|}] + +(****************************) +(* Types with external mode *) + +type ('a : value mod external_) t = #{ x : float#; y : 'a } +type ('a : immediate) t = #{ x : float#; y : 'a } +[%%expect {| +type ('a : value mod external_) t = #{ x : float#; y : 'a; } +type ('a : immediate) t = #{ x : float#; y : 'a; } +|}] + +type u : value mod external_ +type t = #{ x : float#; y : u } +[%%expect {| +type u : value mod external_ +type t = #{ x : float#; y : u; } +|}] + +type u : immediate +type t = #{ x : float#; y : u } +[%%expect {| +type u : immediate +type t = #{ x : float#; y : u; } +|}] + +(* Recursive groups *) + +type ('a : float64) t_float64_id = 'a +type ('a : immediate) t_immediate_id = 'a +[%%expect{| +type ('a : float64) t_float64_id = 'a +type ('a : immediate) t_immediate_id = 'a +|}];; + +type 'a t_float = 'a t_float64_id +and 'a t_imm = 'a t_immediate_id +and ('a, 'b, 'ptr) t = + #{ptr : 'ptr; x : 'a; y : 'a t_float; z : 'b; w : 'b t_imm} +[%%expect{| +Line 4, characters 28-38: +4 | #{ptr : 'ptr; x : 'a; y : 'a t_float; z : 'b; w : 'b t_imm} + ^^^^^^^^^^ +Error: Layout mismatch in final type declaration consistency check. + This is most often caused by the fact that type inference is not + clever enough to propagate layouts through variables in different + declarations. It is also not clever enough to produce a good error + message, so we'll say this instead: + The layout of 'a is float64 + because of the definition of t_float64_id at line 1, characters 0-37. + But the layout of 'a must overlap with value + because it instantiates an unannotated type parameter of t, + defaulted to layout value. + A good next step is to add a layout annotation on a parameter to + the declaration where this error is reported. +|}];; + +type 'a t_float = 'a t_float64_id +and 'a t_imm = 'a t_immediate_id +and ('a : float64, 'b : immediate, 'ptr) t = + #{ptr : 'ptr; x : 'a; y : 'a t_float; z : 'b; w : 'b t_imm} +[%%expect{| +type ('a : float64) t_float = 'a t_float64_id +and ('a : immediate) t_imm = 'a t_immediate_id +and ('a : float64, 'b : immediate, 'ptr) t = #{ + ptr : 'ptr; + x : 'a; + y : 'a t_float; + z : 'b; + w : 'b t_imm; +} +|}];; + +(* Fields can be mutable, but we can't set them yet *) + +type r = #{ mutable i : int } + +let f = #{ i = 1 } + +(* We don't yet have syntax for setting an unboxed record field. + However, the below, using a boxed set field, will never work. *) + +let () = f.i <- 2 +[%%expect{| +type r = #{ mutable i : int; } +val f : r = #{i = 1} +Line 8, characters 9-10: +8 | let () = f.i <- 2 + ^ +Error: This expression has type "r" which is not a record type. +|}] + +(********************************) +(* Private unboxed record types *) + +module M : sig + type t = #{ x : int; y : bool } +end = struct + type t = private #{ x : int; y : bool } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private #{ x : int; y : bool } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private #{ x : int; y : bool; } end + is not included in + sig type t = #{ x : int; y : bool; } end + Type declarations do not match: + type t = private #{ x : int; y : bool; } + is not included in + type t = #{ x : int; y : bool; } + A private unboxed record constructor would be revealed. +|}];; + + +module M : sig + type t = #{ x : int } +end = struct + type t = private #{ x : int; y : bool } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private #{ x : int; y : bool } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private #{ x : int; y : bool; } end + is not included in + sig type t = #{ x : int; } end + Type declarations do not match: + type t = private #{ x : int; y : bool; } + is not included in + type t = #{ x : int; } + A private unboxed record constructor would be revealed. +|}];; + +module M : sig + type t = #{ x : int; y : bool } +end = struct + type t = private #{ x : int } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private #{ x : int } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private #{ x : int; } end + is not included in + sig type t = #{ x : int; y : bool; } end + Type declarations do not match: + type t = private #{ x : int; } + is not included in + type t = #{ x : int; y : bool; } + A private unboxed record constructor would be revealed. +|}];; diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml new file mode 100644 index 00000000000..5f71247652d --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml @@ -0,0 +1,125 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +(* This test is adapted from [testsuite/tests/typing-layouts-products/basics_alpha.ml] *) + +(* [t3] is allowed for unboxed tuples, and disallowed for (un)boxed records *) +type t1 : any mod non_null +type t2 : value +type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2};; +[%%expect{| +type t1 : any mod non_null +type t2 +Line 3, characters 32-41: +3 | type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2};; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-26. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +type t1 : any mod non_null +type t2 : value +type t3 : any & value mod non_null = #{ t1 : t1 ; t2 : t2};; +[%%expect{| +type t1 : any mod non_null +type t2 +Line 3, characters 40-49: +3 | type t3 : any & value mod non_null = #{ t1 : t1 ; t2 : t2};; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-26. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +type t1 : any mod non_null +type t2 : value +type t3 : (any mod non_null) & (value mod non_null) = #{ t1 : t1 ; t2 : t2};; +[%%expect{| +type t1 : any mod non_null +type t2 +Line 3, characters 57-66: +3 | type t3 : (any mod non_null) & (value mod non_null) = #{ t1 : t1 ; t2 : t2};; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-26. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +type t1 : any +type t2 : any mod non_null +type t3 : any & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 40-49: +3 | type t3 : any & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-13. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +(* Should not be allowed for either unboxed tuples or (un)boxed records. *) +type t1 : any +type t2 : any mod non_null +type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2 };; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 32-41: +3 | type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2 };; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-13. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +type t1 : any +type t2 : any mod non_null +type t3 : any & any mod non_null = #{ t1 : t1 ; t2 : t2 };; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 38-47: +3 | type t3 : any & any mod non_null = #{ t1 : t1 ; t2 : t2 };; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-13. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +type t1 : any +type t2 : any mod non_null +type t3 : (any mod non_null) & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 55-64: +3 | type t3 : (any mod non_null) & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; + ^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 1, characters 0-13. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml new file mode 100644 index 00000000000..dc701d9cf85 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml @@ -0,0 +1,128 @@ +(* TEST + flags = "-extension layouts_beta"; + expect; +*) +(* This test is adapted from + [testsuite/tests/typing-unboxed-types/test.ml] *) + +(* Check the unboxing *) + +(* For records *) +type t2 = #{ f : string } ;; +[%%expect{| +type t2 = #{ f : string; } +|}];; + +let x = #{ f = "foo" } in +Obj.repr x == Obj.repr x.#f +;; +[%%expect{| +- : bool = true +|}];; + +(* Representation mismatch between module and signature must be rejected *) +module M : sig + type t = { a : string } +end = struct + type t = #{ a : string } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ a : string } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = #{ a : string; } end + is not included in + sig type t = { a : string; } end + Type declarations do not match: + type t = #{ a : string; } + is not included in + type t = { a : string; } + The first is an unboxed record, but the second is a record. +|}];; + +(* Check interference with representation of float arrays. *) +type t11 = #{ f : float };; +[%%expect{| +type t11 = #{ f : float; } +|}];; +let x = Array.make 10 #{ f = 3.14 } (* represented as a flat array *) +and f (a : t11 array) = a.(0) (* might wrongly assume an array of pointers *) +in assert (f x = #{ f = 3.14});; +[%%expect{| +- : unit = () +|}];; + +(* Check for a potential infinite loop in the typing algorithm. *) +type 'a t12 : value = #{ a : 'a t12 };; +[%%expect{| +type 'a t12 = #{ a : 'a t12; } +|}];; +let f (a : int t12 array) = a.(0);; +[%%expect{| +val f : int t12 array -> int t12 = +|}];; + +(* should work *) +type t14;; +type t15 = #{ a : t14 };; +[%%expect{| +type t14 +type t15 = #{ a : t14; } +|}];; + +(* should fail because the compiler knows that t is actually float and + optimizes the record's representation *) +module S : sig + type t + type u = { f1 : t; f2 : t } +end = struct + type t = #{ a : float } + type u = { f1 : t; f2 : t } +end;; +[%%expect{| +Lines 4-7, characters 6-3: +4 | ......struct +5 | type t = #{ a : float } +6 | type u = { f1 : t; f2 : t } +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = #{ a : float; } type u = { f1 : t; f2 : t; } end + is not included in + sig type t type u = { f1 : t; f2 : t; } end + Type declarations do not match: + type u = { f1 : t; f2 : t; } + is not included in + type u = { f1 : t; f2 : t; } + Their internal representations differ: + the first declaration uses unboxed float representation. +|}];; + +(* implementing [@@immediate] with unboxed records: this works because the + representation of [t] is [int] + *) +module T : sig + type t [@@immediate] +end = struct + type t = #{ i : int } +end;; +[%%expect{| +module T : sig type t : immediate end +|}];; + + +(* MPR#7682 *) +type f = #{field: 'a. 'a list} ;; +let g = Array.make 10 #{ field=[] };; +let h = g.(5);; +[%%expect{| +type f = #{ field : 'a. 'a list; } +val g : f array = + [|#{field = []}; #{field = []}; #{field = []}; #{field = []}; + #{field = []}; #{field = []}; #{field = []}; #{field = []}; + #{field = []}; #{field = []}|] +val h : f = #{field = []} +|}];; diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml new file mode 100644 index 00000000000..0e93f3582f4 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -0,0 +1,1019 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_beta"; + { + expect; + } +*) + +(* These tests are adapted from the tuple tests in + [testsuite/tests/typing-layouts-products/basics.ml] *) + +open Stdlib_upstream_compatible + +(**********************************************************) +(* Test 1: Basic unboxed product layouts and record types. *) + +type t2 = #{ s : string; f : float#; i : int } +[%%expect{| +type t2 = #{ s : string; f : float#; i : int; } +|}] + +(* You can put unboxed and normal products inside unboxed products *) +type t4_inner2 = #{ b : bool; i : int } +type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option } +type t4 = #{ s : string; t4_inner : t4_inner } +[%%expect{| +type t4_inner2 = #{ b : bool; i : int; } +type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option; } +type t4 = #{ s : string; t4_inner : t4_inner; } +|}] + +(* But you can't put unboxed products into tuples (yet) *) +type t_nope_inner = #{ s : string; b : bool } +type t_nope = string * t_nope_inner +[%%expect{| +type t_nope_inner = #{ s : string; b : bool; } +Line 2, characters 23-35: +2 | type t_nope = string * t_nope_inner + ^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of "t_nope_inner" is value & value + because of the definition of t_nope_inner at line 1, characters 0-45. + But the layout of "t_nope_inner" must be a sublayout of value + because it's the type of a tuple element. +|}] + +(********************************************) +(* Test 2: Simple kind annotations on types *) + +type t1 : float64 & value = #{ f : float#; b : bool } +type t2 : value & (float64 & value) = #(string option * t1) +[%%expect{| +type t1 = #{ f : float#; b : bool; } +type t2 = #(string option * t1) +|}] + +type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } +[%%expect{| +Line 1, characters 0-74: +1 | type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The layout of type "t2_wrong" is value & (float64 & value) + because it is an unboxed record. + But the layout of type "t2_wrong" must be a sublayout of value & float64 & value + because of the annotation on the declaration of the type t2_wrong. +|}] + +type ('a : value & bits64) t3 = 'a +type t4_inner = #{ i : int; i64 : int64# } +type t4 = t4_inner t3 +type t5 = t4 t3 +[%%expect{| +type ('a : value & bits64) t3 = 'a +type t4_inner = #{ i : int; i64 : int64#; } +type t4 = t4_inner t3 +type t5 = t4 t3 +|}] + +type t4_wrong_inner = #{ i1 : int; i2 : int } +type t4_wrong = t4_wrong_inner t3 +[%%expect{| +type t4_wrong_inner = #{ i1 : int; i2 : int; } +Line 2, characters 16-30: +2 | type t4_wrong = t4_wrong_inner t3 + ^^^^^^^^^^^^^^ +Error: This type "t4_wrong_inner" should be an instance of type + "('a : value & bits64)" + The layout of t4_wrong_inner is value & value + because of the definition of t4_wrong_inner at line 1, characters 0-45. + But the layout of t4_wrong_inner must be a sublayout of value & bits64 + because of the definition of t3 at line 1, characters 0-34. +|}] + +(* some mutually recusive types *) +type ('a : value & bits64) t6 = 'a t7 +and 'a t7 = { x : 'a t6 } +[%%expect{| +type ('a : value & bits64) t6 = 'a t7 +and ('a : value & bits64) t7 = { x : 'a t6; } +|}] + +type t9_record = #{ i : int; i64 : int64# } +type t9 = t9_record t7 +type t10 = bool t6 +[%%expect{| +type t9_record = #{ i : int; i64 : int64#; } +type t9 = t9_record t7 +Line 3, characters 11-15: +3 | type t10 = bool t6 + ^^^^ +Error: This type "bool" should be an instance of type "('a : value & bits64)" + The layout of bool is value + because it's an enumeration variant type (all constructors are constant). + But the layout of bool must be a sublayout of value & bits64 + because of the definition of t6 at line 1, characters 0-37. +|}] + +(* CR layouts v7.2: The below has a very bad error message. *) +type t6_wrong_inner_record = #{ i : int; i64 : int64 } +and ('a : value & bits64) t6_wrong = 'a t7_wrong +and 'a t7_wrong = { x : t6_wrong_inner_record t6_wrong } +[%%expect{| +Line 1, characters 0-54: +1 | type t6_wrong_inner_record = #{ i : int; i64 : int64 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of t6_wrong_inner_record is value + because it is the primitive type int64. + But the layout of t6_wrong_inner_record must be a sublayout of bits64 + because of the annotation on 'a in the declaration of the type + t6_wrong. +|}] + +(* Just like t6/t7, but with the annotation on the other (the order doesn't + matter) *) +type 'a t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11 } +[%%expect{| +type ('a : value & bits64) t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11; } +|}] + +(*********************************************************************) +(* Test 3: Unboxed records are allowed in function args and returns *) + +type t1_left = #{ i : int; b : bool } +type t1_right_inner = #{ i64 : int64#; so : string option } +type t1_right = #{ i : int; f : float#; inner : t1_right_inner } +type t1 = t1_left -> t1_right +[%%expect{| +type t1_left = #{ i : int; b : bool; } +type t1_right_inner = #{ i64 : int64#; so : string option; } +type t1_right = #{ i : int; f : float#; inner : t1_right_inner; } +type t1 = t1_left -> t1_right +|}] + +type make_record_result = #{ f : float#; s : string } +let f_make_an_unboxed_record (x : string) (y : float#) = #{ f = y; s = x } + +type inner = #{ f1 : float#; f2 : float# } +type t = #{ s : string; inner : inner } +let f_pull_apart_an_unboxed_record (x : t) = + match x with + | #{ s; inner = #{ f1; f2 } } -> + if s = "mul" then + Float_u.mul f1 f2 + else + Float_u.add f1 f2 +[%%expect{| +type make_record_result = #{ f : float#; s : string; } +val f_make_an_unboxed_record : string -> float# -> make_record_result = +type inner = #{ f1 : float#; f2 : float#; } +type t = #{ s : string; inner : inner; } +val f_pull_apart_an_unboxed_record : + t -> Stdlib_upstream_compatible.Float_u.t = +|}] + + +module type S = sig + type a + type b + type c + type d + type e + type f + type g + type h +end + +module F(X : S) = struct + include X + type mix_input_inner2 = #{ d : d; e : e } + type mix_input_inner = #{ c : c; inner2 : mix_input_inner2 } + type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f } + type mix_output_inner2 = #{ f : f; e : e } + type mix_output_inner = #{ c : c; inner2 : mix_output_inner2 } + type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d } + let f_mix_up_an_unboxed_record (x : mix_input) = + let #{ a; b; inner = #{ c; inner2 = #{ d; e } }; f } = x in + #{ b = b; inner = #{ c = c; inner2 = #{ f = f; e = e } }; a = a; d = d } + + type take_few_input1 = #{ a : a; b : b } + type take_few_input3 = #{ d : d; e : e } + type take_few_input5 = #{ g : g; h : h } + type take_few_output = #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } + + let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 (x3 : take_few_input3) x4 (x5 : take_few_input5) = + let #{ a; b } = x1 in + let #{ d; e } = x3 in + let #{ g; h } = x5 in + #{ h = h; g2 = g; x4 = x4; e2 = e; d = d; x2 = x2; b = b; a2 = a } +end +[%%expect{| +module type S = + sig type a type b type c type d type e type f type g type h end +module F : + functor (X : S) -> + sig + type a = X.a + type b = X.b + type c = X.c + type d = X.d + type e = X.e + type f = X.f + type g = X.g + type h = X.h + type mix_input_inner2 = #{ d : d; e : e; } + type mix_input_inner = #{ c : c; inner2 : mix_input_inner2; } + type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f; } + type mix_output_inner2 = #{ f : f; e : e; } + type mix_output_inner = #{ c : c; inner2 : mix_output_inner2; } + type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d; } + val f_mix_up_an_unboxed_record : mix_input -> mix_output + type take_few_input1 = #{ a : a; b : b; } + type take_few_input3 = #{ d : d; e : e; } + type take_few_input5 = #{ g : g; h : h; } + type take_few_output = #{ + h : h; + g2 : g; + x4 : f; + e2 : e; + d : d; + x2 : c; + b : b; + a2 : a; + } + val f_take_a_few_unboxed_records : + take_few_input1 -> + c -> take_few_input3 -> f -> take_few_input5 -> take_few_output + end +|}] + +[%%expect{| +|}] + +(***************************************************) +(* Test 4: Unboxed products don't go in structures *) + +type poly_var_inner = #{ i : int; b : bool } +type poly_var_type = [ `Foo of poly_var_inner ] +[%%expect{| +type poly_var_inner = #{ i : int; b : bool; } +Line 2, characters 31-45: +2 | type poly_var_type = [ `Foo of poly_var_inner ] + ^^^^^^^^^^^^^^ +Error: Polymorphic variant constructor argument types must have layout value. + The layout of "poly_var_inner" is value & value + because of the definition of poly_var_inner at line 1, characters 0-44. + But the layout of "poly_var_inner" must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type poly_var_term_record = #{ i : int; i2 : int } +let poly_var_term = `Foo #{ i = 1; i2 = 2 } +[%%expect{| +type poly_var_term_record = #{ i : int; i2 : int; } +Line 2, characters 25-43: +2 | let poly_var_term = `Foo #{ i = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^ +Error: This expression has type "poly_var_term_record" + but an expression was expected of type "('a : value)" + The layout of poly_var_term_record is value & value + because of the definition of poly_var_term_record at line 1, characters 0-50. + But the layout of poly_var_term_record must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type record_inner = #{ b : bool; f : float# } +type tuple_type = (int * record_inner) +[%%expect{| +type record_inner = #{ b : bool; f : float#; } +Line 2, characters 25-37: +2 | type tuple_type = (int * record_inner) + ^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of "record_inner" is value & float64 + because of the definition of record_inner at line 1, characters 0-45. + But the layout of "record_inner" must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record = #{ i : int; i2 : int } +let record_term = ("hi", #{ i = 1; i2 = 2 }) +[%%expect{| +type record = #{ i : int; i2 : int; } +Line 2, characters 25-43: +2 | let record_term = ("hi", #{ i = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^ +Error: This expression has type "record" but an expression was expected of type + "('a : value)" + The layout of record is value & value + because of the definition of record at line 1, characters 0-36. + But the layout of record must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record_inner = #{ i : int; b : bool } +type record = { x : record_inner } +[%%expect{| +type record_inner = #{ i : int; b : bool; } +Line 2, characters 0-34: +2 | type record = { x : record_inner } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "record_inner" has layout "value & value". + Records may not yet contain types of this layout. +|}] + +type inlined_inner = #{ i : int; b : bool } +type inlined_record = A of { x : inlined_inner } +[%%expect{| +type inlined_inner = #{ i : int; b : bool; } +Line 2, characters 22-48: +2 | type inlined_record = A of { x : inlined_inner } + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "inlined_inner" has layout "value & value". + Inlined records may not yet contain types of this layout. +|}] + +type variant_inner = #{ i : int; b : bool } +type variant = A of variant_inner +[%%expect{| +type variant_inner = #{ i : int; b : bool; } +Line 2, characters 15-33: +2 | type variant = A of variant_inner + ^^^^^^^^^^^^^^^^^^ +Error: Type "variant_inner" has layout "value & value". + Variants may not yet contain types of this layout. +|}] + +type sig_inner = #{ i : int; b : bool } +module type S = sig + val x : sig_inner +end +[%%expect{| +type sig_inner = #{ i : int; b : bool; } +Line 3, characters 10-19: +3 | val x : sig_inner + ^^^^^^^^^ +Error: This type signature for "x" is not a value type. + The layout of type sig_inner is value & value + because of the definition of sig_inner at line 1, characters 0-39. + But the layout of type sig_inner must be a sublayout of value + because it's the type of something stored in a module structure. +|}] + +type m_record = #{ i1 : int; i2 : int } +module M = struct + let x = #{ i1 = 1; i2 = 2 } +end +[%%expect{| +type m_record = #{ i1 : int; i2 : int; } +Line 3, characters 6-7: +3 | let x = #{ i1 = 1; i2 = 2 } + ^ +Error: Types of top-level module bindings must have layout "value", but + the type of "x" has layout "value & value". +|}] + +(* This one is okay, because the record has layout vlue *) +type m_record = #{ i1 : int } +module M = struct + let x = #{ i1 = 1 } +end +[%%expect{| +type m_record = #{ i1 : int; } +module M : sig val x : m_record end +|}] + +type object_inner = #{ i : int; b : bool } +type object_type = < x : object_inner > +[%%expect{| +type object_inner = #{ i : int; b : bool; } +Line 2, characters 21-37: +2 | type object_type = < x : object_inner > + ^^^^^^^^^^^^^^^^ +Error: Object field types must have layout value. + The layout of "object_inner" is value & value + because of the definition of object_inner at line 1, characters 0-42. + But the layout of "object_inner" must be a sublayout of value + because it's the type of an object field. +|}] + +type object_term_record = #{ i1 : int; i2 : int } +let object_term = object val x = #{ i1 = 1; i2 = 2 } end +[%%expect{| +type object_term_record = #{ i1 : int; i2 : int; } +Line 2, characters 29-30: +2 | let object_term = object val x = #{ i1 = 1; i2 = 2 } end + ^ +Error: Variables bound in a class must have layout value. + The layout of x is value & value + because of the definition of object_term_record at line 1, characters 0-49. + But the layout of x must be a sublayout of value + because it's the type of a class field. +|}] + +type class_record = #{ i1 : int; i2 : int } +class class_ = + object + method x = #{ i1 = 1; i2 = 2 } + end +[%%expect{| +type class_record = #{ i1 : int; i2 : int; } +Line 4, characters 15-34: +4 | method x = #{ i1 = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "class_record" + but an expression was expected of type "('a : value)" + The layout of class_record is value & value + because of the definition of class_record at line 1, characters 0-43. + But the layout of class_record must be a sublayout of value + because it's the type of an object field. +|}] + +type capture_record = #{ x : int; y : int } +let capture_in_object utup = object + val f = fun () -> + let #{ x; y } = utup in + x + y +end;; +[%%expect{| +type capture_record = #{ x : int; y : int; } +Line 4, characters 20-24: +4 | let #{ x; y } = utup in + ^^^^ +Error: This expression has type "('a : value)" + but an expression was expected of type "capture_record" + The layout of capture_record is value & value + because of the definition of capture_record at line 1, characters 0-43. + But the layout of capture_record must be a sublayout of value + because it's the type of a variable captured in an object. +|}];; + +(****************************************************) +(* Test 5: Methods may take/return unboxed products *) + +type method_input = #{ a : int; b : int } +type method_output = #{ sum_a : int; sum_b : int } + +class class_with_urecord_manipulating_method = + object + method f (x : method_input) (y : method_input) = + let #{ a; b } = x in + let #{ a = c; b = d } = y in + #{ sum_a = a + c; sum_b = b + d } + end +[%%expect{| +type method_input = #{ a : int; b : int; } +type method_output = #{ sum_a : int; sum_b : int; } +class class_with_urecord_manipulating_method : + object method f : method_input -> method_input -> method_output end +|}] + +(*******************************************) +(* Test 6: Nested expansion in kind checks *) + +(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and boxed + records, in the same way as below. +*) +module type S_coherence_deep = sig + type t1 : any + type t2 = #{ i : int; t1 : t1 } +end +[%%expect{| +Line 3, characters 24-31: +3 | type t2 = #{ i : int; t1 : t1 } + ^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 2, characters 2-15. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +module type S_coherence_deep = sig + type t1 : any + type t2 = { t1 : t1 } [@@unboxed] +end +[%%expect{| +Line 3, characters 14-21: +3 | type t2 = { t1 : t1 } [@@unboxed] + ^^^^^^^ +Error: [@@unboxed] record element types must have a representable layout. + The layout of t1/2 is any + because of the definition of t1 at line 2, characters 2-15. + But the layout of t1/2 must be representable + because it is the type of record field t1. +|}] + +(***********************************************) +(* Test 7: modal kinds for unboxed tuple types *) + +type local_cross1 = #{ i1 : int; i2 : int } +let f_external_urecord_mode_crosses_local_1 + : local_ local_cross1 -> local_cross1 = fun x -> x +[%%expect{| +type local_cross1 = #{ i1 : int; i2 : int; } +val f_external_urecord_mode_crosses_local_1 : + local_ local_cross1 -> local_cross1 = +|}] + +type local_nocross1 = #{ i : int; s : string } +let f_internal_urecord_does_not_mode_cross_local_1 + : local_ local_nocross1 -> local_nocross1 = fun x -> x +[%%expect{| +type local_nocross1 = #{ i : int; s : string; } +Line 3, characters 55-56: +3 | : local_ local_nocross1 -> local_nocross1 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type local_cross2_inner = #{ b : bool; i : int } +type local_cross2 = #{ i : int; inner : local_cross2_inner } +let f_external_urecord_mode_crosses_local_2 + : local_ local_cross2 -> local_cross2 = fun x -> x +[%%expect{| +type local_cross2_inner = #{ b : bool; i : int; } +type local_cross2 = #{ i : int; inner : local_cross2_inner; } +val f_external_urecord_mode_crosses_local_2 : + local_ local_cross2 -> local_cross2 = +|}] + +type local_nocross2_inner = #{ b : bool; s : string } +type local_nocross2 = #{ i : int; inner : local_nocross2_inner } +let f_internal_urecord_does_not_mode_cross_local_2 + : local_ local_nocross2 -> local_nocross2 = fun x -> x +[%%expect{| +type local_nocross2_inner = #{ b : bool; s : string; } +type local_nocross2 = #{ i : int; inner : local_nocross2_inner; } +Line 4, characters 55-56: +4 | : local_ local_nocross2 -> local_nocross2 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type t = #{ i1 : int; i2 : int } +type local_cross3_inner = #{ t : t; i : int } +type local_cross3 = #{ i : int; inner : local_cross3_inner } +let f_external_urecord_mode_crosses_local_3 + : local_ local_cross3 -> local_cross3 = fun x -> x +[%%expect{| +type t = #{ i1 : int; i2 : int; } +type local_cross3_inner = #{ t : t; i : int; } +type local_cross3 = #{ i : int; inner : local_cross3_inner; } +val f_external_urecord_mode_crosses_local_3 : + local_ local_cross3 -> local_cross3 = +|}] + +type t = #{ s : string; i : int } +type local_nocross3_inner = #{ t : t; b : bool } +type local_nocross3 = #{ i : int; inner : local_nocross3_inner } +let f_internal_urecord_does_not_mode_cross_local_3 + : local_ local_nocross3 -> local_nocross3 = fun x -> x +[%%expect{| +type t = #{ s : string; i : int; } +type local_nocross3_inner = #{ t : t; b : bool; } +type local_nocross3 = #{ i : int; inner : local_nocross3_inner; } +Line 5, characters 55-56: +5 | : local_ local_nocross3 -> local_nocross3 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +(****************************************************) +(* Test 8: modal kinds for product kind annotations *) + +(* Nothing unique to unboxed records here *) + +(*********************) +(* Test 9: externals *) + +type t_product : value & value + +type ext_record_arg_record = #{ i : int; b : bool } +external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" +[%%expect{| +type t_product : value & value +type ext_record_arg_record = #{ i : int; b : bool; } +Line 4, characters 26-54: +4 | external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +type ext_record_arg_attr_record = #{ i : int; b : bool } +external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" +[%%expect{| +type ext_record_arg_attr_record = #{ i : int; b : bool; } +Line 2, characters 37-63: +2 | external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external ext_product_arg : t_product -> int = "foo" "bar" +[%%expect{| +Line 1, characters 27-43: +1 | external ext_product_arg : t_product -> int = "foo" "bar" + ^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" +[%%expect{| +Line 1, characters 38-47: +1 | external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" + ^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +type t = #{ i : int; b : bool } +external ext_record_return : int -> t = "foo" "bar" +[%%expect{| +type t = #{ i : int; b : bool; } +Line 2, characters 29-37: +2 | external ext_record_return : int -> t = "foo" "bar" + ^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +type t = #{ i : int; b : bool } +external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" +[%%expect{| +type t = #{ i : int; b : bool; } +Line 2, characters 47-48: +2 | external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" + ^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external ext_product_return : int -> t_product = "foo" "bar" +[%%expect{| +Line 1, characters 30-46: +1 | external ext_product_return : int -> t_product = "foo" "bar" + ^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" +[%%expect{| +Line 1, characters 48-57: +1 | external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" + ^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external[@layout_poly] id : ('a : any). 'a -> 'a = "%identity" + +type id_record = #{ x : int; y : int } +let sum = + let #{ x; y } = id #{ x = 1; y = 2 } in + x + y +[%%expect{| +external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] +type id_record = #{ x : int; y : int; } +val sum : int = 3 +|}] + +(***********************************) +(* Test 9: not allowed in let recs *) + +(* An example that is allowed on tuples but not unboxed products *) +let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () + +type letrec_record = #{ i1 : int; i2 : int } +let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () +[%%expect{| +val e1 : unit = () +type letrec_record = #{ i1 : int; i2 : int; } +Line 4, characters 37-56: +4 | let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "letrec_record" + but an expression was expected of type "('a : value)" + The layout of letrec_record is value & value + because of the definition of letrec_record at line 3, characters 0-44. + But the layout of letrec_record must be a sublayout of value + because it's the type of the recursive variable x. +|}] + +(* Unboxed records of kind value are also disallowed: *) +type letrec_record = #{ i : int } +let e2 = let rec x = #{ i = y } and y = 42 in () +[%%expect{| +type letrec_record = #{ i : int; } +Line 2, characters 21-31: +2 | let e2 = let rec x = #{ i = y } and y = 42 in () + ^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}] + +(* This example motivates having a check in [type_let], because + [Value_rec_check] is not set up to reject it, but we don't support even this + limited form of unboxed let rec (yet). *) +type letrec_simple = #{ i1 : int; i2 : int } +let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 +[%%expect{| +type letrec_simple = #{ i1 : int; i2 : int; } +Line 2, characters 21-41: +2 | let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "letrec_simple" + but an expression was expected of type "('a : value)" + The layout of letrec_simple is value & value + because of the definition of letrec_simple at line 1, characters 0-44. + But the layout of letrec_simple must be a sublayout of value + because it's the type of the recursive variable _x. +|}] + +(**********************************************************) +(* Test 10: unboxed products not allowed in [@@unboxed] declarations (yet) *) + +type unboxed_record = #{ i1 : int; i2 : int } +type t = A of unboxed_record [@@unboxed] +[%%expect{| +type unboxed_record = #{ i1 : int; i2 : int; } +Line 2, characters 9-28: +2 | type t = A of unboxed_record [@@unboxed] + ^^^^^^^^^^^^^^^^^^^ +Error: Type "unboxed_record" has layout "value & value". + Unboxed variants may not yet contain types of this layout. +|}] + +type ('a : value & value) t = A of { x : 'a } [@@unboxed] +[%%expect{| +Line 1, characters 37-43: +1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] + ^^^^^^ +Error: Type "'a" has layout "value & value". + [@@unboxed] inlined records may not yet contain types of this layout. +|}] + +type unboxed_inline_record = #{ i1 : int; i2 : int } +type t = A of { x : unboxed_inline_record } [@@unboxed] +[%%expect{| +type unboxed_inline_record = #{ i1 : int; i2 : int; } +Line 2, characters 16-41: +2 | type t = A of { x : unboxed_inline_record } [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "unboxed_inline_record" has layout "value & value". + [@@unboxed] inlined records may not yet contain types of this layout. +|}] + +(* Unboxed records of kind value are allowed *) + +type unboxed_record = #{ i : int } +type t = A of unboxed_record [@@unboxed] +[%%expect{| +type unboxed_record = #{ i : int; } +type t = A of unboxed_record [@@unboxed] +|}] + +type t = A of { x : unboxed_record } [@@unboxed] +[%%expect{| +type t = A of { x : unboxed_record; } [@@unboxed] +|}] + + +(**************************************) +(* Test 11: Unboxed records and arrays *) + +(* You can write the type of an array of unboxed records, but not create + one. Soon, you can do both. *) +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array + +type t3_record = #{ i : int; b : bool } +type t3 = t3_record array + +type t4_inner = #{ f : float#; bo : bool option } +type t4_record = #{ s : string; inner : t4_inner } +type t4 = t4_record array +[%%expect{| +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array +type t3_record = #{ i : int; b : bool; } +type t3 = t3_record array +type t4_inner = #{ f : float#; bo : bool option; } +type t4_record = #{ s : string; inner : t4_inner; } +type t4 = t4_record array +|}] + +type array_record = #{ i1 : int; i2 : int } +let _ = [| #{ i1 = 1; i2 = 2 } |] +[%%expect{| +type array_record = #{ i1 : int; i2 : int; } +Line 2, characters 8-33: +2 | let _ = [| #{ i1 = 1; i2 = 2 } |] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Unboxed products are not yet supported with array primitives. + Here, layout value & value was used. +|}] + +type array_init_record = #{ i1 : int; i2 : int } +let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) +[%%expect{| +type array_init_record = #{ i1 : int; i2 : int; } +Line 2, characters 31-50: +2 | let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "array_init_record" + but an expression was expected of type "('a : value)" + The layout of array_init_record is value & value + because of the definition of array_init_record at line 1, characters 0-48. + But the layout of array_init_record must be a sublayout of value. +|}] + +(* Arrays of unboxed records of kind value *are* allowed *) +type array_record = #{ i : int } +let _ = [| #{ i = 1 } |] +[%%expect{| +type array_record = #{ i : int; } +- : array_record array = [|#{i = 1}|] +|}] + +let _ = Array.init 3 (fun i -> #{ i }) +[%%expect{| +- : array_record array = [|#{i = 0}; #{i = 1}; #{i = 2}|] +|}] + +(***********************************************************) +(* Test 12: Unboxed products are not allowed as class args *) + +type class_arg_record = #{ a : int; b : int } +class product_instance_variable x = + let sum = let #{ a; b } = x in a + b in + object + method y = sum + end;; +[%%expect{| +type class_arg_record = #{ a : int; b : int; } +Line 3, characters 28-29: +3 | let sum = let #{ a; b } = x in a + b in + ^ +Error: This expression has type "('a : value)" + but an expression was expected of type "class_arg_record" + The layout of class_arg_record is value & value + because of the definition of class_arg_record at line 1, characters 0-45. + But the layout of class_arg_record must be a sublayout of value + because it's the type of a term-level argument to a class constructor. +|}] + +(* But unboxed records of kind value are: *) +type class_arg_record = #{ a : string } +class product_instance_variable x = + let s = let #{ a } = x in a in + object + method y = s + end;; +[%%expect{| +type class_arg_record = #{ a : string; } +class product_instance_variable : + class_arg_record -> object method y : string end +|}] + + +(*****************************************) +(* Test 13: No lazy unboxed products yet *) + +type lazy_record = #{ i1 : int; i2 : int } +let x = lazy #{ i1 = 1; i2 = 2 } +[%%expect{| +type lazy_record = #{ i1 : int; i2 : int; } +Line 2, characters 13-32: +2 | let x = lazy #{ i1 = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "lazy_record" + but an expression was expected of type "('a : value)" + The layout of lazy_record is value & value + because of the definition of lazy_record at line 1, characters 0-42. + But the layout of lazy_record must be a sublayout of value + because it's the type of a lazy expression. +|}] + +type lazy_t_record = #{ i1 : int; i2 : int } +type t = lazy_t_record lazy_t +[%%expect{| +type lazy_t_record = #{ i1 : int; i2 : int; } +Line 2, characters 9-22: +2 | type t = lazy_t_record lazy_t + ^^^^^^^^^^^^^ +Error: This type "lazy_t_record" should be an instance of type "('a : value)" + The layout of lazy_t_record is value & value + because of the definition of lazy_t_record at line 1, characters 0-44. + But the layout of lazy_t_record must be a sublayout of value + because the type argument of lazy_t has layout value. +|}] + +(* Again, unboxed records of kind value can be: *) + +type t = #{ i : int } +let x = lazy #{ i = 1 } +[%%expect{| +type t = #{ i : int; } +val x : t lazy_t = +|}] + +type t2 = t lazy_t +[%%expect{| +type t2 = t lazy_t +|}] + +(*********************************************) +(* Test 14: Unboxed records can't be coerced *) + +type t = private int + +type coerce_record = #{ t1 : t; t2 : t } +type coerce_int_record = #{ i1 : int; i2 : int } +let f (x : coerce_record) = + let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b +[%%expect{| +type t = private int +type coerce_record = #{ t1 : t; t2 : t; } +type coerce_int_record = #{ i1 : int; i2 : int; } +Line 6, characters 28-52: +6 | let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "coerce_record" is not a subtype of "coerce_int_record" +|}] + +(************************************************) +(* Test 15: Not allowed as an optional argument *) + +type optional_record = #{ i1 : int; i2 : int } +let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x +[%%expect{| +type optional_record = #{ i1 : int; i2 : int; } +Line 2, characters 29-48: +2 | let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "optional_record" + but an expression was expected of type "('a : value)" + The layout of optional_record is value & value + because of the definition of optional_record at line 1, characters 0-46. + But the layout of optional_record must be a sublayout of value + because the type argument of option has layout value. +|}] + +(******************************) +(* Test 16: Decomposing [any] *) + +type ('a : value) u = U of 'a [@@unboxed] +type ('a : value) t = #{ u1 : 'a u; u2 : 'a u } + +type ('a : any mod global) needs_any_mod_global + +type should_work = int t needs_any_mod_global +[%%expect{| +type 'a u = U of 'a [@@unboxed] +type 'a t = #{ u1 : 'a u; u2 : 'a u; } +type ('a : any mod global) needs_any_mod_global +type should_work = int t needs_any_mod_global +|}] + +type should_fail = string t needs_any_mod_global +[%%expect{| +Line 1, characters 19-27: +1 | type should_fail = string t needs_any_mod_global + ^^^^^^^^ +Error: This type "string t" should be an instance of type "('a : any mod global)" + The kind of string t is immutable_data + because it is the primitive type string. + But the kind of string t must be a subkind of any mod global + because of the definition of needs_any_mod_global at line 4, characters 0-47. +|}] + +type ('a : any mod external_) t + +type s_record = #{ i1 : int; s : string; i2 : int } +type s = s_record t +[%%expect{| +type ('a : any mod external_) t +type s_record = #{ i1 : int; s : string; i2 : int; } +Line 4, characters 9-17: +4 | type s = s_record t + ^^^^^^^^ +Error: This type "s_record" should be an instance of type + "('a : any mod external_)" + The kind of s_record is immutable_data + because it is the primitive type string. + But the kind of s_record must be a subkind of any mod external_ + because of the definition of t at line 1, characters 0-31. +|}] +(* CR layouts v7.1: Both the above have very bad error messages. *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/disabled.ml b/testsuite/tests/typing-layouts-unboxed-records/disabled.ml new file mode 100644 index 00000000000..61ba712ee89 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/disabled.ml @@ -0,0 +1,39 @@ +(* TEST + expect; +*) + +(* Types *) +type t = #{ a : int } +[%%expect{| +Line 1, characters 0-21: +1 | type t = #{ a : int } + ^^^^^^^^^^^^^^^^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +(* Construction *) +let _ = #{ u = () } +[%%expect{| +Line 1, characters 8-19: +1 | let _ = #{ u = () } + ^^^^^^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +(* Field *) +let get r = r.#x +[%%expect{| +Line 1, characters 12-16: +1 | let get r = r.#x + ^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +(* Patterns *) +let #{ u = () } = () +[%%expect{| +Line 1, characters 4-15: +1 | let #{ u = () } = () + ^^^^^^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/dlambda.ml b/testsuite/tests/typing-layouts-unboxed-records/dlambda.ml new file mode 100644 index 00000000000..ce0332a827b --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/dlambda.ml @@ -0,0 +1,128 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_beta -dlambda"; + { + expect; + } +*) + +(* We implement the same functionality with pattern matching, projection, + and check the lambda for correctness against unboxed records. *) + +type t = #{ i : int ; j : int } +let add (#{ i ; j = _} as r) = i + r.#j +[%%expect{| +0 +type t = #{ i : int; j : int; } +(let + (add/280 = + (function {nlocal = 0} r/283#(*, *) : int + (+ (unboxed_product_field 0 #(*, *) r/283) + (unboxed_product_field 1 #([int], [int]) r/283)))) + (apply (field_imm 1 (global Toploop!)) "add" add/280)) +val add : t -> int = +|}] + +let add2 x y = add x + add y +[%%expect{| +(let + (add/280 = (apply (field_imm 0 (global Toploop!)) "add") + add2/285 = + (function {nlocal = 0} x/287#(*, *) y/288#(*, *) : int + (+ (apply add/280 x/287) (apply add/280 y/288)))) + (apply (field_imm 1 (global Toploop!)) "add2" add2/285)) +val add2 : t -> t -> int = +|}] + + +let add #( i, j ) = i + j +[%%expect{| +(let + (add/289 = + (function {nlocal = 0} param/292#(*, *) : int + (+ (unboxed_product_field 0 #(*, *) param/292) + (unboxed_product_field 1 #(*, *) param/292)))) + (apply (field_imm 1 (global Toploop!)) "add" add/289)) +val add : #(int * int) -> int = +|}] +let add2 x y = add x + add y +[%%expect{| +(let + (add/289 = (apply (field_imm 0 (global Toploop!)) "add") + add2/293 = + (function {nlocal = 0} x/294#(*, *) y/295#(*, *) : int + (+ (apply add/289 x/294) (apply add/289 y/295)))) + (apply (field_imm 1 (global Toploop!)) "add2" add2/293)) +val add2 : #(int * int) -> #(int * int) -> int = +|}] + +let copy_i_to_j #{ i ; j } = #{ i; j = i } +[%%expect{| +(let + (copy_i_to_j/296 = + (function {nlocal = 0} param/300#(*, *) + : #(*, *)(let (i/298 =a (unboxed_product_field 0 #(*, *) param/300)) + (make_unboxed_product #([int], [int]) i/298 i/298)))) + (apply (field_imm 1 (global Toploop!)) "copy_i_to_j" copy_i_to_j/296)) +val copy_i_to_j : t -> t = +|}] + +(* this one is slightly different than the above and below - it + calls unboxed_product_field twice rather than let-binding, but + this should be inconsequential*) +let copy_i_to_j r = #{ r with j = r.#i } +[%%expect{| +(let + (copy_i_to_j/302 = + (function {nlocal = 0} r/303#(*, *) + : #(*, *)(make_unboxed_product #([int], [int]) + (unboxed_product_field 0 #([int], [int]) r/303) + (unboxed_product_field 0 #([int], [int]) r/303)))) + (apply (field_imm 1 (global Toploop!)) "copy_i_to_j" copy_i_to_j/302)) +val copy_i_to_j : t -> t = +|}] + +let copy_i_to_j (#(i, _j) : #(int * int)) = #(i, i) +[%%expect{| +(let + (copy_i_to_j/305 = + (function {nlocal = 0} param/308#(*, *) + : #(*, *)(let (i/306 =a (unboxed_product_field 0 #(*, *) param/308)) + (make_unboxed_product #([int], [int]) i/306 i/306)))) + (apply (field_imm 1 (global Toploop!)) "copy_i_to_j" copy_i_to_j/305)) +val copy_i_to_j : #(int * int) -> #(int * int) = +|}] + +(* compare against @@unboxed records *) +type t = #{ s : string } + +let t = #{ s = "hi" } +[%%expect{| +0 +type t = #{ s : string; } +(let (t/311 = "hi") (apply (field_imm 1 (global Toploop!)) "t" t/311)) +val t : t = #{s = "hi"} +|}] + +let s = #{ s = "hi" }.#s +[%%expect{| +(let (s/313 = "hi") (apply (field_imm 1 (global Toploop!)) "s" s/313)) +val s : string = "hi" +|}] + +type t = { s : string } [@@unboxed] +let t = { s = "hi" } +[%%expect{| +0 +type t = { s : string; } [@@unboxed] +(let (t/317 = "hi") (apply (field_imm 1 (global Toploop!)) "t" t/317)) +val t : t = {s = "hi"} +|}] + +let s = { s = "hi"}.s +[%%expect{| +(let (s/319 = "hi") (apply (field_imm 1 (global Toploop!)) "s" s/319)) +val s : string = "hi" +|}] + diff --git a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml new file mode 100644 index 00000000000..0cd2ba86719 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml @@ -0,0 +1,85 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_beta"; + { + expect; + } +*) + +type t : value = #{ t : t } +let rec t = #{ t = t } +[%%expect{| +type t = #{ t : t; } +Line 2, characters 12-22: +2 | let rec t = #{ t = t } + ^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}] + +type bx = { bx : ubx } +and ubx = #{ ubx : bx } +[%%expect{| +type bx = { bx : ubx; } +and ubx = #{ ubx : bx; } +|}] + +let rec t = #{ ubx = { bx = t } } +[%%expect{| +val t : ubx = #{ubx = {bx = }} +|}] + +let rec t = { bx = #{ ubx = t } } +[%%expect{| +val t : bx = {bx = } +|}] + +(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml] *) + +type t = #{x: int64} +let rec x = #{x = y} and y = 3L;; +[%%expect{| +type t = #{ x : int64; } +Line 2, characters 12-20: +2 | let rec x = #{x = y} and y = 3L;; + ^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}];; + +(* This test is not allowed if 'a' is unboxed, but should be accepted + as written *) +type a = {a: b} +and b = X of a | Y + +let rec a = + {a= + (if Sys.opaque_identity true then + X a + else + Y)};; +[%%expect{| +type a = { a : b; } +and b = X of a | Y +val a : a = {a = X } +|}];; + +type a = #{ a: b } +and b = X of a | Y + +let rec a = + #{a= + (if Sys.opaque_identity true then + X a + else + Y)};; +[%%expect{| +type a = #{ a : b; } +and b = X of a | Y +Lines 5-9, characters 2-10: +5 | ..#{a= +6 | (if Sys.opaque_identity true then +7 | X a +8 | else +9 | Y)}.. +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}];; diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference new file mode 100644 index 00000000000..9c0cd4c1811 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_inline_unboxed_record.ml", line 11, characters 22-24: +11 | type variant = Foo of #{ x : string } + ^^ +Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml b/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml new file mode 100644 index 00000000000..5540637473e --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml @@ -0,0 +1,11 @@ +(* TEST + flags = "-extension-universe beta"; + setup-ocamlc.byte-build-env; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + check-ocamlc.byte-output; +*) + +(* This does not parse. *) + +type variant = Foo of #{ x : string } diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml new file mode 100644 index 00000000000..469f63047e0 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml @@ -0,0 +1,228 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +(* CR layouts v7.2: figure out the story for recursive unboxed products. + Consider that the following is allowed upstream: + type t = { t : t } [@@unboxed] + We should also give good errors for infinite-size unboxed records (see the test at the + bottom of this file with a depth-100 kind). +*) + +(************************************) +(* Basic recursive unboxed products *) + +type t : value = #{ t : t } +[%%expect{| +type t = #{ t : t; } +|}] + +type t : float64 = #{ t : t } +[%%expect{| +type t = #{ t : t; } +|}] + + +type t : value = #{ t : t } +[%%expect{| +type t = #{ t : t; } +|}] + +type bad = #{ bad : bad ; i : int} +[%%expect{| +Line 1, characters 0-34: +1 | type bad = #{ bad : bad ; i : int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of bad is any & any + because it is an unboxed record. + But the layout of bad must be representable + because it is the type of record field bad. +|}] + +type bad = #{ bad : bad } +[%%expect{| +Line 1, characters 0-25: +1 | type bad = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of bad is any + because a dummy kind of any is used to check mutually recursive datatypes. + Please notify the Jane Street compilers group if you see this output. + But the layout of bad must be representable + because it is the type of record field bad. +|}] + +type a_bad = #{ b_bad : b_bad } +and b_bad = #{ a_bad : a_bad } +[%%expect{| +Line 1, characters 0-31: +1 | type a_bad = #{ b_bad : b_bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of a_bad is any + because a dummy kind of any is used to check mutually recursive datatypes. + Please notify the Jane Street compilers group if you see this output. + But the layout of a_bad must be representable + because it is the type of record field a_bad. +|}] + +type bad : any = #{ bad : bad } +[%%expect{| +Line 1, characters 0-31: +1 | type bad : any = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of bad is any + because of the annotation on the declaration of the type bad. + But the layout of bad must be representable + because it is the type of record field bad. +|}] + +type 'a id = #{ a : 'a } +type bad = bad id +[%%expect{| +type 'a id = #{ a : 'a; } +Line 2, characters 0-17: +2 | type bad = bad id + ^^^^^^^^^^^^^^^^^ +Error: The type abbreviation "bad" is cyclic: + "bad" = "bad id", + "bad id" contains "bad" +|}] + + +type 'a bad = #{ bad : 'a bad ; u : 'a} +[%%expect{| +Line 1, characters 0-39: +1 | type 'a bad = #{ bad : 'a bad ; u : 'a} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of 'a bad is any & any + because it is an unboxed record. + But the layout of 'a bad must be representable + because it is the type of record field bad. +|}] + +type 'a bad = { bad : 'a bad ; u : 'a} +[%%expect{| +type 'a bad = { bad : 'a bad; u : 'a; } +|}] + + +(***************************************) +(* Recursive unboxed records with void *) + +type t_void : void + +type ('a : void) t = #{ x : 'a ; y : t_void } +[%%expect{| +type t_void : void +type ('a : void) t = #{ x : 'a; y : t_void; } +|}] + +type t = { x : t_void } [@@unboxed] +[%%expect{| +type t = { x : t_void; } [@@unboxed] +|}] + +type bad : void = #{ bad : bad } +[%%expect{| +type bad = #{ bad : bad; } +|}] + +type ('a : void) bad = #{ bad : 'a bad ; u : 'a} +[%%expect{| +Line 1, characters 0-49: +1 | type ('a : void) bad = #{ bad : 'a bad ; u : 'a} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of 'a bad is any & any + because it is an unboxed record. + But the layout of 'a bad must be representable + because it is the type of record field bad. +|}] + + +(****************************) +(* A particularly bad error *) + +type bad : float64 = #{ bad : bad ; i : int} +[%%expect{| +Line 1, characters 0-44: +1 | type bad : float64 = #{ bad : bad ; i : int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The layout of type "bad" is (((((((((((((((((((((((((((((((((((( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + ( + (float64 & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value + because it is an unboxed record. + But the layout of type "bad" must be a sublayout of float64 + because of the annotation on the declaration of the type bad. +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/separability.ml b/testsuite/tests/typing-layouts-unboxed-records/separability.ml new file mode 100644 index 00000000000..a91205e9579 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/separability.ml @@ -0,0 +1,58 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +type 'a r = #{ a : 'a } +and 'a ok = F : 'a r -> 'a ok [@@unboxed] +[%%expect{| +type 'a r = #{ a : 'a; } +and 'a ok = F : 'a r -> 'a ok [@@unboxed] +|}] + +type 'a r = #{ a : 'a } +type bad = F : 'a r -> bad [@@unboxed] +[%%expect{| +type 'a r = #{ a : 'a; } +Line 2, characters 0-38: +2 | type bad = F : 'a r -> bad [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This type cannot be unboxed because + it might contain both float and non-float values, + depending on the instantiation of the existential variable "'a". + You should annotate it with "[@@ocaml.boxed]". +|}] + +type 'a r = #{ a : 'a } +and 'a r2 = #{ a : 'a r } +and bad = F : 'a r2 -> bad [@@unboxed] +[%%expect{| +Line 3, characters 0-38: +3 | and bad = F : 'a r2 -> bad [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This type cannot be unboxed because + it might contain both float and non-float values, + depending on the instantiation of the existential variable "'a". + You should annotate it with "[@@ocaml.boxed]". +|}] + +(* CR layouts v12: Once we allow products containing void in unboxed GADTs, we'll have to + make sure the below fails separability checking: *) +type t_void : void +and 'a r = #{ a : 'a ; v : t_void } +and bad = F : 'a r -> bad [@@unboxed] +[%%expect{| +Line 2, characters 0-35: +2 | and 'a r = #{ a : 'a ; v : t_void } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of 'a r is any & any + because it is an unboxed record. + But the layout of 'a r must be a sublayout of value + because it's the type of a constructor field. +|}] + diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml new file mode 100644 index 00000000000..5ac1621638c --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml @@ -0,0 +1,827 @@ +(* TEST + flags = " -w +A -strict-sequence -extension layouts_beta"; + expect; +*) + +module Duplicate_label_definitions = struct + type t = { a : int } + and t2 = #{ a : int } +end +[%%expect{| +module Duplicate_label_definitions : + sig type t = { a : int; } and t2 = #{ a : int; } end +|}] + +module Duplicate_label_definitions2 = struct + type t = #{ a : int } + and t2 = #{ a : int } +end +[%%expect{| +Line 3, characters 14-21: +3 | and t2 = #{ a : int } + ^^^^^^^ +Warning 30 [duplicate-definitions]: the unboxed record label a is defined in both types t and t2. + +module Duplicate_label_definitions2 : + sig type t = #{ a : int; } and t2 = #{ a : int; } end +|}] + +external ignore_product : ('a : value & value). 'a -> unit = "%ignore" +[%%expect{| +external ignore_product : ('a : value & value). 'a -> unit = "%ignore" +|}] + +(* This below tests are adapted from [testsuite/tests/typing-warnings/records.ml] *) + +(* Use type information *) +module M1 = struct + type t = #{x: int; y: int} + type u = #{x: bool; y: bool} +end;; +[%%expect{| +module M1 : + sig type t = #{ x : int; y : int; } type u = #{ x : bool; y : bool; } end +|}] + +module OK = struct + open M1 + let f1 (r:t) = r.#x (* ok *) + let f2 r = ignore_product (r:t); r.#x (* non principal *) + + let f3 (r: t) = + match r with #{x; y} -> y + y (* ok *) +end;; +[%%expect{| +Line 3, characters 20-21: +3 | let f1 (r:t) = r.#x (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 4, characters 38-39: +4 | let f2 r = ignore_product (r:t); r.#x (* non principal *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 19-20: +7 | match r with #{x; y} -> y + y (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 22-23: +7 | match r with #{x; y} -> y + y (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 19-20: +7 | match r with #{x; y} -> y + y (* ok *) + ^ +Warning 27 [unused-var-strict]: unused variable x. + +module OK : + sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end +|}, Principal{| +Line 3, characters 20-21: +3 | let f1 (r:t) = r.#x (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 4, characters 38-39: +4 | let f2 r = ignore_product (r:t); r.#x (* non principal *) + ^ +Warning 18 [not-principal]: this type-based unboxed record field disambiguation is not principal. + +Line 4, characters 38-39: +4 | let f2 r = ignore_product (r:t); r.#x (* non principal *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 19-20: +7 | match r with #{x; y} -> y + y (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 22-23: +7 | match r with #{x; y} -> y + y (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 19-20: +7 | match r with #{x; y} -> y + y (* ok *) + ^ +Warning 27 [unused-var-strict]: unused variable x. + +module OK : + sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end +|}] + +module F1 = struct + open M1 + let f r = match r with #{x; y} -> y + y +end;; (* fails *) +[%%expect{| +Line 3, characters 25-32: +3 | let f r = match r with #{x; y} -> y + y + ^^^^^^^ +Warning 41 [ambiguous-name]: these field labels belong to several types: M1.u M1.t +The first one was selected. Please disambiguate if this is wrong. + +Line 3, characters 36-37: +3 | let f r = match r with #{x; y} -> y + y + ^ +Error: This expression has type "bool" but an expression was expected of type + "int" +|}] + +module F2 = struct + open M1 + let f r = + ignore_product (r: t); + match r with + #{x; y} -> y + y +end;; (* fails for -principal *) +[%%expect{| +Line 6, characters 9-10: +6 | #{x; y} -> y + y + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 6, characters 12-13: +6 | #{x; y} -> y + y + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 6, characters 9-10: +6 | #{x; y} -> y + y + ^ +Warning 27 [unused-var-strict]: unused variable x. + +module F2 : sig val f : M1.t -> int end +|}, Principal{| +Line 6, characters 9-10: +6 | #{x; y} -> y + y + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 6, characters 12-13: +6 | #{x; y} -> y + y + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 6, characters 7-14: +6 | #{x; y} -> y + y + ^^^^^^^ +Warning 18 [not-principal]: this type-based unboxed record disambiguation is not principal. + +Line 6, characters 9-10: +6 | #{x; y} -> y + y + ^ +Warning 27 [unused-var-strict]: unused variable x. + +module F2 : sig val f : M1.t -> int end +|}] + +(* Use type information with modules*) +module M = struct + type t = #{x:int} + type u = #{x:bool} +end;; +[%%expect{| +module M : sig type t = #{ x : int; } type u = #{ x : bool; } end +|}] +let f (r:M.t) = r.#M.x;; (* ok *) +[%%expect{| +Line 1, characters 19-22: +1 | let f (r:M.t) = r.#M.x;; (* ok *) + ^^^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +val f : M.t -> int = +|}] +let f (r:M.t) = r.#x;; (* warning *) +[%%expect{| +Line 1, characters 19-20: +1 | let f (r:M.t) = r.#x;; (* warning *) + ^ +Warning 40 [name-out-of-scope]: x was selected from type M.t. +It is not visible in the current scope, and will not +be selected if the type becomes unknown. + +Line 1, characters 19-20: +1 | let f (r:M.t) = r.#x;; (* warning *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +val f : M.t -> int = +|}] +let f (#{x}:M.t) = x;; (* warning *) +[%%expect{| +Line 1, characters 9-10: +1 | let f (#{x}:M.t) = x;; (* warning *) + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 1, characters 7-11: +1 | let f (#{x}:M.t) = x;; (* warning *) + ^^^^ +Warning 40 [name-out-of-scope]: this unboxed record of type M.t contains fields that are +not visible in the current scope: x. +They will not be selected if the type becomes unknown. + +val f : M.t -> int = +|}] + +module M = struct + type t = #{x: int; y: int} +end;; +[%%expect{| +module M : sig type t = #{ x : int; y : int; } end +|}] +module N = struct + type u = #{x: bool; y: bool} +end;; +[%%expect{| +module N : sig type u = #{ x : bool; y : bool; } end +|}] +module OK = struct + open M + open N + let f (r:M.t) = r.#x +end;; +[%%expect{| +Line 4, characters 21-22: +4 | let f (r:M.t) = r.#x + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 2-8: +3 | open N + ^^^^^^ +Warning 33 [unused-open]: unused open N. + +module OK : sig val f : M.t -> int end +|}] + +module M = struct + type t = #{x:int} + module N = struct type s = t = #{x:int} end + type u = #{x:bool} +end;; +[%%expect{| +module M : + sig + type t = #{ x : int; } + module N : sig type s = t = #{ x : int; } end + type u = #{ x : bool; } + end +|}] +module OK = struct + open M.N + let f (r:M.t) = r.#x +end;; +[%%expect{| +module OK : sig val f : M.t -> int end +|}] + +(* Use field information *) +module M = struct + type u = #{x:bool;y:int;z:char} + type t = #{x:int;y:bool} +end;; +[%%expect{| +module M : + sig + type u = #{ x : bool; y : int; z : char; } + type t = #{ x : int; y : bool; } + end +|}] +module OK = struct + open M + let f #{x;z} = x,z +end;; (* ok *) +[%%expect{| +Line 3, characters 10-11: +3 | let f #{x;z} = x,z + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 8-14: +3 | let f #{x;z} = x,z + ^^^^^^ +Warning 9 [missing-record-field-pattern]: the following labels are not bound in this unboxed record pattern: +y +Either bind these labels explicitly or add '; _' to the pattern. + +module OK : sig val f : M.u -> bool * char end +|}] +module F3 = struct + open M + let r = #{x=true;z='z'} +end;; (* fail for missing label *) +[%%expect{| +Line 3, characters 12-13: +3 | let r = #{x=true;z='z'} + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 10-25: +3 | let r = #{x=true;z='z'} + ^^^^^^^^^^^^^^^ +Error: Some unboxed record fields are undefined: "y" +|}] + +module OK = struct + type u = #{x:int;y:bool} + type t = #{x:bool;y:int;z:char} + let r () = #{x=3; y=true} +end;; (* ok *) +[%%expect{| +Line 4, characters 15-16: +4 | let r () = #{x=3; y=true} + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 4, characters 20-21: +4 | let r () = #{x=3; y=true} + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +module OK : + sig + type u = #{ x : int; y : bool; } + type t = #{ x : bool; y : int; z : char; } + val r : unit -> u + end +|}] + +(* Corner cases *) + +module F4 = struct + type foo = #{x:int; y:int} + type bar = #{x:int} + let b : bar = #{x=3; y=4} +end;; (* fail but don't warn *) +[%%expect{| +Line 4, characters 23-24: +4 | let b : bar = #{x=3; y=4} + ^ +Error: This unboxed record expression is expected to have type "bar" + There is no unboxed record field "y" within type "bar" +|}] + +module M = struct type foo = #{x:int;y:int} end;; +[%%expect{| +module M : sig type foo = #{ x : int; y : int; } end +|}] +module N = struct type bar = #{x:int;y:int} end;; +[%%expect{| +module N : sig type bar = #{ x : int; y : int; } end +|}] +let r = #{ M.x = 3; N.y = 4; };; (* error: different definitions *) +[%%expect{| +Line 1, characters 20-23: +1 | let r = #{ M.x = 3; N.y = 4; };; (* error: different definitions *) + ^^^ +Error: The unboxed record field "N.y" belongs to the type "N.bar" + but is mixed here with fields of type "M.foo" +|}] + +module MN = struct include M include N end +module NM = struct include N include M end;; +[%%expect{| +module MN : + sig + type foo = M.foo = #{ x : int; y : int; } + type bar = N.bar = #{ x : int; y : int; } + end +module NM : + sig + type bar = N.bar = #{ x : int; y : int; } + type foo = M.foo = #{ x : int; y : int; } + end +|}] +let r = #{MN.x = 3; NM.y = 4};; (* error: type would change with order *) +[%%expect{| +Line 1, characters 8-29: +1 | let r = #{MN.x = 3; NM.y = 4};; (* error: type would change with order *) + ^^^^^^^^^^^^^^^^^^^^^ +Warning 41 [ambiguous-name]: x belongs to several types: MN.bar MN.foo +The first one was selected. Please disambiguate if this is wrong. + +Line 1, characters 8-29: +1 | let r = #{MN.x = 3; NM.y = 4};; (* error: type would change with order *) + ^^^^^^^^^^^^^^^^^^^^^ +Warning 41 [ambiguous-name]: y belongs to several types: NM.foo NM.bar +The first one was selected. Please disambiguate if this is wrong. + +Line 1, characters 20-24: +1 | let r = #{MN.x = 3; NM.y = 4};; (* error: type would change with order *) + ^^^^ +Error: The unboxed record field "NM.y" belongs to the type "NM.foo" = "M.foo" + but is mixed here with fields of type "MN.bar" = "N.bar" +|}] + +(* Lpw25 *) + +module M = struct + type foo = #{ x: int; y: int } + type bar = #{ x:int; y: int; z: int} +end;; +[%%expect{| +module M : + sig + type foo = #{ x : int; y : int; } + type bar = #{ x : int; y : int; z : int; } + end +|}] +module F5 = struct + open M + let f r = ignore_product (r: foo); #{r with x = 2; z = 3} +end;; +[%%expect{| +Line 3, characters 46-47: +3 | let f r = ignore_product (r: foo); #{r with x = 2; z = 3} + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 53-54: +3 | let f r = ignore_product (r: foo); #{r with x = 2; z = 3} + ^ +Error: This unboxed record expression is expected to have type "M.foo" + There is no unboxed record field "z" within type "M.foo" +|}] +module M = struct + include M + type other = #{ a: int; b: int } +end;; +[%%expect{| +module M : + sig + type foo = M.foo = #{ x : int; y : int; } + type bar = M.bar = #{ x : int; y : int; z : int; } + type other = #{ a : int; b : int; } + end +|}] +module F6 = struct + open M + let f r = ignore_product (r: foo); #{ r with x = 3; a = 4 } +end;; +[%%expect{| +Line 3, characters 47-48: +3 | let f r = ignore_product (r: foo); #{ r with x = 3; a = 4 } + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 54-55: +3 | let f r = ignore_product (r: foo); #{ r with x = 3; a = 4 } + ^ +Error: This unboxed record expression is expected to have type "M.foo" + There is no unboxed record field "a" within type "M.foo" +|}] +module F7 = struct + open M + let r () = #{x=1; y=2} + let r () : other = #{x=1; y=2} +end;; +[%%expect{| +Line 3, characters 15-16: +3 | let r () = #{x=1; y=2} + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 20-21: +3 | let r () = #{x=1; y=2} + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 4, characters 23-24: +4 | let r () : other = #{x=1; y=2} + ^ +Error: This unboxed record expression is expected to have type "M.other" + There is no unboxed record field "x" within type "M.other" +|}] + +module A = struct type t = #{x: int} end +module B = struct type t = #{x: int} end;; +[%%expect{| +module A : sig type t = #{ x : int; } end +module B : sig type t = #{ x : int; } end +|}] +let f (r : B.t) = r.#A.x;; (* fail *) +[%%expect{| +Line 1, characters 21-24: +1 | let f (r : B.t) = r.#A.x;; (* fail *) + ^^^ +Error: The unboxed record field "A.x" belongs to the unboxed record type "A.t" + but a unboxed record field was expected belonging to the unboxed record type + "B.t" +|}] + +(* Spellchecking *) + +module F8 = struct + type t = #{x:int; yyy:int} + let a : t = #{x=1;yyz=2} +end;; +[%%expect{| +Line 3, characters 20-23: +3 | let a : t = #{x=1;yyz=2} + ^^^ +Error: This unboxed record expression is expected to have type "t" + There is no unboxed record field "yyz" within type "t" +Hint: Did you mean "yyy"? +|}] + +(* PR#6004 *) + +type t = A +type s = A + +class f (_ : t) = object end;; +[%%expect{| +type t = A +type s = A +class f : t -> object end +|}] +class g = f A;; (* ok *) + +class f (_ : 'a) (_ : 'a) = object end;; +[%%expect{| +Line 1, characters 12-13: +1 | class g = f A;; (* ok *) + ^ +Warning 42 [disambiguated-name]: this use of A relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +class g : f +class f : 'a -> 'a -> object end +|}] +class g = f (A : t) A;; (* warn with -principal *) +[%%expect{| +Line 1, characters 13-14: +1 | class g = f (A : t) A;; (* warn with -principal *) + ^ +Warning 42 [disambiguated-name]: this use of A relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 1, characters 20-21: +1 | class g = f (A : t) A;; (* warn with -principal *) + ^ +Warning 42 [disambiguated-name]: this use of A relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +class g : f +|}, Principal{| +Line 1, characters 13-14: +1 | class g = f (A : t) A;; (* warn with -principal *) + ^ +Warning 42 [disambiguated-name]: this use of A relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 1, characters 20-21: +1 | class g = f (A : t) A;; (* warn with -principal *) + ^ +Warning 18 [not-principal]: this type-based constructor disambiguation is not principal. + +Line 1, characters 20-21: +1 | class g = f (A : t) A;; (* warn with -principal *) + ^ +Warning 42 [disambiguated-name]: this use of A relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +class g : f +|}] + + +(* PR#5980 *) + +module Shadow1 = struct + type t = #{x: int} + module M = struct + type s = #{x: string} + end + open M (* this open is unused, it isn't reported as shadowing 'x' *) + let y : t = #{x = 0} +end;; +[%%expect{| +Line 7, characters 16-17: +7 | let y : t = #{x = 0} + ^ +Warning 42 [disambiguated-name]: this use of x relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 6, characters 2-8: +6 | open M (* this open is unused, it isn't reported as shadowing 'x' *) + ^^^^^^ +Warning 33 [unused-open]: unused open M. + +module Shadow1 : + sig + type t = #{ x : int; } + module M : sig type s = #{ x : string; } end + val y : t + end +|}] +module Shadow2 = struct + type t = #{x: int} + module M = struct + type s = #{x: string} + end + open M (* this open shadows label 'x' *) + let y = #{x = ""} +end;; +[%%expect{| +Line 6, characters 2-8: +6 | open M (* this open shadows label 'x' *) + ^^^^^^ +Warning 44 [open-shadow-identifier]: this open statement shadows the unboxed label identifier x (which is later used) + +Line 7, characters 10-19: +7 | let y = #{x = ""} + ^^^^^^^^^ +Warning 41 [ambiguous-name]: these field labels belong to several types: M.s t +The first one was selected. Please disambiguate if this is wrong. + +module Shadow2 : + sig + type t = #{ x : int; } + module M : sig type s = #{ x : string; } end + val y : M.s + end +|}] + +(* PR#6235 *) + +module P6235 = struct + type t = #{ loc : string; } + type v = #{ loc : string; x : int; } + type u = [ `Key of t ] + let f (u : u) = match u with `Key #{loc} -> loc +end;; +[%%expect{| +Line 5, characters 38-41: +5 | let f (u : u) = match u with `Key #{loc} -> loc + ^^^ +Warning 42 [disambiguated-name]: this use of loc relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +module P6235 : + sig + type t = #{ loc : string; } + type v = #{ loc : string; x : int; } + type u = [ `Key of t ] + val f : u -> string + end +|}] + +(* Remove interaction between branches *) + +module P6235' = struct + type t = #{ loc : string; } + type v = #{ loc : string; x : int; } + type u = [ `Key of t ] + let f = function + | (_ : u) when false -> "" + |`Key #{loc} -> loc +end;; +[%%expect{| +Line 7, characters 12-15: +7 | |`Key #{loc} -> loc + ^^^ +Warning 42 [disambiguated-name]: this use of loc relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +module P6235' : + sig + type t = #{ loc : string; } + type v = #{ loc : string; x : int; } + type u = [ `Key of t ] + val f : u -> string + end +|}, Principal{| +Line 7, characters 12-15: +7 | |`Key #{loc} -> loc + ^^^ +Warning 42 [disambiguated-name]: this use of loc relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 7, characters 10-16: +7 | |`Key #{loc} -> loc + ^^^^^^ +Warning 18 [not-principal]: this type-based unboxed record disambiguation is not principal. + +module P6235' : + sig + type t = #{ loc : string; } + type v = #{ loc : string; x : int; } + type u = [ `Key of t ] + val f : u -> string + end +|}] + +(** no candidates after filtering; + This caused a temporary trunk regression identified by Florian Angeletti + while reviewing #9196 + *) +module M = struct + type t = #{ x:int; y:int} +end +type u = #{ a:int } +let _ = ( #{ M.x=0 } : u );; +[%%expect{| +module M : sig type t = #{ x : int; y : int; } end +type u = #{ a : int; } +Line 5, characters 13-16: +5 | let _ = ( #{ M.x=0 } : u );; + ^^^ +Error: The unboxed record field "M.x" belongs to the unboxed record type "M.t" + but a unboxed record field was expected belonging to the unboxed record type + "u" +|}] + +(* PR#8747 *) +module M = struct type t = #{ x : int; y: char } end +let f (x : M.t) () = #{ x with y = 'a' } +let g (x : M.t) () = #(#{ x with y = 'a' }, []) +let h (x : M.t) () = #(#{ x with y = 'a' }, #(#{ x with y = 'b' }, []));; +[%%expect{| +module M : sig type t = #{ x : int; y : char; } end +Line 2, characters 31-32: +2 | let f (x : M.t) () = #{ x with y = 'a' } + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 2, characters 21-40: +2 | let f (x : M.t) () = #{ x with y = 'a' } + ^^^^^^^^^^^^^^^^^^^ +Warning 40 [name-out-of-scope]: this unboxed record of type M.t contains fields that are +not visible in the current scope: y. +They will not be selected if the type becomes unknown. + +val f : M.t -> unit -> M.t = +Line 3, characters 33-34: +3 | let g (x : M.t) () = #(#{ x with y = 'a' }, []) + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 3, characters 23-42: +3 | let g (x : M.t) () = #(#{ x with y = 'a' }, []) + ^^^^^^^^^^^^^^^^^^^ +Warning 40 [name-out-of-scope]: this unboxed record of type M.t contains fields that are +not visible in the current scope: y. +They will not be selected if the type becomes unknown. + +val g : M.t -> unit -> #(M.t * 'a list) = +Line 4, characters 33-34: +4 | let h (x : M.t) () = #(#{ x with y = 'a' }, #(#{ x with y = 'b' }, []));; + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 4, characters 23-42: +4 | let h (x : M.t) () = #(#{ x with y = 'a' }, #(#{ x with y = 'b' }, []));; + ^^^^^^^^^^^^^^^^^^^ +Warning 40 [name-out-of-scope]: this unboxed record of type M.t contains fields that are +not visible in the current scope: y. +They will not be selected if the type becomes unknown. + +Line 4, characters 56-57: +4 | let h (x : M.t) () = #(#{ x with y = 'a' }, #(#{ x with y = 'b' }, []));; + ^ +Warning 42 [disambiguated-name]: this use of y relies on type-directed disambiguation, +it will not compile with OCaml 4.00 or earlier. + +Line 4, characters 46-65: +4 | let h (x : M.t) () = #(#{ x with y = 'a' }, #(#{ x with y = 'b' }, []));; + ^^^^^^^^^^^^^^^^^^^ +Warning 40 [name-out-of-scope]: this unboxed record of type M.t contains fields that are +not visible in the current scope: y. +They will not be selected if the type becomes unknown. + +val h : M.t -> unit -> #(M.t * #(M.t * 'a list)) = +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml new file mode 100644 index 00000000000..e308c61471c --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml @@ -0,0 +1,318 @@ +(* TEST + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +type 'a ref_u = #{ contents : 'a } + +(* This test is based on testsuite/tests/typing-misc/records.ml *) + +(* undefined labels *) +type t = #{x:int;y:int};; +#{x=3;z=2};; +[%%expect{| +type 'a ref_u = #{ contents : 'a; } +type t = #{ x : int; y : int; } +Line 7, characters 6-7: +7 | #{x=3;z=2};; + ^ +Error: Unbound unboxed record field "z" +|}];; +fun #{x=3;z=2} -> ();; +[%%expect{| +Line 1, characters 10-11: +1 | fun #{x=3;z=2} -> ();; + ^ +Error: Unbound unboxed record field "z" +|}];; + +(* mixed labels *) +#{x=3; contents=2};; +[%%expect{| +Line 1, characters 7-15: +1 | #{x=3; contents=2};; + ^^^^^^^^ +Error: The unboxed record field "contents" belongs to the type "'a ref_u" + but is mixed here with fields of type "t" +|}];; + +(* private types *) +type u = private #{mutable u:int};; +#{u=3};; +[%%expect{| +type u = private #{ mutable u : int; } +Line 2, characters 0-6: +2 | #{u=3};; + ^^^^^^ +Error: Cannot create values of the private type "u" +|}];; + +(* Punning and abbreviations *) +module M = struct + type t = #{x: int; y: int} +end;; +[%%expect{| +module M : sig type t = #{ x : int; y : int; } end +|}];; + +let f #{M.x; y} = x+y;; +let r () = #{M.x=1; y=2};; +let z () = f (r ());; +[%%expect{| +val f : M.t -> int = +val r : unit -> M.t = +val z : unit -> int = +|}];; + +(* messages *) + +let f (r: int) = + match r with + | #{ contents = 3 } -> () +[%%expect{| +Line 3, characters 4-21: +3 | | #{ contents = 3 } -> () + ^^^^^^^^^^^^^^^^^ +Error: This pattern matches values of type "int ref_u" + but a pattern was expected which matches values of type "int" +|}];; + + + +(* bugs *) +type foo = #{ y: int; z: int };; +type bar = #{ x: int };; +let f (r: bar) = (#{ r with z = 3 } : foo) +[%%expect{| +type foo = #{ y : int; z : int; } +type bar = #{ x : int; } +Line 3, characters 21-22: +3 | let f (r: bar) = (#{ r with z = 3 } : foo) + ^ +Error: This expression has type "bar" but an expression was expected of type + "foo" +|}];; + +type foo = #{ x: int };; +let r : foo = #{ ZZZ.x = 2 };; +[%%expect{| +type foo = #{ x : int; } +Line 2, characters 17-22: +2 | let r : foo = #{ ZZZ.x = 2 };; + ^^^^^ +Error: Unbound module "ZZZ" +|}];; + +(ZZZ.X : int option);; +[%%expect{| +Line 1, characters 1-6: +1 | (ZZZ.X : int option);; + ^^^^^ +Error: Unbound module "ZZZ" +|}];; + +(* PR#5865 *) +let f (x : Complex.t) = x.Complex.z;; +[%%expect{| +Line 1, characters 26-35: +1 | let f (x : Complex.t) = x.Complex.z;; + ^^^^^^^^^ +Error: Unbound record field "Complex.z" +|}];; + +(* PR#6608 *) +#{ true with contents = 0 };; +[%%expect{| +Line 1, characters 3-7: +1 | #{ true with contents = 0 };; + ^^^^ +Error: This expression has type "bool" which is not a unboxed record type. +|}];; + +type ('a, 'b) t = #{ fst : 'a; snd : 'b };; +let with_fst r fst = #{ r with fst };; +with_fst #{ fst=""; snd="" } 2;; +[%%expect{| +type ('a, 'b) t = #{ fst : 'a; snd : 'b; } +val with_fst : ('a, 'b) t -> 'c -> ('c, 'b) t = +Line 3, characters 0-30: +3 | with_fst #{ fst=""; snd="" } 2;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Types of unnamed expressions must have layout value when using + the toplevel, but this expression has layout "value & value". +|}];; + +(* PR#7695 *) +type 'a t = #{ f : 'a; g : 'a };; +let x () = #{ f = 12; g = 43 };; +let foo () = let x = x () in #{x with f = "hola"};; +[%%expect{| +type 'a t = #{ f : 'a; g : 'a; } +val x : unit -> int t = +Line 3, characters 29-49: +3 | let foo () = let x = x () in #{x with f = "hola"};; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "string t" + but an expression was expected of type "int t" + Type "string" is not compatible with type "int" +|}] + +(* PR#7696 *) +let r = #{ (assert false) with contents = 1 } ;; +[%%expect{| +Line 1, characters 8-45: +1 | let r = #{ (assert false) with contents = 1 } ;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 23 [useless-record-with]: all the fields are explicitly listed in this unboxed record: +the 'with' clause is useless. + +val r : int ref_u = #{contents = 1} +|}] + +(* reexport *) + +type ('a,'b) def = #{ x:int } constraint 'b = [> `A] + +type arity = (int, [`A]) def = #{x:int};; +[%%expect{| +type ('a, 'b) def = #{ x : int; } constraint 'b = [> `A ] +Line 3, characters 0-39: +3 | type arity = (int, [`A]) def = #{x:int};; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + "(int, [ `A ]) def" + They have different arities. +|}] + +type ('a,'b) ct = (int,'b) def = #{x:int};; +[%%expect{| +Line 1, characters 0-41: +1 | type ('a,'b) ct = (int,'b) def = #{x:int};; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + "(int, [> `A ]) def" + Their parameters differ: + The type "int" is not equal to the type "'a" +|}] + +type ('a,'b) kind = ('a, 'b) def = A constraint 'b = [> `A];; +[%%expect{| +Line 1, characters 0-59: +1 | type ('a,'b) kind = ('a, 'b) def = A constraint 'b = [> `A];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + "('a, [> `A ]) def" + The original is an unboxed record, but this is a variant. +|}] + +type d = #{ x:int; y : int } +type mut = d = #{x:int; mutable y:int} +[%%expect{| +type d = #{ x : int; y : int; } +Line 2, characters 0-38: +2 | type mut = d = #{x:int; mutable y:int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type "d" + Fields do not match: + "y : int;" + is not the same as: + "mutable y : int;" + This is mutable and the original is not. +|}] + +type missing = d = #{ x:int } +[%%expect{| +Line 1, characters 0-29: +1 | type missing = d = #{ x:int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type "d" + An extra field, "y", is provided in the original definition. +|}] + +type wrong_type = d = #{x:float} +[%%expect{| +Line 1, characters 0-32: +1 | type wrong_type = d = #{x:float} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type "d" + 1. Fields do not match: + "x : int;" + is not the same as: + "x : float;" + The type "int" is not equal to the type "float" + 2. An extra field, "y", is provided in the original definition. +|}] + +type mono = #{foo:int} +type unboxed = mono = #{foo:int} [@@unboxed] +[%%expect{| +type mono = #{ foo : int; } +Line 2, characters 0-44: +2 | type unboxed = mono = #{foo:int} [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This type cannot be unboxed because + cannot use [@@unboxed] on unboxed record. +|}] + +type perm = d = #{y:int; x:int} +[%%expect{| +Line 1, characters 0-31: +1 | type perm = d = #{y:int; x:int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type "d" + Fields "x" and "y" have been swapped. +|}] + +type t = #{ f1 : int ; f2 : int } + +let f () = #{ f1 = 0 + ; Coq__10.f2 = 0 } + +[%%expect{| +type t = #{ f1 : int; f2 : int; } +Line 4, characters 10-20: +4 | ; Coq__10.f2 = 0 } + ^^^^^^^^^^ +Error: Unbound module "Coq__10" +|}] + +module Coq__11 = struct + type t = #{ f1 : int ; f2 : int; f3 : int } +end + +let f () = #{ f1 = 0 + ; Coq__10.f2 = 0 + ; Coq__11.f3 = 0 } + +[%%expect{| +module Coq__11 : sig type t = #{ f1 : int; f2 : int; f3 : int; } end +Line 6, characters 13-23: +6 | ; Coq__10.f2 = 0 + ^^^^^^^^^^ +Error: Unbound module "Coq__10" +Hint: Did you mean "Coq__11"? +|}] + +type a = unit +type b = a = #{ a : int } +[%%expect{| +type a = unit +Line 2, characters 0-25: +2 | type b = a = #{ a : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type "a" + The original is abstract, but this is an unboxed record. +|}] + +type a = unit +type b = a = #{ a : int } +[%%expect{| +type a = unit +Line 2, characters 0-25: +2 | type b = a = #{ a : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type "a" + The original is abstract, but this is an unboxed record. +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml new file mode 100644 index 00000000000..1764b3a7a85 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml @@ -0,0 +1,104 @@ +(* TEST + reference = "${test_source_directory}/unboxed_records.reference"; + include stdlib_upstream_compatible; + flambda2; + { + ocamlc_byte_exit_status = "2"; + setup-ocamlc.byte-build-env; + compiler_reference = "${test_source_directory}/unboxed_records_stable.compilers.reference"; + ocamlc.byte; + check-ocamlc.byte-output; + }{ + ocamlc_byte_exit_status = "2"; + setup-ocamlc.byte-build-env; + flags = "-extension-universe upstream_compatible"; + compiler_reference = "${test_source_directory}/unboxed_records_stable.compilers.reference"; + ocamlc.byte; + check-ocamlc.byte-output; + }{ + ocamlc_byte_exit_status = "2"; + setup-ocamlc.byte-build-env; + flags = "-extension-universe no_extensions"; + compiler_reference = "${test_source_directory}/unboxed_records_disabled.compilers.reference"; + ocamlc.byte; + check-ocamlc.byte-output; + } { + flags = "-extension layouts_alpha"; + native; + } { + flags = "-extension layouts_alpha -Oclassic"; + native; + } { + flags = "-extension layouts_alpha -O3"; + native; + }{ + flags = "-extension layouts_alpha"; + bytecode; + }{ + flags = "-extension layouts_beta"; + native; + }{ + flags = "-extension layouts_beta -Oclassic"; + native; + }{ + flags = "-extension layouts_beta -O3"; + native; + }{ + flags = "-extension layouts_beta"; + bytecode; + } +*) + +type t = #{ i : int ; j : int } +let add #{ i ; j } = i + j +let () = + let t = #{i = 2; j = 3} in + let res = add t in + Printf.printf "Test 1: %d\n" res + +let add2 x y = add x + add y +let () = + let t1 = #{i = 2; j = 3} in + let t2 = #{i = 20; j = 30} in + let res = add2 t1 t2 in + Printf.printf "Test 2: %d\n" res + +let add t = t.#i + t.#j +let () = + let t = #{i = 200; j = 300} in + let res = add t in + Printf.printf "Test 3: %d\n" res + + +let copy_i_to_j #{ i ; j } = #{ i; j = i } +let () = + let t = #{i = 1000; j = 2} in + let res = add (copy_i_to_j t) in + Printf.printf "Test 4: %d\n" res + +let copy_i_to_j r = #{ r with j = r.#i } +let () = + let t = #{i = 1000; j = 2} in + let res = add (copy_i_to_j t) in + Printf.printf "Test 5: %d\n" res + +type r = #{ is: #(int * int) ; i : int } +let add r = + let #(x, y) = r.#is in + let z = r.#i in + let #{ is = #(x2, y2) ; i = z2 } = r in + assert (x == x2 && y == y2 && z == z2); + let #{ is ; i = _ } = r in + let #(x3, y3) = is in + assert (x == x3 && y == y3); + x + y + z +let () = + let t = #{ is = #(1, 10); i = 100} in + let res = add t in + Printf.printf "Test 6: %d\n" res + +let () = + let t = #{ is = #(1, 10); i = 100} in + let res = add #{ t with is = #(2, 20) } in + Printf.printf "Test 7: %d\n" res + diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference new file mode 100644 index 00000000000..c71bd2bd045 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference @@ -0,0 +1,7 @@ +Test 1: 5 +Test 2: 55 +Test 3: 500 +Test 4: 2000 +Test 5: 2000 +Test 6: 111 +Test 7: 122 diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference new file mode 100644 index 00000000000..0a2fe8b747b --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_records.ml", line 52, characters 0-31: +52 | type t = #{ i : int ; j : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference new file mode 100644 index 00000000000..0a2fe8b747b --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_records.ml", line 52, characters 0-31: +52 | type t = #{ i : int ; j : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts-unboxed-records/unique.ml b/testsuite/tests/typing-layouts-unboxed-records/unique.ml new file mode 100644 index 00000000000..9e043d72866 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unique.ml @@ -0,0 +1,92 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha -extension unique"; + { + expect; + } +*) + +(* Uniqueness tests *) + +type t = #{ x : string ; y : string } +let use_string (_s @ unique) = () +let mk : unit -> t @ unique = fun () -> #{ x = "hi"; y = "hi" } +[%%expect{| +type t = #{ x : string; y : string; } +val use_string : ('a : value_or_null). 'a @ unique -> unit = +val mk : unit -> t @ unique = +|}] + +(* Can access different fields *) +let () = + let t = mk () in + use_string t.#x; + use_string t.#y +[%%expect{| +|}] + +let () = + let #{ x ; y } = mk () in + use_string x; + use_string y +[%%expect{| +|}] + +(* Cannot access the same field twice *) +let () = + let t = mk () in + use_string t.#x; + use_string t.#x +[%%expect{| +Line 4, characters 13-17: +4 | use_string t.#x + ^^^^ +Error: This value is used here, but it has already been used as unique: +Line 3, characters 13-17: +3 | use_string t.#x; + ^^^^ + +|}] + +let () = + let #{ x ; y = _ } = mk () in + use_string x; + use_string x +[%%expect{| +Line 4, characters 13-14: +4 | use_string x + ^ +Error: This value is used here, but it has already been used as unique: +Line 3, characters 13-14: +3 | use_string x; + ^ + +|}] + +(* A functional update to a field allows a field to be reused *) +let () = + let t = mk () in + use_string t.#x; + let t = #{ t with x = "fresh" } in + use_string t.#x +[%%expect{| +|}] + +(* But not a functional update to a different field *) +let () = + let t = mk () in + use_string t.#x; + let t = #{ t with y = "fresh" } in + use_string t.#x +[%%expect{| +Line 4, characters 13-14: +4 | let t = #{ t with y = "fresh" } in + ^ +Error: This value is used here, but it has already been used as unique: +Line 3, characters 13-17: +3 | use_string t.#x; + ^^^^ + +|}] + diff --git a/testsuite/tests/typing-layouts-unboxed-records/unused.ml b/testsuite/tests/typing-layouts-unboxed-records/unused.ml new file mode 100644 index 00000000000..e611bda01ed --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unused.ml @@ -0,0 +1,140 @@ +(* TEST + flags = " -w +A -strict-sequence -extension layouts_beta"; + expect; +*) + +(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml] *) + +module Unused_record : sig end = struct + type t = #{ a : int; b : int } + let foo (x : t) = x + let _ = foo +end;; +[%%expect {| +Line 2, characters 14-22: +2 | type t = #{ a : int; b : int } + ^^^^^^^^ +Warning 69 [unused-field]: unused unboxed record field a. + +Line 2, characters 23-30: +2 | type t = #{ a : int; b : int } + ^^^^^^^ +Warning 69 [unused-field]: unused unboxed record field b. + +module Unused_record : sig end +|}] + +module Unused_field : sig end = struct + type t = #{ a : int } + let foo () = #{ a = 0 } + let _ = foo +end;; +[%%expect {| +Line 2, characters 14-21: +2 | type t = #{ a : int } + ^^^^^^^ +Warning 69 [unused-field]: unboxed record field a is never read. +(However, this field is used to build or mutate values.) + +module Unused_field : sig end +|}] + +module Unused_field : sig end = struct + type t = #{ a : int; b : int; c : int } + let foo () = #{ a = 0; b = 0; c = 0 } + let bar x = x.#a + let baz #{ c; _ } = c + let _ = foo, bar, baz +end;; +[%%expect {| +Line 2, characters 23-31: +2 | type t = #{ a : int; b : int; c : int } + ^^^^^^^^ +Warning 69 [unused-field]: unboxed record field b is never read. +(However, this field is used to build or mutate values.) + +module Unused_field : sig end +|}] + +module Unused_mutable_field : sig end = struct + type t = #{ a : int; mutable b : int } + let foo () = #{ a = 0; b = 0 } + let bar x = x.#a, x.#b + let _ = foo, bar +end;; +[%%expect {| +Line 2, characters 23-38: +2 | type t = #{ a : int; mutable b : int } + ^^^^^^^^^^^^^^^ +Warning 69 [unused-field]: mutable unboxed record field b is never mutated. + +module Unused_mutable_field : sig end +|}] + +module Unused_field_exported_private : sig + type t = private #{ a : int } +end = struct + type t = #{ a : int } +end;; +[%%expect {| +module Unused_field_exported_private : sig type t = private #{ a : int; } end +|}] + +module Unused_field_exported_private : sig + type t = private #{ a : int } +end = struct + type t = #{ a : int } + let foo x = x.#a + let _ = foo +end;; +[%%expect {| +module Unused_field_exported_private : sig type t = private #{ a : int; } end +|}] + +module Unused_mutable_field_exported_private : sig + type t = private #{ a : int; mutable b : int } +end = struct + type t = #{ a : int; mutable b : int } + let foo () = #{ a = 0; b = 0 } + let _ = foo +end;; +[%%expect {| +Line 4, characters 23-38: +4 | type t = #{ a : int; mutable b : int } + ^^^^^^^^^^^^^^^ +Warning 69 [unused-field]: mutable unboxed record field b is never mutated. + +module Unused_mutable_field_exported_private : + sig type t = private #{ a : int; mutable b : int; } end +|}] + +module Unused_field_disable_warning : sig +end = struct + type t = #{ a: int; b:int } [@@warning "-unused-field"] +end;; +[%%expect {| +Line 3, characters 2-57: +3 | type t = #{ a: int; b:int } [@@warning "-unused-field"] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 34 [unused-type-declaration]: unused type t. + +module Unused_field_disable_warning : sig end +|}] + +module Unused_field_disable_one_warning : sig +end = struct + type t = #{ a: int [@warning "-unused-field"]; b:int } +end;; +[%%expect {| +Line 3, characters 2-56: +3 | type t = #{ a: int [@warning "-unused-field"]; b:int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 34 [unused-type-declaration]: unused type t. + +Line 3, characters 49-54: +3 | type t = #{ a: int [@warning "-unused-field"]; b:int } + ^^^^^ +Warning 69 [unused-field]: unused unboxed record field b. + +module Unused_field_disable_one_warning : sig end +|}] diff --git a/testsuite/tests/typing-layouts-vec128/basics.ml b/testsuite/tests/typing-layouts-vec128/basics.ml index 80a908507e7..f5d9cabc607 100644 --- a/testsuite/tests/typing-layouts-vec128/basics.ml +++ b/testsuite/tests/typing-layouts-vec128/basics.ml @@ -221,7 +221,7 @@ Line 1, characters 14-26: 1 | type t5_3 = { x : t_vec128 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_vec128" has layout "vec128". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_vec128;; @@ -268,7 +268,7 @@ Line 1, characters 21-33: 1 | type t5_6_1 = A of { x : t_vec128 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_vec128" has layout "vec128". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; (****************************************************) diff --git a/testsuite/tests/typing-layouts-vec128/basics_alpha.ml b/testsuite/tests/typing-layouts-vec128/basics_alpha.ml index 85aac21c005..ed315b5495f 100644 --- a/testsuite/tests/typing-layouts-vec128/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-vec128/basics_alpha.ml @@ -216,7 +216,7 @@ Line 1, characters 14-26: 1 | type t5_3 = { x : t_vec128 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_vec128" has layout "vec128". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_vec128;; @@ -263,7 +263,7 @@ Line 1, characters 21-33: 1 | type t5_6_1 = A of { x : t_vec128 } [@@unboxed];; ^^^^^^^^^^^^ Error: Type "t_vec128" has layout "vec128". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; (****************************************************) diff --git a/testsuite/tests/typing-layouts-word/basics.ml b/testsuite/tests/typing-layouts-word/basics.ml index 1cd109b1cca..7d5cd3f4dd5 100644 --- a/testsuite/tests/typing-layouts-word/basics.ml +++ b/testsuite/tests/typing-layouts-word/basics.ml @@ -221,7 +221,7 @@ Line 1, characters 14-24: 1 | type t5_3 = { x : t_word } [@@unboxed];; ^^^^^^^^^^ Error: Type "t_word" has layout "word". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_word;; @@ -267,7 +267,7 @@ Line 1, characters 21-31: 1 | type t5_6_1 = A of { x : t_word } [@@unboxed];; ^^^^^^^^^^ Error: Type "t_word" has layout "word". - Unboxed inlined records may not yet contain types of this layout. + [@@unboxed] inlined records may not yet contain types of this layout. |}];; (****************************************************) diff --git a/testsuite/tests/typing-layouts-word/basics_alpha.ml b/testsuite/tests/typing-layouts-word/basics_alpha.ml index ab453323b17..9bb8ac061e7 100644 --- a/testsuite/tests/typing-layouts-word/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-word/basics_alpha.ml @@ -219,7 +219,7 @@ Line 1, characters 14-24: 1 | type t5_3 = { x : t_word } [@@unboxed];; ^^^^^^^^^^ Error: Type "t_word" has layout "word". - Unboxed records may not yet contain types of this layout. + [@@unboxed] records may not yet contain types of this layout. |}];; type t5_4 = A of t_word;; diff --git a/testsuite/tests/typing-layouts/basics_alpha.ml b/testsuite/tests/typing-layouts/basics_alpha.ml index 1eebbfc80ca..97eaf998df2 100644 --- a/testsuite/tests/typing-layouts/basics_alpha.ml +++ b/testsuite/tests/typing-layouts/basics_alpha.ml @@ -636,15 +636,16 @@ module M9_4 = struct | ({vur_void = _},i) -> i end;; [%%expect {| -Line 4, characters 8-16: +Line 4, characters 7-21: 4 | | ({vur_void = _},i) -> i - ^^^^^^^^ -Error: The record field "vur_void" belongs to the type "void_unboxed_record" - but is mixed here with fields of type "('a : value)" + ^^^^^^^^^^^^^^ +Error: This pattern matches values of type "void_unboxed_record" + but a pattern was expected which matches values of type + "('a : value_or_null)" The layout of void_unboxed_record is void because of the definition of void_unboxed_record at line 12, characters 0-60. But the layout of void_unboxed_record must be a sublayout of value - because it's a boxed record type. + because it's the type of a tuple element. |}];; module M9_5 = struct diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 8d933726124..782edf4582b 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -229,7 +229,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct and tree_of_label = tree_of_qualified (fun lid env -> - (Env.find_label_by_name lid env).lbl_res) + (Env.find_label_by_name Legacy lid env).lbl_res) (* An abstract type *) @@ -245,6 +245,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | Outval_record_unboxed | Outval_record_mixed_block of mixed_product_shape + type outval_record_unboxed_product_rep = + | Outval_record_unboxed_product + type printing_jkind = | Print_as_value (* can interpret as a value and print *) | Print_as of string (* can't print *) @@ -517,6 +520,19 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct env path decl.type_params ty_list lbl_list pos obj rep end + | {type_kind = Type_record_unboxed_product(lbl_list, rep)} -> + begin match check_depth depth obj ty with + Some x -> x + | None -> + let pos = 0 in + let rep = + match rep with + | Record_unboxed_product -> Outval_record_unboxed_product + in + tree_of_record_unboxed_product_fields depth + env path decl.type_params ty_list + lbl_list pos obj rep + end | {type_kind = Type_open} -> tree_of_extension path ty_list depth obj with @@ -605,6 +621,37 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct in Oval_record (tree_of_fields (pos = 0) pos lbl_list) + and tree_of_record_unboxed_product_fields depth env path type_params ty_list + lbl_list pos obj rep = + let rec tree_of_fields first pos = function + | [] -> [] + | {ld_id; ld_type; ld_jkind} :: 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 lid = + if first then tree_of_label env path (Out_name.create name) + else Oide_ident (Out_name.create name) + and v = + match rep with + | Outval_record_unboxed_product -> + begin match get_and_default_jkind_for_printing ld_jkind with + | Print_as msg -> Oval_stuff msg + | Print_as_value -> + match lbl_list with + | [_] -> + (* singleton unboxed records are erased *) + tree_of_val (depth - 1) obj ty_arg + | _ -> nest tree_of_val (depth - 1) (O.field obj pos) ty_arg + end + in + let pos = if is_void then pos else pos + 1 in + (lid, v) :: tree_of_fields false pos remainder + in + Oval_record_unboxed_product (tree_of_fields (pos = 0) pos lbl_list) + and tree_of_labeled_val_list start depth obj labeled_tys = let rec tree_list i = function | [] -> [] diff --git a/typing/btype.ml b/typing/btype.ml index 5cfddea5b32..fe3d95514eb 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -134,7 +134,8 @@ let type_kind_is_abstract decl = let type_origin decl = match decl.type_kind with | Type_abstract origin -> origin - | Type_variant _ | Type_record _ | Type_open -> Definition + | Type_variant _ | Type_record _ | Type_record_unboxed_product _ | Type_open -> + Definition let dummy_method = "*dummy method*" @@ -344,6 +345,8 @@ let iter_type_expr_kind f = function cstrs | Type_record(lbls, _) -> List.iter (fun d -> f d.ld_type) lbls + | Type_record_unboxed_product(lbls, _) -> + List.iter (fun d -> f d.ld_type) lbls | Type_open -> () diff --git a/typing/ctype.ml b/typing/ctype.ml index 921cc40d6a3..80c6c382b99 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -430,7 +430,7 @@ let in_pervasives p = let is_datatype decl= match decl.type_kind with - Type_record _ | Type_variant _ | Type_open -> true + Type_record _ | Type_record_unboxed_product _ | Type_variant _ | Type_open -> true | Type_abstract _ -> false @@ -713,6 +713,8 @@ let closed_type_decl decl = v | Type_record(r, _rep) -> List.iter (fun l -> close_type l.ld_type) r + | Type_record_unboxed_product(r, _rep) -> + List.iter (fun l -> close_type l.ld_type) r | Type_open -> () end; begin match decl.type_manifest with @@ -1481,6 +1483,12 @@ let map_kind f = function (fun l -> {l with ld_type = f l.ld_type} ) fl, rr) + | Type_record_unboxed_product (fl, rr) -> + Type_record_unboxed_product ( + List.map + (fun l -> + {l with ld_type = f l.ld_type} + ) fl, rr) let instance_declaration decl = @@ -2071,6 +2079,8 @@ let expand_head_opt env ty = type unbox_result = (* unboxing process made a step: either an unboxing or removal of a [Tpoly] *) | Stepped of type_expr + (* unboxing process unboxed a product. Invariant: length >= 2 *) + | Stepped_record_unboxed_product of type_expr list (* no step to make; we're all done here *) | Final_result (* definition not in environment: missing cmi *) @@ -2082,11 +2092,18 @@ let unbox_once env ty = begin match Env.find_type p env with | exception Not_found -> Missing p | decl -> + let apply ty2 = apply env decl.type_params ty2 args in begin match find_unboxed_type decl with - | None -> Final_result | Some ty2 -> let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in - Stepped (apply env decl.type_params ty2 args) + Stepped (apply ty2) + | None -> begin match decl.type_kind with + | Type_record_unboxed_product ([{ld_type = arg; _}], Record_unboxed_product) -> + Stepped (apply arg) + | Type_record_unboxed_product ((_::_::_ as lbls), Record_unboxed_product) -> + Stepped_record_unboxed_product (List.map (fun ld -> apply ld.ld_type) lbls) + | _ -> Final_result + end end end | Tpoly (ty, _) -> Stepped ty @@ -2103,7 +2120,7 @@ let rec get_unboxed_type_representation env ty_prev ty fuel = match unbox_once env ty with | Stepped ty2 -> get_unboxed_type_representation env ty ty2 (fuel - 1) - | Final_result -> Ok ty + | Stepped_record_unboxed_product _ | Final_result -> Ok ty | Missing _ -> Ok ty_prev let get_unboxed_type_representation env ty = @@ -2156,10 +2173,75 @@ let rec estimate_type_jkind ~expand_component env ty = | Tpoly (ty, _) -> estimate_type_jkind ~expand_component env ty | Tpackage _ -> Jkind.Builtin.value ~why:First_class_module +(* CR layouts v7.2: Remove this function once we have have kind-polymorphic type + declarations, and replace its uses with + [estimate_type_jkind ~expand_component:(get_unboxed_type_approximation env)]. + + [type_jkind_deep] calulates a jkind from a type expression, deeply + unfolding unboxed types. + + This deep unfolding is necessary (for now) for declarations like the following: + + type 'a t = #{ i : 'a ; j : 'a } + type int_t : immediate & immediate = int t + + Otherwise, [int_t] will be given kind [value & value]. + + This function duplicates functionality from [find_unboxed_type] and + [constrain_type_jkind]. We're not to factoring out the shared logic because this + function will no longer be necessary once we have kind-polymorphic type declarations. + + Returns (ran_out_of_fuel, best_effort_jkind). +*) +let rec type_jkind_deep env ty_prev ty fuel = + let fuel = fuel - 1 in + if fuel < 0 then + let _, jkind = type_unboxed_jkind_deep env ty fuel in + true, jkind + else + let ty = expand_head_opt env ty in + match unbox_once env ty with + | Stepped ty' -> type_jkind_deep env ty ty' fuel + | Stepped_record_unboxed_product component_tys -> + let out_of_fuel, component_jkinds = types_jkinds_deep env component_tys fuel in + out_of_fuel, Jkind.Builtin.product ~why:Unboxed_record component_jkinds + | Final_result -> type_unboxed_jkind_deep env ty fuel + | Missing _ -> type_unboxed_jkind_deep env ty_prev fuel +and types_jkinds_deep env tys fuel = + List.fold_left_map (fun any_out_of_fuel ty -> + let out_of_fuel, jkind = type_jkind_deep env ty ty fuel in + (any_out_of_fuel || out_of_fuel), jkind + ) false tys +and type_unboxed_jkind_deep env ty fuel = + (* We've scraped off [@@unboxed] and unboxed records as much as we can. *) + match get_desc ty with + | Tvar { jkind } -> false, Jkind.disallow_right jkind + | Tarrow _ -> false, Jkind.for_arrow + | Ttuple _ -> false, Jkind.Builtin.value ~why:Tuple + | Tunboxed_tuple ltys -> + let out_of_fuel, component_jkinds = types_jkinds_deep env (List.map snd ltys) fuel in + out_of_fuel, Jkind.Builtin.product ~why:Unboxed_tuple component_jkinds + | Tconstr (p, _, _) -> begin + try + false, (Env.find_type p env).type_jkind + with + Not_found -> false, Jkind.Builtin.any ~why:(Missing_cmi p) + end + | Tobject _ -> false, Jkind.for_object + | Tfield _ -> false, Jkind.Builtin.value ~why:Tfield + | Tnil -> false, Jkind.Builtin.value ~why:Tnil + | Tlink _ | Tsubst _ -> assert false + | Tvariant row -> + if tvariant_not_immediate row + then false, Jkind.Builtin.value ~why:Polymorphic_variant + else false, Jkind.Builtin.immediate ~why:Immediate_polymorphic_variant + | Tunivar { jkind } -> false, Jkind.disallow_right jkind + | Tpoly (ty, _) -> type_unboxed_jkind_deep env ty fuel + | Tpackage _ -> false, Jkind.Builtin.value ~why:First_class_module + let type_jkind env ty = - estimate_type_jkind env - ~expand_component:(get_unboxed_type_approximation env) - (get_unboxed_type_approximation env ty) + let _, jkind = type_jkind_deep env ty ty 100 in + jkind let type_jkind_purely env ty = if !Clflags.principal || Env.has_local_constraints env then @@ -2251,24 +2333,8 @@ let constrain_type_jkind ~fixed env ty jkind = message. *) Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) | Has_intersection -> - match get_desc ty with - | Tconstr _ -> - if not expanded - then - let ty = expand_head_opt env ty in - loop ~fuel ~expanded:true ty (estimate_type_jkind env ty) jkind - else - begin match unbox_once env ty with - | Missing path -> Error (Jkind.Violation.of_ ~missing_cmi:path - (Not_a_subjkind (ty's_jkind, jkind))) - | Final_result -> - Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) - | Stepped ty -> - loop ~fuel:(fuel - 1) ~expanded:false ty - (estimate_type_jkind env ty) jkind - end - | Tunboxed_tuple ltys -> - let num_components = List.length ltys in + let product tys = + let num_components = List.length tys in let recur ty's_jkinds jkinds = (* Note: here we "duplicate" the fuel, which may seem like cheating. Fuel counts expansions, and its purpose is to guard @@ -2277,8 +2343,7 @@ let constrain_type_jkind ~fixed env ty jkind = that's fine. *) let results = Misc.Stdlib.List.map3 - (fun (_, ty) -> loop ~fuel ~expanded:false ty) - ltys ty's_jkinds jkinds + (loop ~fuel:(fuel - 1) ~expanded:false) tys ty's_jkinds jkinds in Misc.Stdlib.Monad.Result.all_unit results in @@ -2294,8 +2359,28 @@ let constrain_type_jkind ~fixed env ty jkind = mode-crossing restrictions, so we recur, just duplicating the jkind. *) recur ty's_jkinds (List.init num_components (fun _ -> jkind)) - | _ -> Misc.fatal_error "unboxed tuple jkinds don't line up" + | _ -> Misc.fatal_error "unboxed product jkinds don't line up" end + in + match get_desc ty with + | Tconstr _ -> + if not expanded + then + let ty = expand_head_opt env ty in + loop ~fuel ~expanded:true ty (estimate_type_jkind env ty) jkind + else + begin match unbox_once env ty with + | Missing path -> Error (Jkind.Violation.of_ ~missing_cmi:path + (Not_a_subjkind (ty's_jkind, jkind))) + | Final_result -> + Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) + | Stepped ty -> + loop ~fuel:(fuel - 1) ~expanded:false ty + (estimate_type_jkind env ty) jkind + | Stepped_record_unboxed_product tys -> + product tys + end + | Tunboxed_tuple ltys -> product (List.map snd ltys) | _ -> Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) in loop ~fuel:100 ~expanded:false ty (estimate_type_jkind env ty) jkind @@ -3175,6 +3260,10 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = when equal_record_representation r r' -> mcomp_list type_pairs env tl1 tl2; mcomp_record_description type_pairs env lst lst' + | Type_record_unboxed_product (lst,r), Type_record_unboxed_product (lst',r') + when equal_record_unboxed_product_representation r r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' | Type_variant (v1,r), Type_variant (v2,r') when equal_variant_representation r r' -> mcomp_list type_pairs env tl1 tl2; diff --git a/typing/ctype.mli b/typing/ctype.mli index 309837a2a6b..6caadd85790 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -219,7 +219,7 @@ val instance_poly: val polyfy: Env.t -> type_expr -> type_expr list -> type_expr * bool val instance_label: fixed:bool -> - label_description -> type_expr list * type_expr * type_expr + _ gen_label_description -> type_expr list * type_expr * type_expr (* Same, for a label *) val prim_mode : (Mode.allowed * 'r) Mode.Locality.t option -> (Primitive.mode * Primitive.native_repr) diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 706898be068..1dfac3eb53e 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -221,20 +221,24 @@ let none = create_expr (Ttuple []) ~level:(-1) ~scope:Btype.generic_level ~id:(-1) (* Clearly ill-formed type *) -let dummy_label = +let dummy_label (type rep) (record_form : rep record_form) : rep gen_label_description = + let repres : rep = match record_form with + | Legacy -> Record_unboxed + | Unboxed_product -> Record_unboxed_product + 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_num = -1; lbl_pos = -1; lbl_all = [||]; - lbl_repres = Record_unboxed; + lbl_repres = repres; lbl_private = Public; lbl_loc = Location.none; lbl_attributes = []; lbl_uid = Uid.internal_not_actually_unique; } -let label_descrs ty_res lbls repres priv = - let all_labels = Array.make (List.length lbls) dummy_label in +let label_descrs record_form ty_res lbls repres priv = + let all_labels = Array.make (List.length lbls) (dummy_label record_form) in let rec describe_labels num pos = function [] -> [] | l :: rest -> @@ -280,11 +284,20 @@ let constructors_of_type ~current_unit ty_path decl = match decl.type_kind with | Type_variant (cstrs,rep) -> constructor_descrs ~current_unit ty_path decl cstrs rep - | Type_record _ | Type_abstract _ | Type_open -> [] + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ | Type_open -> [] let labels_of_type ty_path decl = match decl.type_kind with | Type_record(labels, rep) -> - label_descrs (newgenconstr ty_path decl.type_params) + label_descrs Legacy (newgenconstr ty_path decl.type_params) + labels rep decl.type_private + | Type_record_unboxed_product _ + | Type_variant _ | Type_abstract _ | Type_open -> [] + +let unboxed_labels_of_type ty_path decl = + match decl.type_kind with + | Type_record_unboxed_product(labels, rep) -> + label_descrs Unboxed_product (newgenconstr ty_path decl.type_params) labels rep decl.type_private + | Type_record _ | Type_variant _ | Type_abstract _ | Type_open -> [] diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 3bc77cda150..606fa6eab1b 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -25,6 +25,9 @@ val extension_descr: val labels_of_type: Path.t -> type_declaration -> (Ident.t * label_description) list +val unboxed_labels_of_type: + Path.t -> type_declaration -> + (Ident.t * unboxed_label_description) list val constructors_of_type: current_unit:Compilation_unit.t option -> Path.t -> type_declaration -> (Ident.t * constructor_description) list diff --git a/typing/env.ml b/typing/env.ml index fdc7b035ed4..ff40100f9cc 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -127,6 +127,9 @@ let label_usage_complaint priv mut lu let used_labels : label_usage usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let used_unboxed_labels : label_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 + (** Map indexed by the name of module components. *) module NameMap = String.Map @@ -611,7 +614,7 @@ module IdTbl = end type type_descr_kind = - (label_description, constructor_description) type_kind + (label_description, unboxed_label_description, constructor_description) type_kind type type_descriptions = type_descr_kind @@ -621,6 +624,7 @@ type t = { values: (lock, value_entry, value_data) IdTbl.t; constrs: constructor_data TycompTbl.t; labels: label_data TycompTbl.t; + unboxed_labels: unboxed_label_description TycompTbl.t; types: (empty, type_data, type_data) IdTbl.t; modules: (lock, module_entry, module_data) IdTbl.t; modtypes: (empty, modtype_data, modtype_data) IdTbl.t; @@ -663,6 +667,7 @@ and structure_components = { mutable comp_values: value_data NameMap.t; mutable comp_constrs: constructor_data list NameMap.t; mutable comp_labels: label_data list NameMap.t; + mutable comp_unboxed_labels: unboxed_label_description list NameMap.t; mutable comp_types: type_data NameMap.t; mutable comp_modules: module_data NameMap.t; mutable comp_modtypes: modtype_data NameMap.t; @@ -742,6 +747,7 @@ let empty_structure = comp_values = NameMap.empty; comp_constrs = NameMap.empty; comp_labels = NameMap.empty; + comp_unboxed_labels = NameMap.empty; comp_types = NameMap.empty; comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; comp_classes = NameMap.empty; @@ -763,7 +769,7 @@ type lookup_error = | Unbound_value of Longident.t * unbound_value_hint | Unbound_type of Longident.t | Unbound_constructor of Longident.t - | Unbound_label of Longident.t + | Unbound_label of (Longident.t * record_form_packed) | Unbound_module of Longident.t | Unbound_class of Longident.t | Unbound_modtype of Longident.t @@ -811,6 +817,31 @@ let mode_default mode = { context = None } +let used_labels_by_form (type rep) (record_form : rep record_form) = + match record_form with + | Legacy -> !used_labels + | Unboxed_product -> !used_unboxed_labels + +let find_used_label_by_uid (type rep) (record_form : rep record_form) uid = + Types.Uid.Tbl.find (used_labels_by_form record_form) uid + +let env_labels (type rep) (record_form : rep record_form) env : rep gen_label_description TycompTbl.t = + match record_form with + | Legacy -> env.labels + | Unboxed_product -> env.unboxed_labels + +let add_label (type rep) (record_form : rep record_form) env lbl_id (lbl : rep gen_label_description) = + match record_form with + | Legacy -> + { env with labels = TycompTbl.add lbl_id lbl env.labels } + | Unboxed_product -> + { env with unboxed_labels = TycompTbl.add lbl_id lbl env.unboxed_labels } + +let comp_labels (type rep) (record_form : rep record_form) sc : rep gen_label_description list NameMap.t = + match record_form with + | Legacy -> sc.comp_labels + | Unboxed_product -> sc.comp_unboxed_labels + let same_type_declarations e1 e2 = e1.types == e2.types && e1.modules == e2.modules && @@ -838,6 +869,9 @@ let check_shadowing env = function | `Label (Some (l1, l2)) when not (!same_constr env l1.lbl_res l2.lbl_res) -> Some "label" + | `Unboxed_label (Some (l1, l2)) + when not (!same_constr env l1.lbl_res l2.lbl_res) -> + Some "unboxed label" | `Value (Some (Val_unbound _, _)) -> None | `Value (Some (_, _)) -> Some "value" | `Type (Some _) -> Some "type" @@ -847,14 +881,14 @@ let check_shadowing env = function | `Module_type (Some _) -> Some "module type" | `Class (Some _) -> Some "class" | `Class_type (Some _) -> Some "class type" - | `Constructor _ | `Label _ + | `Constructor _ | `Label _ | `Unboxed_label _ | `Value None | `Type None | `Module None | `Module_type None | `Class None | `Class_type None | `Component None -> None let empty = { values = IdTbl.empty; constrs = TycompTbl.empty; - labels = TycompTbl.empty; types = IdTbl.empty; + labels = TycompTbl.empty; unboxed_labels = TycompTbl.empty; types = IdTbl.empty; modules = IdTbl.empty; modtypes = IdTbl.empty; classes = IdTbl.empty; cltypes = IdTbl.empty; summary = Env_empty; local_constraints = Path.Map.empty; @@ -1134,6 +1168,7 @@ let reset_declaration_caches () = Types.Uid.Tbl.clear !module_declarations; Types.Uid.Tbl.clear !used_constructors; Types.Uid.Tbl.clear !used_labels; + Types.Uid.Tbl.clear !used_unboxed_labels; () let reset_cache ~preserve_persistent_env = @@ -1331,7 +1366,8 @@ and find_cstr path name env = match tda.tda_descriptions with | Type_variant (cstrs, _) -> List.find (fun cstr -> cstr.cstr_name = name) cstrs - | Type_record _ | Type_abstract _ | Type_open -> raise Not_found + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ | Type_open -> + raise Not_found @@ -1377,11 +1413,12 @@ let find_class path env = let find_ident_constructor id env = (TycompTbl.find_same id env.constrs).cda_description -let find_ident_label id env = - TycompTbl.find_same id env.labels +let find_ident_label record_form id env = + TycompTbl.find_same id (env_labels record_form env) let find_type p env = - (find_type_data p env).tda_declaration + let td = (find_type_data p env) in + td.tda_declaration let find_type_descrs p env = (find_type_data p env).tda_descriptions @@ -1476,6 +1513,8 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid) | Label -> Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid) + | Unboxed_label -> + Shape.leaf ((TycompTbl.find_same id env.unboxed_labels).lbl_uid) | Extension_constructor -> (TycompTbl.find_same id env.constrs).cda_shape | Value -> @@ -1898,7 +1937,8 @@ let rec components_of_module_maker let c = { comp_values = NameMap.empty; comp_constrs = NameMap.empty; - comp_labels = NameMap.empty; comp_types = NameMap.empty; + comp_labels = NameMap.empty; comp_unboxed_labels = NameMap.empty; + comp_types = NameMap.empty; comp_modules = NameMap.empty; comp_modtypes = NameMap.empty; comp_classes = NameMap.empty; comp_cltypes = NameMap.empty } in @@ -1962,6 +2002,16 @@ let rec components_of_module_maker add_to_tbl descr.lbl_name descr c.comp_labels) lbls; Type_record (lbls, repr) + | Type_record_unboxed_product (_, repr) -> + let (lbls : unboxed_label_description list) = List.map snd + (Datarepr.unboxed_labels_of_type path final_decl) + in + List.iter + (fun descr -> + c.comp_unboxed_labels <- + add_to_tbl descr.lbl_name descr c.comp_unboxed_labels) + lbls; + Type_record_unboxed_product (lbls, repr) | Type_abstract r -> Type_abstract r | Type_open -> Type_open in @@ -2155,10 +2205,13 @@ and store_constructor ~check type_decl type_id cstr_id cstr env = { cda_description = cstr; cda_address = None; cda_shape } env.constrs; } -and store_label ~check type_decl type_id lbl_id lbl env = +and store_label + : 'rep. record_form:'rep record_form -> check:_ -> _ -> _ -> _ -> + 'rep gen_label_description -> _ -> _ = + fun ~record_form ~check type_decl type_id lbl_id lbl env -> Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> if check && not type_decl.type_loc.Location.loc_ghost - && Warnings.is_active (Warnings.Unused_field ("", Unused)) + && Warnings.is_active (Warnings.Unused_field ("", "", Unused)) then begin let ty_name = Ident.name type_id in let priv = type_decl.type_private in @@ -2166,10 +2219,9 @@ and store_label ~check type_decl type_id lbl_id lbl env = let loc = lbl.lbl_loc in let mut = lbl.lbl_mut in let k = lbl.lbl_uid in - if not (Types.Uid.Tbl.mem !used_labels k) then + if not (Types.Uid.Tbl.mem (used_labels_by_form record_form) k) then let used = label_usages () in - Types.Uid.Tbl.add !used_labels k - (add_label_usage used); + Types.Uid.Tbl.add (used_labels_by_form record_form) k (add_label_usage used); if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_') then !add_delayed_check_forward (fun () -> @@ -2177,7 +2229,8 @@ and store_label ~check type_decl type_id lbl_id lbl env = (fun complaint -> if not (is_in_signature env) then Location.prerr_warning - loc (Warnings.Unused_field(name, complaint))) + loc (Warnings.Unused_field(record_form_to_string record_form, + name, complaint))) (label_usage_complaint priv mut used)) end); Builtin_attributes.mark_alerts_used lbl.lbl_attributes; @@ -2186,9 +2239,7 @@ and store_label ~check type_decl type_id lbl_id lbl env = Builtin_attributes.mark_deprecated_mutable_used lbl.lbl_attributes; | Immutable -> () end; - { env with - labels = TycompTbl.add lbl_id lbl env.labels; - } + add_label record_form env lbl_id lbl and store_type ~check id info shape env = let loc = info.type_loc in @@ -2213,7 +2264,14 @@ and store_type ~check id info shape env = Type_record (List.map snd labels, repr), List.fold_left (fun env (lbl_id, lbl) -> - store_label ~check info id lbl_id lbl env) + store_label ~record_form:Legacy ~check info id lbl_id lbl env) + env labels + | Type_record_unboxed_product (_, repr) -> + let labels = Datarepr.unboxed_labels_of_type path info in + Type_record_unboxed_product (List.map snd labels, repr), + List.fold_left + (fun env (lbl_id, lbl) -> + store_label ~record_form:Unboxed_product ~check info id lbl_id lbl env) env labels | Type_abstract r -> Type_abstract r, env | Type_open -> Type_open, env @@ -2757,8 +2815,8 @@ let mark_extension_used usage ext = | mark -> mark usage | exception Not_found -> () -let mark_label_used usage ld = - match Types.Uid.Tbl.find !used_labels ld.ld_uid with +let mark_label_used record_form usage ld = + match find_used_label_by_uid record_form ld.ld_uid with | mark -> mark usage | exception Not_found -> () @@ -2769,14 +2827,14 @@ let mark_constructor_description_used usage env cstr = | mark -> mark usage | exception Not_found -> () -let mark_label_description_used usage env lbl = +let mark_label_description_used record_form usage env lbl = let ty_path = match get_desc lbl.lbl_res with | Tconstr(path, _, _) -> path | _ -> assert false in mark_type_path_used env ty_path; - match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with + match find_used_label_by_uid record_form lbl.lbl_uid with | mark -> mark usage | exception Not_found -> () @@ -2885,9 +2943,9 @@ let use_cltype ~use ~loc path desc = (Path.name path) end -let use_label ~use ~loc usage env lbl = +let use_label ~record_form ~use ~loc usage env lbl = if use then begin - mark_label_description_used usage env lbl; + mark_label_description_used record_form usage env lbl; Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name; if is_mutating_label_usage usage then Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes @@ -3099,14 +3157,21 @@ let lookup_ident_cltype ~errors ~use ~loc s env = | exception Not_found -> may_lookup_error errors loc env (Unbound_cltype (Lident s)) -let lookup_all_ident_labels ~errors ~use ~loc usage s env = - match TycompTbl.find_all ~mark:use s env.labels with - | [] -> may_lookup_error errors loc env (Unbound_label (Lident s)) +let find_all_labels (type rep) ~(record_form : rep record_form) ~mark s env + : (rep gen_label_description * (unit -> unit)) list = + match record_form with + | Legacy -> TycompTbl.find_all ~mark s env.labels + | Unboxed_product -> TycompTbl.find_all ~mark s env.unboxed_labels + +let lookup_all_ident_labels (type rep) ~(record_form : rep record_form) ~errors ~use ~loc + usage s env = + match find_all_labels ~record_form ~mark:use s env with + | [] -> may_lookup_error errors loc env (Unbound_label (Lident s, P record_form)) | lbls -> begin List.map (fun (lbl, use_fn) -> let use_fn () = - use_label ~use ~loc usage env lbl; + use_label ~record_form ~use ~loc usage env lbl; use_fn () in (lbl, use_fn)) @@ -3303,15 +3368,15 @@ let lookup_dot_cltype ~errors ~use ~loc l s env = | exception Not_found -> may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s))) -let lookup_all_dot_labels ~errors ~use ~loc usage l s env = +let lookup_all_dot_labels ~record_form ~errors ~use ~loc usage l s env = let (_, _, comps) = lookup_structure_components ~errors ~use ~loc l env in - match NameMap.find s comps.comp_labels with + match NameMap.find s (comp_labels record_form comps) with | [] | exception Not_found -> - may_lookup_error errors loc env (Unbound_label (Ldot(l, s))) + may_lookup_error errors loc env (Unbound_label (Ldot(l, s), P record_form)) | lbls -> List.map (fun lbl -> - let use_fun () = use_label ~use ~loc usage env lbl in + let use_fun () = use_label ~record_form ~use ~loc usage env lbl in (lbl, use_fun)) lbls @@ -3351,6 +3416,9 @@ let add_components slot root env0 comps locks = let labels = add_l (fun x -> `Label x) comps.comp_labels env0.labels in + let unboxed_labels = + add_l (fun x -> `Unboxed_label x) comps.comp_unboxed_labels env0.unboxed_labels + in let values = add_v (fun x -> `Value x) comps.comp_values env0.values in @@ -3373,6 +3441,7 @@ let add_components slot root env0 comps locks = summary = Env_open(env0.summary, root); constrs; labels; + unboxed_labels; values; types; modtypes; @@ -3616,27 +3685,36 @@ let lookup_cltype ~errors ~use ~loc lid env = | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env | Lapply _ -> assert false -let lookup_all_labels ~errors ~use ~loc usage lid env = +let lookup_all_labels ~errors ~use ~record_form ~loc usage lid env = match lid with - | Lident s -> lookup_all_ident_labels ~errors ~use ~loc usage s env - | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc usage l s env + | Lident s -> lookup_all_ident_labels ~errors ~use ~record_form ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~record_form ~loc usage l s env | Lapply _ -> assert false -let lookup_label ~errors ~use ~loc usage lid env = - match lookup_all_labels ~errors ~use ~loc usage lid env with +let lookup_label ~errors ~use ~record_form ~loc usage lid env = + match lookup_all_labels ~errors ~use ~record_form ~loc usage lid env with | [] -> assert false | (desc, use) :: _ -> use (); desc -let lookup_all_labels_from_type ~use ~loc usage ty_path env = - match find_type_descrs ty_path env with +let lookup_all_labels_from_type (type rep) ~use ~(record_form : rep record_form) + ~loc usage ty_path env : (rep gen_label_description * (unit -> unit)) list = + match (find_type_descrs ty_path env, record_form) with | exception Not_found -> [] - | Type_variant _ | Type_abstract _ | Type_open -> [] - | Type_record (lbls, _) -> + | ((Type_variant _ | Type_abstract _ | Type_open), _) -> [] + | (Type_record (lbls, _), Legacy) -> List.map (fun lbl -> - let use_fun () = use_label ~use ~loc usage env lbl in + let use_fun () = use_label ~record_form ~use ~loc usage env lbl in (lbl, use_fun)) lbls + | (Type_record_unboxed_product (lbls, _), Unboxed_product) -> + List.map + (fun lbl -> + let use_fun () = use_label ~record_form ~use ~loc usage env lbl in + (lbl, use_fun)) + lbls + | (Type_record (_, _), Unboxed_product) -> [] + | (Type_record_unboxed_product (_, _), Legacy) -> [] let lookup_all_constructors ~errors ~use ~loc usage lid env = match lid with @@ -3652,7 +3730,7 @@ let lookup_constructor ~errors ~use ~loc usage lid env = let lookup_all_constructors_from_type ~use ~loc usage ty_path env = match find_type_descrs ty_path env with | exception Not_found -> [] - | Type_record _ | Type_abstract _ | Type_open -> [] + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ | Type_open -> [] | Type_variant (cstrs, _) -> List.map (fun cstr -> @@ -3699,9 +3777,9 @@ let find_constructor_by_name lid env = let loc = Location.(in_file !input_name) in lookup_constructor ~errors:false ~use:false ~loc Positive lid env -let find_label_by_name lid env = +let find_label_by_name record_form lid env = let loc = Location.(in_file !input_name) in - lookup_label ~errors:false ~use:false ~loc Projection lid env + lookup_label ~record_form ~errors:false ~use:false ~loc Projection lid env (* Stable name lookup for printing *) @@ -3769,17 +3847,17 @@ let lookup_constructor ?(use=true) ~loc lid env = let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env = lookup_all_constructors_from_type ~use ~loc usage ty_path env -let lookup_all_labels ?(use=true) ~loc usage lid env = - match lookup_all_labels ~errors:true ~use ~loc usage lid env with +let lookup_all_labels ?(use=true) ~record_form ~loc usage lid env = + match lookup_all_labels ~errors:true ~use ~record_form ~loc usage lid env with | exception Error(Lookup_error(loc', env', err)) -> (Error(loc', env', err) : _ result) | lbls -> Ok lbls -let lookup_label ?(use=true) ~loc lid env = - lookup_label ~errors:true ~use ~loc lid env +let lookup_label ?(use=true) ~record_form ~loc lid env = + lookup_label ~errors:true ~use ~record_form ~loc lid env -let lookup_all_labels_from_type ?(use=true) ~loc usage ty_path env = - lookup_all_labels_from_type ~use ~loc usage ty_path env +let lookup_all_labels_from_type ?(use=true) ~record_form ~loc usage ty_path env = + lookup_all_labels_from_type ~use ~record_form ~loc usage ty_path env let lookup_instance_variable ?(use=true) ~loc name env = match IdTbl.find_name_and_locks wrap_value ~mark:use name env.values with @@ -3942,8 +4020,12 @@ let fold_values f = and fold_constructors f = find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) (fun cda acc -> f cda.cda_description acc) -and fold_labels f = - find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f +and fold_labels record_form f = + find_all_simple_list + (fun env -> env_labels record_form env) + (fun sc -> comp_labels record_form sc) + f + and fold_types f = find_all wrap_identity (fun env -> env.types) (fun sc -> sc.comp_types) @@ -4086,8 +4168,8 @@ let extract_modules path env = fold_modules (fun name _ _ acc -> name :: acc) path env [] let extract_constructors path env = fold_constructors (fun desc acc -> desc.cstr_name :: acc) path env [] -let extract_labels path env = - fold_labels (fun desc acc -> desc.lbl_name :: acc) path env [] +let extract_labels record_form path env = + fold_labels record_form (fun desc acc -> desc.lbl_name :: acc) path env [] let extract_classes path env = fold_classes (fun name _ _ acc -> name :: acc) path env [] let extract_modtypes path env = @@ -4199,10 +4281,11 @@ let report_lookup_error _loc env ppf = function fprintf ppf "Unbound constructor %a" (Style.as_inline_code !print_longident) lid; spellcheck ppf extract_constructors env lid; - | Unbound_label lid -> - fprintf ppf "Unbound record field %a" - (Style.as_inline_code !print_longident) lid; - spellcheck ppf extract_labels env lid; + | Unbound_label (lid, record_form) -> + let P record_form = record_form in + fprintf ppf "Unbound %s field %a" + (record_form_to_string record_form) (Style.as_inline_code !print_longident) lid; + spellcheck ppf (extract_labels record_form) env lid; | Unbound_class lid -> begin fprintf ppf "Unbound class %a" (Style.as_inline_code !print_longident) lid; diff --git a/typing/env.mli b/typing/env.mli index 6f2b75b1da6..b1540ee1880 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -68,7 +68,7 @@ val diff: t -> t -> Ident.t list val same_type_declarations: t -> t -> bool type type_descr_kind = - (label_description, constructor_description) type_kind + (label_description, unboxed_label_description, constructor_description) type_kind (* alias for compatibility *) type type_descriptions = type_descr_kind @@ -103,7 +103,7 @@ val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> class_type_declaration val find_ident_constructor: Ident.t -> t -> constructor_description -val find_ident_label: Ident.t -> t -> label_description +val find_ident_label: 'rcd record_form -> Ident.t -> t -> 'rcd gen_label_description val find_type_expansion: Path.t -> t -> type_expr list * type_expr * int @@ -167,7 +167,7 @@ val mark_extension_used: type label_usage = Projection | Mutation | Construct | Exported_private | Exported val mark_label_used: - label_usage -> label_declaration -> unit + _ record_form -> label_usage -> label_declaration -> unit (* Lookup by long identifiers *) @@ -218,7 +218,7 @@ type lookup_error = | Unbound_value of Longident.t * unbound_value_hint | Unbound_type of Longident.t | Unbound_constructor of Longident.t - | Unbound_label of Longident.t + | Unbound_label of (Longident.t * record_form_packed) | Unbound_module of Longident.t | Unbound_class of Longident.t | Unbound_modtype of Longident.t @@ -302,15 +302,15 @@ val lookup_all_constructors_from_type: (constructor_description * (unit -> unit)) list val lookup_label: - ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> - label_description + ?use:bool -> record_form:'rcd record_form -> loc:Location.t -> label_usage -> Longident.t -> t -> + 'rcd gen_label_description val lookup_all_labels: - ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> - ((label_description * (unit -> unit)) list, + ?use:bool -> record_form:'rcd record_form -> loc:Location.t -> label_usage -> Longident.t -> t -> + (('rcd gen_label_description * (unit -> unit)) list, Location.t * t * lookup_error) result val lookup_all_labels_from_type: - ?use:bool -> loc:Location.t -> label_usage -> Path.t -> t -> - (label_description * (unit -> unit)) list + ?use:bool -> record_form:'rcd record_form -> loc:Location.t -> label_usage -> Path.t -> t -> + ('rcd gen_label_description * (unit -> unit)) list val lookup_instance_variable: ?use:bool -> loc:Location.t -> string -> t -> @@ -332,7 +332,7 @@ val find_cltype_by_name: val find_constructor_by_name: Longident.t -> t -> constructor_description val find_label_by_name: - Longident.t -> t -> label_description + 'rep record_form -> Longident.t -> t -> 'rep gen_label_description (** The [find_*_index] functions computes a "namespaced" De Bruijn index of an identifier in a given environment. In other words, it returns how many @@ -629,7 +629,7 @@ val fold_constructors: (constructor_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_labels: - (label_description -> 'a -> 'a) -> + 'rcd record_form -> ('rcd gen_label_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a (** Persistent structures are only traversed if they are already loaded. *) diff --git a/typing/includecore.ml b/typing/includecore.ml index f569354eeaf..3c79b8836e2 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -186,18 +186,21 @@ type privacy_mismatch = | Private_type_abbreviation | Private_variant_type | Private_record_type + | Private_record_unboxed_product_type | Private_extensible_variant | Private_row_type type type_kind = | Kind_abstract | Kind_record + | Kind_record_unboxed_product | Kind_variant | Kind_open let of_kind = function | Type_abstract _ -> Kind_abstract | Type_record (_, _) -> Kind_record + | Type_record_unboxed_product (_, _) -> Kind_record_unboxed_product | Type_variant (_, _) -> Kind_variant | Type_open -> Kind_open @@ -339,6 +342,7 @@ let report_privacy_mismatch ppf err = | Private_type_abbreviation -> true, "type abbreviation" | Private_variant_type -> false, "variant constructor(s)" | Private_record_type -> true, "record constructor" + | Private_record_unboxed_product_type -> true, "unboxed record constructor" | Private_extensible_variant -> true, "extensible variant" | Private_row_type -> true, "row type" in Format.fprintf ppf "%s %s would be revealed." @@ -530,6 +534,7 @@ let report_kind_mismatch first second ppf (kind1, kind2) = let kind_to_string = function | Kind_abstract -> "abstract" | Kind_record -> "a record" + | Kind_record_unboxed_product -> "an unboxed record" | Kind_variant -> "a variant" | Kind_open -> "an extensible variant" in pr "%s is %s, but %s is %s." @@ -734,46 +739,53 @@ module Record_diffing = struct representation is if one is a flat float record with a boxed float \ field, and the other isn't." - let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + let compare_with_representation (type rep) ~loc (record_form : rep record_form) env + params1 params2 l r (rep1 : rep) (rep2 : rep) = if not (equal ~loc env params1 params2 l r) then let patch = diffing loc env params1 params2 l r in Some (Record_mismatch (Label_mismatch patch)) else - match rep1, rep2 with - | Record_unboxed, Record_unboxed -> None - | Record_unboxed, _ -> Some (Unboxed_representation (First, [])) - | _, Record_unboxed -> Some (Unboxed_representation (Second, [])) - - | Record_inlined _, Record_inlined _ -> None - | Record_inlined _, _ -> - Some (Record_mismatch (Inlined_representation First)) - | _, Record_inlined _ -> - Some (Record_mismatch (Inlined_representation Second)) - - | Record_float, Record_float -> None - | Record_float, _ -> - Some (Record_mismatch (Float_representation First)) - | _, Record_float -> - Some (Record_mismatch (Float_representation Second)) - - | Record_ufloat, Record_ufloat -> None - | Record_ufloat, _ -> - Some (Record_mismatch (Ufloat_representation First)) - | _, Record_ufloat -> - Some (Record_mismatch (Ufloat_representation Second)) - - | Record_mixed m1, Record_mixed m2 -> begin - match find_mismatch_in_mixed_record_representations m1 m2 with - | None -> None - | Some mismatch -> Some (Record_mismatch mismatch) - end - | Record_mixed _, _ -> - Some (Record_mismatch (Mixed_representation First)) - | _, Record_mixed _ -> - Some (Record_mismatch (Mixed_representation Second)) - - | Record_boxed _, Record_boxed _ -> None + match record_form with + | Legacy -> + begin match rep1, rep2 with + | Record_unboxed, Record_unboxed -> None + | Record_unboxed, _ -> Some (Unboxed_representation (First, [])) + | _, Record_unboxed -> Some (Unboxed_representation (Second, [])) + + | Record_inlined _, Record_inlined _ -> None + | Record_inlined _, _ -> + Some (Record_mismatch (Inlined_representation First)) + | _, Record_inlined _ -> + Some (Record_mismatch (Inlined_representation Second)) + + | Record_float, Record_float -> None + | Record_float, _ -> + Some (Record_mismatch (Float_representation First)) + | _, Record_float -> + Some (Record_mismatch (Float_representation Second)) + + | Record_ufloat, Record_ufloat -> None + | Record_ufloat, _ -> + Some (Record_mismatch (Ufloat_representation First)) + | _, Record_ufloat -> + Some (Record_mismatch (Ufloat_representation Second)) + + | Record_mixed m1, Record_mixed m2 -> + begin match find_mismatch_in_mixed_record_representations m1 m2 with + | None -> None + | Some mismatch -> Some (Record_mismatch mismatch) + end + | Record_mixed _, _ -> + Some (Record_mismatch (Mixed_representation First)) + | _, Record_mixed _ -> + Some (Record_mismatch (Mixed_representation Second)) + | Record_boxed _, Record_boxed _ -> None + end + | Unboxed_product -> + begin match rep1, rep2 with + | Record_unboxed_product, Record_unboxed_product -> None + end end (* just like List.find_map, but also gives index if found *) @@ -947,6 +959,8 @@ let privacy_mismatch env decl1 decl2 = | Private, Public -> begin match decl1.type_kind, decl2.type_kind with | Type_record _, Type_record _ -> Some Private_record_type + | Type_record_unboxed_product _, Type_record_unboxed_product _ -> + Some Private_record_unboxed_product_type | Type_variant _, Type_variant _ -> Some Private_variant_type | Type_open, Type_open -> Some Private_extensible_variant | Type_abstract _, Type_abstract _ @@ -1257,6 +1271,23 @@ let type_declarations ?(equality = false) ~loc env ~mark name | () -> None in if err <> None then err else + let mark_and_compare_records record_form labels1 rep1 labels2 rep2 = + if mark then begin + let mark usage lbls = + List.iter (Env.mark_label_used record_form usage) lbls + in + let usage : Env.label_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private + in + mark usage labels1; + if equality then mark Env.Exported labels2 + end; + Record_diffing.compare_with_representation ~loc record_form env + decl1.type_params decl2.type_params + labels1 labels2 + rep1 rep2 + in let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract _) -> (* Note that [decl2.type_jkind] is an upper bound. @@ -1287,21 +1318,10 @@ let type_declarations ?(equality = false) ~loc env ~mark name rep1 rep2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - if mark then begin - let mark usage lbls = - List.iter (Env.mark_label_used usage) lbls - in - let usage : Env.label_usage = - if decl2.type_private = Public then Env.Exported - else Env.Exported_private - in - mark usage labels1; - if equality then mark Env.Exported labels2 - end; - Record_diffing.compare_with_representation ~loc env - decl1.type_params decl2.type_params - labels1 labels2 - rep1 rep2 + mark_and_compare_records Legacy labels1 rep1 labels2 rep2 + | (Type_record_unboxed_product(labels1,rep1), + Type_record_unboxed_product(labels2,rep2)) -> + mark_and_compare_records Unboxed_product labels1 rep1 labels2 rep2 | (Type_open, Type_open) -> None | (_, _) -> Some (Kind (of_kind decl1.type_kind, of_kind decl2.type_kind)) in diff --git a/typing/includecore.mli b/typing/includecore.mli index d7d9575b9ed..182ab99741f 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -46,12 +46,14 @@ type privacy_mismatch = | Private_type_abbreviation | Private_variant_type | Private_record_type + | Private_record_unboxed_product_type | Private_extensible_variant | Private_row_type type type_kind = | Kind_abstract | Kind_record + | Kind_record_unboxed_product | Kind_variant | Kind_open diff --git a/typing/jkind.ml b/typing/jkind.ml index b654907a843..2f505e38852 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -1064,9 +1064,19 @@ module Builtin = struct fresh_jkind Jkind_desc.Builtin.immediate ~annotation:(mk_annot "immediate") ~why:(Immediate_creation why) +<<<<<<< HEAD let product ~why ts = let desc, annotation = Jkind_desc.product ts in fresh_jkind desc ~annotation ~why:(Product_creation why) +||||||| parent of 80bf6fd31d (Basic unboxed records) + let product ~why ts = + fresh_jkind (Jkind_desc.product ts) ~why:(Product_creation why) +======= + let product ~why = function + | [] -> Misc.fatal_error "Jkind.Builtin.product: empty product" + | [t] -> t + | ts -> fresh_jkind (Jkind_desc.product ts) ~why:(Product_creation why) +>>>>>>> 80bf6fd31d (Basic unboxed records) end let add_nullability_crossing t = @@ -1506,6 +1516,7 @@ module Format_history = struct let format_product_creation_reason ppf : History.product_creation_reason -> _ = function | Unboxed_tuple -> fprintf ppf "it is an unboxed tuple" + | Unboxed_record -> fprintf ppf "it is an unboxed record" let format_creation_reason ppf ~layout_or_kind : History.creation_reason -> unit = function @@ -1988,6 +1999,7 @@ module Debug_printers = struct let product_creation_reason ppf : History.product_creation_reason -> _ = function | Unboxed_tuple -> fprintf ppf "Unboxed_tuple" + | Unboxed_record -> fprintf ppf "Unboxed_record" let creation_reason ppf : History.creation_reason -> unit = function | Annotated (ctx, loc) -> diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index 2d098c24e55..795d76f50ee 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -307,7 +307,9 @@ module History = struct | Unification_var | Array_type_argument - type product_creation_reason = Unboxed_tuple + type product_creation_reason = + | Unboxed_tuple + | Unboxed_record type creation_reason = | Annotated : ('l * 'r) annotation_context * Location.t -> creation_reason diff --git a/typing/mtype.ml b/typing/mtype.ml index 0a2e342afdd..3f704cb1719 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -91,7 +91,9 @@ and strengthen_lazy_sig' ~aliasable sg p = let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with Some _, Public, _ -> decl - | Some _, Private, (Type_record _ | Type_variant _) -> decl + | Some _, Private, (Type_record _ | Type_record_unboxed_product _ + | Type_variant _) -> + decl | _ -> let manif = Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id), @@ -298,7 +300,8 @@ let rec sig_make_manifest sg = let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with Some _, Public, _ -> decl - | Some _, Private, (Type_record _ | Type_variant _) -> decl + | Some _, Private, + (Type_record _ | Type_record_unboxed_product _ | Type_variant _) -> decl | _ -> let manif = Some (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil))) @@ -306,7 +309,7 @@ let rec sig_make_manifest sg = match decl.type_kind with | Type_abstract _ -> { decl with type_private = Public; type_manifest = manif } - | (Type_record _ | Type_variant _ | Type_open) -> + | (Type_record _ | Type_record_unboxed_product _ | Type_variant _ | Type_open) -> { decl with type_manifest = manif } in Sig_type(Ident.rename id, newdecl, rs, vis) :: sig_make_manifest rem diff --git a/typing/oprint.ml b/typing/oprint.ml index 7306bc99c2e..c656e3e79b0 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -277,6 +277,8 @@ let print_out_value ppf tree = | Oval_stuff s -> pp_print_string ppf s | Oval_record fel -> fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel + | Oval_record_unboxed_product fel -> + fprintf ppf "@[<1>#{%a}@]" (cautious (print_fields true)) fel | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | Oval_tuple tree_list -> @@ -584,6 +586,7 @@ and print_out_type_3 ppf = | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ppf lbls + | Otyp_record_unboxed_product lbls -> print_record_unboxed_product_decl ppf lbls | Otyp_module (p, fl) -> fprintf ppf "@[<1>(module %a" print_ident p; let first = ref true in @@ -608,6 +611,9 @@ and print_simple_out_type ppf typ = and print_record_decl ppf lbls = fprintf ppf "{%a@;<1 -2>}" (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls +and print_record_unboxed_product_decl ppf lbls = + fprintf ppf "#{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls and print_fields open_row ppf = function [] -> @@ -977,6 +983,10 @@ and print_out_type_decl kwd ppf td = fprintf ppf " =%a %a" print_private td.otype_private print_record_decl lbls + | Otyp_record_unboxed_product lbls -> + fprintf ppf " =%a %a" + print_private td.otype_private + print_record_unboxed_product_decl lbls | Otyp_sum constrs -> let variants fmt constrs = if constrs = [] then fprintf fmt "|" else diff --git a/typing/outcometree.mli b/typing/outcometree.mli index bfb431dc2cf..4566f02f335 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -52,6 +52,7 @@ type out_value = | Oval_list of out_value list | Oval_printer of (Format.formatter -> unit) | Oval_record of (out_ident * out_value) list + | Oval_record_unboxed_product of (out_ident * out_value) list | Oval_string of string * int * out_string (* string, size-to-print, kind *) | Oval_stuff of string | Oval_tuple of (string option * out_value) list @@ -135,6 +136,7 @@ and out_type = | Otyp_manifest of out_type * out_type | Otyp_object of { fields: (string * out_type) list; open_row:bool} | Otyp_record of (string * out_mutability * out_type * out_modality list) list + | Otyp_record_unboxed_product of (string * out_mutability * out_type * out_modality list) list | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of (string option * out_type) list diff --git a/typing/parmatch.ml b/typing/parmatch.ml index de72ed0b18a..1c37c85dd5b 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -182,14 +182,17 @@ let all_coherent column = List.equal (fun (lbl1, _) (lbl2, _) -> lbl1 = lbl2) l1 l2 | Record (lbl1 :: _), Record (lbl2 :: _) -> Array.length lbl1.lbl_all = Array.length lbl2.lbl_all + | Record_unboxed_product (lbl1 :: _), Record_unboxed_product (lbl2 :: _) -> + Array.length lbl1.lbl_all = Array.length lbl2.lbl_all | Array (am1, _, _), Array (am2, _, _) -> am1 = am2 | Any, _ | _, Any | Record [], Record [] + | Record_unboxed_product [], Record_unboxed_product [] | Variant _, Variant _ | Lazy, Lazy -> true | ( Construct _ | Constant _ | Tuple _ | Unboxed_tuple _ | Record _ - | Array _ | Variant _ | Lazy ), _ -> false + | Record_unboxed_product _ | Array _ | Variant _ | Lazy ), _ -> false in match List.find @@ -443,6 +446,14 @@ let record_arg ph = | Record args -> args | _ -> fatal_error "Parmatch.as_record" +(* extract unboxed record fields as a whole *) +let record_unboxed_product_arg ph = + let open Patterns.Head in + match ph.pat_desc with + | Any -> [] + | Record_unboxed_product args -> args + | _ -> fatal_error "Parmatch.as_record_unboxed_product" + let extract_fields lbls arg = let get_field pos arg = @@ -463,13 +474,16 @@ let simple_match_args discr head args = | Unboxed_tuple _ | Array _ | Lazy -> args - | Record lbls -> extract_fields (record_arg discr) (List.combine lbls args) + | Record lbls -> extract_fields (record_arg discr) (List.combine lbls args) + | Record_unboxed_product lbls -> + extract_fields (record_unboxed_product_arg discr) (List.combine lbls args) | Any -> begin match discr.pat_desc with | Construct cstr -> Patterns.omegas cstr.cstr_arity | Variant { has_arg = true } | Lazy -> [Patterns.omega] - | Record lbls -> omega_list lbls + | Record lbls -> omega_list lbls + | Record_unboxed_product lbls -> omega_list lbls | Array (_, _, len) -> Patterns.omegas len | Tuple lbls -> omega_list lbls | Unboxed_tuple lbls -> omega_list lbls @@ -581,6 +595,19 @@ let do_set_args ~erase_mutable q r = match q with omegas args, closed)) q.pat_type q.pat_env:: rest +| {pat_desc = Tpat_record_unboxed_product (omegas,closed)} -> + let args,rest = read_args omegas r in + make_pat + (Tpat_record_unboxed_product + (List.map2 (fun (lid, lbl,_) arg -> + if erase_mutable && Types.is_mutable lbl.lbl_mut + then + lid, lbl, omega + else + lid, lbl, arg) + omegas args, closed)) + q.pat_type q.pat_env:: + rest | {pat_desc = Tpat_construct (lid, c, omegas, _)} -> let args,rest = read_args omegas r in make_pat @@ -868,6 +895,7 @@ let full_match closing env = match env with | Tuple _ | Unboxed_tuple _ | Record _ + | Record_unboxed_product _ | Lazy -> true (* Written as a non-fragile matching, PR#7451 originated from a fragile matching @@ -884,6 +912,7 @@ let should_extend ext env = match ext with Path.same path ext | Construct {cstr_tag=Extension _} -> false | Constant _ | Tuple _ | Unboxed_tuple _ | Variant _ | Record _ + | Record_unboxed_product _ | Array _ | Lazy -> false | Any -> assert false end @@ -911,7 +940,8 @@ let pat_of_constrs ex_pat cstrs = let pats_of_type env ty = match Ctype.extract_concrete_typedecl env ty with - | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _}) -> + | Typedecl (_, path, {type_kind = Type_variant _ | Type_record _ + | Type_record_unboxed_product _ }) -> begin match Env.find_type_descrs path env with | Type_variant (cstrs,_) when List.length cstrs <= 1 || (* Only explode when all constructors are GADTs *) @@ -924,6 +954,8 @@ let pats_of_type env ty = labels in [make_pat (Tpat_record (fields, Closed)) ty env] + | Type_record_unboxed_product (_labels, _) -> + assert false | Type_variant _ | Type_abstract _ | Type_open -> [omega] end | Has_no_typedecl -> @@ -1171,6 +1203,7 @@ let rec has_instance p = match p.pat_desc with | Tpat_unboxed_tuple labeled_ps -> has_instances (List.map (fun (_, p, _) -> p) labeled_ps) | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) + | Tpat_record_unboxed_product (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) | Tpat_lazy p -> has_instance p @@ -2091,6 +2124,10 @@ let rec collect_paths_from_pat r p = match p.pat_desc with List.fold_left (fun r (_, _, p) -> collect_paths_from_pat r p) r lps +| Tpat_record_unboxed_product (lps,_) -> + List.fold_left + (fun r (_, _, p) -> collect_paths_from_pat r p) + r lps | Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_,_) -> collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> @@ -2237,6 +2274,10 @@ let inactive ~partial pat = List.for_all (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) ldps + | Tpat_record_unboxed_product (ldps,_) -> + List.for_all + (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) + ldps | Tpat_or (p,q,_) -> loop p && loop q in diff --git a/typing/patterns.ml b/typing/patterns.ml index 87ef2197c21..1442387eaf1 100644 --- a/typing/patterns.ml +++ b/typing/patterns.ml @@ -60,6 +60,8 @@ module Simple = struct | `Variant of label * pattern option * row_desc ref | `Record of (Longident.t loc * label_description * pattern) list * closed_flag + | `Record_unboxed_product of + (Longident.t loc * unboxed_label_description * pattern) list * closed_flag | `Array of mutability * Jkind.sort * pattern list | `Lazy of pattern ] @@ -105,6 +107,8 @@ module General = struct `Variant (cstr, arg, row_desc) | Tpat_record (fields, closed) -> `Record (fields, closed) + | Tpat_record_unboxed_product (fields, closed) -> + `Record_unboxed_product (fields, closed) | Tpat_array (am, arg_sort, ps) -> `Array (am, arg_sort, ps) | Tpat_or (p, q, row_desc) -> `Or (p, q, row_desc) | Tpat_lazy p -> `Lazy p @@ -125,6 +129,8 @@ module General = struct Tpat_variant (cstr, arg, row_desc) | `Record (fields, closed) -> Tpat_record (fields, closed) + | `Record_unboxed_product (fields, closed) -> + Tpat_record_unboxed_product (fields, closed) | `Array (am, arg_sort, ps) -> Tpat_array (am, arg_sort, ps) | `Or (p, q, row_desc) -> Tpat_or (p, q, row_desc) | `Lazy p -> Tpat_lazy p @@ -149,6 +155,7 @@ module Head : sig | Tuple of string option list | Unboxed_tuple of (string option * Jkind.sort) list | Record of label_description list + | Record_unboxed_product of unboxed_label_description list | Variant of { tag: label; has_arg: bool; cstr_row: row_desc ref; @@ -175,6 +182,7 @@ end = struct | Tuple of string option list | Unboxed_tuple of (string option * Jkind.sort) list | Record of label_description list + | Record_unboxed_product of unboxed_label_description list | Variant of { tag: label; has_arg: bool; cstr_row: row_desc ref; @@ -216,6 +224,10 @@ end = struct let lbls = List.map (fun (_,lbl,_) -> lbl) largs in let pats = List.map (fun (_,_,pat) -> pat) largs in Record lbls, pats + | `Record_unboxed_product (largs, _) -> + let lbls = List.map (fun (_,lbl,_) -> lbl) largs in + let pats = List.map (fun (_,_,pat) -> pat) largs in + Record_unboxed_product lbls, pats | `Lazy p -> Lazy, [p] in @@ -231,6 +243,7 @@ end = struct | Unboxed_tuple l -> List.length l | Array (_, _, n) -> n | Record l -> List.length l + | Record_unboxed_product l -> List.length l | Variant { has_arg; _ } -> if has_arg then 1 else 0 | Lazy -> 1 @@ -261,6 +274,14 @@ end = struct ) lbls in Tpat_record (lst, Closed) + | Record_unboxed_product lbls -> + let lst = + List.map (fun lbl -> + let lid_loc = mkloc (Longident.Lident lbl.lbl_name) in + (lid_loc, lbl, omega) + ) lbls + in + Tpat_record_unboxed_product (lst, Closed) in { t with pat_desc; diff --git a/typing/patterns.mli b/typing/patterns.mli index d50379464da..59f632110bb 100644 --- a/typing/patterns.mli +++ b/typing/patterns.mli @@ -47,6 +47,8 @@ module Simple : sig | `Variant of label * pattern option * row_desc ref | `Record of (Longident.t loc * label_description * pattern) list * closed_flag + | `Record_unboxed_product of + (Longident.t loc * unboxed_label_description * pattern) list * closed_flag | `Array of mutability * Jkind.sort * pattern list | `Lazy of pattern ] @@ -85,6 +87,7 @@ module Head : sig | Tuple of string option list | Unboxed_tuple of (string option * Jkind.sort) list | Record of label_description list + | Record_unboxed_product of unboxed_label_description list | Variant of { tag: label; has_arg: bool; cstr_row: row_desc ref; diff --git a/typing/predef.mli b/typing/predef.mli index 3a7c8575abd..71b1e05bc75 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -145,7 +145,7 @@ val add_or_null : (* Construct the [type_kind] of [or_null]. For re-exporting [or_null] while users can't define their own types with null constructors. *) (* CR layouts v3.5: remove this when users can define null constructors. *) -val or_null_kind : type_expr -> ('a, constructor_declaration) type_kind +val or_null_kind : type_expr -> ('a, 'b, constructor_declaration) type_kind (* To initialize linker tables *) diff --git a/typing/printpat.ml b/typing/printpat.ml index 5fae273b9cd..e40d396658a 100644 --- a/typing/printpat.ml +++ b/typing/printpat.ml @@ -59,6 +59,27 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> pretty_extra ppf extra pretty_val { v with pat_extra = rem } | [] -> + let pretty_record ~unboxed lvs = + let filtered_lvs = List.filter + (function + | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) + | _ -> true) lvs in + begin match filtered_lvs with + | [] -> fprintf ppf "{ _ }" + | (_, lbl, _) :: q -> + let elision_mark ppf = + (* we assume that there is no label repetitions here *) + if Array.length lbl.lbl_all > 1 + List.length q then + fprintf ppf ";@ _@ " + else () in + if unboxed then + fprintf ppf "@[#{%a%t}@]" + pretty_lvals filtered_lvs elision_mark + else + fprintf ppf "@[{%a%t}@]" + pretty_lvals filtered_lvs elision_mark + end + in match v.pat_desc with | Tpat_any -> fprintf ppf "_" | Tpat_var (x,_,_,_) -> fprintf ppf "%s" (Ident.name x) @@ -89,22 +110,8 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> fprintf ppf "`%s" l | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w - | Tpat_record (lvs,_) -> - let filtered_lvs = List.filter - (function - | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) - | _ -> true) lvs in - begin match filtered_lvs with - | [] -> fprintf ppf "{ _ }" - | (_, lbl, _) :: q -> - let elision_mark ppf = - (* we assume that there is no label repetitions here *) - if Array.length lbl.lbl_all > 1 + List.length q then - fprintf ppf ";@ _@ " - else () in - fprintf ppf "@[{%a%t}@]" - pretty_lvals filtered_lvs elision_mark - end + | Tpat_record (lvs,_) -> pretty_record ~unboxed:false lvs + | Tpat_record_unboxed_product (lvs,_) -> pretty_record ~unboxed:true lvs | Tpat_array (am, _arg_sort, vs) -> let punct = if Types.is_mutable am then '|' else ':' in fprintf ppf "@[[%c %a %c]@]" punct (pretty_vals " ;") vs punct @@ -166,7 +173,8 @@ and pretty_labeled_val_sort ppf (l, p, _) = end; pretty_val ppf p -and pretty_lvals ppf = function +and pretty_lvals : 'a. _ -> (_ * 'a gen_label_description * _) list -> _ = + fun ppf -> function | [] -> () | [_,lbl,v] -> fprintf ppf "%s=%a" lbl.lbl_name pretty_val v diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 2f94fccf32e..4964d97a63a 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -139,6 +139,7 @@ let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n | Type | Constructor | Label + | Unboxed_label | Module | Module_type | Extension_constructor @@ -155,9 +156,10 @@ module Namespace = struct | Class -> 3 | Class_type -> 4 | Extension_constructor | Value | Constructor | Label -> 5 + | Unboxed_label -> 6 (* we do not handle those component *) - let size = 1 + id Value + let size = 1 + id Unboxed_label let pp ppf x = @@ -174,7 +176,7 @@ module Namespace = struct | Some Module_type -> to_lookup Env.find_modtype_by_name | Some Class -> to_lookup Env.find_class_by_name | Some Class_type -> to_lookup Env.find_cltype_by_name - | None | Some(Value|Extension_constructor|Constructor|Label) -> + | None | Some(Value|Extension_constructor|Constructor|Label|Unboxed_label) -> fun _ -> raise Not_found let location namespace id = @@ -186,7 +188,7 @@ module Namespace = struct | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc - | Some (Extension_constructor|Value|Constructor|Label) | None -> + | Some (Extension_constructor|Value|Constructor|Label|Unboxed_label) | None -> Location.none ) with Not_found -> None @@ -1868,6 +1870,8 @@ let prepare_decl id decl = cstrs | Type_record(l, _rep) -> List.iter (fun l -> prepare_type l.ld_type) l + | Type_record_unboxed_product(l, _rep) -> + List.iter (fun l -> prepare_type l.ld_type) l | Type_open -> () end; ty_manifest, params @@ -1887,6 +1891,8 @@ let tree_of_type_decl id decl = decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private + | Type_record_unboxed_product _ -> + decl.type_private = Private | Type_variant (tll, _rep) -> decl.type_private = Private || List.exists (fun cd -> cd.cd_res <> None) tll @@ -1947,6 +1953,10 @@ let tree_of_type_decl id decl = tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), decl.type_private, (match rep with Record_unboxed -> true | _ -> false) + | Type_record_unboxed_product(lbls, Record_unboxed_product) -> + tree_of_manifest (Otyp_record_unboxed_product (List.map tree_of_label lbls)), + decl.type_private, + false | Type_open -> tree_of_manifest Otyp_open, decl.type_private, diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 6e26099cd2f..4f7beb6e8e5 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -215,6 +215,10 @@ let record_representation i ppf = let open Types in function line i ppf "Record_mixed (value_prefix_len %d)\n" value_prefix_len; array (i+1) flat_element ppf flat_suffix +let record_unboxed_product_representation i ppf = let open Types in function + | Record_unboxed_product -> + line i ppf "Record_unboxed_product\n" + let attribute i ppf k a = line i ppf "%s \"%s\"\n" k a.Parsetree.attr_name.txt; Printast.payload i ppf a.Parsetree.attr_payload @@ -347,6 +351,9 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> | Tpat_record (l, _c) -> line i ppf "Tpat_record\n"; list i longident_x_pattern ppf l; + | Tpat_record_unboxed_product (l, _c) -> + line i ppf "Tpat_record_unboxed_product\n"; + list i longident_x_pattern ppf l; | Tpat_array (am, arg_sort, l) -> line i ppf "Tpat_array %a\n" fmt_mutable_mode_flag am; line i ppf "%a\n" Jkind.Sort.format arg_sort; @@ -523,10 +530,23 @@ and expression i ppf x = record_representation (i+1) ppf representation; line i ppf "extended_expression =\n"; option (i+1) expression ppf (Option.map fst extended_expression); + | Texp_record_unboxed_product { fields; representation; extended_expression } -> + line i ppf "Texp_record_unboxed_product\n"; + let i = i+1 in + line i ppf "fields =\n"; + array (i+1) record_field ppf fields; + line i ppf "representation =\n"; + record_unboxed_product_representation (i+1) ppf representation; + line i ppf "extended_expression =\n"; + option (i+1) expression ppf extended_expression; | Texp_field (e, li, _, _, _) -> line i ppf "Texp_field\n"; expression i ppf e; longident i ppf li; + | Texp_unboxed_field (e, li, _, _) -> + line i ppf "Texp_unboxed_field\n"; + expression i ppf e; + longident i ppf li; | Texp_setfield (e1, am, li, _, e2) -> line i ppf "Texp_setfield\n"; locality_mode i ppf am; @@ -682,6 +702,9 @@ and type_kind i ppf x = | Ttype_record l -> line i ppf "Ttype_record\n"; list (i+1) label_decl ppf l; + | Ttype_record_unboxed_product l -> + line i ppf "Ttype_record_unboxed_product\n"; + list (i+1) label_decl ppf l; | Ttype_open -> line i ppf "Ttype_open\n" @@ -1115,7 +1138,8 @@ and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; and field_decl i ppf {ca_type=ty; ca_loc=_; ca_modalities=_} = core_type (i+1) ppf ty -and longident_x_pattern i ppf (li, _, p) = +and longident_x_pattern : 'a. _ -> _ -> _ * 'a * _ -> _ = + fun i ppf (li, _, p) -> line i ppf "%a\n" fmt_longident li; pattern (i+1) ppf p; @@ -1175,11 +1199,14 @@ and string_x_expression i ppf (s, _, e) = line i ppf " \"%a\"\n" fmt_ident s; expression (i+1) ppf e; -and record_field i ppf = function - | _, Overridden (li, e) -> +and record_field + : 'a. _ -> _ -> 'a * _ -> _ + = fun i ppf (_, record_label_definition) -> + match record_label_definition with + | Overridden (li, e) -> line i ppf "%a\n" fmt_longident li; expression (i+1) ppf e; - | _, Kept _ -> + | Kept _ -> line i ppf "" and label_x_apply_arg i ppf (l, e) = diff --git a/typing/shape.ml b/typing/shape.ml index 58f7f15e0ac..943f372177d 100644 --- a/typing/shape.ml +++ b/typing/shape.ml @@ -87,6 +87,7 @@ module Sig_component_kind = struct | Type | Constructor | Label + | Unboxed_label | Module | Module_type | Extension_constructor @@ -98,6 +99,7 @@ module Sig_component_kind = struct | Type -> "type" | Constructor -> "constructor" | Label -> "label" + | Unboxed_label -> "unboxed label" | Module -> "module" | Module_type -> "module type" | Extension_constructor -> "extension constructor" @@ -111,6 +113,7 @@ module Sig_component_kind = struct | Type | Constructor | Label + | Unboxed_label | Module | Module_type | Class @@ -127,6 +130,7 @@ module Sig_component_kind = struct | Class_type -> 6 | Constructor -> 7 | Label -> 8 + | Unboxed_label -> 9 let compare a b = let a = rank a in @@ -152,6 +156,7 @@ module Item = struct let type_ id = Ident.name id, Sig_component_kind.Type let constr id = Ident.name id, Sig_component_kind.Constructor let label id = Ident.name id, Sig_component_kind.Label + let unboxed_label id = Ident.name id, Sig_component_kind.Unboxed_label let module_ id = Ident.name id, Sig_component_kind.Module let module_type id = Ident.name id, Sig_component_kind.Module_type let extension_constructor id = @@ -388,6 +393,7 @@ let of_path ~find_shape ~namespace path = match (ns : Sig_component_kind.t) with | Constructor -> Type | Label -> Type + | Unboxed_label -> Type | _ -> Module in proj (aux namespace path) (name, ns) @@ -438,6 +444,11 @@ module Map = struct let item = Item.label id in Item.Map.add item (proj shape item) t + let add_unboxed_label t id uid = Item.Map.add (Item.unboxed_label id) (leaf uid) t + let add_unboxed_label_proj t id shape = + let item = Item.unboxed_label id in + Item.Map.add item (proj shape item) t + let add_module t id shape = Item.Map.add (Item.module_ id) shape t let add_module_proj t id shape = let item = Item.module_ id in diff --git a/typing/shape.mli b/typing/shape.mli index 1ad142a5d0e..6a5dc595659 100644 --- a/typing/shape.mli +++ b/typing/shape.mli @@ -79,6 +79,7 @@ module Sig_component_kind : sig | Type | Constructor | Label + | Unboxed_label | Module | Module_type | Extension_constructor @@ -106,6 +107,7 @@ module Item : sig val type_ : Ident.t -> t val constr : Ident.t -> t val label : Ident.t -> t + val unboxed_label : Ident.t -> t val module_ : Ident.t -> t val module_type : Ident.t -> t val extension_constructor : Ident.t -> t @@ -183,6 +185,9 @@ module Map : sig val add_label : t -> Ident.t -> Uid.t -> t val add_label_proj : t -> Ident.t -> shape -> t + val add_unboxed_label : t -> Ident.t -> Uid.t -> t + val add_unboxed_label_proj : t -> Ident.t -> shape -> t + val add_module : t -> Ident.t -> shape -> t val add_module_proj : t -> Ident.t -> shape -> t diff --git a/typing/subst.ml b/typing/subst.ml index 112c93eb35e..b63ee52467b 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -525,6 +525,9 @@ let record_representation ~prepare_jkind loc = function 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; @@ -548,6 +551,14 @@ let type_declaration' copy_scope s decl = 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 end; type_manifest = diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index e146df9b681..f8c395c1f6e 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -193,6 +193,7 @@ let type_kind sub = function | Ttype_abstract -> () | Ttype_variant list -> List.iter (constructor_decl sub) list | Ttype_record list -> List.iter (label_decl sub) list + | Ttype_record_unboxed_product list -> List.iter (label_decl sub) list | Ttype_open -> () let type_declaration sub x = @@ -266,6 +267,8 @@ let pat | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po | Tpat_record (l, _) -> List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l + | Tpat_record_unboxed_product (l, _) -> + List.iter (fun (lid, _, i) -> iter_loc sub lid; sub.pat sub i) l | Tpat_array (_, _, l) -> List.iter (sub.pat sub) l | Tpat_alias (p, _, s, _, _) -> sub.pat sub p; iter_loc sub s | Tpat_lazy p -> sub.pat sub p @@ -352,9 +355,18 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) fields; Option.iter (fun (exp, _) -> sub.expr sub exp) extended_expression; + | Texp_record_unboxed_product { fields; extended_expression; _} -> + Array.iter (function + | _, Kept _ -> () + | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression; | Texp_field (exp, lid, _, _, _) -> iter_loc sub lid; sub.expr sub exp + | Texp_unboxed_field (exp, lid, _, _) -> + iter_loc sub lid; + sub.expr sub exp | Texp_setfield (exp1, _, lid, _, exp2) -> iter_loc sub lid; sub.expr sub exp1; diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 9eb5c868526..66846e69841 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -223,6 +223,8 @@ let type_kind sub = function | Ttype_abstract -> Ttype_abstract | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list) | Ttype_record list -> Ttype_record (List.map (label_decl sub) list) + | Ttype_record_unboxed_product list -> + Ttype_record_unboxed_product (List.map (label_decl sub) list) | Ttype_open -> Ttype_open let type_declaration sub x = @@ -313,6 +315,9 @@ let pat Tpat_variant (l, Option.map (sub.pat sub) po, rd) | Tpat_record (l, closed) -> Tpat_record (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) + | Tpat_record_unboxed_product (l, closed) -> + Tpat_record_unboxed_product + (List.map (tuple3 (map_loc sub) id (sub.pat sub)) l, closed) | Tpat_array (am, arg_sort, l) -> Tpat_array (am, arg_sort, List.map (sub.pat sub) l) | Tpat_alias (p, id, s, uid, m) -> Tpat_alias (sub.pat sub p, id, map_loc sub s, uid, m) @@ -433,6 +438,13 @@ let expr sub x = comp_clauses } in + let map_fields fields = + Array.map (function + | label, Kept (t, mut, uu) -> label, Kept (t, mut, uu) + | label, Overridden (lid, exp) -> + label, Overridden (map_loc sub lid, sub.expr sub exp)) + fields + in let exp_desc = match x.exp_desc with | Texp_ident (path, lid, vd, idk, uu) -> @@ -478,20 +490,21 @@ let expr sub x = | Texp_variant (l, expo) -> Texp_variant (l, Option.map (fun (e, am) -> (sub.expr sub e, am)) expo) | Texp_record { fields; representation; extended_expression; alloc_mode } -> - let fields = Array.map (function - | label, Kept (t, mut, uu) -> label, Kept (t, mut, uu) - | label, Overridden (lid, exp) -> - label, Overridden (map_loc sub lid, sub.expr sub exp)) - fields - in Texp_record { - fields; representation; + fields = map_fields fields; representation; extended_expression = Option.map (fun (exp, ubr) -> (sub.expr sub exp, ubr)) extended_expression; alloc_mode } + | Texp_record_unboxed_product { fields; representation; extended_expression } -> + Texp_record_unboxed_product { + fields = map_fields fields; representation; + extended_expression = Option.map (sub.expr sub) extended_expression + } | Texp_field (exp, lid, ld, float, ubr) -> Texp_field (sub.expr sub exp, map_loc sub lid, ld, float, ubr) + | Texp_unboxed_field (exp, lid, ld, uu) -> + Texp_unboxed_field (sub.expr sub exp, map_loc sub lid, ld, uu) | Texp_setfield (exp1, am, lid, ld, exp2) -> Texp_setfield ( sub.expr sub exp1, diff --git a/typing/typecore.ml b/typing/typecore.ml index b4b3c5c1922..770e6ef8dde 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -57,14 +57,16 @@ type type_expected = { } module Datatype_kind = struct - type t = Record | Variant + type t = Record | Record_unboxed_product | Variant let type_name = function | Record -> "record" + | Record_unboxed_product -> "unboxed record" | Variant -> "variant" let label_name = function | Record -> "field" + | Record_unboxed_product -> "unboxed record field" | Variant -> "constructor" end @@ -82,10 +84,16 @@ type wrong_kind_context = type wrong_kind_sort = | Constructor | Record + | Record_unboxed_product | Boolean | List | Unit +let record_form_to_wrong_kind_sort : type rep. rep record_form -> wrong_kind_sort = + function + | Legacy -> Record + | Unboxed_product -> Record_unboxed_product + type contains_gadt = | Contains_gadt | No_gadt @@ -136,7 +144,7 @@ type error = | Partial_tuple_pattern_bad_type | Extra_tuple_label of string option * type_expr | Missing_tuple_label of string option * type_expr - | Label_mismatch of Longident.t * Errortrace.unification_error + | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : Errortrace.unification_error * Parsetree.pattern_desc option -> error | Or_pattern_type_clash of Ident.t * Errortrace.unification_error @@ -172,7 +180,7 @@ type error = } | Apply_wrong_label of arg_label * type_expr * bool | Label_multiply_defined of string - | Label_missing of Ident.t list + | Label_missing of record_form_packed * Ident.t list | Label_not_mutable of Longident.t | Wrong_name of string * type_expected * wrong_name | Name_type_mismatch of @@ -238,7 +246,7 @@ type error = | Unbound_existential of Ident.t list * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr - | Expr_not_a_record_type of type_expr + | Expr_not_a_record_type of record_form_packed * type_expr | Submode_failed of Value.error * submode_reason * Env.locality_context option * @@ -815,20 +823,26 @@ let src_pos loc attrs env = ; exp_env = env } -type record_extraction_result = - | Record_type of Path.t * Path.t * Types.label_declaration list * record_representation +type 'rep record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list * 'rep | Not_a_record_type | Maybe_a_record_type let extract_concrete_typedecl_protected env ty = extract_concrete_typedecl env (protect_expansion env ty) -let extract_concrete_record env ty = - match extract_concrete_typedecl_protected env ty with - | Typedecl(p0, p, {type_kind=Type_record (fields, repres)}) -> +let extract_concrete_record (type rep) (record_form : rep record_form) env ty + : (rep record_extraction_result) = + match record_form, extract_concrete_typedecl_protected env ty with + | Legacy, Typedecl(p0, p, {type_kind=Type_record (fields, repres)}) -> + Record_type (p0, p, fields, repres) + | Unboxed_product, + Typedecl(p0, p, {type_kind=Type_record_unboxed_product (fields, repres)}) -> Record_type (p0, p, fields, repres) - | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type - | May_have_typedecl -> Maybe_a_record_type + | Legacy, Typedecl(_, _, {type_kind=Type_record_unboxed_product _}) + | Unboxed_product, Typedecl(_, _, {type_kind=Type_record _}) + | _, Has_no_typedecl | _, Typedecl(_, _, _) -> Not_a_record_type + | _, May_have_typedecl -> Maybe_a_record_type type variant_extraction_result = | Variant_type of Path.t * Path.t * Types.constructor_declaration list @@ -844,8 +858,8 @@ let extract_concrete_variant env ty = | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type | May_have_typedecl -> Maybe_a_variant_type -let extract_label_names env ty = - match extract_concrete_record env ty with +let extract_label_names record_form env ty = + match extract_concrete_record record_form env ty with | Record_type (_, _,fields, _) -> List.map (fun l -> l.Types.ld_id) fields | Not_a_record_type | Maybe_a_record_type -> assert false @@ -1342,6 +1356,35 @@ and build_as_type_and_mode_extra env p ~mode : _ -> _ * _ = function and build_as_type_aux (env : Env.t) p ~mode = let build_as_type env p = fst (build_as_type_and_mode env p ~mode) in + let build_record_as_type lpl = + let lbl = snd3 (List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type, mode else + (* The jkind here is filled in via unification with [ty_res] in + [unify_pat]. *) + (* XXX layouts v2: This should be a sort variable and could be now (but + think about when it gets defaulted.) + + RAE: why? It looks fine as-is. *) + let ty = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in + let ppl = List.map (fun (_, l, p) -> l.lbl_num, p) lpl in + let do_label lbl = + let _, ty_arg, ty_res = instance_label ~fixed:false lbl in + unify_pat env {p with pat_type = ty} ty_res; + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_num ppl && + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in + if refinable then begin + let arg = List.assoc lbl.lbl_num ppl in + unify_pat env + {arg with pat_type = build_as_type env arg} ty_arg + end else begin + let _, ty_arg', ty_res' = instance_label ~fixed:false lbl in + unify_pat_types p.pat_loc env ty_arg ty_arg'; + unify_pat env p ty_res' + end in + Array.iter do_label lbl.lbl_all; + ty, mode + in match p.pat_desc with Tpat_alias(p1,_, _, _, _) -> build_as_type_and_mode env p1 ~mode | Tpat_tuple pl -> @@ -1387,34 +1430,8 @@ and build_as_type_aux (env : Env.t) p ~mode = ~name:None ~fixed:None ~closed:false)) in ty, mode - | Tpat_record (lpl,_) -> - let lbl = snd3 (List.hd lpl) in - if lbl.lbl_private = Private then p.pat_type, mode else - (* The jkind here is filled in via unification with [ty_res] in - [unify_pat]. *) - (* XXX layouts v2: This should be a sort variable and could be now (but - think about when it gets defaulted.) - - RAE: why? It looks fine as-is. *) - let ty = newvar (Jkind.Builtin.any ~why:Dummy_jkind) in - let ppl = List.map (fun (_, l, p) -> l.lbl_num, p) lpl in - let do_label lbl = - let _, ty_arg, ty_res = instance_label ~fixed:false lbl in - unify_pat env {p with pat_type = ty} ty_res; - let refinable = - lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_num ppl && - match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in - if refinable then begin - let arg = List.assoc lbl.lbl_num ppl in - unify_pat env - {arg with pat_type = build_as_type env arg} ty_arg - end else begin - let _, ty_arg', ty_res' = instance_label ~fixed:false lbl in - unify_pat_types p.pat_loc env ty_arg ty_arg'; - unify_pat env p ty_res' - end in - Array.iter do_label lbl.lbl_all; - ty, mode + | Tpat_record (lpl,_) -> build_record_as_type lpl + | Tpat_record_unboxed_product (lpl,_) -> build_record_as_type lpl | Tpat_or(p1, p2, row) -> begin match row with None -> @@ -1701,14 +1718,14 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials end; (ty_args_ty, ty_args_gf, existential_ctyp) -let solve_Ppat_record_field ~refine loc penv label label_lid record_ty = +let solve_Ppat_record_field ~refine loc penv label label_lid record_ty record_form = with_local_level_iter ~post:generalize_structure begin fun () -> let (_, ty_arg, ty_res) = instance_label ~fixed:false label in begin try unify_pat_types_refine ~refine loc penv ty_res (instance record_ty) with Error(_loc, _env, Pattern_type_clash(err, _)) -> raise(Error(label_lid.loc, !!penv, - Label_mismatch(label_lid.txt, err))) + Label_mismatch(P record_form, label_lid.txt, err))) end; (ty_arg, [ty_res; ty_arg]) end @@ -2016,12 +2033,12 @@ end) = struct (* we selected a name out of the lexical scope *) let warn_out_of_scope warn lid env tpath = - if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + if Warnings.is_active (Name_out_of_scope ("", Name "")) then begin let path_s = Printtyp.wrap_printing_env ~error:true env (fun () -> Printtyp.string_of_path tpath) in warn lid.loc - (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) + (Warnings.Name_out_of_scope (path_s, Name (Longident.last lid.txt))) end (* warn if the selected name is not the last introduced in scope @@ -2159,7 +2176,7 @@ module Label = NameChoice (struct let get_name lbl = lbl.lbl_name let get_type lbl = lbl.lbl_res let lookup_all_from_type loc usage path env = - Env.lookup_all_labels_from_type ~loc usage path env + Env.lookup_all_labels_from_type ~record_form:Legacy ~loc usage path env let in_env lbl = match lbl.lbl_repres with | Record_boxed _ | Record_float | Record_ufloat | Record_unboxed @@ -2167,6 +2184,26 @@ module Label = NameChoice (struct | Record_inlined _ -> false end) +module Unboxed_label = NameChoice (struct + type t = unboxed_label_description + type usage = Env.label_usage + let kind = Datatype_kind.Record_unboxed_product + let get_name lbl = lbl.lbl_name + let get_type lbl = lbl.lbl_res + let lookup_all_from_type loc usage path env = + Env.lookup_all_labels_from_type ~record_form:Unboxed_product ~loc usage path env + let in_env (lbl : t) = + match lbl.lbl_repres with + | Record_unboxed_product -> true +end) + +let label_get_type_path + (type rep) + (record_form : rep record_form) + (d : rep gen_label_description) = + match record_form with | Legacy -> Label.get_type_path d + | Unboxed_product -> Unboxed_label.get_type_path d + (* In record-construction expressions and patterns, we have many labels at once; find a candidate type in the intersection of the candidates of each label. In the [closed] expression case, this candidate must @@ -2192,8 +2229,23 @@ let disambiguate_label_by_ids closed ids labels : (_, _) result = | labels -> Ok labels +type 'rep candidates = ('rep gen_label_description * (unit -> unit)) list +let label_disambiguate + (type rep) + ?warn ?(filter : (rep candidates -> (rep candidates, rep candidates) result) option) + (record_form : rep record_form) usage lid env expected_type + (scope : (rep candidates, _) result) + : rep gen_label_description = + match record_form with + | Legacy -> + Label.disambiguate ?warn ?filter usage lid env expected_type scope + | Unboxed_product -> + Unboxed_label.disambiguate ?warn ?filter usage lid env expected_type scope + (* Only issue warnings once per record constructor/pattern *) -let disambiguate_sort_lid_a_list loc closed env usage expected_type lid_a_list = +let disambiguate_sort_lid_a_list + (type rep) + (record_form : rep record_form) loc closed env usage expected_type lid_a_list = let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in let w_pr = ref false and w_amb = ref [] and w_scope = ref [] and w_scope_ty = ref "" in @@ -2202,15 +2254,14 @@ let disambiguate_sort_lid_a_list loc closed env usage expected_type lid_a_list = match msg with | Not_principal _ -> w_pr := true | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb - | Name_out_of_scope(ty, [s], _) -> + | Name_out_of_scope(ty, Name s) -> w_scope := s :: !w_scope; w_scope_ty := ty | _ -> Location.prerr_warning loc msg in let process_label lid = - let scope = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in - let filter : Label.nonempty_candidate_filter = - disambiguate_label_by_ids closed ids in - Label.disambiguate ~warn ~filter usage lid env expected_type scope in + let scope = Env.lookup_all_labels ~record_form ~loc:lid.loc usage lid.txt env in + let filter = disambiguate_label_by_ids closed ids in + label_disambiguate ~warn ~filter record_form usage lid env expected_type scope in let lbl_a_list = (* If one label is qualified [{ foo = ...; M.bar = ... }], we will disambiguate all labels using one of the qualifying modules, @@ -2260,12 +2311,13 @@ let disambiguate_sort_lid_a_list loc closed env usage expected_type lid_a_list = in if !w_pr then Location.prerr_warning loc - (Warnings.Not_principal "this type-based record disambiguation") + (Warnings.Not_principal + ("this type-based " ^ (record_form_to_string record_form) ^" disambiguation")) else begin match List.rev !w_amb with (_,types,ex)::_ as amb -> let paths = - List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in + List.map (fun (_,lbl,_) -> label_get_type_path record_form lbl) lbl_a_list in let path = List.hd paths in let fst3 (x,_,_) = x in if List.for_all (compare_type_path env path) (List.tl paths) then @@ -2278,9 +2330,10 @@ let disambiguate_sort_lid_a_list loc closed env usage expected_type lid_a_list = amb | _ -> () end; - if !w_scope <> [] then - Location.prerr_warning loc - (Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true)); + (if !w_scope <> [] then + let warning = Warnings.Fields {record_form = record_form_to_string record_form; + fields = List.rev !w_scope} in + Location.prerr_warning loc (Warnings.Name_out_of_scope (!w_scope_ty, warning))); (* Invariant: records are sorted in the typed tree *) List.sort (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_num lbl2.lbl_num) @@ -2293,7 +2346,7 @@ let map_fold_cont f xs k = (* Checks over the labels mentioned in a record pattern: no duplicate definitions (error); properly closed (warning) *) -let check_recordpat_labels loc lbl_pat_list closed = +let check_recordpat_labels loc lbl_pat_list closed record_form = match lbl_pat_list with | [] -> () (* should not happen *) | (_, label1, _) :: _ -> @@ -2305,7 +2358,7 @@ let check_recordpat_labels loc lbl_pat_list closed = else defined.(label.lbl_num) <- true in List.iter check_defined lbl_pat_list; if closed = Closed - && Warnings.is_active (Warnings.Missing_record_field_pattern "") + && Warnings.is_active (Warnings.Missing_record_field_pattern ("", "")) then begin let undefined = ref [] in for i = 0 to Array.length all - 1 do @@ -2313,7 +2366,8 @@ let check_recordpat_labels loc lbl_pat_list closed = done; if !undefined <> [] then begin let u = String.concat ", " (List.rev !undefined) in - Location.prerr_warning loc (Warnings.Missing_record_field_pattern u) + let form = record_form_to_string record_form in + Location.prerr_warning loc (Warnings.Missing_record_field_pattern (form, u)) end end @@ -2404,7 +2458,8 @@ let rec has_literal_pattern p = | Ppat_array (_, ps) -> List.exists has_literal_pattern ps | Ppat_unboxed_tuple (ps, _) -> has_literal_pattern_labeled_tuple ps - | Ppat_record (ps, _) -> + | Ppat_record (ps, _) + | Ppat_record_unboxed_product (ps, _) -> List.exists (fun (_,p) -> has_literal_pattern p) ps | Ppat_or (p, q) -> has_literal_pattern p || has_literal_pattern q @@ -2611,6 +2666,56 @@ and type_pat_aux pat_env = !!penv; pat_unique_barrier = Unique_barrier.not_computed () } in + let type_record_pat (type rep) (record_form : rep record_form) lid_sp_list closed = + assert (lid_sp_list <> []); + let expected_type, record_ty = + match extract_concrete_record record_form !!penv expected_ty with + | Record_type(p0, p, _, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> + None, newvar (Jkind.Builtin.any ~why:Dummy_jkind) + | Not_a_record_type -> + let wks = record_form_to_wrong_kind_sort record_form in + let error = Wrong_expected_kind(wks, Pattern, expected_ty) in + raise (Error (loc, !!penv, error)) + in + let type_label_pat (label_lid, label, sarg) = + let ty_arg = + solve_Ppat_record_field ~refine:false loc penv label label_lid + record_ty record_form in + check_project_mutability ~loc ~env:!!penv label.lbl_mut alloc_mode.mode; + let mode = + Modality.Value.Const.apply label.lbl_modalities alloc_mode.mode + in + let alloc_mode = simple_pat_mode mode in + (label_lid, label, type_pat tps Value ~alloc_mode sarg ty_arg) + in + let make_record_pat (lbl_pat_list : (_ * rep gen_label_description * _) list) = + check_recordpat_labels loc lbl_pat_list closed record_form; + let pat_desc = match record_form with + | Legacy -> Tpat_record (lbl_pat_list, closed) + | Unboxed_product -> Tpat_record_unboxed_product (lbl_pat_list, closed) + in + { + pat_desc; pat_loc = loc; pat_extra=[]; + pat_type = instance record_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !!penv; + pat_unique_barrier = Unique_barrier.not_computed (); + } + in + let lbl_a_list = + wrap_disambiguate + ("This " ^ (record_form_to_string record_form) ^ " pattern is expected to have") + (mk_expected expected_ty) + (disambiguate_sort_lid_a_list record_form loc false !!penv Env.Projection + expected_type) + lid_sp_list + in + let lbl_a_list = List.map type_label_pat lbl_a_list in + rvp @@ solve_expected (make_record_pat lbl_a_list) + in match sp.ppat_desc with Ppat_any -> rvp { @@ -2829,49 +2934,10 @@ and type_pat_aux pat_env = !!penv; pat_unique_barrier = Unique_barrier.not_computed () } | Ppat_record(lid_sp_list, closed) -> - assert (lid_sp_list <> []); - let expected_type, record_ty = - match extract_concrete_record !!penv expected_ty with - | Record_type(p0, p, _, _) -> - let ty = generic_instance expected_ty in - Some (p0, p, is_principal expected_ty), ty - | Maybe_a_record_type -> - None, newvar (Jkind.Builtin.value ~why:Boxed_record) - | Not_a_record_type -> - let error = Wrong_expected_kind(Record, Pattern, expected_ty) in - raise (Error (loc, !!penv, error)) - in - let type_label_pat (label_lid, label, sarg) = - let ty_arg = - solve_Ppat_record_field ~refine:false loc penv label label_lid - record_ty in - check_project_mutability ~loc ~env:!!penv label.lbl_mut alloc_mode.mode; - let mode = - Modality.Value.Const.apply label.lbl_modalities alloc_mode.mode - in - let alloc_mode = simple_pat_mode mode in - (label_lid, label, type_pat tps Value ~alloc_mode sarg ty_arg) - in - let make_record_pat lbl_pat_list = - check_recordpat_labels loc lbl_pat_list closed; - { - pat_desc = Tpat_record (lbl_pat_list, closed); - pat_loc = loc; pat_extra=[]; - pat_type = instance record_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !!penv; - pat_unique_barrier = Unique_barrier.not_computed (); - } - in - let lbl_a_list = - wrap_disambiguate "This record pattern is expected to have" - (mk_expected expected_ty) - (disambiguate_sort_lid_a_list loc false !!penv Env.Projection - expected_type) - lid_sp_list - in - let lbl_a_list = List.map type_label_pat lbl_a_list in - rvp @@ solve_expected (make_record_pat lbl_a_list) + type_record_pat Legacy lid_sp_list closed + | Ppat_record_unboxed_product(lid_sp_list, closed) -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + type_record_pat Unboxed_product lid_sp_list closed | Ppat_array (mut, spl) -> let mut = match mut with @@ -3130,8 +3196,8 @@ let rec pat_tuple_arity spat = | Ppat_any | Ppat_exception _ | Ppat_var _ -> Maybe_local_tuple | Ppat_constant _ | Ppat_interval _ | Ppat_construct _ | Ppat_variant _ - | Ppat_record _ | Ppat_array _ | Ppat_type _ | Ppat_lazy _ - | Ppat_unpack _ | Ppat_extension _ -> Not_local_tuple + | Ppat_record _ | Ppat_record_unboxed_product _ | Ppat_array _ | Ppat_type _ + | Ppat_lazy _ | Ppat_unpack _ | Ppat_extension _ -> Not_local_tuple | Ppat_or(sp1, sp2) -> combine_pat_tuple_arity (pat_tuple_arity sp1) (pat_tuple_arity sp2) | Ppat_constraint(p, _, _) | Ppat_open(_, p) | Ppat_alias(p, _) -> pat_tuple_arity p @@ -3323,6 +3389,22 @@ let rec check_counter_example_pat | Backtrack_or -> false | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in + let type_label_pats (type rep) (fields : (_ * rep gen_label_description * _) list) + closed (record_form : rep record_form) = + let record_ty = generic_instance expected_ty in + let type_label_pat (label_lid, label, targ) k = + let ty_arg = + solve_Ppat_record_field ~refine loc penv label label_lid record_ty record_form in + check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) + in + match record_form with + | Legacy -> + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record (fields, closed))) + | Unboxed_product -> + map_fold_cont type_label_pat fields + (fun fields -> mkp k (Tpat_record_unboxed_product (fields, closed))) + in match tp.pat_desc with Tpat_any | Tpat_var _ -> let k' () = mkp k tp.pat_desc in @@ -3399,15 +3481,8 @@ let rec check_counter_example_pat Some p, [ty] -> check_rec p ty (fun p -> k (Some p)) | _ -> k None end - | Tpat_record(fields, closed) -> - let record_ty = generic_instance expected_ty in - let type_label_pat (label_lid, label, targ) k = - let ty_arg = - solve_Ppat_record_field ~refine loc penv label label_lid record_ty in - check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) - in - map_fold_cont type_label_pat fields - (fun fields -> mkp k (Tpat_record (fields, closed))) + | Tpat_record(fields, closed) -> type_label_pats fields closed Legacy + | Tpat_record_unboxed_product(fields, closed) -> type_label_pats fields closed Unboxed_product | Tpat_array (mut, original_arg_sort, tpl) -> let ty_elt, arg_sort = solve_Ppat_array ~refine loc penv mut expected_ty in assert (Jkind.Sort.equate original_arg_sort arg_sort); @@ -3985,7 +4060,17 @@ let rec is_nonexpansive exp = | Kept _ -> true) fields && is_nonexpansive_opt (Option.map fst extended_expression) + | Texp_record_unboxed_product { fields; extended_expression } -> + Array.for_all + (fun (lbl, definition) -> + match definition with + | Overridden (_, exp) -> + lbl.lbl_mut = Immutable && is_nonexpansive exp + | Kept _ -> true) + fields + && is_nonexpansive_opt extended_expression | Texp_field(exp, _, _, _, _) -> is_nonexpansive exp + | Texp_unboxed_field(exp, _, _, _) -> is_nonexpansive exp | Texp_ifthenelse(_cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (_e1, _jkind, e2) -> is_nonexpansive e2 (* PR#4354 *) @@ -4465,7 +4550,8 @@ let check_partial_application ~statement exp = | Texp_ident _ | Texp_constant _ | Texp_tuple _ | Texp_unboxed_tuple _ | Texp_construct _ | Texp_variant _ | Texp_record _ - | Texp_field _ | Texp_setfield _ | Texp_array _ + | Texp_record_unboxed_product _ + | Texp_field _ | Texp_unboxed_field _ | Texp_setfield _ | Texp_array _ | Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_while _ | Texp_for _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ | Texp_assert _ @@ -4566,7 +4652,8 @@ let shallow_iter_ppat f p = | Ppat_exception p | Ppat_alias (p,_) | Ppat_open (_,p) | Ppat_constraint (p,_,_) | Ppat_lazy p -> f p - | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args + | Ppat_record (args, _flag) | Ppat_record_unboxed_product (args, _flag) -> + List.iter (fun (_,p) -> f p) args let exists_ppat f p = let exception Found in @@ -5162,6 +5249,203 @@ and type_expect_ unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected)); exp in + let type_expect_record (type rep) (record_form : rep record_form) + (lid_sexp_list: (Longident.t loc * Parsetree.expression) list) + (opt_sexp : Parsetree.expression option) = + assert (lid_sexp_list <> []); + let opt_exp = + match opt_sexp with + None -> None + | Some sexp -> + let exp, mode = + with_local_level_if_principal begin fun () -> + let mode = Value.newvar () in + let exp = type_exp ~recarg env (mode_default mode) sexp in + exp, mode + end ~post:(fun (exp, _) -> generalize_structure_exp exp) + in + Some (exp, mode) + in + let ty_record, expected_type = + let expected_opath = + match extract_concrete_record record_form env ty_expected with + | Record_type (p0, p, _, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let wks = record_form_to_wrong_kind_sort record_form in + let error = + Wrong_expected_kind(wks, Expression explanation, ty_expected) + in + raise (Error (loc, env, error)) + in + let opt_exp_opath = + match opt_exp with + | None -> None + | Some (exp, _) -> + match extract_concrete_record record_form env exp.exp_type with + | Record_type (p0, p, _, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type (P record_form, exp.exp_type) in + raise (Error (exp.exp_loc, env, error)) + in + match expected_opath, opt_exp_opath with + | None, None -> + newvar (Jkind.of_new_sort ~why:Record_projection), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + let ty = + with_local_level ~post:generalize_structure + (fun () -> newconstr p' (instance_list decl.type_params)) + in + ty, opt_exp_opath + in + let closed = (opt_sexp = None) in + let lbl_a_list = + wrap_disambiguate + ("This " ^ (record_form_to_string record_form) ^ " expression is expected to have") + (mk_expected ty_record) + (disambiguate_sort_lid_a_list record_form loc closed env Env.Construct expected_type) + lid_sexp_list + in + let repres_might_allocate (type rep) (record_form : rep record_form) (rep : rep) = + match record_form with + | Legacy -> begin match rep with + | Record_unboxed | Record_inlined (_, _, Variant_unboxed) -> false + | Record_boxed _ | Record_float | Record_ufloat | Record_mixed _ + | Record_inlined (_, _, (Variant_boxed _ | Variant_extensible)) + -> true + end + | Unboxed_product -> begin match rep with + | Record_unboxed_product -> false + end + in + let alloc_mode, argument_mode = + if List.exists + (fun (_, {lbl_repres; _}, _) -> repres_might_allocate record_form lbl_repres) + lbl_a_list then + let alloc_mode, argument_mode = register_allocation expected_mode in + Some alloc_mode, argument_mode + else + None, expected_mode + in + let type_label_exp ((_, label, _) as x) = + check_construct_mutability ~loc ~env label.lbl_mut argument_mode; + let argument_mode = mode_modality label.lbl_modalities argument_mode in + type_label_exp true env argument_mode loc ty_record x record_form + in + let lbl_exp_list = List.map type_label_exp lbl_a_list in + with_explanation (fun () -> + unify_exp_types loc env (instance ty_record) (instance ty_expected)); + (* note: check_duplicates would better be implemented in + disambiguate_sort_lid_a_list directly *) + let rec check_duplicates = function + | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_num = lbl2.lbl_num -> + raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name)) + | _ :: rem -> + check_duplicates rem + | [] -> () + in + check_duplicates lbl_exp_list; + let opt_exp, label_definitions = + let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in + let matching_label lbl = + List.find + (fun (_, lbl',_) -> lbl'.lbl_num = lbl.lbl_num) + lbl_exp_list + in + match opt_exp with + None -> + let label_definitions = + Array.map (fun lbl -> + match matching_label lbl with + | (lid, _lbl, lbl_exp) -> + Overridden (lid, lbl_exp) + | exception Not_found -> + let present_indices = + List.map (fun (_, lbl, _) -> lbl.lbl_num) lbl_exp_list + in + let label_names = extract_label_names record_form env ty_expected in + let rec missing_labels n = function + [] -> [] + | lbl :: rem -> + if List.mem n present_indices + then missing_labels (n + 1) rem + else lbl :: missing_labels (n + 1) rem + in + let missing = missing_labels 0 label_names in + raise(Error(loc, env, Label_missing (P record_form, missing)))) + lbl.lbl_all + in + None, label_definitions + | Some (exp, mode) -> + let ty_exp = instance exp.exp_type in + let unify_kept lbl = + let _, ty_arg1, ty_res1 = instance_label ~fixed:false lbl in + unify_exp_types exp.exp_loc env ty_exp ty_res1; + match matching_label lbl with + | lid, _lbl, lbl_exp -> + (* do not connect result types for overridden labels *) + Overridden (lid, lbl_exp) + | exception Not_found -> begin + let _, ty_arg2, ty_res2 = instance_label ~fixed:false lbl in + unify_exp_types loc env ty_arg1 ty_arg2; + with_explanation (fun () -> + unify_exp_types loc env (instance ty_expected) ty_res2); + check_project_mutability ~loc:exp.exp_loc ~env lbl.lbl_mut mode; + let mode = Modality.Value.Const.apply lbl.lbl_modalities mode in + check_construct_mutability ~loc ~env lbl.lbl_mut argument_mode; + let argument_mode = + mode_modality lbl.lbl_modalities argument_mode + in + submode ~loc ~env mode argument_mode; + Kept (ty_arg1, lbl.lbl_mut, + unique_use ~loc ~env mode + (as_single_mode argument_mode)) + end + in + let label_definitions = Array.map unify_kept lbl.lbl_all in + let ubr = Unique_barrier.not_computed () in + Some ({exp with exp_type = ty_exp}, ubr), label_definitions + in + let num_fields = + match lbl_exp_list with [] -> assert false + | (_, lbl,_)::_ -> Array.length lbl.lbl_all in + (if opt_sexp <> None && List.length lid_sexp_list = num_fields then + Location.prerr_warning loc (Warnings.Useless_record_with (record_form_to_string record_form))); + let label_descriptions, representation = + let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in + lbl_all, lbl_repres + in + let fields = + Array.map2 (fun descr def -> descr, def) + label_descriptions label_definitions + in + match record_form with + | Legacy -> + re { + exp_desc = Texp_record { + fields; representation; + extended_expression = opt_exp; + alloc_mode; + }; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | Unboxed_product -> + re { + exp_desc = Texp_record_unboxed_product { + fields; representation; + extended_expression = (Option.map fst opt_exp); + }; + exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + in match desc with | Pexp_ident lid -> let path, (actual_mode : Env.actual_mode), desc, kind = @@ -5568,179 +5852,13 @@ and type_expect_ exp_env = env } end | Pexp_record(lid_sexp_list, opt_sexp) -> - assert (lid_sexp_list <> []); - let opt_exp = - match opt_sexp with - None -> None - | Some sexp -> - let exp, mode = - with_local_level_if_principal begin fun () -> - let mode = Value.newvar () in - let exp = type_exp ~recarg env (mode_default mode) sexp in - exp, mode - end ~post:(fun (exp, _) -> generalize_structure_exp exp) - in - Some (exp, mode) - in - let ty_record, expected_type = - let expected_opath = - match extract_concrete_record env ty_expected with - | Record_type (p0, p, _, _) -> Some (p0, p, is_principal ty_expected) - | Maybe_a_record_type -> None - | Not_a_record_type -> - let error = - Wrong_expected_kind(Record, Expression explanation, ty_expected) - in - raise (Error (loc, env, error)) - in - let opt_exp_opath = - match opt_exp with - | None -> None - | Some (exp, _) -> - match extract_concrete_record env exp.exp_type with - | Record_type (p0, p, _, _) -> Some (p0, p, is_principal exp.exp_type) - | Maybe_a_record_type -> None - | Not_a_record_type -> - let error = Expr_not_a_record_type exp.exp_type in - raise (Error (exp.exp_loc, env, error)) - in - match expected_opath, opt_exp_opath with - | None, None -> - newvar (Jkind.of_new_sort ~why:Record_projection), None - | Some _, None -> ty_expected, expected_opath - | Some(_, _, true), Some _ -> ty_expected, expected_opath - | (None | Some (_, _, false)), Some (_, p', _) -> - let decl = Env.find_type p' env in - let ty = - with_local_level ~post:generalize_structure - (fun () -> newconstr p' (instance_list decl.type_params)) - in - ty, opt_exp_opath - in - let closed = (opt_sexp = None) in - let lbl_a_list = - wrap_disambiguate "This record expression is expected to have" - (mk_expected ty_record) - (disambiguate_sort_lid_a_list loc closed env Env.Construct expected_type) - lid_sexp_list - in - let alloc_mode, argument_mode = - if List.exists - (fun (_, {lbl_repres; _}, _) -> - match lbl_repres with - | Record_unboxed | Record_inlined (_, _, Variant_unboxed) -> false - | _ -> true) - lbl_a_list then - let alloc_mode, argument_mode = register_allocation expected_mode in - Some alloc_mode, argument_mode - else - None, expected_mode - in - let type_label_exp ((_, label, _) as x) = - check_construct_mutability ~loc ~env label.lbl_mut argument_mode; - let argument_mode = mode_modality label.lbl_modalities argument_mode in - type_label_exp true env argument_mode loc ty_record x - in - let lbl_exp_list = List.map type_label_exp lbl_a_list in - with_explanation (fun () -> - unify_exp_types loc env (instance ty_record) (instance ty_expected)); - (* note: check_duplicates would better be implemented in - disambiguate_sort_lid_a_list directly *) - let rec check_duplicates = function - | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_num = lbl2.lbl_num -> - raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name)) - | _ :: rem -> - check_duplicates rem - | [] -> () - in - check_duplicates lbl_exp_list; - let opt_exp, label_definitions = - let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in - let matching_label lbl = - List.find - (fun (_, lbl',_) -> lbl'.lbl_num = lbl.lbl_num) - lbl_exp_list - in - match opt_exp with - None -> - let label_definitions = - Array.map (fun lbl -> - match matching_label lbl with - | (lid, _lbl, lbl_exp) -> - Overridden (lid, lbl_exp) - | exception Not_found -> - let present_indices = - List.map (fun (_, lbl, _) -> lbl.lbl_num) lbl_exp_list - in - let label_names = extract_label_names env ty_expected in - let rec missing_labels n = function - [] -> [] - | lbl :: rem -> - if List.mem n present_indices - then missing_labels (n + 1) rem - else lbl :: missing_labels (n + 1) rem - in - let missing = missing_labels 0 label_names in - raise(Error(loc, env, Label_missing missing))) - lbl.lbl_all - in - None, label_definitions - | Some (exp, mode) -> - let ty_exp = instance exp.exp_type in - let unify_kept lbl = - let _, ty_arg1, ty_res1 = instance_label ~fixed:false lbl in - unify_exp_types exp.exp_loc env ty_exp ty_res1; - match matching_label lbl with - | lid, _lbl, lbl_exp -> - (* do not connect result types for overridden labels *) - Overridden (lid, lbl_exp) - | exception Not_found -> begin - let _, ty_arg2, ty_res2 = instance_label ~fixed:false lbl in - unify_exp_types loc env ty_arg1 ty_arg2; - with_explanation (fun () -> - unify_exp_types loc env (instance ty_expected) ty_res2); - check_project_mutability ~loc:exp.exp_loc ~env lbl.lbl_mut mode; - let mode = Modality.Value.Const.apply lbl.lbl_modalities mode in - check_construct_mutability ~loc ~env lbl.lbl_mut argument_mode; - let argument_mode = - mode_modality lbl.lbl_modalities argument_mode - in - submode ~loc ~env mode argument_mode; - Kept (ty_arg1, lbl.lbl_mut, - unique_use ~loc ~env mode - (as_single_mode argument_mode)) - end - in - let label_definitions = Array.map unify_kept lbl.lbl_all in - let ubr = Unique_barrier.not_computed () in - Some ({exp with exp_type = ty_exp}, ubr), label_definitions - in - let num_fields = - match lbl_exp_list with [] -> assert false - | (_, lbl,_)::_ -> Array.length lbl.lbl_all in - if opt_sexp <> None && List.length lid_sexp_list = num_fields then - Location.prerr_warning loc Warnings.Useless_record_with; - let label_descriptions, representation = - let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in - lbl_all, lbl_repres - in - let fields = - Array.map2 (fun descr def -> descr, def) - label_descriptions label_definitions - in - re { - exp_desc = Texp_record { - fields; representation; - extended_expression = opt_exp; - alloc_mode; - }; - exp_loc = loc; exp_extra = []; - exp_type = instance ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } + type_expect_record Legacy lid_sexp_list opt_sexp + | Pexp_record_unboxed_product(lid_sexp_list, opt_sexp) -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + type_expect_record Unboxed_product lid_sexp_list opt_sexp | Pexp_field(srecord, lid) -> let (record, rmode, label, _) = - type_label_access env srecord Env.Projection lid + type_label_access Legacy env srecord Env.Projection lid in let ty_arg = with_local_level_if_principal begin fun () -> @@ -5787,9 +5905,35 @@ and type_expect_ exp_type = ty_arg; exp_attributes = sexp.pexp_attributes; exp_env = env } + | Pexp_unboxed_field(srecord, lid) -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + let (record, rmode, label, _) = + type_label_access Unboxed_product env srecord Env.Projection lid + in + let ty_arg = + with_local_level_if_principal begin fun () -> + (* [ty_arg] is the type of field, [ty_res] is the type of record, they + could share type variables, which are now instantiated *) + let (_, ty_arg, ty_res) = instance_label ~fixed:false label in + (* we now link the two record types *) + unify_exp env record ty_res; + ty_arg + end ~post:generalize_structure + in + check_project_mutability ~loc:record.exp_loc ~env label.lbl_mut rmode; + let mode = Modality.Value.Const.apply label.lbl_modalities rmode in + let mode = mode_cross_left_value env ty_arg mode in + submode ~loc ~env mode expected_mode; + let uu = unique_use ~loc ~env mode (as_single_mode expected_mode) in + rue { + exp_desc = Texp_unboxed_field(record, lid, label, uu); + exp_loc = loc; exp_extra = []; + exp_type = ty_arg; + exp_attributes = sexp.pexp_attributes; + exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> let (record, rmode, label, expected_type) = - type_label_access env srecord Env.Mutation lid in + type_label_access Legacy env srecord Env.Mutation lid in let ty_record = if expected_type = None then newvar (Jkind.of_new_sort ~why:Record_assignment) @@ -5801,7 +5945,7 @@ and type_expect_ submode ~loc:record.exp_loc ~env rmode mode_mutate_mutable; let mode = mutable_mode m0 |> mode_default in let mode = mode_modality label.lbl_modalities mode in - type_label_exp false env mode loc ty_record (lid, label, snewval) + type_label_exp false env mode loc ty_record (lid, label, snewval) Legacy | Immutable -> raise(Error(loc, env, Label_not_mutable lid.txt)) in @@ -7034,7 +7178,9 @@ and type_function ret_info; fun_alloc_mode; } -and type_label_access env srecord usage lid = +and type_label_access + : 'rep . 'rep record_form -> _ -> _ -> _ -> _ -> _ * _ * 'rep gen_label_description * _ + = fun record_form env srecord usage lid -> let mode = Value.newvar () in let record = with_local_level_if_principal ~post:generalize_structure_exp @@ -7042,18 +7188,18 @@ and type_label_access env srecord usage lid = in let ty_exp = record.exp_type in let expected_type = - match extract_concrete_record env ty_exp with + match extract_concrete_record record_form env ty_exp with | Record_type(p0, p, _, _) -> Some(p0, p, is_principal ty_exp) | Maybe_a_record_type -> None | Not_a_record_type -> - let error = Expr_not_a_record_type ty_exp in + let error = Expr_not_a_record_type (P record_form, ty_exp) in raise (Error (record.exp_loc, env, error)) in - let labels = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in + let labels = Env.lookup_all_labels ~record_form ~loc:lid.loc usage lid.txt env in let label = wrap_disambiguate "This expression has" (mk_expected ty_exp) - (Label.disambiguate usage lid env expected_type) labels in + (label_disambiguate record_form usage lid env expected_type) labels in (record, mode, label, expected_type) (* Typing format strings for printing or reading. @@ -7315,8 +7461,12 @@ and type_option_some env expected_mode sarg ty ty0 = (* [expected_mode] is the expected mode of the field. It's already adjusted for allocation, mutation and modalities. *) -and type_label_exp create env (arg_mode : expected_mode) loc ty_expected - (lid, label, sarg) = +and type_label_exp + : type rep. + _ -> _ -> _ -> _ -> _ -> + _ * rep gen_label_description * _ -> rep record_form -> + _ * rep gen_label_description * _ + = fun create env arg_mode loc ty_expected (lid, label, sarg) record_form -> (* Here also ty_expected may be at generic_level *) let separate = !Clflags.principal || Env.has_local_constraints env in (* #4682: we try two type-checking approaches for [arg] using backtracking: @@ -7339,7 +7489,7 @@ and type_label_exp create env (arg_mode : expected_mode) loc ty_expected begin try unify env (instance ty_res) (instance ty_expected) with Unify err -> - raise (Error(lid.loc, env, Label_mismatch(lid.txt, err))) + raise (Error(lid.loc, env, Label_mismatch(P record_form, lid.txt, err))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance ty_arg in @@ -7392,6 +7542,7 @@ and type_label_exp create env (arg_mode : expected_mode) loc ty_expected in (lid, label, arg) + and type_argument ?explanation ?recarg env (mode : expected_mode) sarg ty_expected' ty_expected = (* ty_expected' may be generic *) @@ -9808,11 +9959,12 @@ let report_error ~loc env = function (Style.as_inline_code Printtyp.type_expr) typ (tuple_component ~print_article:true) lbl hint () - | Label_mismatch(lid, err) -> + | Label_mismatch(P record_form, lid, err) -> report_unification_error ~loc env err (function ppf -> - fprintf ppf "The record field %a@ belongs to the type" - (Style.as_inline_code longident) lid) + fprintf ppf "The %s field %a@ belongs to the type" + (record_form_to_string record_form) + (Style.as_inline_code longident) lid) (function ppf -> fprintf ppf "but is mixed here with fields of type") | Pattern_type_clash (err, pat) -> @@ -9935,11 +10087,11 @@ let report_error ~loc env = function | Label_multiply_defined s -> Location.errorf ~loc "The record field label %s is defined several times" s - | Label_missing labels -> + | Label_missing (P record_form, labels) -> let print_label ppf lbl = Style.inline_code ppf (Ident.name lbl) in let print_labels ppf = List.iter (fprintf ppf "@ %a" print_label) in - Location.errorf ~loc "@[Some record fields are undefined:%a@]" - print_labels labels + Location.errorf ~loc "@[Some %s fields are undefined:%a@]" + (record_form_to_string record_form) print_labels labels | Label_not_mutable lid -> Location.errorf ~loc "The record field %a is not mutable" (Style.as_inline_code longident) lid @@ -10304,17 +10456,19 @@ let report_error ~loc env = function | List -> "list literal" | Unit -> "unit literal" | Record -> "record" + | Record_unboxed_product -> "unboxed record" in Location.errorf ~loc "This %s should not be a %s,@ \ the expected type is@ %a%t" ctx sort (Style.as_inline_code Printtyp.type_expr) ty (report_type_expected_explanation_opt explanation) - | Expr_not_a_record_type ty -> + | Expr_not_a_record_type (P record_form, ty) -> Location.errorf ~loc "This expression has type %a@ \ - which is not a record type." + which is not a %s type." (Style.as_inline_code Printtyp.type_expr) ty + (record_form_to_string record_form) | Submode_failed(fail_reason, submode_reason, locality_context, contention_context, shared_context) -> diff --git a/typing/typecore.mli b/typing/typecore.mli index ec9cf902837..9b1e13a1b72 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -79,7 +79,7 @@ val mk_expected: val is_nonexpansive: Typedtree.expression -> bool module Datatype_kind : sig - type t = Record | Variant + type t = Record | Record_unboxed_product | Variant val type_name : t -> string val label_name : t -> string end @@ -98,6 +98,7 @@ type wrong_kind_context = type wrong_kind_sort = | Constructor | Record + | Record_unboxed_product | Boolean | List | Unit @@ -200,7 +201,7 @@ type error = | Partial_tuple_pattern_bad_type | Extra_tuple_label of string option * type_expr | Missing_tuple_label of string option * type_expr - | Label_mismatch of Longident.t * Errortrace.unification_error + | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : Errortrace.unification_error * Parsetree.pattern_desc option -> error @@ -224,7 +225,7 @@ type error = } | Apply_wrong_label of arg_label * type_expr * bool | Label_multiply_defined of string - | Label_missing of Ident.t list + | Label_missing of record_form_packed * Ident.t list | Label_not_mutable of Longident.t | Wrong_name of string * type_expected * wrong_name | Name_type_mismatch of @@ -291,7 +292,7 @@ type error = | Unbound_existential of Ident.t list * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr - | Expr_not_a_record_type of type_expr + | Expr_not_a_record_type of record_form_packed * type_expr | Submode_failed of Mode.Value.error * submode_reason * Env.locality_context option * diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 21072183491..948ec8b4902 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -29,6 +29,7 @@ type native_repr_kind = Unboxed | Untagged type jkind_sort_loc = | Cstr_tuple of { unboxed : bool } | Record of { unboxed : bool } + | Record_unboxed_product | Inlined_record of { unboxed : bool } | Mixed_product | External @@ -624,6 +625,7 @@ let verify_unboxed_attr unboxed_attr sdecl = | [{pld_mutable = Mutable}] -> bad "it is mutable" | [{pld_mutable = Immutable}] -> () end + | Ptype_record_unboxed_product _ -> bad "cannot use [@@unboxed] on unboxed record" | Ptype_variant constructors -> begin match constructors with | [] -> bad "it has no constructor" | (_::_::_) -> bad "it has more than one constructor" @@ -766,6 +768,7 @@ let transl_declaration env sdecl (id, uid) = | Ptype_record [{pld_mutable=Immutable; _}] -> Option.value unboxed_attr ~default:!Clflags.unboxed_types, Option.is_none unboxed_attr + | Ptype_record_unboxed_product _ -> false, false | _ -> false, false (* Not unboxable, mark as boxed *) in verify_unboxed_attr unboxed_attr sdecl; @@ -813,8 +816,8 @@ let transl_declaration env sdecl (id, uid) = ~why:(Primitive Predef.ident_or_null) in Ttype_abstract, type_kind, jkind - | (Ptype_variant _ | Ptype_record _ | Ptype_open) when - Builtin_attributes.has_or_null_reexport sdecl.ptype_attributes -> + | (Ptype_variant _ | Ptype_record _ | Ptype_record_unboxed_product _ | Ptype_open) + when Builtin_attributes.has_or_null_reexport sdecl.ptype_attributes -> raise (Error (sdecl.ptype_loc, Non_abstract_reexport path)) | Ptype_abstract -> Ttype_abstract, Type_abstract Definition, @@ -915,6 +918,17 @@ let transl_declaration env sdecl (id, uid) = Jkind.Builtin.value ~why:Boxed_record in Ttype_record lbls, Type_record(lbls', rep), jkind + | Ptype_record_unboxed_product lbls -> + Language_extension.assert_enabled ~loc:sdecl.ptype_loc Layouts + Language_extension.Beta; + let lbls, lbls' = + transl_labels ~new_var_jkind:Any ~allow_unboxed:true + env None true lbls Record_unboxed_product + in + let jkind_ls = List.map (fun _ -> any) 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 | Ptype_open -> Ttype_open, Type_open, Jkind.Builtin.value ~why:Extensible_variant in @@ -988,7 +1002,9 @@ let transl_declaration env sdecl (id, uid) = let uid = decl.typ_type.type_uid in match decl.typ_type.type_kind with | Type_variant (cstrs, _) -> Shape.str ~uid (shape_map_cstrs cstrs) - | Type_record (labels, _) -> Shape.str ~uid (shape_map_labels labels) + | Type_record (labels, _) + | Type_record_unboxed_product (labels, _) -> + Shape.str ~uid (shape_map_labels labels) | Type_abstract _ | Type_open -> Shape.leaf uid in decl, typ_shape @@ -1072,7 +1088,8 @@ let check_constraints env sdecl (_, decl) = | Type_variant (l, _rep) -> let find_pl = function Ptype_variant pl -> pl - | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false + | Ptype_record _ | Ptype_record_unboxed_product _ | Ptype_abstract | Ptype_open -> + assert false in let pl = find_pl sdecl.ptype_kind in let pl_index = @@ -1106,8 +1123,17 @@ let check_constraints env sdecl (_, decl) = l | Type_record (l, _) -> let find_pl = function - Ptype_record pl -> pl - | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false + | Ptype_record pl -> pl + | Ptype_record_unboxed_product _ | Ptype_variant _ | Ptype_abstract + | Ptype_open -> + assert false + in + let pl = find_pl sdecl.ptype_kind in + check_constraints_labels env visited l pl + | Type_record_unboxed_product (l, _) -> + let find_pl = function + | Ptype_record_unboxed_product pl -> pl + | Ptype_record _ | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false in let pl = find_pl sdecl.ptype_kind in check_constraints_labels env visited l pl @@ -1142,7 +1168,8 @@ let narrow_to_manifest_jkind env loc decl = with the same constructors and labels. *) let check_kind_coherence env loc dpath decl = match decl.type_kind, decl.type_manifest with - | (Type_variant _ | Type_record _ | Type_open), Some ty -> + | (Type_variant _ | Type_record _ | Type_record_unboxed_product _ | Type_open), + Some ty -> if !Clflags.allow_illegal_crossing then begin let jkind' = Ctype.type_jkind_purely env ty in begin match Jkind.sub_jkind_l jkind' decl.type_jkind with @@ -1660,6 +1687,23 @@ let update_decl_jkind env dpath decl = No updating required for [or_null_reexport], and we must not incorrectly override the jkind to [non_null]. *) + | Type_record_unboxed_product (lbls, rep) -> + begin match rep with + | 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 + ) lbls + |> List.split + in + let type_jkind = Jkind.Builtin.product ~why:Unboxed_record jkinds in + let type_jkind, type_has_illegal_crossings = add_crossings type_jkind in + { decl with type_kind = Type_record_unboxed_product (lbls, rep); + type_jkind; + type_has_illegal_crossings }, + type_jkind + end | Type_variant _ when Builtin_attributes.has_or_null_reexport decl.type_attributes -> decl, decl.type_jkind @@ -2039,7 +2083,9 @@ let check_abbrev_regularity ~abs_env env id_loc_list to_check tdecl = decl to_check let check_duplicates sdecl_list = - let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in + let labels = Hashtbl.create 7 in + let unboxed_labels = Hashtbl.create 7 in + let constrs = Hashtbl.create 7 in List.iter (fun sdecl -> match sdecl.ptype_kind with Ptype_variant cl -> @@ -2064,6 +2110,16 @@ let check_duplicates sdecl_list = ("label", cname.txt, name', sdecl.ptype_name.txt)) with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt) fl + | Ptype_record_unboxed_product fl -> + List.iter + (fun {pld_name=cname;pld_loc=loc} -> + try + let name' = Hashtbl.find unboxed_labels cname.txt in + Location.prerr_warning loc + (Warnings.Duplicate_definitions + ("unboxed record label", cname.txt, name', sdecl.ptype_name.txt)) + with Not_found -> Hashtbl.add unboxed_labels cname.txt sdecl.ptype_name.txt) + fl | Ptype_abstract -> () | Ptype_open -> ()) sdecl_list @@ -3540,6 +3596,9 @@ let report_error ppf = function | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun l -> l.Types.ld_type) "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_record_unboxed_product (tl, _), _ -> + explain_unbound ppf ty tl (fun l -> l.Types.ld_type) + "unboxed record field" (fun l -> Ident.name l.Types.ld_id ^ ": ") | Type_abstract _, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () @@ -3700,14 +3759,15 @@ let report_error ppf = function | Inlined_record { unboxed = false } | Record { unboxed = false } -> "Record element types" | Inlined_record { unboxed = true } - | Record { unboxed = true } -> "Unboxed record element types" + | Record { unboxed = true } -> "[@@unboxed] record element types" + | Record_unboxed_product -> "Unboxed record element types" | External -> "Types in an external" | External_with_layout_poly -> "Types in an external" in let extra = match kloc with - | Mixed_product - | Cstr_tuple _ | Record _ | Inlined_record _ | External -> dprintf "" + | Mixed_product | Cstr_tuple _ | Record _ | Inlined_record _ | External + | Record_unboxed_product -> dprintf "" | External_with_layout_poly -> dprintf "@ (locally-scoped type variables with layout 'any' are@ \ made representable by %a)" @@ -3729,9 +3789,10 @@ let report_error ppf = function match lloc with | Mixed_product -> "Structures with non-value elements" | Inlined_record { unboxed = false } -> "Inlined records" - | Inlined_record { unboxed = true } -> "Unboxed inlined records" + | Inlined_record { unboxed = true } -> "[@@unboxed] inlined records" | Record { unboxed = false } -> "Records" - | Record { unboxed = true }-> "Unboxed records" + | Record { unboxed = true }-> "[@@unboxed] records" + | Record_unboxed_product -> "Unboxed records" | Cstr_tuple { unboxed = false } -> "Variants" | Cstr_tuple { unboxed = true } -> "Unboxed variants" | External | External_with_layout_poly -> assert false diff --git a/typing/typedecl.mli b/typing/typedecl.mli index c317c6b67f0..78ba9b81903 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -74,6 +74,7 @@ type native_repr_kind = Unboxed | Untagged type jkind_sort_loc = | Cstr_tuple of { unboxed : bool } | Record of { unboxed : bool } + | Record_unboxed_product | Inlined_record of { unboxed : bool } | Mixed_product | External diff --git a/typing/typedecl_separability.ml b/typing/typedecl_separability.ml index e76c182e654..c49f36b2a19 100644 --- a/typing/typedecl_separability.ml +++ b/typing/typedecl_separability.ml @@ -46,30 +46,29 @@ type type_structure = | Open | Algebraic | Unboxed of argument_to_unbox + | Unboxed_product let structure : type_definition -> type_structure = fun def -> - match def.type_kind with - | Type_open -> Open - | Type_abstract _ -> + match (def.type_kind, find_unboxed_type def) with + | Type_open, _ -> Open + | Type_abstract _, _ -> begin match def.type_manifest with | None -> Abstract | Some type_expr -> Synonym type_expr end - | Type_record _ | Type_variant _ -> - begin match find_unboxed_type def with - | None -> Algebraic - | Some ty -> - let params = - match def.type_kind with - | Type_variant ([{cd_res = Some ret_type}], _) -> - begin match get_desc ret_type with - | Tconstr (_, tyl, _) -> tyl - | _ -> assert false - end - | _ -> def.type_params - in - Unboxed { argument_type = ty; result_type_parameter_instances = params } - end + | (Type_record _ | Type_variant _), None -> Algebraic + | Type_record_unboxed_product _, None -> Unboxed_product + | (Type_record _ | Type_record_unboxed_product _ | Type_variant _), Some ty -> + let params = + match def.type_kind with + | Type_variant ([{cd_res = Some ret_type}], _) -> + begin match get_desc ret_type with + | Tconstr (_, tyl, _) -> tyl + | _ -> assert false + end + | _ -> def.type_params + in + Unboxed { argument_type = ty; result_type_parameter_instances = params } type error = | Non_separable_evar of string option @@ -633,6 +632,12 @@ let check_def check_type env constructor.argument_type Sep |> msig_of_context ~decl_loc:def.type_loc ~parameters:constructor.result_type_parameter_instances + | Unboxed_product -> + (* CR layouts 7.3: we give products best_msig, as they are + not affected by the flat float array optimization. + See test [typing-layouts-unboxed-records/separability.ml]. + *) + best_msig def let compute_decl env decl = if Config.flat_float_array then check_def env decl diff --git a/typing/typedecl_variance.ml b/typing/typedecl_variance.ml index ddda684a88d..54dcb11b2b6 100644 --- a/typing/typedecl_variance.ml +++ b/typing/typedecl_variance.ml @@ -355,6 +355,10 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = compute_variance_type env ~check rloc decl (mn @ List.map (fun {Types.ld_mutable; ld_type} -> (Types.is_mutable ld_mutable, ld_type)) ftl) + | Type_record_unboxed_product (ftl, _) -> + compute_variance_type env ~check rloc decl + (mn @ List.map (fun {Types.ld_mutable; ld_type} -> + (Types.is_mutable ld_mutable, ld_type)) ftl) in if mn = [] || not abstract then List.map Variance.strengthen vari diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 160fc1165ee..ce3a997dd60 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -150,6 +150,10 @@ and 'k pattern_desc = (Longident.t loc * label_description * value general_pattern) list * closed_flag -> value pattern_desc + | Tpat_record_unboxed_product : + (Longident.t loc * unboxed_label_description * value general_pattern) list * + closed_flag -> + value pattern_desc | Tpat_array : mutability * Jkind.sort * value general_pattern list -> value pattern_desc | Tpat_lazy : value general_pattern -> value pattern_desc @@ -215,9 +219,16 @@ and expression_desc = extended_expression : (expression * Unique_barrier.t) option; alloc_mode : alloc_mode option } + | Texp_record_unboxed_product of { + fields : ( Types.unboxed_label_description * record_label_definition ) array; + representation : Types.record_unboxed_product_representation; + extended_expression : expression option; + } | Texp_field of expression * Longident.t loc * label_description * texp_field_boxing * Unique_barrier.t + | Texp_unboxed_field of + expression * Longident.t loc * unboxed_label_description * unique_use | Texp_setfield of expression * Mode.Locality.l * Longident.t loc * label_description * expression | Texp_array of mutability * Jkind.Sort.t * expression list * alloc_mode @@ -737,6 +748,7 @@ and type_kind = Ttype_abstract | Ttype_variant of constructor_declaration list | Ttype_record of label_declaration list + | Ttype_record_unboxed_product of label_declaration list | Ttype_open and label_declaration = @@ -919,6 +931,7 @@ let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category = | Tpat_construct _ -> Value | Tpat_variant _ -> Value | Tpat_record _ -> Value + | Tpat_record_unboxed_product _ -> Value | Tpat_array _ -> Value | Tpat_lazy _ -> Value | Tpat_any -> Value @@ -951,6 +964,8 @@ let shallow_iter_pattern_desc | Tpat_variant(_, pat, _) -> Option.iter f.f pat | Tpat_record (lbl_pat_list, _) -> List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list + | Tpat_record_unboxed_product (lbl_pat_list, _) -> + List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list | Tpat_array (_, _, patl) -> List.iter f.f patl | Tpat_lazy p -> f.f p | Tpat_any @@ -974,6 +989,9 @@ let shallow_map_pattern_desc (List.map (fun (label, pat, sort) -> label, f.f pat, sort) pats) | Tpat_record (lpats, closed) -> Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed) + | Tpat_record_unboxed_product (lpats, closed) -> + Tpat_record_unboxed_product + (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed) | Tpat_construct (lid, c, pats, ty) -> Tpat_construct (lid, c, List.map f.f pats, ty) | Tpat_array (am, arg_sort, pats) -> @@ -1081,6 +1099,10 @@ let iter_pattern_full ~both_sides_of_or f sort pat = List.iter (fun (_, lbl, pat) -> (loop f) (Jkind.sort_of_jkind lbl.lbl_jkind) pat) lbl_pat_list + | Tpat_record_unboxed_product (lbl_pat_list, _) -> + List.iter (fun (_, lbl, pat) -> + (loop f) (Jkind.sort_of_jkind lbl.lbl_jkind) pat) + lbl_pat_list (* Cases where the inner things must be value: *) | Tpat_variant (_, pat, _) -> Option.iter (loop f Jkind.Sort.value) pat | Tpat_tuple patl -> diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 1bb9bf0898e..ddf253c657b 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -189,6 +189,15 @@ and 'k pattern_desc = (** { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) + Invariant: n > 0 + *) + | Tpat_record_unboxed_product : + (Longident.t loc * Types.unboxed_label_description * value general_pattern) list * + closed_flag -> + value pattern_desc + (** { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + Invariant: n > 0 *) | Tpat_array : @@ -393,10 +402,28 @@ and expression_desc = or [None] if it is [Record_unboxed], in which case it does not need allocation. *) + | Texp_record_unboxed_product of { + fields : ( Types.unboxed_label_description * record_label_definition ) array; + representation : Types.record_unboxed_product_representation; + extended_expression : expression option; + } + (** #{ l1=P1; ...; ln=Pn } (extended_expression = None) + #{ E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) + + Invariant: n > 0 + + If the type is #{ l1: t1; l2: t2 }, the expression + #{ E0 with t2=P2 } is represented as + Texp_record_unboxed_product + { fields = [| l1, Kept t1; l2 Override P2 |]; representation; + extended_expression = Some E0 } + *) | Texp_field of expression * Longident.t loc * Types.label_description * texp_field_boxing * Unique_barrier.t (** [texp_field_boxing] provides extra information depending on if the projection requires boxing. *) + | Texp_unboxed_field of expression * Longident.t loc * Types.unboxed_label_description * + unique_use | Texp_setfield of expression * Mode.Locality.l * Longident.t loc * Types.label_description * expression @@ -987,6 +1014,7 @@ and type_kind = Ttype_abstract | Ttype_variant of constructor_declaration list | Ttype_record of label_declaration list + | Ttype_record_unboxed_product of label_declaration list | Ttype_open and label_declaration = diff --git a/typing/typemod.ml b/typing/typemod.ml index cc6ddf36a92..9c32a274423 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1368,7 +1368,7 @@ end = struct let open Sig_component_kind in match component with | Value -> names.values - | Type | Label | Constructor -> names.types + | Type | Label | Unboxed_label | Constructor -> names.types | Module -> names.modules | Module_type -> names.modtypes | Extension_constructor -> names.typexts diff --git a/typing/typemod.mli b/typing/typemod.mli index ae6ee3a7546..3e75654c7ce 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -78,6 +78,7 @@ module Sig_component_kind : sig | Type | Constructor | Label + | Unboxed_label | Module | Module_type | Extension_constructor diff --git a/typing/typeopt.ml b/typing/typeopt.ml index e75d007dae4..1a6ecdd683c 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -166,6 +166,8 @@ let classify ~classify_product env loc ty sort : _ classification = Any | Type_record _ | Type_variant _ | Type_open -> Addr + | Type_record_unboxed_product _ -> + Any with Not_found -> (* This can happen due to e.g. missing -I options, causing some .cmi files to be unavailable. @@ -510,6 +512,12 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty fallback_if_missing_cmi ~default:(num_nodes_visited, mk_nn Pgenval) (fun () -> value_kind_record env ~loc ~visited ~depth ~num_nodes_visited labels rep) + | Type_record_unboxed_product ([{ld_type}], Record_unboxed_product) -> + let depth = depth + 1 in + fallback_if_missing_cmi ~default:(num_nodes_visited, mk_nn Pgenval) + (fun () -> value_kind env ~loc ~visited ~depth ~num_nodes_visited ld_type) + | Type_record_unboxed_product (([] | _::_::_), Record_unboxed_product) -> + assert false | Type_abstract _ -> num_nodes_visited, mk_nn (value_kind_of_value_jkind decl.type_jkind) diff --git a/typing/types.ml b/typing/types.ml index 5364405ca1b..4336cf6061a 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -272,11 +272,12 @@ type type_declaration = type_has_illegal_crossings: bool; } -and type_decl_kind = (label_declaration, constructor_declaration) type_kind +and type_decl_kind = (label_declaration, label_declaration, constructor_declaration) type_kind -and ('lbl, 'cstr) type_kind = +and ('lbl, 'lbl_flat, 'cstr) type_kind = Type_abstract of type_origin | Type_record of 'lbl list * record_representation + | Type_record_unboxed_product of 'lbl_flat list * record_unboxed_product_representation | Type_variant of 'cstr list * variant_representation | Type_open @@ -313,6 +314,9 @@ and record_representation = | Record_ufloat | Record_mixed of mixed_product_shape +and record_unboxed_product_representation = + | Record_unboxed_product + and variant_representation = | Variant_unboxed | Variant_boxed of (constructor_representation * @@ -677,6 +681,9 @@ let equal_record_representation r1 r2 = match r1, r2 with | Record_ufloat | Record_mixed _), _ -> false +let equal_record_unboxed_product_representation r1 r2 = match r1, r2 with + | Record_unboxed_product, Record_unboxed_product -> true + let may_equal_constr c1 c2 = c1.cstr_arity = c2.cstr_arity && (match c1.cstr_tag,c2.cstr_tag with @@ -686,10 +693,45 @@ let may_equal_constr c1 c2 = | tag1, tag2 -> equal_tag tag1 tag2) +type 'a gen_label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + 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_pos: int; (* Position in block *) + lbl_num: int; (* Position in type *) + lbl_all: 'a gen_label_description array; (* All the labels in this type *) + lbl_repres: 'a; (* Representation for outer record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + lbl_uid: Uid.t; + } + +type label_description = record_representation gen_label_description + +type unboxed_label_description = record_unboxed_product_representation gen_label_description + +type _ record_form = + | Legacy : record_representation record_form + | Unboxed_product : record_unboxed_product_representation record_form + +type record_form_packed = + | P : _ record_form -> record_form_packed + +let record_form_to_string (type rep) (record_form : rep record_form) = + match record_form with + | Legacy -> "record" + | Unboxed_product -> "unboxed record" + let find_unboxed_type decl = match decl.type_kind with Type_record ([{ld_type = arg; _}], Record_unboxed) | Type_record ([{ld_type = arg; _}], Record_inlined (_, _, Variant_unboxed)) + | Type_record_unboxed_product + ([{ld_type = arg; _}], Record_unboxed_product) | Type_variant ([{cd_args = Cstr_tuple [{ca_type = arg; _}]; _}], Variant_unboxed) | Type_variant ([{cd_args = Cstr_record [{ld_type = arg; _}]; _}], Variant_unboxed) -> @@ -697,6 +739,7 @@ let find_unboxed_type decl = | Type_record (_, ( Record_inlined _ | Record_unboxed | Record_boxed _ | Record_float | Record_ufloat | Record_mixed _)) + | Type_record_unboxed_product (_, Record_unboxed_product) | Type_variant (_, ( Variant_boxed _ | Variant_unboxed | Variant_extensible )) | Type_abstract _ | Type_open -> @@ -711,23 +754,6 @@ let item_visibility = function | Sig_class (_, _, _, vis) | Sig_class_type (_, _, _, vis) -> vis -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - 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_pos: int; (* Position in block *) - lbl_num: int; (* Position in type *) - lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation; (* Representation for outer record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - lbl_uid: Uid.t; - } - let lbl_pos_void = -1 let rec bound_value_identifiers = function diff --git a/typing/types.mli b/typing/types.mli index 137e33d1c1a..a056895bfcc 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -547,11 +547,12 @@ type type_declaration = (* CR layouts v2.8: remove type_has_illegal_crossings *) } -and type_decl_kind = (label_declaration, constructor_declaration) type_kind +and type_decl_kind = (label_declaration, label_declaration, constructor_declaration) type_kind -and ('lbl, 'cstr) type_kind = +and ('lbl, 'lbl_flat, 'cstr) type_kind = Type_abstract of type_origin | Type_record of 'lbl list * record_representation + | Type_record_unboxed_product of 'lbl_flat list * record_unboxed_product_representation | Type_variant of 'cstr list * variant_representation | Type_open @@ -613,6 +614,12 @@ and record_representation = is tagged such that polymorphic operations will not work. *) +and record_unboxed_product_representation = + | Record_unboxed_product + (* We give all unboxed records the same representation, as their layouts are + encapsulated by their label's jkinds. We keep this variant for uniformity with boxed + records, and to make it easier to support different representations in the future. *) + and variant_representation = | Variant_unboxed | Variant_boxed of (constructor_representation * @@ -873,10 +880,13 @@ val may_equal_constr : val equal_record_representation : record_representation -> record_representation -> bool +val equal_record_unboxed_product_representation : + record_unboxed_product_representation -> record_unboxed_product_representation -> bool + val equal_variant_representation : variant_representation -> variant_representation -> bool -type label_description = +type 'a gen_label_description = { lbl_name: string; (* Short name *) lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) @@ -886,8 +896,8 @@ type label_description = lbl_jkind : jkind_l; (* Jkind of the argument *) lbl_pos: int; (* Position in block *) lbl_num: int; (* Position in the type *) - lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation; (* Representation for outer record *) + lbl_all: 'a gen_label_description array; (* All the labels in this type *) + lbl_repres: 'a; (* Representation for outer record *) lbl_private: private_flag; (* Read-only field? *) lbl_loc: Location.t; lbl_attributes: Parsetree.attributes; @@ -897,6 +907,19 @@ type label_description = 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 + +type unboxed_label_description = record_unboxed_product_representation gen_label_description + +type _ record_form = + | Legacy : record_representation record_form + | Unboxed_product : record_unboxed_product_representation record_form + +type record_form_packed = + | P : _ record_form -> record_form_packed + +val record_form_to_string : _ record_form -> string + (** The special value we assign to lbl_pos for label descriptions corresponding to void types, because they can't sensibly be projected. diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml index c0753513c97..d00a597c139 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -461,6 +461,7 @@ module Projection : sig type t = | Tuple_field of int | Record_field of string + | Record_unboxed_product_field of string | Construct_field of string * int | Variant_field of label | Array_index of int @@ -472,6 +473,7 @@ end = struct type t = | Tuple_field of int | Record_field of string + | Record_unboxed_product_field of string | Construct_field of string * int | Variant_field of label | Array_index of int @@ -481,25 +483,35 @@ end = struct match t1, t2 with | Tuple_field i, Tuple_field j -> Int.compare i j | Record_field l1, Record_field l2 -> String.compare l1 l2 + | Record_unboxed_product_field l1, Record_unboxed_product_field l2 -> + String.compare l1 l2 | Construct_field (l1, i), Construct_field (l2, j) -> ( match String.compare l1 l2 with 0 -> Int.compare i j | i -> i) | Variant_field l1, Variant_field l2 -> String.compare l1 l2 | Array_index i, Array_index j -> Int.compare i j | Memory_address, Memory_address -> 0 | ( Tuple_field _, - ( Record_field _ | Construct_field _ | Variant_field _ | Array_index _ - | Memory_address ) ) -> + ( Record_field _ | Record_unboxed_product_field _ | Construct_field _ + | Variant_field _ | Array_index _ | Memory_address ) ) -> -1 - | ( ( Record_field _ | Construct_field _ | Variant_field _ | Array_index _ - | Memory_address ), + | ( ( Record_field _ | Record_unboxed_product_field _ | Construct_field _ + | Variant_field _ | Array_index _ | Memory_address ), Tuple_field _ ) -> 1 | ( Record_field _, + ( Record_unboxed_product_field _ | Construct_field _ | Variant_field _ + | Array_index _ | Memory_address ) ) -> + -1 + | ( ( Record_unboxed_product_field _ | Construct_field _ | Variant_field _ + | Array_index _ | Memory_address ), + Record_field _ ) -> + 1 + | ( Record_unboxed_product_field _, (Construct_field _ | Variant_field _ | Array_index _ | Memory_address) ) -> -1 | ( (Construct_field _ | Variant_field _ | Array_index _ | Memory_address), - Record_field _ ) -> + Record_unboxed_product_field _ ) -> 1 | Construct_field _, (Variant_field _ | Array_index _ | Memory_address) -> -1 @@ -780,6 +792,10 @@ module Paths : sig [modal_child gf (Projection.Record_field s) t]. *) val record_field : Modality.Value.Const.t -> string -> t -> t + (** [record_unboxed_product_field gf s t] is + [modal_child gf (Projection.Record_unboxed_product_field s) t]. *) + val record_unboxed_product_field : Modality.Value.Const.t -> string -> t -> t + (** [construct_field gf s i t] is [modal_child gf (Projection.Construct_field(s, i)) t]. *) val construct_field : Modality.Value.Const.t -> string -> int -> t -> t @@ -832,6 +848,9 @@ end = struct let record_field gf s t = modal_child gf (Projection.Record_field s) t + let record_unboxed_product_field gf s t = + modal_child gf (Projection.Record_unboxed_product_field s) t + let construct_field gf s i t = modal_child gf (Projection.Construct_field (s, i)) t @@ -888,6 +907,10 @@ module Value : sig val implicit_record_field : Modality.Value.Const.t -> string -> t -> unique_use -> t + (** Analogous to [implicit_record_field], but for unboxed records *) + val implicit_record_unboxed_product_field : + Modality.Value.Const.t -> string -> t -> unique_use -> t + (** Mark the value as aliased_or_unique *) val mark_maybe_unique : t -> UF.t @@ -920,6 +943,13 @@ end = struct let paths = Paths.record_field gf s paths in Existing { paths; occ; unique_use } + let implicit_record_unboxed_product_field gf s t unique_use = + match t with + | Fresh -> Fresh + | Existing { paths; occ; unique_use = _ } -> + let paths = Paths.record_unboxed_product_field gf s paths in + Existing { paths; occ; unique_use } + let mark_implicit_borrow_memory_address access = function | Fresh -> UF.unused | Existing { paths; occ; _ } -> @@ -1127,6 +1157,20 @@ and pattern_match_single pat paths : Ienv.Extension.t * UF.t = |> conjuncts_pattern_match in ext, UF.par uf_read uf_pats + | Tpat_record_unboxed_product (pats, _) -> + (* No borrow since unboxed data can not be consumed. *) + no_borrow_memory_address (); + let ext, uf_pats = + List.map + (fun (_, l, pat) -> + let paths = + Paths.record_unboxed_product_field l.lbl_modalities l.lbl_name paths + in + pattern_match_single pat paths) + pats + |> conjuncts_pattern_match + in + ext, uf_pats | Tpat_array (mut, _, pats) -> let uf_read = borrow_memory_address () in let ext, uf_pats = @@ -1371,9 +1415,32 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = fields in UF.par uf_ext (UF.pars (Array.to_list uf_fields)) + | Texp_record_unboxed_product { fields; extended_expression } -> + let value, uf_ext = + match extended_expression with + | None -> Value.fresh, UF.unused + | Some exp -> check_uniqueness_exp_as_value ienv exp + in + let uf_fields = + Array.map + (fun field -> + match field with + | l, Kept (_, _, unique_use) -> + let value = + Value.implicit_record_unboxed_product_field l.lbl_modalities + l.lbl_name value unique_use + in + Value.mark_maybe_unique value + | _, Overridden (_, e) -> check_uniqueness_exp ienv e) + fields + in + UF.par uf_ext (UF.pars (Array.to_list uf_fields)) | Texp_field _ -> let value, uf = check_uniqueness_exp_as_value ienv exp in UF.seq uf (Value.mark_maybe_unique value) + | Texp_unboxed_field (_, _, _, _) -> + let value, uf = check_uniqueness_exp_as_value ienv exp in + UF.seq uf (Value.mark_maybe_unique value) | Texp_setfield (rcd, _, _, _, arg) -> let value, uf_rcd = check_uniqueness_exp_as_value ienv rcd in let uf_arg = check_uniqueness_exp ienv arg in @@ -1511,6 +1578,17 @@ and check_uniqueness_exp_as_value ienv exp : Value.t * UF.t = Paths.mark (Usage.maybe_unique unique_use occ) paths, Value.fresh in value, UF.seqs [uf; uf_read; uf_boxing]) + | Texp_unboxed_field (e, _, l, unique_use) -> ( + let value, uf = check_uniqueness_exp_as_value ienv e in + match Value.paths value with + | None -> Value.fresh, uf + | Some paths -> + let occ = Occurrence.mk loc in + let paths = + Paths.record_unboxed_product_field l.lbl_modalities l.lbl_name paths + in + let value = Value.existing paths unique_use occ in + value, uf) (* CR-someday anlorenzen: This could also support let-bindings. *) | _ -> Value.fresh, check_uniqueness_exp ienv exp diff --git a/typing/untypeast.ml b/typing/untypeast.ml index df7af0077cc..58edfc93048 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -247,6 +247,8 @@ let type_kind sub tk = match tk with Ptype_variant (List.map (sub.constructor_declaration sub) list) | Ttype_record list -> Ptype_record (List.map (sub.label_declaration sub) list) + | Ttype_record_unboxed_product list -> + Ptype_record_unboxed_product (List.map (sub.label_declaration sub) list) | Ttype_open -> Ptype_open let constructor_argument sub {ca_loc; ca_type; ca_modalities} = @@ -392,6 +394,9 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | Tpat_record (list, closed) -> Ppat_record (List.map (fun (lid, _, pat) -> map_loc sub lid, sub.pat sub pat) list, closed) + | Tpat_record_unboxed_product (list, closed) -> + Ppat_record_unboxed_product (List.map (fun (lid, _, pat) -> + map_loc sub lid, sub.pat sub pat) list, closed) | Tpat_array (am, _, list) -> Ppat_array (mutable_ am, List.map (sub.pat sub) list) | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) @@ -581,8 +586,17 @@ let expression sub exp = in Pexp_record (list, Option.map (fun (exp, _) -> sub.expr sub exp) extended_expression) + | Texp_record_unboxed_product { fields; extended_expression; _ } -> + let list = Array.fold_left (fun l -> function + | _, Kept _ -> l + | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) + [] fields + in + Pexp_record_unboxed_product (list, Option.map (sub.expr sub) extended_expression) | Texp_field (exp, lid, _label, _, _) -> Pexp_field (sub.expr sub exp, map_loc sub lid) + | Texp_unboxed_field (exp, lid, _label, _) -> + Pexp_unboxed_field (sub.expr sub exp, map_loc sub lid) | Texp_setfield (exp1, _, lid, _label, exp2) -> Pexp_setfield (sub.expr sub exp1, map_loc sub lid, sub.expr sub exp2) diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml index 32c742a2512..9744b4c9050 100644 --- a/typing/value_rec_check.ml +++ b/typing/value_rec_check.ml @@ -183,6 +183,12 @@ let classify_expression : Typedtree.expression -> sd = | Texp_record _ -> Static + | Texp_record_unboxed_product { representation = Record_unboxed_product; + fields = [| _, Overridden (_,e) |] } -> + classify_expression env e + | Texp_record_unboxed_product _ -> + Dynamic + | Texp_variant _ | Texp_tuple _ | Texp_extension_constructor _ @@ -250,6 +256,7 @@ let classify_expression : Typedtree.expression -> sd = | Texp_ifthenelse _ | Texp_send _ | Texp_field _ + | Texp_unboxed_field _ | Texp_assert _ | Texp_try _ | Texp_override _ @@ -769,6 +776,23 @@ let rec expression : Typedtree.expression -> term_judg = array field es; option expression (Option.map fst eo) << Dereference ] + | Texp_record_unboxed_product { fields = es; extended_expression = eo; + representation = rep } -> + begin match rep with + | Record_unboxed_product -> + let field (_, field_def) = + let env = + match field_def with + | Kept _ -> empty + | Overridden (_, e) -> expression e + in + env << Return + in + join [ + array field es; + option expression eo << Dereference + ] + end | Texp_ifthenelse (cond, ifso, ifnot) -> (* Gc |- c: m[Dereference] @@ -840,6 +864,8 @@ let rec expression : Typedtree.expression -> term_judg = G |- e.x: m *) expression e << Dereference + | Texp_unboxed_field (e, _, _, _) -> + expression e << Dereference | Texp_setinstvar (pth,_,_,e) -> (* G |- e: m[Dereference] @@ -1419,6 +1445,7 @@ and is_destructuring_pattern : type k . k general_pattern -> bool = | Tpat_construct _ -> true | Tpat_variant _ -> true | Tpat_record (_, _) -> true + | Tpat_record_unboxed_product (_, _) -> true | Tpat_array _ -> true | Tpat_lazy _ -> true | Tpat_value pat -> is_destructuring_pattern (pat :> pattern) diff --git a/utils/warnings.ml b/utils/warnings.ml index ecf7d149a90..e21300fca8d 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -42,6 +42,10 @@ type upstream_compat_warning = | Unboxed_attribute of string (* example: unboxed attribute on an external declaration with float# is missing. *) +type name_out_of_scope_warning = + | Name of string + | Fields of { record_form : string ; fields : string list } + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -51,7 +55,7 @@ type t = | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) - | Missing_record_field_pattern of string (* 9 *) + | Missing_record_field_pattern of string * string (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) | Redundant_subpat (* 12 *) @@ -65,7 +69,7 @@ type t = | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) - | Useless_record_with (* 23 *) + | Useless_record_with of string (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 8, used to be 25 *) | Unused_var of string (* 26 *) @@ -83,7 +87,7 @@ type t = | Unused_constructor of string * constructor_usage_warning (* 37 *) | Unused_extension of string * bool * constructor_usage_warning (* 38 *) | Unused_rec_flag (* 39 *) - | Name_out_of_scope of string * string list * bool (* 40 *) + | Name_out_of_scope of string * name_out_of_scope_warning (* 40 *) | Ambiguous_name of string list * string list * bool * string (* 41 *) | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) @@ -112,7 +116,7 @@ type t = | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) - | Unused_field of string * field_usage_warning (* 69 *) + | Unused_field of string * string * field_usage_warning (* 69 *) | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) @@ -155,7 +159,7 @@ let number = function | Ignored_extra_argument -> 20 | Nonreturning_statement -> 21 | Preprocessor _ -> 22 - | Useless_record_with -> 23 + | Useless_record_with _ -> 23 | Bad_module_name _ -> 24 | All_clauses_guarded -> 8 (* used to be 25 *) | Unused_var _ -> 26 @@ -955,8 +959,8 @@ let message = function | Partial_match s -> "this pattern-matching is not exhaustive.\n\ Here is an example of a case that is not matched:\n" ^ s - | Missing_record_field_pattern s -> - "the following labels are not bound in this record pattern:\n" ^ s ^ + | Missing_record_field_pattern (record_form, s) -> + "the following labels are not bound in this " ^ record_form ^ " pattern:\n" ^ s ^ "\nEither bind these labels explicitly or add '; _' to the pattern." | Non_unit_statement -> "this expression should have type unit." @@ -985,8 +989,8 @@ let message = function | Nonreturning_statement -> "this statement never returns (or has an unsound type.)" | Preprocessor s -> s - | Useless_record_with -> - "all the fields are explicitly listed in this record:\n\ + | Useless_record_with s -> + "all the fields are explicitly listed in this " ^ s ^ ":\n\ the 'with' clause is useless." | Bad_module_name (modname) -> "bad source file name: \"" ^ modname ^ "\" is not a valid module name." @@ -1034,15 +1038,14 @@ let message = function end | Unused_rec_flag -> "unused rec flag." - | Name_out_of_scope (ty, [nm], false) -> + | Name_out_of_scope (ty, Name nm) -> nm ^ " was selected from type " ^ ty ^ ".\nIt is not visible in the current scope, and will not \n\ be selected if the type becomes unknown." - | Name_out_of_scope (_, _, false) -> assert false - | Name_out_of_scope (ty, slist, true) -> - "this record of type "^ ty ^" contains fields that are \n\ + | Name_out_of_scope (ty, Fields { record_form ; fields }) -> + "this " ^ record_form ^ " of type "^ ty ^" contains fields that are \n\ not visible in the current scope: " - ^ String.concat " " slist ^ ".\n\ + ^ String.concat " " fields ^ ".\n\ They will not be selected if the type becomes unknown." | Ambiguous_name ([s], tl, false, expansion) -> s ^ " belongs to several types: " ^ String.concat " " tl ^ @@ -1165,13 +1168,13 @@ let message = function "This pattern depends on mutable state.\n\ It prevents the remaining arguments from being uncurried, which will \ cause additional closure allocations." - | Unused_field (s, Unused) -> "unused record field " ^ s ^ "." - | Unused_field (s, Not_read) -> - "record field " ^ s ^ + | Unused_field (record_form, s, Unused) -> "unused " ^ record_form ^ " field " ^ s ^ "." + | Unused_field (record_form, s, Not_read) -> + record_form ^ " field " ^ s ^ " is never read.\n\ (However, this field is used to build or mutate values.)" - | Unused_field (s, Not_mutated) -> - "mutable record field " ^ s ^ + | Unused_field (record_form, s, Not_mutated) -> + "mutable " ^ record_form ^ " field " ^ s ^ " is never mutated." | Missing_mli -> "Cannot find interface file." diff --git a/utils/warnings.mli b/utils/warnings.mli index a9cd239ec2f..e1b44eb79f8 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -44,6 +44,10 @@ type upstream_compat_warning = | Non_value_sort of string | Unboxed_attribute of string +type name_out_of_scope_warning = + | Name of string + | Fields of { record_form : string ; fields : string list } + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -53,7 +57,7 @@ type t = | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) - | Missing_record_field_pattern of string (* 9 *) + | Missing_record_field_pattern of string * string (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) | Redundant_subpat (* 12 *) @@ -67,7 +71,7 @@ type t = | Ignored_extra_argument (* 20 *) | Nonreturning_statement (* 21 *) | Preprocessor of string (* 22 *) - | Useless_record_with (* 23 *) + | Useless_record_with of string (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 8, used to be 25 *) | Unused_var of string (* 26 *) @@ -87,7 +91,7 @@ type t = | Unused_constructor of string * constructor_usage_warning (* 37 *) | Unused_extension of string * bool * constructor_usage_warning (* 38 *) | Unused_rec_flag (* 39 *) - | Name_out_of_scope of string * string list * bool (* 40 *) + | Name_out_of_scope of string * name_out_of_scope_warning (* 40 *) | Ambiguous_name of string list * string list * bool * string (* 41 *) | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) @@ -116,7 +120,7 @@ type t = | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) - | Unused_field of string * field_usage_warning (* 69 *) + | Unused_field of string * string * field_usage_warning (* 69 *) | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) From bbff92b63e4cc115ca3e346f7e52bf65aeb2f1cb Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 26 Nov 2024 19:48:48 -0500 Subject: [PATCH 02/19] Respond to ccasin's 2024-11-27 PR comments --- parsing/parser.mly | 4 - .../tests/parsetree/source_jane_street.ml | 2 + .../typing-layouts-unboxed-records/basics.ml | 343 +++++++---- .../basics_alpha.ml | 43 +- .../basics_from_typing_atat_unboxed.ml | 27 +- .../basics_from_unboxed_tuples_tests.ml | 34 +- .../typing-layouts-unboxed-records/dlambda.ml | 128 ----- .../typing-layouts-unboxed-records/letrec.ml | 5 +- ...ule_dot_unboxed_record.compilers.reference | 4 + .../parsing_module_dot_unboxed_record.ml | 17 + .../recursive.ml | 40 +- .../separability.ml | 45 ++ .../typing-warnings.ml | 5 +- .../typing_misc_unboxed_records.ml | 27 +- .../unboxed_records.ml | 540 +++++++++++++++++- .../unboxed_records.reference | 106 +++- ...boxed_records_disabled.compilers.reference | 6 +- ...unboxed_records_stable.compilers.reference | 6 +- .../typing-layouts-unboxed-records/unused.ml | 37 +- typing/env.ml | 15 + typing/typecore.ml | 53 +- typing/typecore.mli | 2 + typing/typedecl.ml | 24 +- typing/typedecl.mli | 1 + 24 files changed, 1113 insertions(+), 401 deletions(-) delete mode 100644 testsuite/tests/typing-layouts-unboxed-records/dlambda.ml create mode 100644 testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference create mode 100644 testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml diff --git a/parsing/parser.mly b/parsing/parser.mly index 24a1ea39339..6976ac419e4 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -3079,10 +3079,6 @@ comprehension_clause: { let (exten, fields) = $4 in Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) (Pexp_record(fields, exten))) } - | od=open_dot_declaration DOT HASHLBRACE record_expr_content RBRACE - { let (exten, fields) = $4 in - Pexp_open(od, mkexp ~loc:($startpos($3), $endpos) - (Pexp_record_unboxed_product(fields, exten))) } | mod_longident DOT LBRACE record_expr_content error { unclosed "{" $loc($3) "}" $loc($5) } | array_exprs(LBRACKETBAR, BARRBRACKET) diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index cec9dab8715..5c232c039af 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -850,10 +850,12 @@ result: 7 type 'a with_idx : value & immediate = #{ data : 'a ; i : int } let idx #{ data = _ ; i } = i +let #{ data = payload; _ } = #{ data = "payload" ; i = 0 } let inc r = #{ r with i = r.#i + 1 } [%%expect{| type 'a with_idx = #{ data : 'a; i : int; } val idx : 'a with_idx -> int @@ global many = +val payload : string @@ global many = "payload" val inc : 'a with_idx -> 'a with_idx @@ global many = |}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index de091ba0be0..7c12d0694f9 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -12,32 +12,6 @@ open Stdlib_upstream_compatible (**************************************************************************) (* Basic examples: construction, functional updates, projection, matching *) -module With_index : sig - type 'a t : value & immediate - type 'a t_boxed : value - - val unbox_t : 'a t_boxed -> 'a t - val box_t : 'a t -> 'a t_boxed - val inc : 'a t -> 'a t -end = struct - type 'a t = #{ data : 'a ; i : int } - type 'a t_boxed = { data : 'a ; i : int } - - let unbox_t { data ; i = idx } = #{ data ; i = idx } - let box_t #{ data ; i = idx } = { data ; i = idx } - let inc t = #{ t with i = t.#i + 1 } -end -[%%expect{| -module With_index : - sig - type 'a t : value & immediate - type 'a t_boxed - val unbox_t : 'a t_boxed -> 'a t - val box_t : 'a t -> 'a t_boxed - val inc : 'a t -> 'a t - end -|}] - (* We can change the type of an unboxed record with a functional update. *) type ('a : value & value) t = #{ x : 'a ; y : string } @@ -57,7 +31,6 @@ type t = #{ i : int; j : int; } val add : t -> int = |}] - (* Unboxed records are not subject to the mixed-block restriction *) type t = #{ f : float# ; i : int } @@ -94,8 +67,27 @@ Error: Types of top-level module bindings must have layout "value", but the type of "disallowed" has layout "float64 & value". |}] +;; +#{ f = #3.14; i = 0};; +[%%expect{| +Line 1, characters 0-20: +1 | #{ f = #3.14; i = 0};; + ^^^^^^^^^^^^^^^^^^^^ +Error: Types of unnamed expressions must have layout value when using + the toplevel, but this expression has layout "float64 & value". +|}] + (* However, we can have a top-level unboxed record if its kind is value *) +type m_record = #{ i1 : int } +module M = struct + let x = #{ i1 = 1 } +end +[%%expect{| +type m_record = #{ i1 : int; } +module M : sig val x : m_record end +|}] + type wrap_int = #{ i : int } type wrap_wrap_int = #{ wi : wrap_int} let w5 = #{ i = 5 } @@ -114,6 +106,12 @@ type t = #{ s : string; } val s : t = #{s = "hi"} |}] +;; +#{ i1 = 1 };; +[%%expect{| +- : m_record = #{i1 = 1} +|}] + (* Accessing inner products *) type t = #{ is: #(int * int) } @@ -126,64 +124,19 @@ type t = #{ is : #(int * int); } val add : t -> int = |}] -(******************************) -(* Basic unboxed record types *) - -type t1 = #{ i1 : int } -type t2 = #{ f2: float# ; i2: int ; s2 : string} -type t3 = #{ f3: float# } -[%%expect{| -type t1 = #{ i1 : int; } -type t2 = #{ f2 : float#; i2 : int; s2 : string; } -type t3 = #{ f3 : float#; } -|}] - -(* You can put unboxed and normal products inside unboxed products *) - -type t4 = #(string * t2) -type t5 = #{ r5 : t1 ; r5_ : t2 ; s5 : string} -[%%expect{| -type t4 = #(string * t2) -type t5 = #{ r5 : t1; r5_ : t2; s5 : string; } -|}] - -(* But you can't put unboxed products into normal tuples and records (yet) *) - -type bad = { r : t2 } -[%%expect{| -Line 1, characters 0-21: -1 | type bad = { r : t2 } - ^^^^^^^^^^^^^^^^^^^^^ -Error: Type "t2" has layout "float64 & value & value". - Records may not yet contain types of this layout. -|}] +(* Mutable fields are not allowed *) -type bad = t2 * t2 +type mut = #{ mutable i : int } [%%expect{| -Line 1, characters 11-13: -1 | type bad = t2 * t2 - ^^ -Error: Tuple element types must have layout value. - The layout of "t2" is float64 & value & value - because of the definition of t2 at line 2, characters 0-48. - But the layout of "t2" must be a sublayout of value - because it's the type of a tuple element. +Line 1, characters 14-29: +1 | type mut = #{ mutable i : int } + ^^^^^^^^^^^^^^^ +Error: Unboxed records labels cannot be mutable |}] (*********************************) (* Parameterized unboxed records *) -type 'a t = #{ x : 'a } -let convert (r : int t) : int t = - { r with x = string } -[%%expect{| -type 'a t = #{ x : 'a; } -Line 3, characters 2-23: -3 | { r with x = string } - ^^^^^^^^^^^^^^^^^^^^^ -Error: This expression should not be a record, the expected type is "int t" -|}] - (* Checks of constrain_type_jkind *) type 'a r = #{ i: 'a } @@ -231,29 +184,90 @@ type ('a : float64, 'b : immediate) t = #{ x : string; y : 'a; z : 'b } type ('a : float64, 'b : immediate) t = #{ x : string; y : 'a; z : 'b; } |}];; -(***************************************************) -(* Simple kind annotations on unboxed record types *) +type ('a : value & float64 & value) t1 +type ('a : value) t2 +[%%expect{| +type ('a : value & float64 & value) t1 +type 'a t2 +|}] + +type s = r t1 +and r = #{ x : int; y : float#; z : s t2 } +[%%expect{| +type s = r t1 +and r = #{ x : int; y : float#; z : s t2; } +|}] -type t1 : immediate = #{ i1 : int } -type t2 : float64 & immediate & value = #{ f2: float# ; i2: int ; s2 : string} -type t3 : float64 = #{ f3: float# } -type t5 : immediate & (float64 & immediate & value) & value = #{ r5 : t1 ; r5_ : t2 ; s5 : string} +type s = r_bad t1 +and r_bad = #{ y : float#; z : s t2 } [%%expect{| -type t1 = #{ i1 : int; } -type t2 = #{ f2 : float#; i2 : int; s2 : string; } -type t3 = #{ f3 : float#; } -type t5 = #{ r5 : t1; r5_ : t2; s5 : string; } +Line 2, characters 0-37: +2 | and r_bad = #{ y : float#; z : s t2 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of r_bad is any & any + because it is an unboxed record. + But the layout of r_bad must be a sublayout of value & float64 & value + because of the definition of t1 at line 1, characters 0-38. |}] -type t5_bad : immediate & float64 & immediate & value & value = #{ r5 : t1 ; r5_ : t2 ; s5 : string} +(* CR layouts v7.2: the following should typecheck. *) +type 'a t = #{ a : 'a ; a' : 'a } constraint 'a = r +and r = #{ i : int ; f : float# } [%%expect{| -Line 1, characters 0-100: -1 | type t5_bad : immediate & float64 & immediate & value & value = #{ r5 : t1 ; r5_ : t2 ; s5 : string} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type "t5_bad" is value & (float64 & value & value) & value +Line 2, characters 0-33: +2 | and r = #{ i : int ; f : float# } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of r is any & any because it is an unboxed record. - But the layout of type "t5_bad" must be a sublayout of value & float64 & value & value & value - because of the annotation on the declaration of the type t5_bad. + But the layout of r must be representable + because it instantiates an unannotated type parameter of t. +|}] + +(*******************) +(* Types with [as] *) + +let f (x : < m: 'a. ([< `Foo of int & float] as 'a) -> unit>) + : < m: 'a. ([< `Foo of int & float] as 'a) -> unit> = x;; + +type t = #{ x : 'a. ([< `Foo of int & float ] as 'a) -> unit };; +let f t = #{ x = t.#x };; +[%%expect{| +val f : + < m : 'a. ([< `Foo of int & float ] as 'a) -> unit > -> + < m : 'b. ([< `Foo of int & float ] as 'b) -> unit > = +type t = #{ x : 'a. ([< `Foo of int & float ] as 'a) -> unit; } +val f : t -> t = +|}] + +module Bad : sig + type t = #{ i : int ; a: ( as 'a) } +end = struct + type t = #{ i : int ; a: ( as 'a) } +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ i : int ; a: ( as 'a) } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = #{ i : int; a : < x : 'a * 'a > as 'a; } end + is not included in + sig type t = #{ i : int; a : < x : 'a > as 'a; } end + Type declarations do not match: + type t = #{ i : int; a : < x : 'a * 'a > as 'a; } + is not included in + type t = #{ i : int; a : < x : 'a > as 'a; } + Fields do not match: + "a : < x : 'a * 'a > as 'a;" + is not the same as: + "a : < x : 'a > as 'a;" + The type "< x : 'a * 'a > as 'a" is not equal to the type + "< x : 'b > as 'b" + The method "x" has type "< x : 'c > * < x : 'c > as 'c", + but the expected method type was "< x : 'b > as 'b" |}] (**********************) @@ -323,17 +337,15 @@ module M : sig type t : float64 & value end module M : sig type t - type tup = t * t end = struct type t = #{ s : string } - type tup = t * t end [%%expect{| -module M : sig type t type tup = t * t end +module M : sig type t end |}] -(****************************) -(* Types with external mode *) +(*************************************) +(* Types that mode cross externality *) type ('a : value mod external_) t = #{ x : float#; y : 'a } type ('a : immediate) t = #{ x : float#; y : 'a } @@ -403,28 +415,37 @@ and ('a : float64, 'b : immediate, 'ptr) t = #{ } |}];; -(* Fields can be mutable, but we can't set them yet *) - -type r = #{ mutable i : int } - -let f = #{ i = 1 } - (* We don't yet have syntax for setting an unboxed record field. However, the below, using a boxed set field, will never work. *) -let () = f.i <- 2 +type r = #{ i : int } +let f = #{ i = 1 } [%%expect{| -type r = #{ mutable i : int; } +type r = #{ i : int; } val f : r = #{i = 1} -Line 8, characters 9-10: -8 | let () = f.i <- 2 +|}] + +let () = f.i <- 2 +[%%expect{| +Line 1, characters 9-10: +1 | let () = f.i <- 2 ^ -Error: This expression has type "r" which is not a record type. +Error: This expression has type "r", + which is an unboxed record rather than a boxed one. |}] (********************************) (* Private unboxed record types *) +module M : sig + type t = private #{ x : int; y : bool } +end = struct + type t = #{ x : int; y : bool } +end;; +[%%expect{| +module M : sig type t = private #{ x : int; y : bool; } end +|}] + module M : sig type t = #{ x : int; y : bool } end = struct @@ -491,3 +512,103 @@ Error: Signature mismatch: type t = #{ x : int; y : bool; } A private unboxed record constructor would be revealed. |}];; + +(*****************************************************) +(* Special-cased errors for boxed/unboxed mismatches *) + +type t_u = #{ u : int } +type t = { b : int } +[%%expect{| +type t_u = #{ u : int; } +type t = { b : int; } +|}] + +let f () : t_u = { b = 1 } +[%%expect{| +Line 1, characters 17-26: +1 | let f () : t_u = { b = 1 } + ^^^^^^^^^ +Error: This boxed record expression should be unboxed instead, + the expected type is "t_u" +|}] + +let f () : t = #{ u = 2 } +[%%expect{| +Line 1, characters 15-25: +1 | let f () : t = #{ u = 2 } + ^^^^^^^^^^ +Error: This unboxed record expression should be boxed instead, + the expected type is "t" +|}] + +let ({ b } : t_u) = assert false +[%%expect{| +Line 1, characters 5-10: +1 | let ({ b } : t_u) = assert false + ^^^^^ +Error: This boxed record pattern should be unboxed instead, + the expected type is "t_u" +|}] + +let (#{ u } : t) = assert false +[%%expect{| +Line 1, characters 5-11: +1 | let (#{ u } : t) = assert false + ^^^^^^ +Error: This unboxed record pattern should be boxed instead, + the expected type is "t" +|}] + +let bad_get (t_u : t_u) = t_u.u +[%%expect{| +Line 1, characters 26-29: +1 | let bad_get (t_u : t_u) = t_u.u + ^^^ +Error: This expression has type "t_u", + which is an unboxed record rather than a boxed one. +|}] + +let bad_get (t : t) = t.#b +[%%expect{| +Line 1, characters 22-23: +1 | let bad_get (t : t) = t.#b + ^ +Error: This expression has type "t", + which is a boxed record rather than an unboxed one. +|}] + +let _ = #{ b = 5 } +[%%expect{| +Line 1, characters 11-12: +1 | let _ = #{ b = 5 } + ^ +Error: Unbound unboxed record field "b" +Hint: There is a boxed record field with this name. +|}] + +let _ = { u = 5 } +[%%expect{| +Line 1, characters 10-11: +1 | let _ = { u = 5 } + ^ +Error: Unbound record field "u" +Hint: There is an unboxed record field with this name. +|}] + +let bad_get t_u = t_u.u +[%%expect{| +Line 1, characters 22-23: +1 | let bad_get t_u = t_u.u + ^ +Error: Unbound record field "u" +Hint: There is an unboxed record field with this name. +|}] + +let bad_get t = t.#b +[%%expect{| +Line 1, characters 19-20: +1 | let bad_get t = t.#b + ^ +Error: Unbound unboxed record field "b" +Hint: There is a boxed record field with this name. +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml index 5f71247652d..a021db9745b 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml @@ -7,7 +7,44 @@ } *) -(* This test is adapted from [testsuite/tests/typing-layouts-products/basics_alpha.ml] *) +(*****************************) +(* Unboxed records with void *) + +type t_void : void + +type ('a : void) t = #{ x : 'a ; y : t_void } +[%%expect{| +type t_void : void +type ('a : void) t = #{ x : 'a; y : t_void; } +|}] + +type t = { x : t_void } [@@unboxed] +[%%expect{| +type t = { x : t_void; } [@@unboxed] +|}] + +type bad : void = #{ bad : bad } +[%%expect{| +type bad = #{ bad : bad; } +|}] + +type ('a : void) bad = #{ bad : 'a bad ; u : 'a} +[%%expect{| +Line 1, characters 0-49: +1 | type ('a : void) bad = #{ bad : 'a bad ; u : 'a} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of 'a bad is any & any + because it is an unboxed record. + But the layout of 'a bad must be representable + because it is the type of record field bad. +|}] + +(***************************************************************************************) +(* The below is adapted from [testsuite/tests/typing-layouts-products/basics_alpha.ml]. + + CR layouts v7.2: once unboxed records are in stable, fold this test back into the + original or move it to [typing-layouts-products]. *) (* [t3] is allowed for unboxed tuples, and disallowed for (un)boxed records *) type t1 : any mod non_null @@ -26,6 +63,9 @@ Error: Unboxed record element types must have a representable layout. because it is the type of record field t1. |}] +(* CR layouts v7.2: once [any] is allowed in unboxed record declarations, check + that [non_null] behaves correctly in the following tests. *) + type t1 : any mod non_null type t2 : value type t3 : any & value mod non_null = #{ t1 : t1 ; t2 : t2};; @@ -122,4 +162,3 @@ Error: Unboxed record element types must have a representable layout. But the layout of t1 must be representable because it is the type of record field t1. |}] - diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml index dc701d9cf85..0edb668fa58 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml @@ -3,7 +3,10 @@ expect; *) (* This test is adapted from - [testsuite/tests/typing-unboxed-types/test.ml] *) + [testsuite/tests/typing-unboxed-types/test.ml]. + + CR layouts v7.2: once unboxed records are in stable, fold this test back into the + original or move it to [typing-layouts-products]. *) (* Check the unboxing *) @@ -43,6 +46,28 @@ Error: Signature mismatch: The first is an unboxed record, but the second is a record. |}];; +module M : sig + type t = #{ a : string } +end = struct + type t = { a : string } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = { a : string } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = { a : string; } end + is not included in + sig type t = #{ a : string; } end + Type declarations do not match: + type t = { a : string; } + is not included in + type t = #{ a : string; } + The first is a record, but the second is an unboxed record. +|}] + (* Check interference with representation of float arrays. *) type t11 = #{ f : float };; [%%expect{| diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml index 0e93f3582f4..98c0f4a39aa 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -8,7 +8,10 @@ *) (* These tests are adapted from the tuple tests in - [testsuite/tests/typing-layouts-products/basics.ml] *) + [testsuite/tests/typing-layouts-products/basics.ml]. + + CR layouts v7.2: once unboxed records are in stable, fold this test back into the + original or move it to [typing-layouts-products]. *) open Stdlib_upstream_compatible @@ -49,10 +52,10 @@ Error: Tuple element types must have layout value. (* Test 2: Simple kind annotations on types *) type t1 : float64 & value = #{ f : float#; b : bool } -type t2 : value & (float64 & value) = #(string option * t1) +type t2 : value & (float64 & value) = #{ so : string option ; t1 : t1 } [%%expect{| type t1 = #{ f : float#; b : bool; } -type t2 = #(string option * t1) +type t2 = #{ so : string option; t1 : t1; } |}] type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } @@ -251,9 +254,6 @@ module F : end |}] -[%%expect{| -|}] - (***************************************************) (* Test 4: Unboxed products don't go in structures *) @@ -301,12 +301,12 @@ Error: Tuple element types must have layout value. |}] type record = #{ i : int; i2 : int } -let record_term = ("hi", #{ i = 1; i2 = 2 }) +let tuple_term = ("hi", #{ i = 1; i2 = 2 }) [%%expect{| type record = #{ i : int; i2 : int; } -Line 2, characters 25-43: -2 | let record_term = ("hi", #{ i = 1; i2 = 2 }) - ^^^^^^^^^^^^^^^^^^ +Line 2, characters 24-42: +2 | let tuple_term = ("hi", #{ i = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^ Error: This expression has type "record" but an expression was expected of type "('a : value)" The layout of record is value & value @@ -377,16 +377,6 @@ Error: Types of top-level module bindings must have layout "value", but the type of "x" has layout "value & value". |}] -(* This one is okay, because the record has layout vlue *) -type m_record = #{ i1 : int } -module M = struct - let x = #{ i1 = 1 } -end -[%%expect{| -type m_record = #{ i1 : int; } -module M : sig val x : m_record end -|}] - type object_inner = #{ i : int; b : bool } type object_type = < x : object_inner > [%%expect{| @@ -477,6 +467,8 @@ class class_with_urecord_manipulating_method : (* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and boxed records, in the same way as below. + + CR layouts v7.2: These should typecheck for all record forms. *) module type S_coherence_deep = sig type t1 : any @@ -509,7 +501,7 @@ Error: [@@unboxed] record element types must have a representable layout. |}] (***********************************************) -(* Test 7: modal kinds for unboxed tuple types *) +(* Test 7: modal kinds for unboxed record types *) type local_cross1 = #{ i1 : int; i2 : int } let f_external_urecord_mode_crosses_local_1 diff --git a/testsuite/tests/typing-layouts-unboxed-records/dlambda.ml b/testsuite/tests/typing-layouts-unboxed-records/dlambda.ml deleted file mode 100644 index ce0332a827b..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/dlambda.ml +++ /dev/null @@ -1,128 +0,0 @@ -(* TEST - flambda2; - include stdlib_upstream_compatible; - flags = "-extension layouts_beta -dlambda"; - { - expect; - } -*) - -(* We implement the same functionality with pattern matching, projection, - and check the lambda for correctness against unboxed records. *) - -type t = #{ i : int ; j : int } -let add (#{ i ; j = _} as r) = i + r.#j -[%%expect{| -0 -type t = #{ i : int; j : int; } -(let - (add/280 = - (function {nlocal = 0} r/283#(*, *) : int - (+ (unboxed_product_field 0 #(*, *) r/283) - (unboxed_product_field 1 #([int], [int]) r/283)))) - (apply (field_imm 1 (global Toploop!)) "add" add/280)) -val add : t -> int = -|}] - -let add2 x y = add x + add y -[%%expect{| -(let - (add/280 = (apply (field_imm 0 (global Toploop!)) "add") - add2/285 = - (function {nlocal = 0} x/287#(*, *) y/288#(*, *) : int - (+ (apply add/280 x/287) (apply add/280 y/288)))) - (apply (field_imm 1 (global Toploop!)) "add2" add2/285)) -val add2 : t -> t -> int = -|}] - - -let add #( i, j ) = i + j -[%%expect{| -(let - (add/289 = - (function {nlocal = 0} param/292#(*, *) : int - (+ (unboxed_product_field 0 #(*, *) param/292) - (unboxed_product_field 1 #(*, *) param/292)))) - (apply (field_imm 1 (global Toploop!)) "add" add/289)) -val add : #(int * int) -> int = -|}] -let add2 x y = add x + add y -[%%expect{| -(let - (add/289 = (apply (field_imm 0 (global Toploop!)) "add") - add2/293 = - (function {nlocal = 0} x/294#(*, *) y/295#(*, *) : int - (+ (apply add/289 x/294) (apply add/289 y/295)))) - (apply (field_imm 1 (global Toploop!)) "add2" add2/293)) -val add2 : #(int * int) -> #(int * int) -> int = -|}] - -let copy_i_to_j #{ i ; j } = #{ i; j = i } -[%%expect{| -(let - (copy_i_to_j/296 = - (function {nlocal = 0} param/300#(*, *) - : #(*, *)(let (i/298 =a (unboxed_product_field 0 #(*, *) param/300)) - (make_unboxed_product #([int], [int]) i/298 i/298)))) - (apply (field_imm 1 (global Toploop!)) "copy_i_to_j" copy_i_to_j/296)) -val copy_i_to_j : t -> t = -|}] - -(* this one is slightly different than the above and below - it - calls unboxed_product_field twice rather than let-binding, but - this should be inconsequential*) -let copy_i_to_j r = #{ r with j = r.#i } -[%%expect{| -(let - (copy_i_to_j/302 = - (function {nlocal = 0} r/303#(*, *) - : #(*, *)(make_unboxed_product #([int], [int]) - (unboxed_product_field 0 #([int], [int]) r/303) - (unboxed_product_field 0 #([int], [int]) r/303)))) - (apply (field_imm 1 (global Toploop!)) "copy_i_to_j" copy_i_to_j/302)) -val copy_i_to_j : t -> t = -|}] - -let copy_i_to_j (#(i, _j) : #(int * int)) = #(i, i) -[%%expect{| -(let - (copy_i_to_j/305 = - (function {nlocal = 0} param/308#(*, *) - : #(*, *)(let (i/306 =a (unboxed_product_field 0 #(*, *) param/308)) - (make_unboxed_product #([int], [int]) i/306 i/306)))) - (apply (field_imm 1 (global Toploop!)) "copy_i_to_j" copy_i_to_j/305)) -val copy_i_to_j : #(int * int) -> #(int * int) = -|}] - -(* compare against @@unboxed records *) -type t = #{ s : string } - -let t = #{ s = "hi" } -[%%expect{| -0 -type t = #{ s : string; } -(let (t/311 = "hi") (apply (field_imm 1 (global Toploop!)) "t" t/311)) -val t : t = #{s = "hi"} -|}] - -let s = #{ s = "hi" }.#s -[%%expect{| -(let (s/313 = "hi") (apply (field_imm 1 (global Toploop!)) "s" s/313)) -val s : string = "hi" -|}] - -type t = { s : string } [@@unboxed] -let t = { s = "hi" } -[%%expect{| -0 -type t = { s : string; } [@@unboxed] -(let (t/317 = "hi") (apply (field_imm 1 (global Toploop!)) "t" t/317)) -val t : t = {s = "hi"} -|}] - -let s = { s = "hi"}.s -[%%expect{| -(let (s/319 = "hi") (apply (field_imm 1 (global Toploop!)) "s" s/319)) -val s : string = "hi" -|}] - diff --git a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml index 0cd2ba86719..1068fb85d72 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml @@ -34,7 +34,10 @@ let rec t = { bx = #{ ubx = t } } val t : bx = {bx = } |}] -(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml] *) +(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml]. + + CR layouts v7.2: once unboxed records are in stable, fold this test back into the + original or move it to [typing-layouts-products]. *) type t = #{x: int64} let rec x = #{x = y} and y = 3L;; diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference new file mode 100644 index 00000000000..11f6958ebe9 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_module_dot_unboxed_record.ml", line 15, characters 11-12: +15 | let t = M.#{ i = 1 } + ^ +Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml b/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml new file mode 100644 index 00000000000..0309a84c82a --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml @@ -0,0 +1,17 @@ +(* TEST + flags = "-extension-universe beta"; + setup-ocamlc.byte-build-env; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + check-ocamlc.byte-output; +*) + +(* CR layouts v7.2: These should parse. *) + +module M = struct + type t = #{ i : int } +end + +let t = M.#{ i = 1 } + +let M.#{ i } = #{ i = 1 } diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml index 469f63047e0..f6a0933dbb8 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; + flags = "-extension layouts_beta"; { expect; } @@ -33,6 +33,9 @@ type t : value = #{ t : t } type t = #{ t : t; } |}] +(* CR layouts v7.2: Once we support unboxed records with elements of kind [any], and + detect bad recursive unboxed records with an occurs check, this error should improve. +*) type bad = #{ bad : bad ; i : int} [%%expect{| Line 1, characters 0-34: @@ -114,41 +117,6 @@ type 'a bad = { bad : 'a bad ; u : 'a} type 'a bad = { bad : 'a bad; u : 'a; } |}] - -(***************************************) -(* Recursive unboxed records with void *) - -type t_void : void - -type ('a : void) t = #{ x : 'a ; y : t_void } -[%%expect{| -type t_void : void -type ('a : void) t = #{ x : 'a; y : t_void; } -|}] - -type t = { x : t_void } [@@unboxed] -[%%expect{| -type t = { x : t_void; } [@@unboxed] -|}] - -type bad : void = #{ bad : bad } -[%%expect{| -type bad = #{ bad : bad; } -|}] - -type ('a : void) bad = #{ bad : 'a bad ; u : 'a} -[%%expect{| -Line 1, characters 0-49: -1 | type ('a : void) bad = #{ bad : 'a bad ; u : 'a} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of 'a bad is any & any - because it is an unboxed record. - But the layout of 'a bad must be representable - because it is the type of record field bad. -|}] - - (****************************) (* A particularly bad error *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/separability.ml b/testsuite/tests/typing-layouts-unboxed-records/separability.ml index a91205e9579..23a4edc394a 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/separability.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/separability.ml @@ -14,6 +14,13 @@ type 'a r = #{ a : 'a; } and 'a ok = F : 'a r -> 'a ok [@@unboxed] |}] +type 'a r = #{ a : 'a } +and 'a ok = F : { x : 'a r } -> 'a ok [@@unboxed] +[%%expect{| +type 'a r = #{ a : 'a; } +and 'a ok = F : { x : 'a r; } -> 'a ok [@@unboxed] +|}] + type 'a r = #{ a : 'a } type bad = F : 'a r -> bad [@@unboxed] [%%expect{| @@ -27,6 +34,19 @@ Error: This type cannot be unboxed because You should annotate it with "[@@ocaml.boxed]". |}] +type 'a r = #{ a : 'a } +type bad = F : { x : 'a r } -> bad [@@unboxed] +[%%expect{| +type 'a r = #{ a : 'a; } +Line 2, characters 0-46: +2 | type bad = F : { x : 'a r } -> bad [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This type cannot be unboxed because + it might contain both float and non-float values, + depending on the instantiation of the existential variable "'a". + You should annotate it with "[@@ocaml.boxed]". +|}] + type 'a r = #{ a : 'a } and 'a r2 = #{ a : 'a r } and bad = F : 'a r2 -> bad [@@unboxed] @@ -40,6 +60,18 @@ Error: This type cannot be unboxed because You should annotate it with "[@@ocaml.boxed]". |}] +type 'a r = #{ a : 'a } +and bad = F : { x : 'a r } -> bad [@@unboxed] +[%%expect{| +Line 2, characters 0-45: +2 | and bad = F : { x : 'a r } -> bad [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This type cannot be unboxed because + it might contain both float and non-float values, + depending on the instantiation of the existential variable "'a". + You should annotate it with "[@@ocaml.boxed]". +|}] + (* CR layouts v12: Once we allow products containing void in unboxed GADTs, we'll have to make sure the below fails separability checking: *) type t_void : void @@ -56,3 +88,16 @@ Error: because it's the type of a constructor field. |}] +type t_void : void +and 'a r = #{ a : 'a ; v : t_void } +and bad = F : { x : 'a r } -> bad [@@unboxed] +[%%expect{| +Line 2, characters 0-35: +2 | and 'a r = #{ a : 'a ; v : t_void } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of 'a r is any & any + because it is an unboxed record. + But the layout of 'a r must be a sublayout of value + because it is the type of record field x. +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml index 5ac1621638c..19431efc9fb 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml @@ -31,7 +31,10 @@ external ignore_product : ('a : value & value). 'a -> unit = "%ignore" external ignore_product : ('a : value & value). 'a -> unit = "%ignore" |}] -(* This below tests are adapted from [testsuite/tests/typing-warnings/records.ml] *) +(* This below tests are adapted from [testsuite/tests/typing-warnings/records.ml]. + + CR layouts v7.2: once unboxed records are in stable, fold this test back into the + original or move it to [typing-layouts-products]. *) (* Use type information *) module M1 = struct diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml index e308c61471c..53097b2df98 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml @@ -1,5 +1,5 @@ (* TEST - flags = "-extension layouts_alpha"; + flags = "-extension layouts_beta"; { expect; } @@ -39,10 +39,10 @@ Error: The unboxed record field "contents" belongs to the type "'a ref_u" |}];; (* private types *) -type u = private #{mutable u:int};; +type u = private #{u:int};; #{u=3};; [%%expect{| -type u = private #{ mutable u : int; } +type u = private #{ u : int; } Line 2, characters 0-6: 2 | #{u=3};; ^^^^^^ @@ -133,15 +133,12 @@ Error: This expression has type "bool" which is not a unboxed record type. type ('a, 'b) t = #{ fst : 'a; snd : 'b };; let with_fst r fst = #{ r with fst };; -with_fst #{ fst=""; snd="" } 2;; +let #{ fst; snd} = with_fst #{ fst=""; snd="" } 2;; [%%expect{| type ('a, 'b) t = #{ fst : 'a; snd : 'b; } val with_fst : ('a, 'b) t -> 'c -> ('c, 'b) t = -Line 3, characters 0-30: -3 | with_fst #{ fst=""; snd="" } 2;; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Types of unnamed expressions must have layout value when using - the toplevel, but this expression has layout "value & value". +val fst : int = 2 +val snd : string = "" |}];; (* PR#7695 *) @@ -208,18 +205,8 @@ Error: This variant or record definition does not match that of type |}] type d = #{ x:int; y : int } -type mut = d = #{x:int; mutable y:int} [%%expect{| type d = #{ x : int; y : int; } -Line 2, characters 0-38: -2 | type mut = d = #{x:int; mutable y:int} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This variant or record definition does not match that of type "d" - Fields do not match: - "y : int;" - is not the same as: - "mutable y : int;" - This is mutable and the original is not. |}] type missing = d = #{ x:int } @@ -253,7 +240,7 @@ Line 2, characters 0-44: 2 | type unboxed = mono = #{foo:int} [@@unboxed] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This type cannot be unboxed because - cannot use [@@unboxed] on unboxed record. + [@@unboxed] may not be used on unboxed records. |}] type perm = d = #{y:int; x:int} diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml index 1764b3a7a85..61eb15691f2 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml @@ -49,38 +49,456 @@ } *) -type t = #{ i : int ; j : int } -let add #{ i ; j } = i + j -let () = - let t = #{i = 2; j = 3} in - let res = add t in - Printf.printf "Test 1: %d\n" res +open Stdlib_upstream_compatible -let add2 x y = add x + add y -let () = - let t1 = #{i = 2; j = 3} in - let t2 = #{i = 20; j = 30} in - let res = add2 t1 t2 in - Printf.printf "Test 2: %d\n" res +type ints = #{ x : int ; y : int } + +let print_floatu prefix x = Printf.printf "%s: %.2f\n" prefix (Float_u.to_float x) +let print_float prefix x = Printf.printf "%s: %.2f\n" prefix x +let print_int prefix x = Printf.printf "%s: %d\n" prefix x +let print_ints prefix #{ x; y } = Printf.printf "%s: [%d %d]\n" prefix x y + +(********************************************************) +(* Test 1: Basic functions manipulating unboxed records *) + +type unboxed_float_int = #{ f : float# ; i : int } + +(* takes an unboxed record *) +let mult_float_by_int #{ f ; i } = Float_u.(mul f (of_int i)) + +(* returns a unboxed record *) +let div_mod m n = #{ x = m/n; y = m mod n } + +type cd = #{ c : int ; d : int } +type abcd = #{ a : int ; b : int ; cd : cd } + +type ghi = #{ g : int; h : int ; i : int } +type fghi = #{ f : int ; ghi : ghi } +type efghi = #{ e : int ; fghi : fghi } + +type add_some_stuff_res_inner = #{ res2 : int ; res3 : int } +type add_some_stuff_res = #{ res1 : int ; res23 : add_some_stuff_res_inner } + +(* take multiple nested unboxed records, returns an unboxed record *) +let add_some_stuff x y = + let #{ a ; b ; cd = #{ c; d }} = x in + let #{ e ; fghi = #{ f ; ghi = #{ g; h; i } } } = y in + #{ res1 = a+b+c; res23 = #{ res2 = d+e+f; res3 = g+h+i } } + +let test1 () = + let pi = #3.14 in + print_floatu "Test 1, twice pi inlined" + ((mult_float_by_int [@inlined]) #{ f = pi; i = 2 }); + print_floatu "Test 1, twice pi not inlined" + ((mult_float_by_int [@inlined never]) #{ f = pi; i = 2 }); + print_ints "Test 1, 14/3 inlined" ((div_mod [@inlined hint]) 14 3); + print_ints "Test 1, 14/3 not inlined" ((div_mod [@inlined never]) 14 3); + let #{ res1 ; res23 = #{ res2 ; res3 }} = + (add_some_stuff [@inlined]) + #{a=1; b=2; cd=#{c=3;d=4}} + #{e=5; fghi=#{f=6;ghi=#{g=7;h=8;i=9}}} + in + Printf.printf "Test 1, [6 15 24] inlined: [%d %d %d]\n" res1 res2 res3; + let #{ res1 ; res23 = #{ res2 ; res3 }} = + (add_some_stuff [@inlined never]) + #{a=1; b=2; cd=#{c=3;d=4}} + #{e=5; fghi=#{f=6;ghi=#{g=7;h=8;i=9}}} + in + Printf.printf "Test 1, [6 15 24] not inlined: [%d %d %d]\n" res1 res2 res3 + +let _ = test1 () + +(**********************************) +(* Test 2: higher-order functions *) + +type ff' = #{ f : float# ; f' : float } +type t = #{ i : int ; ff' : ff' } + +let[@inline never] add_t + #{ i = i1; ff' = #{ f = f1; f' = f1'}} + #{ i = i2; ff' = #{ f = f2; f' = f2'}} + = + #{ i = i1 + i2; ff' = #{ f = Float_u.add f1 f2; f' = f1' +. f2'}} + +let[@inline never] sub_t + #{ i = i1; ff' = #{ f = f1; f' = f1'}} + #{ i = i2; ff' = #{ f = f2; f' = f2'}} + = + #{ i = i1 - i2; ff' = #{ f = Float_u.sub f1 f2; f' = f1' -. f2'}} + +let[@inline never] twice f (x : t) = f (f x) + +let[@inline never] compose f g (x : t) = f (g x) + +let t_sum #{ i; ff' = #{ f ; f' }} = + ((Float.of_int i) +. (Float_u.to_float f +. f')) + +let print_t_sum prefix t = Printf.printf "%s: %.2f\n" prefix (t_sum t) + +let[@inline never] twice_on_pi f = + let pi = #{ i = 1; ff' = #{ f = #2.0; f' = 0.14 } } in + twice f pi + +let times_four = + twice (fun x -> add_t x x) + +let _ = + let pi = #{ i = 1; ff' = #{ f = #2.0; f' = 0.14 } } in + let one = #{ i = 0; ff' = #{ f = #1.0; f' = 0.0 } } in + let zero = #{ i = 0; ff' = #{ f = #0.0; f' = 0.0 } } in + + print_t_sum "Test 2, add pi twice" + (twice (fun x -> add_t x pi) zero); + print_t_sum "Test 2, add pi four times" + (twice (twice (fun x -> add_t x pi)) zero); + print_t_sum "Test 2, increment pi twice" + (twice_on_pi (fun x -> add_t one x)); + print_t_sum "Test 2, increment pi four times" + (twice_on_pi (twice (fun x -> add_t one x))); + print_t_sum "Test 2, e times four" + (times_four #{ i = 1; ff' = #{ f = #1.0 ; f' = 2.72 } }); + print_t_sum "Test 2, pi times sixteen" + (twice_on_pi times_four); + print_t_sum "Test 2, pi times sixteen again" + (compose times_four times_four pi); + print_t_sum "Test 2, pi minus four" + (let two = twice (fun x -> add_t x one) zero in + let add_two = add_t two in + let add_two_after = compose add_two in + let minus_four = + add_two_after (twice (fun x -> add_t x #{ i = -1; ff' = #{f = -#1.0; f' = -1.0 } })) + in + minus_four pi) + +(***************************************) +(* Test 3: unboxed records in closures *) + +type int_floatu = #{ i : int ; f : float# } +type floatarray_floatu = #{ fa : float array ; f : float# } + +(* [go]'s closure should have an unboxed record with an [int] (immediate), a [float#] + (float64) and a [float array] (value). *) +let[@inline never] f3 bounds steps_init () = + let[@inline never] rec go k = + let #{ i = n; f = m } = bounds in + let #{ fa = steps; f = init } = steps_init in + if k = n + then init + else begin + let acc = go (k + 1) in + steps.(k) <- Float_u.to_float acc; + Float_u.add m acc + end + in + go 0 + + +(* many args - odd args are floats, even args are unboxed records *) +let[@inline_never] f3_manyargs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 steps () = + let #{ x = start_k; y = end_k } = x0 in + let[@inline never] rec go k = + if k = end_k + then 0.0 + else begin + let #{ i = x2_1; ff' = #{ f = x2_2; f' = x2_3 } } = x2 in + let #{ i = x4_1; ff' = #{ f = x4_2; f' = x4_3 } } = x4 in + let #{ i = x6_1; ff' = #{ f = x6_2; f' = x6_3 } } = x6 in + let #{ i = x8_1; ff' = #{ f = x8_2; f' = x8_3 } } = x8 in + let sum = + Float.of_int x2_1 +. Float_u.to_float x2_2 +. x2_3 +. + Float.of_int x4_1 +. Float_u.to_float x4_2 +. x4_3 +. + Float.of_int x6_1 +. Float_u.to_float x6_2 +. x6_3 +. + Float.of_int x8_1 +. Float_u.to_float x8_2 +. x8_3 + in + let acc = go (k + 1) in + steps.(k) <- acc; + acc +. ((x1 +. x3 +. x5 +. x7 +. x9) *. sum) + end + in + go start_k + +let test3 () = + (* Test f3 *) + let steps = Array.init 10 (fun _ -> 0.0) in + let five_pi = f3 #{ i = 5; f = #3.14} #{ fa = steps ; f = #0.0 } in + print_floatu "Test 3, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps; + + (* Test f3_manyargs + + (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 50.86 + 3 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 152.58 + 6 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 306.16 + 9 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 457.74 + + ( but we expect some floating point error ) + *) + let steps = Array.init 10 (fun _ -> 0.0) in + let x1 = 3.14 in + let x3 = 2.72 in + let x5 = 1.62 in + let x7 = 1.41 in + let x9 = 42.0 in + + (* these sum to 3 *) + let x2 = #{ i = 7; ff' = #{ f = #40.0 ; f' = 2.0 } } in + let x4 = #{ i = -23; ff' = #{ f = #100.0 ; f' = 9.0 } } in + let x6 = #{ i = -242; ff' = #{ f = #5.5 ; f' = 84.5 } } in + let x8 = #{ i = -2; ff' = #{ f = #20.0 ; f' = 2.0 } } in + + let f3_manyargs = f3_manyargs #{ x = 4; y = 8} x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in + print_float "Test 3, 610.68: " (f3_manyargs ()); + Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps + +let _ = test3 () + +(*********************************************) +(* Test 4: Partial and indirect applications *) + +type tt = #{ x1 : t ; x2 : t } + +let[@inline never] test4 () = + let one = #{ i = -1; ff' = #{ f = #1.33 ; f' = 0.67 } } in + let two = #{ i = -5; ff' = #{ f = #12.7 ; f' = -5.7 } } in + + (* Simple indirect call *) + let[@inline never] go f = f one two in + let #{ x1 ; x2 } = #{ x1 = go add_t; x2 = go sub_t } in + print_t_sum "Test 4, 1 + 2" x1; + print_t_sum "Test 4, 1 - 2" x2; + + (* partial application to an unboxed record and with one remaining *) + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 #{ i = 5 ; f = #3.14 }) in + let five_pi = f #{ fa = steps ; f = #0.0 } in + print_floatu "Test 4, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; + + (* That test again, but making f3 also opaque to prevent expansion of the + partial application. *) + let f3 = Sys.opaque_identity f3 in + + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 #{ i = 5 ; f = #3.14 }) in + let five_pi = f #{ fa = steps ; f = #0.0 } in + print_floatu "Test 4, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps + +let _ = test4 () + +(****************************) +(* Test 5: Over application *) + +let[@inline never] f5 n m = + let[@inline never] go f = + f (add_t n m) + in + go + +let test5 () = + let one = #{ i = -1; ff' = #{ f = #1.33 ; f' = 0.67 } } in + let pi = #{ i = 1; ff' = #{ f = #2.0 ; f' = 0.14 } } in + let e = #{ i = 1; ff' = #{ f = #0.1 ; f' = 1.62 } } in + let _ : unit = + f5 pi e + (fun n s m -> print_t_sum s (add_t n m)) "Test 5, pi+e+1" + one + in + () + +let _ = test5 () + +(*************************************) +(* Test 6: methods on unboxed record *) + +(* CR layouts: add tests that unboxed records in objects, once that is + allowed. *) + +(* unboxed record args and returns *) +let f6_1 () = object + method f6_m1 t1 t2 t3 = + add_t (sub_t t1 t2) t3 +end + +(* recursion *) +let f6_2 n = object(self) + method f6_m2 n3 tup f = + if n3 = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) then + tup + else f (self#f6_m2 (n3+1) tup f) +end + +(* overapplication to unboxed record and value args *) +let f6_3 n k = object + method f6_m3 n3 tup f = + let n = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) in + f (n + k + n3) tup +end + +let test6 () = + let one = #{ i = -1; ff' = #{ f = #1.33 ; f' = 0.67 } } in + let pi = #{ i = 1; ff' = #{ f = #2.0 ; f' = 0.14 } } in + let e = #{ i = 1; ff' = #{ f = #0.1 ; f' = 1.62 } } in + let add3 n (m, k) = n + m + k in + + (* (3.14 - 2.72) + 1 = 1.42 *) + let o = (Sys.opaque_identity f6_1) () in + print_t_sum "Test 6, 1.42" + (o#f6_m1 pi e one); + + (* 4.25 * 8 = 34 *) + let t_4_25 = #{ i = 2; ff' = #{ f = #1.1 ; f' = 1.15 } } in + let o = (Sys.opaque_identity f6_2) (4,7) in + let result = o#f6_m2 8 t_4_25 (fun x -> add_t x x) in + print_t_sum "Test 6, 34.00" result; + + (* (1 + 2 + 3 + (-2) + (-12) + 4) * (2.72 + (-1) + 10) = -46.88 *) + let o = (Sys.opaque_identity f6_3) (1,2) 3 in + let negative_one = #{ i = -3; ff' = #{ f = #1.33 ; f' = 0.67 } } in + let ten = #{ i = -1; ff' = #{ f = #13.2 ; f' = -2.2 } } in + let result = + o#f6_m3 (-2) e + (fun[@inline never] i m1 m2 n m3 -> + Float.of_int (add3 i n) *. (t_sum m1 +. t_sum m2 +. t_sum m3)) + negative_one (-12,4) ten + in + print_float "Test 6, -46.88" result + +let _ = test6 () + +(**************************************) +(* Test 7: letop with unboxed records *) + +let ( let* ) x f = + let one = #{ i = 0; ff' = #{ f = #1.0 ; f' = 0.0 } } in + f Float_u.(add_t x one) + +let _ = + let* pi_plus_one = #{ i = 1; ff' = #{ f = #2.0 ; f' = 0.14 } } in + print_t_sum "Test 7, 4.14" pi_plus_one + +let ( let* ) x (f : _ -> t) = + let one = #{ i = 0; ff' = #{ f = #1.0 ; f' = 0.0 } } in + add_t one (f x) +let ( and* ) x y = (x, t_sum y) +let _ = + let one = #{ i = 0; ff' = #{ f = #1.0 ; f' = 0.0 } } in + let e = #{ i = 1; ff' = #{ f = #0.1 ; f' = 1.62 } } in + let result = + let* x = 42 + and* y = one + and* z = e in + #{ i = 42; ff' = #{ f = Float_u.of_float y ; f' = z } } + in + print_t_sum "Test 7, 46.72" result + +(**************************************************************) +(* Test 8 ommitted, reordering only applies to unboxed tuples *) +(* Partial patterns tested below. *) + +(**********************************) +(* Test 9: Continuations / @local *) + +type zy = #{ z : float ; y : int } +type zyxw = #{ zy : zy ; x : float# ; w : string } +type yz = #{ y_ : int ; z_ : float } +type wxyz = #{ w : string ; x : float# ; yz : yz } + +let print4 prefix #{ zy = #{ z; y }; x; w } = + Printf.printf "%s: [%.1f %d %.1f %s]\n" prefix z y (Float_u.to_float x) w + +let _ = + let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w } in + let[@inline never] g i p1 p2 = + let z = + if i < 0 then + swap p1 + else if i = 0 then + swap p2 + else + swap #{ w = "hi"; x = #42.0; yz = #{ y_ = 84; z_ = 3.0} } + in z + in + print4 "Test 9, [3.0 2 1.0 a]" + (g (-1) #{ w = "a"; x = #1.0; yz = #{ y_ = 2; z_ = 3.0 } } + #{ w = "a"; x = #4.0; yz = #{ y_ = 5; z_ = 6.0 } }); + + let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w } in + let[@inline never] g i p1 p2 = + let z = + if i < 0 then + swap p1 + else if i = 0 then + swap p2 + else + swap #{ w = "hi"; x = #42.0; yz = #{ y_ = 84; z_ = 3.0} } + in z + in + print4 "Test 9, [6.0 5 4.0 b]" + (g 0 #{ w = "a"; x = #1.0; yz = #{ y_ = 2; z_ = 3.0 } } + #{ w = "b"; x = #4.0; yz = #{ y_ = 5; z_ = 6.0 } }); + + let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w } in + let[@inline never] g i p1 p2 = + let z = + if i < 0 then + swap p1 + else if i = 0 then + swap p2 + else + swap #{ w = "hi"; x = #42.0; yz = #{ y_ = 84; z_ = 3.0} } + in z + in + print4 "Test 9, [3.0 84 42.0 hi]" + (g 1 #{ w = "a"; x = #1.0; yz = #{ y_ = 2; z_ = 3.0 } } + #{ w = "b"; x = #4.0; yz = #{ y_ = 5; z_ = 6.0 } }) + +(**************************) +(* Test 10: Loopification *) + +type xy = #{ x : float ; y : int } +type wxyz_ = #{ w : float# ; xy : xy ; z : int } + +let print4 prefix #{ w; xy = #{x;y}; z } = + Printf.printf "%s: [%.1f %.1f %d %d]\n" prefix + (Float_u.to_float w) x y z + +let[@loop] rec fib n (#{ w; xy = #{x;y}; z } as p) = + let w = Float_u.to_float w in + if Float.compare w (Float.of_int n) > 0 then p else + let next = Float_u.of_float (w +. x) in + fib n #{ w = next; xy = #{ x = w; y = Float.to_int x}; z = y} + +let _ = + print4 "Test 10, #(1.0, #(0.0, 0), 0)" + (fib 0 #{ w = #1.0; xy = #{ x = 0.0; y = 0 }; z = 0 }); + print4 "Test 10, #(5.0, #(3.0, 2), 1))" + (fib 4 #{ w = #1.0; xy = #{ x = 0.0; y = 0 }; z = 0 }); + print4 "Test 10, #(144.0, #(89.0, 55), 34)" + (fib 100 #{ w = #1.0; xy = #{ x = 0.0; y = 0}; z = 0}); + +(****************************************************************************) +(* Test 11: Basic tests of functional updates, projection, partial patterns *) + +type t_ = #{ i : int ; j : int } let add t = t.#i + t.#j let () = let t = #{i = 200; j = 300} in let res = add t in - Printf.printf "Test 3: %d\n" res - + Printf.printf "Test 11: %d\n" res let copy_i_to_j #{ i ; j } = #{ i; j = i } let () = let t = #{i = 1000; j = 2} in let res = add (copy_i_to_j t) in - Printf.printf "Test 4: %d\n" res + Printf.printf "Test 11: %d\n" res let copy_i_to_j r = #{ r with j = r.#i } let () = let t = #{i = 1000; j = 2} in let res = add (copy_i_to_j t) in - Printf.printf "Test 5: %d\n" res + Printf.printf "Test 11: %d\n" res type r = #{ is: #(int * int) ; i : int } let add r = @@ -88,17 +506,101 @@ let add r = let z = r.#i in let #{ is = #(x2, y2) ; i = z2 } = r in assert (x == x2 && y == y2 && z == z2); - let #{ is ; i = _ } = r in + let #{ is ; _ } = r in let #(x3, y3) = is in assert (x == x3 && y == y3); x + y + z let () = let t = #{ is = #(1, 10); i = 100} in let res = add t in - Printf.printf "Test 6: %d\n" res + Printf.printf "Test 11: %d\n" res let () = let t = #{ is = #(1, 10); i = 100} in let res = add #{ t with is = #(2, 20) } in - Printf.printf "Test 7: %d\n" res + Printf.printf "Test 11: %d\n" res + + +(*******************************************************************************) +(* Test 12: unboxed records in closures, using projection and partial patterns *) + +(* This test is adapted from test 3. *) + +(* [go]'s closure should have an unboxed record with an [int] (immediate), a [float#] + (float64) and a [float array] (value). *) +let[@inline never] f3 (bounds : int_floatu) (steps_init : floatarray_floatu) () = + let[@inline never] rec go k = + let n = bounds.#i in + let (#{ f = m; _ } : int_floatu) = bounds in + let init = steps_init.#f in + if k = n + then init + else begin + let acc = go (k + 1) in + let steps = steps_init.#fa in + steps.(k) <- Float_u.to_float acc; + Float_u.add m acc + end + in + go 0 + + +(* many args - odd args are floats, even args are unboxed records *) +let[@inline_never] f3_manyargs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 steps () = + let (#{ x = start_k; y = end_k } : ints) = x0 in + let[@inline never] rec go k = + if k = end_k + then 0.0 + else begin + let #{ i = x2_1; ff' = #{ f = x2_2; f' = x2_3 } } = x2 in + let #{ i = x4_1; ff' = #{ f = x4_2; f' = x4_3 } } = x4 in + let #{ i = x6_1; ff' = #{ f = x6_2; f' = x6_3 } } = x6 in + let #{ i = x8_1; ff' = #{ f = x8_2; f' = x8_3 } } = x8 in + let sum = + Float.of_int x2_1 +. Float_u.to_float x2_2 +. x2_3 +. + Float.of_int x4_1 +. Float_u.to_float x4_2 +. x4_3 +. + Float.of_int x6_1 +. Float_u.to_float x6_2 +. x6_3 +. + Float.of_int x8_1 +. Float_u.to_float x8_2 +. x8_3 + in + let acc = go (k + 1) in + steps.(k) <- acc; + acc +. ((x1 +. x3 +. x5 +. x7 +. x9) *. sum) + end + in + go start_k + +let test12 () = + (* Test f3 *) + let steps = Array.init 10 (fun _ -> 0.0) in + let five_pi = f3 #{ i = 5; f = #3.14} #{ fa = steps ; f = #0.0 } in + print_floatu "Test 12, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 12, step %d: %.2f\n") steps; + + (* Test f3_manyargs + + (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 50.86 + 3 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 152.58 + 6 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 306.16 + 9 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 457.74 + + ( but we expect some floating point error ) + *) + let steps = Array.init 10 (fun _ -> 0.0) in + let x1 = 3.14 in + let x3 = 2.72 in + let x5 = 1.62 in + let x7 = 1.41 in + let x9 = 42.0 in + + (* these sum to 3 *) + let x2 = #{ i = 7; ff' = #{ f = #40.0 ; f' = 2.0 } } in + let x4 = #{ #{ x2 with i = -23 } with ff' = #{ f = #100.0 ; f' = 9.0 } } in + let x6 = #{ + #{ (Sys.opaque_identity x4) with i = -242 } with ff' = #{ f = #5.5 ; f' = 84.5 } + } in + let x8 = #{ i = -2; ff' = #{ (Sys.opaque_identity x2.#ff') with f = #20.0 } } in + let f3_manyargs = f3_manyargs #{ x = 4; y = 8} x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in + print_float "Test 3, 610.68: " (f3_manyargs ()); + Array.iteri (Printf.printf " Test 12, step %d: %.2f\n") steps +let _ = test12 () diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference index c71bd2bd045..4e713daf31b 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference @@ -1,7 +1,99 @@ -Test 1: 5 -Test 2: 55 -Test 3: 500 -Test 4: 2000 -Test 5: 2000 -Test 6: 111 -Test 7: 122 +Test 1, twice pi inlined: 6.28 +Test 1, twice pi not inlined: 6.28 +Test 1, 14/3 inlined: [4 2] +Test 1, 14/3 not inlined: [4 2] +Test 1, [6 15 24] inlined: [6 15 24] +Test 1, [6 15 24] not inlined: [6 15 24] +Test 2, add pi twice: 6.28 +Test 2, add pi four times: 12.56 +Test 2, increment pi twice: 5.14 +Test 2, increment pi four times: 7.14 +Test 2, e times four: 18.88 +Test 2, pi times sixteen: 50.24 +Test 2, pi times sixteen again: 50.24 +Test 2, pi minus four: -0.86 +Test 3, 5 * pi: : 15.70 + Test 3, step 0: 12.56 + Test 3, step 1: 9.42 + Test 3, step 2: 6.28 + Test 3, step 3: 3.14 + Test 3, step 4: 0.00 + Test 3, step 5: 0.00 + Test 3, step 6: 0.00 + Test 3, step 7: 0.00 + Test 3, step 8: 0.00 + Test 3, step 9: 0.00 +Test 3, 610.68: : 610.68 + Test 3, step 0: 0.00 + Test 3, step 1: 0.00 + Test 3, step 2: 0.00 + Test 3, step 3: 0.00 + Test 3, step 4: 458.01 + Test 3, step 5: 305.34 + Test 3, step 6: 152.67 + Test 3, step 7: 0.00 + Test 3, step 8: 0.00 + Test 3, step 9: 0.00 +Test 4, 1 + 2: 3.00 +Test 4, 1 - 2: -1.00 +Test 4, 5 * pi: : 15.70 + Test 4, step 0: 12.56 + Test 4, step 1: 9.42 + Test 4, step 2: 6.28 + Test 4, step 3: 3.14 + Test 4, step 4: 0.00 + Test 4, step 5: 0.00 + Test 4, step 6: 0.00 + Test 4, step 7: 0.00 + Test 4, step 8: 0.00 + Test 4, step 9: 0.00 +Test 4, 5 * pi: : 15.70 + Test 4, step 0: 12.56 + Test 4, step 1: 9.42 + Test 4, step 2: 6.28 + Test 4, step 3: 3.14 + Test 4, step 4: 0.00 + Test 4, step 5: 0.00 + Test 4, step 6: 0.00 + Test 4, step 7: 0.00 + Test 4, step 8: 0.00 + Test 4, step 9: 0.00 +Test 5, pi+e+1: 6.86 +Test 6, 1.42: 1.42 +Test 6, 34.00: 34.00 +Test 6, -46.88: -46.88 +Test 7, 4.14: 4.14 +Test 7, 46.72: 46.72 +Test 9, [3.0 2 1.0 a]: [3.0 2 1.0 a] +Test 9, [6.0 5 4.0 b]: [6.0 5 4.0 b] +Test 9, [3.0 84 42.0 hi]: [3.0 84 42.0 hi] +Test 10, #(1.0, #(0.0, 0), 0): [1.0 0.0 0 0] +Test 10, #(5.0, #(3.0, 2), 1)): [5.0 3.0 2 1] +Test 10, #(144.0, #(89.0, 55), 34): [144.0 89.0 55 34] +Test 11: 500 +Test 11: 2000 +Test 11: 2000 +Test 11: 111 +Test 11: 122 +Test 12, 5 * pi: : 15.70 + Test 12, step 0: 12.56 + Test 12, step 1: 9.42 + Test 12, step 2: 6.28 + Test 12, step 3: 3.14 + Test 12, step 4: 0.00 + Test 12, step 5: 0.00 + Test 12, step 6: 0.00 + Test 12, step 7: 0.00 + Test 12, step 8: 0.00 + Test 12, step 9: 0.00 +Test 3, 610.68: : 610.68 + Test 12, step 0: 0.00 + Test 12, step 1: 0.00 + Test 12, step 2: 0.00 + Test 12, step 3: 0.00 + Test 12, step 4: 458.01 + Test 12, step 5: 305.34 + Test 12, step 6: 152.67 + Test 12, step 7: 0.00 + Test 12, step 8: 0.00 + Test 12, step 9: 0.00 diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference index 0a2fe8b747b..75e6f993887 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference @@ -1,4 +1,4 @@ -File "unboxed_records.ml", line 52, characters 0-31: -52 | type t = #{ i : int ; j : int } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +File "unboxed_records.ml", line 54, characters 0-34: +54 | type ints = #{ x : int ; y : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference index 0a2fe8b747b..75e6f993887 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference @@ -1,4 +1,4 @@ -File "unboxed_records.ml", line 52, characters 0-31: -52 | type t = #{ i : int ; j : int } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +File "unboxed_records.ml", line 54, characters 0-34: +54 | type ints = #{ x : int ; y : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts-unboxed-records/unused.ml b/testsuite/tests/typing-layouts-unboxed-records/unused.ml index e611bda01ed..dbc6fa950cb 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unused.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unused.ml @@ -3,7 +3,10 @@ expect; *) -(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml] *) +(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml]. + + CR layouts v7.2: Once unboxed records are in stable, fold this test back into the + original or move it to [typing-layouts-products]. *) module Unused_record : sig end = struct type t = #{ a : int; b : int } @@ -56,21 +59,6 @@ Warning 69 [unused-field]: unboxed record field b is never read. module Unused_field : sig end |}] -module Unused_mutable_field : sig end = struct - type t = #{ a : int; mutable b : int } - let foo () = #{ a = 0; b = 0 } - let bar x = x.#a, x.#b - let _ = foo, bar -end;; -[%%expect {| -Line 2, characters 23-38: -2 | type t = #{ a : int; mutable b : int } - ^^^^^^^^^^^^^^^ -Warning 69 [unused-field]: mutable unboxed record field b is never mutated. - -module Unused_mutable_field : sig end -|}] - module Unused_field_exported_private : sig type t = private #{ a : int } end = struct @@ -91,23 +79,6 @@ end;; module Unused_field_exported_private : sig type t = private #{ a : int; } end |}] -module Unused_mutable_field_exported_private : sig - type t = private #{ a : int; mutable b : int } -end = struct - type t = #{ a : int; mutable b : int } - let foo () = #{ a = 0; b = 0 } - let _ = foo -end;; -[%%expect {| -Line 4, characters 23-38: -4 | type t = #{ a : int; mutable b : int } - ^^^^^^^^^^^^^^^ -Warning 69 [unused-field]: mutable unboxed record field b is never mutated. - -module Unused_mutable_field_exported_private : - sig type t = private #{ a : int; mutable b : int; } end -|}] - module Unused_field_disable_warning : sig end = struct type t = #{ a: int; b:int } [@@warning "-unused-field"] diff --git a/typing/env.ml b/typing/env.ml index ff40100f9cc..68fdd6506e6 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -4286,6 +4286,21 @@ let report_lookup_error _loc env ppf = function fprintf ppf "Unbound %s field %a" (record_form_to_string record_form) (Style.as_inline_code !print_longident) lid; spellcheck ppf (extract_labels record_form) env lid; + let label_of_other_form = match record_form with + | Legacy -> + (match find_label_by_name Unboxed_product lid env with + | _ -> Some "an unboxed record" + | exception Not_found -> None) + | Unboxed_product -> + (match find_label_by_name Legacy lid env with + | _ -> Some "a boxed record" + | exception Not_found -> None) + in + (match label_of_other_form with + | Some other_form -> + Format.fprintf ppf "@\n@{Hint@}: There is %s field with this name." + other_form + | None -> ()); | Unbound_class lid -> begin fprintf ppf "Unbound class %a" (Style.as_inline_code !print_longident) lid; diff --git a/typing/typecore.ml b/typing/typecore.ml index 770e6ef8dde..c3cefcb14fd 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -246,7 +246,9 @@ type error = | Unbound_existential of Ident.t list * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr | Expr_not_a_record_type of record_form_packed * type_expr + | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr | Submode_failed of Value.error * submode_reason * Env.locality_context option * @@ -825,6 +827,7 @@ let src_pos loc attrs env = type 'rep record_extraction_result = | Record_type of Path.t * Path.t * Types.label_declaration list * 'rep + | Record_type_of_other_form | Not_a_record_type | Maybe_a_record_type @@ -840,7 +843,8 @@ let extract_concrete_record (type rep) (record_form : rep record_form) env ty Typedecl(p0, p, {type_kind=Type_record_unboxed_product (fields, repres)}) -> Record_type (p0, p, fields, repres) | Legacy, Typedecl(_, _, {type_kind=Type_record_unboxed_product _}) - | Unboxed_product, Typedecl(_, _, {type_kind=Type_record _}) + | Unboxed_product, Typedecl(_, _, {type_kind=Type_record _}) -> + Record_type_of_other_form | _, Has_no_typedecl | _, Typedecl(_, _, _) -> Not_a_record_type | _, May_have_typedecl -> Maybe_a_record_type @@ -861,7 +865,7 @@ let extract_concrete_variant env ty = let extract_label_names record_form env ty = match extract_concrete_record record_form env ty with | Record_type (_, _,fields, _) -> List.map (fun l -> l.Types.ld_id) fields - | Not_a_record_type | Maybe_a_record_type -> assert false + | Record_type_of_other_form | Not_a_record_type | Maybe_a_record_type -> assert false let has_poly_constraint spat = match spat.ppat_desc with @@ -2673,6 +2677,9 @@ and type_pat_aux | Record_type(p0, p, _, _) -> let ty = generic_instance expected_ty in Some (p0, p, is_principal expected_ty), ty + | Record_type_of_other_form -> + let error = Wrong_expected_record_boxing(Pattern, P record_form, expected_ty) in + raise (Error (loc, !!penv, error)) | Maybe_a_record_type -> None, newvar (Jkind.Builtin.any ~why:Dummy_jkind) | Not_a_record_type -> @@ -5270,6 +5277,12 @@ and type_expect_ let expected_opath = match extract_concrete_record record_form env ty_expected with | Record_type (p0, p, _, _) -> Some (p0, p, is_principal ty_expected) + | Record_type_of_other_form -> + let error = + Wrong_expected_record_boxing + (Expression explanation, P record_form, ty_expected) + in + raise (Error (loc, env, error)) | Maybe_a_record_type -> None | Not_a_record_type -> let wks = record_form_to_wrong_kind_sort record_form in @@ -5285,6 +5298,11 @@ and type_expect_ match extract_concrete_record record_form env exp.exp_type with | Record_type (p0, p, _, _) -> Some (p0, p, is_principal exp.exp_type) | Maybe_a_record_type -> None + | Record_type_of_other_form -> + let error = + Expr_record_type_has_wrong_boxing (P record_form, exp.exp_type) + in + raise (Error (exp.exp_loc, env, error)) | Not_a_record_type -> let error = Expr_not_a_record_type (P record_form, exp.exp_type) in raise (Error (exp.exp_loc, env, error)) @@ -7192,6 +7210,9 @@ and type_label_access | Record_type(p0, p, _, _) -> Some(p0, p, is_principal ty_exp) | Maybe_a_record_type -> None + | Record_type_of_other_form -> + let error = Expr_record_type_has_wrong_boxing (P record_form, ty_exp) in + raise (Error (record.exp_loc, env, error)) | Not_a_record_type -> let error = Expr_not_a_record_type (P record_form, ty_exp) in raise (Error (record.exp_loc, env, error)) @@ -7542,7 +7563,6 @@ and type_label_exp in (lid, label, arg) - and type_argument ?explanation ?recarg env (mode : expected_mode) sarg ty_expected' ty_expected = (* ty_expected' may be generic *) @@ -10463,12 +10483,39 @@ let report_error ~loc env = function the expected type is@ %a%t" ctx sort (Style.as_inline_code Printtyp.type_expr) ty (report_type_expected_explanation_opt explanation) + | Wrong_expected_record_boxing(ctx, P record_form, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let expected, actual = + match record_form with + | Legacy -> "unboxed", "boxed" + | Unboxed_product -> "boxed", "unboxed" + in + Location.errorf ~loc + "This %s record %s should be %s instead,@ \ + the expected type is@ %a%t" + actual ctx expected (Style.as_inline_code Printtyp.type_expr) ty + (report_type_expected_explanation_opt explanation) | Expr_not_a_record_type (P record_form, ty) -> Location.errorf ~loc "This expression has type %a@ \ which is not a %s type." (Style.as_inline_code Printtyp.type_expr) ty (record_form_to_string record_form) + | Expr_record_type_has_wrong_boxing (P record_form, ty) -> + let expected, actual = + match record_form with + | Legacy -> "a boxed", "an unboxed" + | Unboxed_product -> "an unboxed", "a boxed" + in + Location.errorf ~loc + "This expression has type %a,@ \ + which is %s record rather than %s one." + (Style.as_inline_code Printtyp.type_expr) ty + actual expected | Submode_failed(fail_reason, submode_reason, locality_context, contention_context, shared_context) -> diff --git a/typing/typecore.mli b/typing/typecore.mli index 9b1e13a1b72..4af8a308a7e 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -292,7 +292,9 @@ type error = | Unbound_existential of Ident.t list * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr | Expr_not_a_record_type of record_form_packed * type_expr + | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr | Submode_failed of Mode.Value.error * submode_reason * Env.locality_context option * diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 948ec8b4902..0fa645971bd 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -86,6 +86,7 @@ type error = | Duplicate_constructor of string | Too_many_constructors | Duplicate_label of string + | Unboxed_mutable_label | Recursive_abbrev of string * Env.t * reaching_type_path | Cycle_in_def of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option @@ -437,7 +438,8 @@ let check_representable ~why ~allow_unboxed env loc kloc typ = end | Error err -> raise (Error (loc,Jkind_sort {kloc; typ; err})) -let transl_labels ~new_var_jkind ~allow_unboxed env univars closed lbls kloc = +let transl_labels (type rep) ~(record_form : rep record_form) ~new_var_jkind + ~allow_unboxed env univars closed lbls kloc = assert (lbls <> []); let all_labels = ref String.Set.empty in List.iter @@ -453,7 +455,10 @@ let transl_labels ~new_var_jkind ~allow_unboxed env univars closed lbls kloc = let mut : mutability = match mut with | Immutable -> Immutable - | Mutable -> Mutable Mode.Alloc.Comonadic.Const.legacy + | Mutable -> + match record_form with + | Legacy -> Mutable Mode.Alloc.Comonadic.Const.legacy + | Unboxed_product -> raise(Error(loc, Unboxed_mutable_label)) in let modalities = Typemode.transl_modalities ~maturity:Stable mut attrs modalities @@ -531,7 +536,7 @@ let transl_constructor_arguments ~new_var_jkind ~unboxed let lbls, lbls' = (* CR layouts: we forbid [@@unboxed] variants from being non-value, see comment in [check_representable]. *) - transl_labels ~new_var_jkind ~allow_unboxed:(not unboxed) + transl_labels ~record_form:Legacy ~new_var_jkind ~allow_unboxed:(not unboxed) env univars closed l (Inlined_record { unboxed }) in Types.Cstr_record lbls', @@ -625,7 +630,8 @@ let verify_unboxed_attr unboxed_attr sdecl = | [{pld_mutable = Mutable}] -> bad "it is mutable" | [{pld_mutable = Immutable}] -> () end - | Ptype_record_unboxed_product _ -> bad "cannot use [@@unboxed] on unboxed record" + | Ptype_record_unboxed_product _ -> + bad "[@@unboxed] may not be used on unboxed records" | Ptype_variant constructors -> begin match constructors with | [] -> bad "it has no constructor" | (_::_::_) -> bad "it has more than one constructor" @@ -902,8 +908,8 @@ let transl_declaration env sdecl (id, uid) = let lbls, lbls' = (* CR layouts: we forbid [@@unboxed] records from being non-value, see comment in [check_representable]. *) - transl_labels ~new_var_jkind:Any ~allow_unboxed:(not unbox) - env None true lbls (Record { unboxed = unbox }) + transl_labels ~record_form:Legacy ~new_var_jkind:Any + ~allow_unboxed:(not unbox) env None true lbls (Record { unboxed = unbox }) in let rep, jkind = if unbox then @@ -922,8 +928,8 @@ let transl_declaration env sdecl (id, uid) = Language_extension.assert_enabled ~loc:sdecl.ptype_loc Layouts Language_extension.Beta; let lbls, lbls' = - transl_labels ~new_var_jkind:Any ~allow_unboxed:true - env None true lbls Record_unboxed_product + transl_labels ~record_form:Unboxed_product ~new_var_jkind:Any + ~allow_unboxed:true env None true lbls Record_unboxed_product in let jkind_ls = List.map (fun _ -> any) lbls in let jkind = Jkind.Builtin.product ~why:Unboxed_record jkind_ls in @@ -3495,6 +3501,8 @@ let report_error ppf = function (Config.max_tag + 1) "non-constant constructors" | Duplicate_label s -> fprintf ppf "Two labels are named %a" Style.inline_code s + | Unboxed_mutable_label -> + fprintf ppf "Unboxed records labels cannot be mutable" | Recursive_abbrev (s, env, reaching_path) -> let reaching_path = Reaching_path.simplify reaching_path in Printtyp.wrap_printing_env ~error:true env @@ fun () -> diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 78ba9b81903..13693ebd5a7 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -122,6 +122,7 @@ type error = | Duplicate_constructor of string | Too_many_constructors | Duplicate_label of string + | Unboxed_mutable_label | Recursive_abbrev of string * Env.t * reaching_type_path | Cycle_in_def of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option From 4e451d5af6d01fa4d1d330a3eb46878beb8033b0 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Sun, 1 Dec 2024 18:53:22 -0500 Subject: [PATCH 03/19] Unique tests for anfelor's 2024-11-27 review --- .../typing-layouts-unboxed-records/unique.ml | 82 ++++++++++++++----- 1 file changed, 63 insertions(+), 19 deletions(-) diff --git a/testsuite/tests/typing-layouts-unboxed-records/unique.ml b/testsuite/tests/typing-layouts-unboxed-records/unique.ml index 9e043d72866..90452cc3f52 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unique.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unique.ml @@ -9,57 +9,60 @@ (* Uniqueness tests *) +let unique_use : 'a @ unique -> unit = fun _ -> () +let unique_use2 : ('a : value & value) @ unique -> unit = fun _ -> () + type t = #{ x : string ; y : string } -let use_string (_s @ unique) = () let mk : unit -> t @ unique = fun () -> #{ x = "hi"; y = "hi" } [%%expect{| +val unique_use : ('a : value_or_null). 'a @ unique -> unit = +val unique_use2 : ('a : value & value). 'a @ unique -> unit = type t = #{ x : string; y : string; } -val use_string : ('a : value_or_null). 'a @ unique -> unit = val mk : unit -> t @ unique = |}] (* Can access different fields *) let () = let t = mk () in - use_string t.#x; - use_string t.#y + unique_use t.#x; + unique_use t.#y [%%expect{| |}] let () = let #{ x ; y } = mk () in - use_string x; - use_string y + unique_use x; + unique_use y [%%expect{| |}] (* Cannot access the same field twice *) let () = let t = mk () in - use_string t.#x; - use_string t.#x + unique_use t.#x; + unique_use t.#x [%%expect{| Line 4, characters 13-17: -4 | use_string t.#x +4 | unique_use t.#x ^^^^ Error: This value is used here, but it has already been used as unique: Line 3, characters 13-17: -3 | use_string t.#x; +3 | unique_use t.#x; ^^^^ |}] let () = let #{ x ; y = _ } = mk () in - use_string x; - use_string x + unique_use x; + unique_use x [%%expect{| Line 4, characters 13-14: -4 | use_string x +4 | unique_use x ^ Error: This value is used here, but it has already been used as unique: Line 3, characters 13-14: -3 | use_string x; +3 | unique_use x; ^ |}] @@ -67,26 +70,67 @@ Line 3, characters 13-14: (* A functional update to a field allows a field to be reused *) let () = let t = mk () in - use_string t.#x; + unique_use t.#x; let t = #{ t with x = "fresh" } in - use_string t.#x + unique_use t.#x [%%expect{| |}] (* But not a functional update to a different field *) let () = let t = mk () in - use_string t.#x; + unique_use t.#x; let t = #{ t with y = "fresh" } in - use_string t.#x + unique_use t.#x [%%expect{| Line 4, characters 13-14: 4 | let t = #{ t with y = "fresh" } in ^ Error: This value is used here, but it has already been used as unique: Line 3, characters 13-17: -3 | use_string t.#x; +3 | unique_use t.#x; ^^^^ |}] +let () = + let t = mk () in + unique_use2 t; + let _ = #{ t with y = "fresh" } in + () +[%%expect{| +Line 4, characters 13-14: +4 | let _ = #{ t with y = "fresh" } in + ^ +Error: This value is used here, + but it is part of a value that has already been used as unique: +Line 3, characters 14-15: +3 | unique_use2 t; + ^ + +|}] + +(* Functional updates to unboxed records don't implicitly borrow the record + (unlike boxed records). *) +let [@warning "-23"] () = + let t = mk () in + unique_use2 t; + let t = #{ t with x = "fresh"; y = "fresh" } in + unique_use t.#x +[%%expect{| +|}] + +type t = #{ x : unit ; y : string } +let mk : unit -> t @ unique = fun () -> #{ x = () ; y = "fresh" } +[%%expect{| +type t = #{ x : unit; y : string; } +val mk : unit -> t @ unique = +|}] + +let [@warning "-23"] () = + let t = mk () in + unique_use2 t; + let t = #{ t with x = (); y = "fresh" } in + unique_use t.#x +[%%expect{| +|}] From b0169c42ffe9afa261fe275edccda7c08eec913a Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Mon, 2 Dec 2024 11:58:44 -0500 Subject: [PATCH 04/19] Add failing uniqueness test with CR --- .../typing-layouts-unboxed-records/unique.ml | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/testsuite/tests/typing-layouts-unboxed-records/unique.ml b/testsuite/tests/typing-layouts-unboxed-records/unique.ml index 90452cc3f52..8ca82a81c32 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unique.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unique.ml @@ -134,3 +134,23 @@ let [@warning "-23"] () = unique_use t.#x [%%expect{| |}] + +(* CR uniqueness: this test should succeed since unboxed records have no memory address + and the first field is of type unit and thus mode-crosses uniqueness. We should fix + this by allowing multiple unique uses for values that mode-cross uniqueness. *) +let () = + let t = mk () in + unique_use2 t; + let t = #{ t with y = "fresh" } in + unique_use2 t +[%%expect{| +Line 4, characters 13-14: +4 | let t = #{ t with y = "fresh" } in + ^ +Error: This value is used here, + but it is part of a value that has already been used as unique: +Line 3, characters 14-15: +3 | unique_use2 t; + ^ + +|}] From 7b98a69b28c5420265e9a04553b8cddf8830eead Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Mon, 2 Dec 2024 12:38:57 -0500 Subject: [PATCH 05/19] Revert changes to flambda_parser.new-messages --- .../parser/flambda_parser.new-messages | 653 ++++++++---------- 1 file changed, 281 insertions(+), 372 deletions(-) diff --git a/middle_end/flambda2/parser/flambda_parser.new-messages b/middle_end/flambda2/parser/flambda_parser.new-messages index 636c4ba34ed..c4034c79c6b 100644 --- a/middle_end/flambda2/parser/flambda_parser.new-messages +++ b/middle_end/flambda2/parser/flambda_parser.new-messages @@ -459,11 +459,11 @@ expect_test_spec: KWD_LET SYMBOL EQUAL KWD_CLOSURE IDENT AT IDENT TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_FLOAT AMP TILDEMINUS +expect_test_spec: KWD_APPLY AMP TILDEMINUS ## ## Ends in an error in state: 84. ## -## alloc_mode_for_allocations_opt -> AMP . region [ SYMBOL LPAREN KWD_WITH KWD_IN KWD_END KWD_AND INT IDENT FLOAT ] +## alloc_mode_for_allocations_opt -> AMP . region [ SYMBOL RPAREN LPAREN KWD_WITH KWD_UNROLL KWD_INLINING_STATE KWD_INLINED KWD_IN KWD_END KWD_AND INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## AMP @@ -505,7 +505,7 @@ expect_test_spec: KWD_LET KWD_SET_OF_CLOSURES SYMBOL EQUAL KWD_CLOSURE IDENT KWD -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH TILDEMINUS ## ## Ends in an error in state: 94. ## @@ -517,7 +517,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH TILDEMINU -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE TILDEMINUS ## ## Ends in an error in state: 95. ## @@ -529,7 +529,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE TI -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT TILDEMINUS ## ## Ends in an error in state: 97. ## @@ -541,7 +541,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE ID -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT EQUAL TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQUAL TILDEMINUS ## ## Ends in an error in state: 98. ## @@ -553,7 +553,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE ID -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT TILDEMINUS ## ## Ends in an error in state: 99. ## @@ -566,7 +566,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE ID -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT SEMICOLON TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE IDENT EQUAL FLOAT SEMICOLON TILDEMINUS ## ## Ends in an error in state: 101. ## @@ -1329,7 +1329,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_INT_ARITH FLOAT KWD_LAND FLOAT TILDEM expect_test_spec: KWD_LET IDENT EQUAL PRIM_BYTES_LOAD TILDEMINUS ## -## Ends in an error in state: 241. +## Ends in an error in state: 239. ## ## prefix_binop -> PRIM_BYTES_LOAD . string_accessor_width [ LPAREN ] ## @@ -1341,7 +1341,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BYTES_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_NATIVEINT TILDEMINUS ## -## Ends in an error in state: 244. +## Ends in an error in state: 242. ## ## unop -> PRIM_BOX_NATIVEINT . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1353,7 +1353,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_NATIVEINT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT64 TILDEMINUS ## -## Ends in an error in state: 246. +## Ends in an error in state: 244. ## ## unop -> PRIM_BOX_INT64 . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1365,7 +1365,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT64 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT32 TILDEMINUS ## -## Ends in an error in state: 248. +## Ends in an error in state: 246. ## ## unop -> PRIM_BOX_INT32 . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1377,7 +1377,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_INT32 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_FLOAT TILDEMINUS ## -## Ends in an error in state: 250. +## Ends in an error in state: 248. ## ## unop -> PRIM_BOX_FLOAT . alloc_mode_for_allocations_opt [ SYMBOL INT IDENT FLOAT ] ## @@ -1389,9 +1389,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BOX_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET TILDEMINUS ## -## Ends in an error in state: 253. +## Ends in an error in state: 251. ## -## binop_app -> PRIM_BLOCK_SET . block_access_kind simple DOT LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET . block_access_kind simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET @@ -1401,7 +1401,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 255. +## Ends in an error in state: 253. ## ## block_access_kind -> KWD_FLOAT . size_opt [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1413,7 +1413,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE TILDEMINUS ## -## Ends in an error in state: 256. +## Ends in an error in state: 254. ## ## size_opt -> KWD_SIZE . LPAREN targetint RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1425,7 +1425,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN TILDEMINUS ## -## Ends in an error in state: 257. +## Ends in an error in state: 255. ## ## size_opt -> KWD_SIZE LPAREN . targetint RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1437,7 +1437,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN INT TILDEMINUS ## -## Ends in an error in state: 259. +## Ends in an error in state: 257. ## ## size_opt -> KWD_SIZE LPAREN targetint . RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1449,9 +1449,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_SIZE LPAREN INT TILDEMI expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM LPAREN ## -## Ends in an error in state: 262. +## Ends in an error in state: 260. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind . simple DOT LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind . simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind @@ -1460,19 +1460,19 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM LPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 273, spurious reduction of production tag_opt -> -## In state 278, spurious reduction of production size_opt -> -## In state 279, spurious reduction of production block_access_kind -> block_access_field_kind tag_opt size_opt +## In state 271, spurious reduction of production tag_opt -> +## In state 276, spurious reduction of production size_opt -> +## In state 277, spurious reduction of production block_access_kind -> block_access_field_kind tag_opt size_opt ## expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT TILDEMINUS ## -## Ends in an error in state: 263. +## Ends in an error in state: 261. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple . DOT LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE DOT ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple . DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind simple @@ -1482,9 +1482,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 264. +## Ends in an error in state: 262. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT . LPAREN tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT . LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind simple DOT @@ -1494,9 +1494,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 265. +## Ends in an error in state: 263. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN . tag RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN . simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN @@ -1504,33 +1504,34 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 266. +## Ends in an error in state: 264. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag . RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## simple -> simple . TILDE coercion [ TILDE RPAREN ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple . RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple ## -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 267. +## Ends in an error in state: 265. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN . init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN . init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN ## -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN LESSMINUS TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN LESSMINUS TILDEMINUS ## -## Ends in an error in state: 268. +## Ends in an error in state: 266. ## ## init_or_assign -> LESSMINUS . [ SYMBOL INT IDENT FLOAT ] ## init_or_assign -> LESSMINUS . AMP [ SYMBOL INT IDENT FLOAT ] @@ -1541,34 +1542,34 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN EQUAL TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL TILDEMINUS ## -## Ends in an error in state: 271. +## Ends in an error in state: 269. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign . simple [ KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign . simple [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign ## -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN INT RPAREN EQUAL FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL FLOAT TILDEMINUS ## -## Ends in an error in state: 272. +## Ends in an error in state: 270. ## -## binop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign simple . [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] +## ternop_app -> PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign simple . [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN tag RPAREN init_or_assign simple +## PRIM_BLOCK_SET block_access_kind simple DOT LPAREN simple RPAREN init_or_assign simple ## expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM TILDEMINUS ## -## Ends in an error in state: 273. +## Ends in an error in state: 271. ## ## block_access_kind -> block_access_field_kind . tag_opt size_opt [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1580,7 +1581,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_IMM TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG TILDEMINUS ## -## Ends in an error in state: 274. +## Ends in an error in state: 272. ## ## tag_opt -> KWD_TAG . LPAREN tag RPAREN [ SYMBOL LPAREN KWD_SIZE INT IDENT FLOAT ] ## @@ -1592,7 +1593,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN TILDEMINUS ## -## Ends in an error in state: 275. +## Ends in an error in state: 273. ## ## tag_opt -> KWD_TAG LPAREN . tag RPAREN [ SYMBOL LPAREN KWD_SIZE INT IDENT FLOAT ] ## @@ -1604,7 +1605,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT TILDEMINUS ## -## Ends in an error in state: 276. +## Ends in an error in state: 274. ## ## tag_opt -> KWD_TAG LPAREN tag . RPAREN [ SYMBOL LPAREN KWD_SIZE INT IDENT FLOAT ] ## @@ -1616,7 +1617,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT TILDEMIN expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT RPAREN TILDEMINUS ## -## Ends in an error in state: 278. +## Ends in an error in state: 276. ## ## block_access_kind -> block_access_field_kind tag_opt . size_opt [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -1628,9 +1629,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_SET KWD_TAG LPAREN INT RPAREN T expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD TILDEMINUS ## -## Ends in an error in state: 280. +## Ends in an error in state: 278. ## -## unop -> PRIM_BLOCK_LOAD . mutability block_access_kind LPAREN tag RPAREN [ SYMBOL INT IDENT FLOAT ] +## prefix_binop -> PRIM_BLOCK_LOAD . mutability block_access_kind [ LPAREN ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_LOAD @@ -1640,9 +1641,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 283. +## Ends in an error in state: 281. ## -## unop -> PRIM_BLOCK_LOAD mutability . block_access_kind LPAREN tag RPAREN [ SYMBOL INT IDENT FLOAT ] +## prefix_binop -> PRIM_BLOCK_LOAD mutability . block_access_kind [ LPAREN ] ## ## The known suffix of the stack is as follows: ## PRIM_BLOCK_LOAD mutability @@ -1650,53 +1651,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD KWD_IMMUTABLE_UNIQUE TILDE -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD KWD_IMM SYMBOL -## -## Ends in an error in state: 284. -## -## unop -> PRIM_BLOCK_LOAD mutability block_access_kind . LPAREN tag RPAREN [ SYMBOL INT IDENT FLOAT ] -## -## The known suffix of the stack is as follows: -## PRIM_BLOCK_LOAD mutability block_access_kind -## -## WARNING: This example involves spurious reductions. -## This implies that, although the LR(1) items shown above provide an -## accurate view of the past (what has been recognized so far), they -## may provide an INCOMPLETE view of the future (what was expected next). -## In state 273, spurious reduction of production tag_opt -> -## In state 278, spurious reduction of production size_opt -> -## In state 279, spurious reduction of production block_access_kind -> block_access_field_kind tag_opt size_opt -## - - - -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN TILDEMINUS -## -## Ends in an error in state: 285. -## -## unop -> PRIM_BLOCK_LOAD mutability block_access_kind LPAREN . tag RPAREN [ SYMBOL INT IDENT FLOAT ] -## -## The known suffix of the stack is as follows: -## PRIM_BLOCK_LOAD mutability block_access_kind LPAREN -## - - - -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN INT TILDEMINUS -## -## Ends in an error in state: 286. -## -## unop -> PRIM_BLOCK_LOAD mutability block_access_kind LPAREN tag . RPAREN [ SYMBOL INT IDENT FLOAT ] -## -## The known suffix of the stack is as follows: -## PRIM_BLOCK_LOAD mutability block_access_kind LPAREN tag -## - - - expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK TILDEMINUS ## -## Ends in an error in state: 288. +## Ends in an error in state: 283. ## ## block -> PRIM_BLOCK . mutability tag alloc_mode_for_allocations_opt LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1708,7 +1665,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 289. +## Ends in an error in state: 284. ## ## block -> PRIM_BLOCK mutability . tag alloc_mode_for_allocations_opt LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1720,7 +1677,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK KWD_IMMUTABLE_UNIQUE TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT TILDEMINUS ## -## Ends in an error in state: 290. +## Ends in an error in state: 285. ## ## block -> PRIM_BLOCK mutability tag . alloc_mode_for_allocations_opt LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1732,7 +1689,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT AMP IDENT TILDEMINUS ## -## Ends in an error in state: 291. +## Ends in an error in state: 286. ## ## block -> PRIM_BLOCK mutability tag alloc_mode_for_allocations_opt . LPAREN loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1744,7 +1701,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT AMP IDENT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT LPAREN TILDEMINUS ## -## Ends in an error in state: 292. +## Ends in an error in state: 287. ## ## block -> PRIM_BLOCK mutability tag alloc_mode_for_allocations_opt LPAREN . loption(separated_nonempty_list(COMMA,simple)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1756,7 +1713,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK INT LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_LOAD TILDEMINUS ## -## Ends in an error in state: 297. +## Ends in an error in state: 292. ## ## prefix_binop -> PRIM_BIGSTRING_LOAD . string_accessor_width [ LPAREN ] ## @@ -1768,7 +1725,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET TILDEMINUS ## -## Ends in an error in state: 303. +## Ends in an error in state: 296. ## ## ternop_app -> PRIM_ARRAY_SET . array_kind array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1780,7 +1737,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 306. +## Ends in an error in state: 299. ## ## ternop_app -> PRIM_ARRAY_SET array_kind . array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1792,7 +1749,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_VEC128 TILDEMINUS ## -## Ends in an error in state: 308. +## Ends in an error in state: 301. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width . simple DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1804,7 +1761,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET KWD_VEC128 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT TILDEMINUS ## -## Ends in an error in state: 309. +## Ends in an error in state: 302. ## ## simple -> simple . TILDE coercion [ TILDE DOT ] ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple . DOT LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] @@ -1817,7 +1774,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 310. +## Ends in an error in state: 303. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT . LPAREN simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1829,7 +1786,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 311. +## Ends in an error in state: 304. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN . simple RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1841,7 +1798,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 312. +## Ends in an error in state: 305. ## ## simple -> simple . TILDE coercion [ TILDE RPAREN ] ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple . RPAREN init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] @@ -1854,7 +1811,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT TILD expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 313. +## Ends in an error in state: 306. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple RPAREN . init_or_assign simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1866,7 +1823,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAR expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL TILDEMINUS ## -## Ends in an error in state: 314. +## Ends in an error in state: 307. ## ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1878,7 +1835,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAR expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAREN EQUAL FLOAT TILDEMINUS ## -## Ends in an error in state: 315. +## Ends in an error in state: 308. ## ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] ## ternop_app -> PRIM_ARRAY_SET array_kind array_accessor_width simple DOT LPAREN simple RPAREN init_or_assign simple . [ KWD_WITH KWD_IN KWD_AND ] @@ -1891,7 +1848,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_SET FLOAT DOT LPAREN FLOAT RPAR expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD TILDEMINUS ## -## Ends in an error in state: 316. +## Ends in an error in state: 309. ## ## binop_app -> PRIM_ARRAY_LOAD . array_kind mutability array_accessor_width simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1903,7 +1860,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 317. +## Ends in an error in state: 310. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind . mutability array_accessor_width simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1915,7 +1872,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 318. +## Ends in an error in state: 311. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability . array_accessor_width simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1927,7 +1884,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_IMMUTABLE_UNIQUE TILDE expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_VEC128 TILDEMINUS ## -## Ends in an error in state: 319. +## Ends in an error in state: 312. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width . simple DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1939,7 +1896,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD KWD_VEC128 TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT TILDEMINUS ## -## Ends in an error in state: 320. +## Ends in an error in state: 313. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple . DOT LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE DOT ] @@ -1952,7 +1909,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 321. +## Ends in an error in state: 314. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple DOT . LPAREN simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1964,7 +1921,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 322. +## Ends in an error in state: 315. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple DOT LPAREN . simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -1976,7 +1933,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN TILDEMINU expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 323. +## Ends in an error in state: 316. ## ## binop_app -> PRIM_ARRAY_LOAD array_kind mutability array_accessor_width simple DOT LPAREN simple . RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE RPAREN ] @@ -1989,7 +1946,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LOAD FLOAT DOT LPAREN FLOAT TIL expect_test_spec: KWD_LET IDENT EQUAL KWD_REC_INFO TILDEMINUS ## -## Ends in an error in state: 326. +## Ends in an error in state: 319. ## ## named -> KWD_REC_INFO . rec_info_atom [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2001,7 +1958,7 @@ expect_test_spec: KWD_LET IDENT EQUAL KWD_REC_INFO TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH TILDEMINUS ## -## Ends in an error in state: 328. +## Ends in an error in state: 321. ## ## named -> unop . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2013,7 +1970,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH FLOAT TILDEMINUS ## -## Ends in an error in state: 329. +## Ends in an error in state: 322. ## ## named -> unop simple . [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] @@ -2026,7 +1983,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_ARRAY_LENGTH FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL FLOAT TILDEMINUS ## -## Ends in an error in state: 331. +## Ends in an error in state: 324. ## ## binop_app -> simple . infix_binop simple [ KWD_WITH KWD_IN KWD_AND ] ## named -> simple . [ KWD_WITH KWD_IN KWD_AND ] @@ -2040,7 +1997,7 @@ expect_test_spec: KWD_LET IDENT EQUAL FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT TILDEMINUS ## -## Ends in an error in state: 345. +## Ends in an error in state: 338. ## ## binop_app -> simple infix_binop . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2052,7 +2009,7 @@ expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT FLOAT TILDEMINUS ## -## Ends in an error in state: 346. +## Ends in an error in state: 339. ## ## binop_app -> simple infix_binop simple . [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] @@ -2065,7 +2022,7 @@ expect_test_spec: KWD_LET IDENT EQUAL FLOAT MINUSDOT FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ TILDEMINUS ## -## Ends in an error in state: 350. +## Ends in an error in state: 343. ## ## binop_app -> prefix_binop . LPAREN simple COMMA simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2075,9 +2032,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN TILDEMINUS ## -## Ends in an error in state: 351. +## Ends in an error in state: 344. ## ## binop_app -> prefix_binop LPAREN . simple COMMA simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2087,9 +2044,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 352. +## Ends in an error in state: 345. ## ## binop_app -> prefix_binop LPAREN simple . COMMA simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE COMMA ] @@ -2100,9 +2057,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT COMMA TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT COMMA TILDEMINUS ## -## Ends in an error in state: 353. +## Ends in an error in state: 346. ## ## binop_app -> prefix_binop LPAREN simple COMMA . simple RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2112,9 +2069,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT COMMA TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT COMMA FLOAT TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BLOCK_LOAD LPAREN FLOAT COMMA FLOAT TILDEMINUS ## -## Ends in an error in state: 354. +## Ends in an error in state: 347. ## ## binop_app -> prefix_binop LPAREN simple COMMA simple . RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## simple -> simple . TILDE coercion [ TILDE RPAREN ] @@ -2127,7 +2084,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_PHYS_EQ LPAREN FLOAT COMMA FLOAT TILD expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET TILDEMINUS ## -## Ends in an error in state: 359. +## Ends in an error in state: 352. ## ## ternop_app -> bytes_or_bigstring_set . string_accessor_width simple DOT LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2139,7 +2096,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT TILDEMINUS ## -## Ends in an error in state: 360. +## Ends in an error in state: 353. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width . simple DOT LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2151,7 +2108,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT TILDEMINUS ## -## Ends in an error in state: 361. +## Ends in an error in state: 354. ## ## simple -> simple . TILDE coercion [ TILDE DOT ] ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple . DOT LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] @@ -2164,7 +2121,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT TILDEMINUS expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT TILDEMINUS ## -## Ends in an error in state: 362. +## Ends in an error in state: 355. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT . LPAREN simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2176,7 +2133,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT TILDEMINU expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN TILDEMINUS ## -## Ends in an error in state: 363. +## Ends in an error in state: 356. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN . simple RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2188,7 +2145,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN TI expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 364. +## Ends in an error in state: 357. ## ## simple -> simple . TILDE coercion [ TILDE RPAREN ] ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN simple . RPAREN simple [ KWD_WITH KWD_IN KWD_AND ] @@ -2201,7 +2158,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FL expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 365. +## Ends in an error in state: 358. ## ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN simple RPAREN . simple [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2213,7 +2170,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FL expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FLOAT RPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 366. +## Ends in an error in state: 359. ## ## simple -> simple . TILDE coercion [ TILDE KWD_WITH KWD_IN KWD_AND ] ## ternop_app -> bytes_or_bigstring_set string_accessor_width simple DOT LPAREN simple RPAREN simple . [ KWD_WITH KWD_IN KWD_AND ] @@ -2226,7 +2183,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BIGSTRING_SET INT FLOAT DOT LPAREN FL expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED TILDEMINUS ## -## Ends in an error in state: 369. +## Ends in an error in state: 362. ## ## separated_nonempty_list(KWD_AND,symbol_binding) -> symbol_binding . [ KWD_WITH KWD_IN ] ## separated_nonempty_list(KWD_AND,symbol_binding) -> symbol_binding . KWD_AND separated_nonempty_list(KWD_AND,symbol_binding) [ KWD_WITH KWD_IN ] @@ -2239,7 +2196,7 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED TILDEMINUS expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_AND TILDEMINUS ## -## Ends in an error in state: 370. +## Ends in an error in state: 363. ## ## separated_nonempty_list(KWD_AND,symbol_binding) -> symbol_binding KWD_AND . separated_nonempty_list(KWD_AND,symbol_binding) [ KWD_WITH KWD_IN ] ## @@ -2251,7 +2208,7 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_AND TILDEMINUS expect_test_spec: KWD_LET SYMBOL TILDEMINUS ## -## Ends in an error in state: 371. +## Ends in an error in state: 364. ## ## static_closure_binding -> symbol . EQUAL fun_decl [ KWD_WITH KWD_IN KWD_AND ] ## static_data_binding -> symbol . EQUAL static_data [ KWD_WITH KWD_IN KWD_AND ] @@ -2264,7 +2221,7 @@ expect_test_spec: KWD_LET SYMBOL TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL TILDEMINUS ## -## Ends in an error in state: 372. +## Ends in an error in state: 365. ## ## static_closure_binding -> symbol EQUAL . fun_decl [ KWD_WITH KWD_IN KWD_AND ] ## static_data_binding -> symbol EQUAL . static_data [ KWD_WITH KWD_IN KWD_AND ] @@ -2277,7 +2234,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK TILDEMINUS ## -## Ends in an error in state: 374. +## Ends in an error in state: 367. ## ## static_data -> STATIC_CONST_FLOAT_BLOCK . LPAREN loption(separated_nonempty_list(COMMA,float_or_variable)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2289,7 +2246,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN TILDEMINUS ## -## Ends in an error in state: 375. +## Ends in an error in state: 368. ## ## static_data -> STATIC_CONST_FLOAT_BLOCK LPAREN . loption(separated_nonempty_list(COMMA,float_or_variable)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2301,7 +2258,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN TILDEMINU expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 381. +## Ends in an error in state: 374. ## ## separated_nonempty_list(COMMA,float_or_variable) -> float_or_variable . [ RPAREN ] ## separated_nonempty_list(COMMA,float_or_variable) -> float_or_variable . COMMA separated_nonempty_list(COMMA,float_or_variable) [ RPAREN ] @@ -2314,7 +2271,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT TIL expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT COMMA TILDEMINUS ## -## Ends in an error in state: 382. +## Ends in an error in state: 375. ## ## separated_nonempty_list(COMMA,float_or_variable) -> float_or_variable COMMA . separated_nonempty_list(COMMA,float_or_variable) [ RPAREN ] ## @@ -2326,7 +2283,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_BLOCK LPAREN IDENT COM expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY TILDEMINUS ## -## Ends in an error in state: 384. +## Ends in an error in state: 377. ## ## static_data -> STATIC_CONST_FLOAT_ARRAY . LBRACKPIPE loption(separated_nonempty_list(SEMICOLON,float_or_variable)) RBRACKPIPE [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2338,7 +2295,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE TILDEMINUS ## -## Ends in an error in state: 385. +## Ends in an error in state: 378. ## ## static_data -> STATIC_CONST_FLOAT_ARRAY LBRACKPIPE . loption(separated_nonempty_list(SEMICOLON,float_or_variable)) RBRACKPIPE [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2350,7 +2307,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE TILDE expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT TILDEMINUS ## -## Ends in an error in state: 389. +## Ends in an error in state: 382. ## ## separated_nonempty_list(SEMICOLON,float_or_variable) -> float_or_variable . [ RBRACKPIPE ] ## separated_nonempty_list(SEMICOLON,float_or_variable) -> float_or_variable . SEMICOLON separated_nonempty_list(SEMICOLON,float_or_variable) [ RBRACKPIPE ] @@ -2363,7 +2320,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT SEMICOLON TILDEMINUS ## -## Ends in an error in state: 390. +## Ends in an error in state: 383. ## ## separated_nonempty_list(SEMICOLON,float_or_variable) -> float_or_variable SEMICOLON . separated_nonempty_list(SEMICOLON,float_or_variable) [ RBRACKPIPE ] ## @@ -2375,7 +2332,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_FLOAT_ARRAY LBRACKPIPE IDENT expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK TILDEMINUS ## -## Ends in an error in state: 394. +## Ends in an error in state: 387. ## ## static_data -> STATIC_CONST_BLOCK . mutability tag LPAREN loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2387,7 +2344,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK KWD_IMMUTABLE_UNIQUE TILDEMINUS ## -## Ends in an error in state: 395. +## Ends in an error in state: 388. ## ## static_data -> STATIC_CONST_BLOCK mutability . tag LPAREN loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2399,7 +2356,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK KWD_IMMUTABLE_UNIQUE T expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT TILDEMINUS ## -## Ends in an error in state: 396. +## Ends in an error in state: 389. ## ## static_data -> STATIC_CONST_BLOCK mutability tag . LPAREN loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2411,7 +2368,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN TILDEMINUS ## -## Ends in an error in state: 397. +## Ends in an error in state: 390. ## ## static_data -> STATIC_CONST_BLOCK mutability tag LPAREN . loption(separated_nonempty_list(COMMA,field_of_block)) RPAREN [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2423,7 +2380,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL TILDEMINUS ## -## Ends in an error in state: 404. +## Ends in an error in state: 397. ## ## separated_nonempty_list(COMMA,field_of_block) -> field_of_block . [ RPAREN ] ## separated_nonempty_list(COMMA,field_of_block) -> field_of_block . COMMA separated_nonempty_list(COMMA,field_of_block) [ RPAREN ] @@ -2436,7 +2393,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL TILD expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL COMMA TILDEMINUS ## -## Ends in an error in state: 405. +## Ends in an error in state: 398. ## ## separated_nonempty_list(COMMA,field_of_block) -> field_of_block COMMA . separated_nonempty_list(COMMA,field_of_block) [ RPAREN ] ## @@ -2448,7 +2405,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL STATIC_CONST_BLOCK INT LPAREN SYMBOL COMM expect_test_spec: KWD_LET SYMBOL EQUAL KWD_MUTABLE TILDEMINUS ## -## Ends in an error in state: 407. +## Ends in an error in state: 400. ## ## static_data -> KWD_MUTABLE . STRING [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2460,7 +2417,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL KWD_MUTABLE TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT TILDEMINUS ## -## Ends in an error in state: 411. +## Ends in an error in state: 404. ## ## static_data -> variable . COLON static_data_kind [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2472,7 +2429,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON TILDEMINUS ## -## Ends in an error in state: 412. +## Ends in an error in state: 405. ## ## static_data -> variable COLON . static_data_kind [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2484,7 +2441,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_NATIVEINT TILDEMINUS ## -## Ends in an error in state: 413. +## Ends in an error in state: 406. ## ## static_data_kind -> KWD_NATIVEINT . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2496,7 +2453,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_NATIVEINT TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT64 TILDEMINUS ## -## Ends in an error in state: 415. +## Ends in an error in state: 408. ## ## static_data_kind -> KWD_INT64 . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2508,7 +2465,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT64 TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT32 TILDEMINUS ## -## Ends in an error in state: 417. +## Ends in an error in state: 410. ## ## static_data_kind -> KWD_INT32 . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2520,7 +2477,7 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_INT32 TILDEMINUS expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 419. +## Ends in an error in state: 412. ## ## static_data_kind -> KWD_FLOAT . KWD_BOXED [ KWD_WITH KWD_IN KWD_AND ] ## @@ -2532,9 +2489,9 @@ expect_test_spec: KWD_LET SYMBOL EQUAL IDENT COLON KWD_FLOAT TILDEMINUS expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 428. +## Ends in an error in state: 421. ## -## code -> code_header . kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header . kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header @@ -2544,7 +2501,7 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN TILDEMINUS ## -## Ends in an error in state: 429. +## Ends in an error in state: 422. ## ## kinded_args -> LPAREN . separated_nonempty_list(COMMA,kinded_variable) RPAREN [ IDENT EQUAL ] ## @@ -2556,7 +2513,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 430. +## Ends in an error in state: 423. ## ## kinded_variable -> variable . kind_with_subkind_opt [ RPAREN COMMA ] ## @@ -2568,7 +2525,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON TILDEMINUS ## -## Ends in an error in state: 431. +## Ends in an error in state: 424. ## ## kind_with_subkind_opt -> COLON . kind_with_subkind [ RPAREN COMMA ] ## @@ -2580,7 +2537,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK TILDEMINUS ## -## Ends in an error in state: 432. +## Ends in an error in state: 425. ## ## subkind -> LBRACK . ctors RBRACK [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## @@ -2592,7 +2549,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT TILDEMINUS ## -## Ends in an error in state: 433. +## Ends in an error in state: 426. ## ## tag -> INT . [ KWD_OF ] ## targetint -> INT . [ RBRACK PIPE ] @@ -2605,7 +2562,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT PIPE TILDEMINUS ## -## Ends in an error in state: 435. +## Ends in an error in state: 428. ## ## ctors_nonempty -> targetint PIPE . ctors_nonempty [ RBRACK ] ## @@ -2617,7 +2574,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT PIPE TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE INT TILDEMINUS ## -## Ends in an error in state: 436. +## Ends in an error in state: 429. ## ## nonconst_ctor -> tag . KWD_OF kinds_with_subkinds_nonempty [ RBRACK PIPE ] ## @@ -2629,7 +2586,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF TILDEMINUS ## -## Ends in an error in state: 437. +## Ends in an error in state: 430. ## ## nonconst_ctor -> tag KWD_OF . kinds_with_subkinds_nonempty [ RBRACK PIPE ] ## @@ -2641,7 +2598,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_VAL TILDEMINUS ## -## Ends in an error in state: 438. +## Ends in an error in state: 431. ## ## subkind -> KWD_VAL . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_VAL . KWD_ARRAY [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2654,7 +2611,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_VAL TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_NATIVEINT TILDEMINUS ## -## Ends in an error in state: 442. +## Ends in an error in state: 435. ## ## naked_number_kind -> KWD_NATIVEINT . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_NATIVEINT . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2667,7 +2624,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_NATIVEINT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT64 TILDEMINUS ## -## Ends in an error in state: 444. +## Ends in an error in state: 437. ## ## naked_number_kind -> KWD_INT64 . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_INT64 . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2680,7 +2637,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT64 TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT32 TILDEMINUS ## -## Ends in an error in state: 446. +## Ends in an error in state: 439. ## ## naked_number_kind -> KWD_INT32 . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_INT32 . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2693,7 +2650,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_INT32 TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_IMM TILDEMINUS ## -## Ends in an error in state: 448. +## Ends in an error in state: 441. ## ## naked_number_kind -> KWD_IMM . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_IMM . KWD_TAGGED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2707,7 +2664,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_IMM TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT TILDEMINUS ## -## Ends in an error in state: 451. +## Ends in an error in state: 444. ## ## naked_number_kind -> KWD_FLOAT . [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## subkind -> KWD_FLOAT . KWD_BOXED [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] @@ -2722,7 +2679,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT CARET TILDEMINUS ## -## Ends in an error in state: 454. +## Ends in an error in state: 447. ## ## subkind -> KWD_FLOAT CARET . plain_int [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## @@ -2734,7 +2691,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT CARET TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_ANY TILDEMINUS ## -## Ends in an error in state: 456. +## Ends in an error in state: 449. ## ## subkind -> KWD_ANY . KWD_ARRAY [ STAR RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL COMMA ] ## @@ -2746,7 +2703,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_ANY TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_REC_INFO TILDEMINUS ## -## Ends in an error in state: 462. +## Ends in an error in state: 455. ## ## separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind . [ RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL ] ## separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind . STAR separated_nonempty_list(STAR,kind_with_subkind) [ RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL ] @@ -2759,7 +2716,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_REC_INFO TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT STAR TILDEMINUS ## -## Ends in an error in state: 463. +## Ends in an error in state: 456. ## ## separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind STAR . separated_nonempty_list(STAR,kind_with_subkind) [ RPAREN RBRACK PIPE MINUSGREATER KWD_LOCAL EQUAL ] ## @@ -2771,7 +2728,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT STAR TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT RPAREN ## -## Ends in an error in state: 467. +## Ends in an error in state: 460. ## ## separated_nonempty_list(PIPE,nonconst_ctor) -> nonconst_ctor . [ RBRACK ] ## separated_nonempty_list(PIPE,nonconst_ctor) -> nonconst_ctor . PIPE separated_nonempty_list(PIPE,nonconst_ctor) [ RBRACK ] @@ -2783,18 +2740,18 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT RPARE ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 451, spurious reduction of production naked_number_kind -> KWD_FLOAT -## In state 460, spurious reduction of production kind_with_subkind -> naked_number_kind -## In state 462, spurious reduction of production separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind -## In state 459, spurious reduction of production kinds_with_subkinds_nonempty -> separated_nonempty_list(STAR,kind_with_subkind) -## In state 461, spurious reduction of production nonconst_ctor -> tag KWD_OF kinds_with_subkinds_nonempty +## In state 444, spurious reduction of production naked_number_kind -> KWD_FLOAT +## In state 453, spurious reduction of production kind_with_subkind -> naked_number_kind +## In state 455, spurious reduction of production separated_nonempty_list(STAR,kind_with_subkind) -> kind_with_subkind +## In state 452, spurious reduction of production kinds_with_subkinds_nonempty -> separated_nonempty_list(STAR,kind_with_subkind) +## In state 454, spurious reduction of production nonconst_ctor -> tag KWD_OF kinds_with_subkinds_nonempty ## expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE TILDEMINUS ## -## Ends in an error in state: 468. +## Ends in an error in state: 461. ## ## separated_nonempty_list(PIPE,nonconst_ctor) -> nonconst_ctor PIPE . separated_nonempty_list(PIPE,nonconst_ctor) [ RBRACK ] ## @@ -2806,7 +2763,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON LBRACK INT KWD_OF KWD_FLOAT PIPE expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON KWD_REC_INFO TILDEMINUS ## -## Ends in an error in state: 478. +## Ends in an error in state: 471. ## ## separated_nonempty_list(COMMA,kinded_variable) -> kinded_variable . [ RPAREN ] ## separated_nonempty_list(COMMA,kinded_variable) -> kinded_variable . COMMA separated_nonempty_list(COMMA,kinded_variable) [ RPAREN ] @@ -2819,7 +2776,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COLON KWD_REC_INFO TILDEM expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COMMA TILDEMINUS ## -## Ends in an error in state: 479. +## Ends in an error in state: 472. ## ## separated_nonempty_list(COMMA,kinded_variable) -> kinded_variable COMMA . separated_nonempty_list(COMMA,kinded_variable) [ RPAREN ] ## @@ -2831,9 +2788,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT COMMA TILDEMINUS expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT LPAREN IDENT RPAREN TILDEMINUS ## -## Ends in an error in state: 481. +## Ends in an error in state: 474. ## -## code -> code_header kinded_args . variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args . variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args @@ -2843,9 +2800,9 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT LPAREN IDENT expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 482. +## Ends in an error in state: 475. ## -## code -> code_header kinded_args variable . variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable . variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args variable @@ -2855,9 +2812,9 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT TILDEM expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 483. +## Ends in an error in state: 476. ## -## code -> code_header kinded_args variable variable . variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable . variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args variable variable @@ -2867,9 +2824,9 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT TILDEMINUS ## -## Ends in an error in state: 484. +## Ends in an error in state: 477. ## -## code -> code_header kinded_args variable variable variable . variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable . MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: ## code_header kinded_args variable variable variable @@ -2877,45 +2834,33 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT TILDEMINUS -## -## Ends in an error in state: 485. +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER TILDEMINUS ## -## code -> code_header kinded_args variable variable variable variable . MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] -## -## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable -## - - - -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER TILDEMINUS -## -## Ends in an error in state: 486. +## Ends in an error in state: 478. ## -## code -> code_header kinded_args variable variable variable variable MINUSGREATER . continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable MINUSGREATER . continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable MINUSGREATER +## code_header kinded_args variable variable variable MINUSGREATER ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT TILDEMINUS ## -## Ends in an error in state: 487. +## Ends in an error in state: 479. ## -## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id . exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id . exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id +## code_header kinded_args variable variable variable MINUSGREATER continuation_id ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR TILDEMINUS ## -## Ends in an error in state: 488. +## Ends in an error in state: 480. ## ## exn_continuation_id -> STAR . continuation_id [ KWD_LOCAL EQUAL COLON ] ## @@ -2925,21 +2870,21 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT TILDEMINUS ## -## Ends in an error in state: 490. +## Ends in an error in state: 482. ## -## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id . return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id . return_arity boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id +## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON TILDEMINUS ## -## Ends in an error in state: 491. +## Ends in an error in state: 483. ## ## return_arity -> COLON . kinds_with_subkinds [ KWD_LOCAL EQUAL ] ## @@ -2949,45 +2894,45 @@ expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON KWD_UNIT TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT COLON KWD_UNIT TILDEMINUS ## -## Ends in an error in state: 495. +## Ends in an error in state: 487. ## -## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity . boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity . boption(KWD_LOCAL) EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity +## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT KWD_LOCAL TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT KWD_LOCAL TILDEMINUS ## -## Ends in an error in state: 497. +## Ends in an error in state: 489. ## -## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) . EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) . EQUAL expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) +## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) ## -expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT EQUAL TILDEMINUS +expect_test_spec: KWD_LET KWD_CODE KWD_SIZE LPAREN INT RPAREN IDENT IDENT IDENT IDENT MINUSGREATER IDENT STAR IDENT EQUAL TILDEMINUS ## -## Ends in an error in state: 498. +## Ends in an error in state: 490. ## -## code -> code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL . expr [ KWD_WITH KWD_IN KWD_AND ] +## code -> code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL . expr [ KWD_WITH KWD_IN KWD_AND ] ## ## The known suffix of the stack is as follows: -## code_header kinded_args variable variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL +## code_header kinded_args variable variable variable MINUSGREATER continuation_id exn_continuation_id return_arity boption(KWD_LOCAL) EQUAL ## expect_test_spec: KWD_INVALID TILDEMINUS ## -## Ends in an error in state: 499. +## Ends in an error in state: 491. ## ## atomic_expr -> KWD_INVALID . STRING [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -2999,7 +2944,7 @@ expect_test_spec: KWD_INVALID TILDEMINUS expect_test_spec: KWD_CONT TILDEMINUS ## -## Ends in an error in state: 502. +## Ends in an error in state: 494. ## ## atomic_expr -> KWD_CONT . apply_cont_expr [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3011,7 +2956,7 @@ expect_test_spec: KWD_CONT TILDEMINUS expect_test_spec: KWD_APPLY TILDEMINUS ## -## Ends in an error in state: 504. +## Ends in an error in state: 496. ## ## atomic_expr -> KWD_APPLY . apply_expr [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3023,9 +2968,9 @@ expect_test_spec: KWD_APPLY TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT TILDEMINUS ## -## Ends in an error in state: 505. +## Ends in an error in state: 497. ## -## call_kind -> KWD_DIRECT . LPAREN code_id function_slot_opt alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT . LPAREN code_id function_slot_opt alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT @@ -3035,9 +2980,9 @@ expect_test_spec: KWD_APPLY KWD_DIRECT TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN TILDEMINUS ## -## Ends in an error in state: 506. +## Ends in an error in state: 498. ## -## call_kind -> KWD_DIRECT LPAREN . code_id function_slot_opt alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN . code_id function_slot_opt alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT LPAREN @@ -3047,9 +2992,9 @@ expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT TILDEMINUS ## -## Ends in an error in state: 507. +## Ends in an error in state: 499. ## -## call_kind -> KWD_DIRECT LPAREN code_id . function_slot_opt alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN code_id . function_slot_opt alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT LPAREN code_id @@ -3059,9 +3004,9 @@ expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT TILDEMINUS expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AT IDENT TILDEMINUS ## -## Ends in an error in state: 508. +## Ends in an error in state: 500. ## -## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt . alloc_mode_for_applications_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt . alloc_mode_for_allocations_opt RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: ## KWD_DIRECT LPAREN code_id function_slot_opt @@ -3069,57 +3014,21 @@ expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AT IDENT TILDEMINUS -expect_test_spec: KWD_APPLY AMP TILDEMINUS -## -## Ends in an error in state: 509. -## -## alloc_mode_for_applications_opt -> AMP . region AMP region [ SYMBOL RPAREN LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] -## -## The known suffix of the stack is as follows: -## AMP -## - - - -expect_test_spec: KWD_APPLY AMP IDENT TILDEMINUS -## -## Ends in an error in state: 510. -## -## alloc_mode_for_applications_opt -> AMP region . AMP region [ SYMBOL RPAREN LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] -## -## The known suffix of the stack is as follows: -## AMP region -## - - - -expect_test_spec: KWD_APPLY AMP IDENT AMP TILDEMINUS -## -## Ends in an error in state: 511. -## -## alloc_mode_for_applications_opt -> AMP region AMP . region [ SYMBOL RPAREN LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] -## -## The known suffix of the stack is as follows: -## AMP region AMP -## - - - -expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AMP IDENT AMP IDENT TILDEMINUS +expect_test_spec: KWD_APPLY KWD_DIRECT LPAREN IDENT AMP IDENT TILDEMINUS ## -## Ends in an error in state: 513. +## Ends in an error in state: 501. ## -## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_applications_opt . RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] +## call_kind -> KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_allocations_opt . RPAREN [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## ## The known suffix of the stack is as follows: -## KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_applications_opt +## KWD_DIRECT LPAREN code_id function_slot_opt alloc_mode_for_allocations_opt ## expect_test_spec: KWD_APPLY KWD_CCALL TILDEMINUS ## -## Ends in an error in state: 515. +## Ends in an error in state: 503. ## ## call_kind -> KWD_CCALL . boption(KWD_NOALLOC) [ SYMBOL LPAREN KWD_UNROLL KWD_INLINING_STATE KWD_INLINED INT IDENT FLOAT ] ## @@ -3129,9 +3038,9 @@ expect_test_spec: KWD_APPLY KWD_CCALL TILDEMINUS -expect_test_spec: KWD_APPLY KWD_CCALL KWD_NOALLOC TILDEMINUS +expect_test_spec: KWD_APPLY AMP IDENT TILDEMINUS ## -## Ends in an error in state: 518. +## Ends in an error in state: 506. ## ## apply_expr -> call_kind . option(inlined) option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3143,7 +3052,7 @@ expect_test_spec: KWD_APPLY KWD_CCALL KWD_NOALLOC TILDEMINUS expect_test_spec: KWD_APPLY KWD_UNROLL TILDEMINUS ## -## Ends in an error in state: 519. +## Ends in an error in state: 507. ## ## inlined -> KWD_UNROLL . LPAREN plain_int RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3155,7 +3064,7 @@ expect_test_spec: KWD_APPLY KWD_UNROLL TILDEMINUS expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN TILDEMINUS ## -## Ends in an error in state: 520. +## Ends in an error in state: 508. ## ## inlined -> KWD_UNROLL LPAREN . plain_int RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3167,7 +3076,7 @@ expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN INT TILDEMINUS ## -## Ends in an error in state: 521. +## Ends in an error in state: 509. ## ## inlined -> KWD_UNROLL LPAREN plain_int . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3179,7 +3088,7 @@ expect_test_spec: KWD_APPLY KWD_UNROLL LPAREN INT TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED TILDEMINUS ## -## Ends in an error in state: 523. +## Ends in an error in state: 511. ## ## inlined -> KWD_INLINED . LPAREN KWD_ALWAYS RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## inlined -> KWD_INLINED . LPAREN KWD_HINT RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] @@ -3194,7 +3103,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN TILDEMINUS ## -## Ends in an error in state: 524. +## Ends in an error in state: 512. ## ## inlined -> KWD_INLINED LPAREN . KWD_ALWAYS RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## inlined -> KWD_INLINED LPAREN . KWD_HINT RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] @@ -3209,7 +3118,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_NEVER TILDEMINUS ## -## Ends in an error in state: 525. +## Ends in an error in state: 513. ## ## inlined -> KWD_INLINED LPAREN KWD_NEVER . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3221,7 +3130,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_NEVER TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_HINT TILDEMINUS ## -## Ends in an error in state: 527. +## Ends in an error in state: 515. ## ## inlined -> KWD_INLINED LPAREN KWD_HINT . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3233,7 +3142,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_HINT TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_DEFAULT TILDEMINUS ## -## Ends in an error in state: 529. +## Ends in an error in state: 517. ## ## inlined -> KWD_INLINED LPAREN KWD_DEFAULT . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3245,7 +3154,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_DEFAULT TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS TILDEMINUS ## -## Ends in an error in state: 531. +## Ends in an error in state: 519. ## ## inlined -> KWD_INLINED LPAREN KWD_ALWAYS . RPAREN [ SYMBOL LPAREN KWD_INLINING_STATE INT IDENT FLOAT ] ## @@ -3257,7 +3166,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS RPAREN TILDEMINUS ## -## Ends in an error in state: 533. +## Ends in an error in state: 521. ## ## apply_expr -> call_kind option(inlined) . option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3269,7 +3178,7 @@ expect_test_spec: KWD_APPLY KWD_INLINED LPAREN KWD_ALWAYS RPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE TILDEMINUS ## -## Ends in an error in state: 534. +## Ends in an error in state: 522. ## ## inlining_state -> KWD_INLINING_STATE . LPAREN inlining_state_depth RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -3281,7 +3190,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN TILDEMINUS ## -## Ends in an error in state: 535. +## Ends in an error in state: 523. ## ## inlining_state -> KWD_INLINING_STATE LPAREN . inlining_state_depth RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -3293,7 +3202,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH TILDEMINUS ## -## Ends in an error in state: 536. +## Ends in an error in state: 524. ## ## inlining_state_depth -> KWD_DEPTH . LPAREN plain_int RPAREN [ RPAREN ] ## @@ -3305,7 +3214,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH TILDEMINUS expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN TILDEMINUS ## -## Ends in an error in state: 537. +## Ends in an error in state: 525. ## ## inlining_state_depth -> KWD_DEPTH LPAREN . plain_int RPAREN [ RPAREN ] ## @@ -3317,7 +3226,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN TILDEMINU expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT TILDEMINUS ## -## Ends in an error in state: 538. +## Ends in an error in state: 526. ## ## inlining_state_depth -> KWD_DEPTH LPAREN plain_int . RPAREN [ RPAREN ] ## @@ -3329,7 +3238,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT TILDE expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPAREN TILDEMINUS ## -## Ends in an error in state: 540. +## Ends in an error in state: 528. ## ## inlining_state -> KWD_INLINING_STATE LPAREN inlining_state_depth . RPAREN [ SYMBOL LPAREN INT IDENT FLOAT ] ## @@ -3341,7 +3250,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPARE expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPAREN RPAREN TILDEMINUS ## -## Ends in an error in state: 542. +## Ends in an error in state: 530. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) . func_name_with_optional_arities simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3353,7 +3262,7 @@ expect_test_spec: KWD_APPLY KWD_INLINING_STATE LPAREN KWD_DEPTH LPAREN INT RPARE expect_test_spec: KWD_APPLY LPAREN TILDEMINUS ## -## Ends in an error in state: 543. +## Ends in an error in state: 531. ## ## func_name_with_optional_arities -> LPAREN . simple COLON blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3365,7 +3274,7 @@ expect_test_spec: KWD_APPLY LPAREN TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT TILDEMINUS ## -## Ends in an error in state: 544. +## Ends in an error in state: 532. ## ## func_name_with_optional_arities -> LPAREN simple . COLON blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## simple -> simple . TILDE coercion [ TILDE COLON ] @@ -3378,7 +3287,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON TILDEMINUS ## -## Ends in an error in state: 545. +## Ends in an error in state: 533. ## ## func_name_with_optional_arities -> LPAREN simple COLON . blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3390,7 +3299,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_UNIT TILDEMINUS ## -## Ends in an error in state: 548. +## Ends in an error in state: 536. ## ## func_name_with_optional_arities -> LPAREN simple COLON blank_or(kinds_with_subkinds) . MINUSGREATER kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3402,7 +3311,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_UNIT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER TILDEMINUS ## -## Ends in an error in state: 549. +## Ends in an error in state: 537. ## ## func_name_with_optional_arities -> LPAREN simple COLON blank_or(kinds_with_subkinds) MINUSGREATER . kinds_with_subkinds RPAREN [ MINUSGREATER LPAREN ] ## @@ -3414,7 +3323,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_UNIT TILDEMINUS ## -## Ends in an error in state: 550. +## Ends in an error in state: 538. ## ## func_name_with_optional_arities -> LPAREN simple COLON blank_or(kinds_with_subkinds) MINUSGREATER kinds_with_subkinds . RPAREN [ MINUSGREATER LPAREN ] ## @@ -3426,7 +3335,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_UNIT T expect_test_spec: KWD_APPLY FLOAT TILDEMINUS ## -## Ends in an error in state: 552. +## Ends in an error in state: 540. ## ## func_name_with_optional_arities -> simple . [ MINUSGREATER LPAREN ] ## simple -> simple . TILDE coercion [ TILDE MINUSGREATER LPAREN ] @@ -3439,7 +3348,7 @@ expect_test_spec: KWD_APPLY FLOAT TILDEMINUS expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 553. +## Ends in an error in state: 541. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities . simple_args MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3451,7 +3360,7 @@ expect_test_spec: KWD_APPLY LPAREN FLOAT COLON KWD_FLOAT MINUSGREATER KWD_FLOAT expect_test_spec: KWD_APPLY FLOAT LPAREN FLOAT RPAREN TILDEMINUS ## -## Ends in an error in state: 554. +## Ends in an error in state: 542. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities simple_args . MINUSGREATER result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3463,7 +3372,7 @@ expect_test_spec: KWD_APPLY FLOAT LPAREN FLOAT RPAREN TILDEMINUS expect_test_spec: KWD_APPLY FLOAT MINUSGREATER TILDEMINUS ## -## Ends in an error in state: 555. +## Ends in an error in state: 543. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER . result_continuation exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3475,7 +3384,7 @@ expect_test_spec: KWD_APPLY FLOAT MINUSGREATER TILDEMINUS expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT TILDEMINUS ## -## Ends in an error in state: 557. +## Ends in an error in state: 545. ## ## apply_expr -> call_kind option(inlined) option(inlining_state) func_name_with_optional_arities simple_args MINUSGREATER result_continuation . exn_continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3487,7 +3396,7 @@ expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT TILDEMINUS expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT STAR TILDEMINUS ## -## Ends in an error in state: 558. +## Ends in an error in state: 546. ## ## exn_continuation -> STAR . continuation [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3499,7 +3408,7 @@ expect_test_spec: KWD_APPLY FLOAT MINUSGREATER IDENT STAR TILDEMINUS expect_test_spec: KWD_HCF TILDEMINUS ## -## Ends in an error in state: 569. +## Ends in an error in state: 557. ## ## expr -> inner_expr . [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## where_expr -> inner_expr . KWD_WHERE recursive loption(separated_nonempty_list(KWD_ANDWHERE,continuation_binding)) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] @@ -3512,7 +3421,7 @@ expect_test_spec: KWD_HCF TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE TILDEMINUS ## -## Ends in an error in state: 570. +## Ends in an error in state: 558. ## ## where_expr -> inner_expr KWD_WHERE . recursive loption(separated_nonempty_list(KWD_ANDWHERE,continuation_binding)) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3524,7 +3433,7 @@ expect_test_spec: KWD_HCF KWD_WHERE TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE KWD_REC TILDEMINUS ## -## Ends in an error in state: 571. +## Ends in an error in state: 559. ## ## where_expr -> inner_expr KWD_WHERE recursive . loption(separated_nonempty_list(KWD_ANDWHERE,continuation_binding)) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3536,7 +3445,7 @@ expect_test_spec: KWD_HCF KWD_WHERE KWD_REC TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT TILDEMINUS ## -## Ends in an error in state: 574. +## Ends in an error in state: 562. ## ## continuation_binding -> continuation_id . continuation_sort kinded_args EQUAL continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3548,7 +3457,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT KWD_DEFINE_ROOT_SYMBOL TILDEMINUS ## -## Ends in an error in state: 577. +## Ends in an error in state: 565. ## ## continuation_binding -> continuation_id continuation_sort . kinded_args EQUAL continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3560,7 +3469,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT KWD_DEFINE_ROOT_SYMBOL TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT RPAREN TILDEMINUS ## -## Ends in an error in state: 578. +## Ends in an error in state: 566. ## ## continuation_binding -> continuation_id continuation_sort kinded_args . EQUAL continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3572,7 +3481,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT LPAREN IDENT RPAREN TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL TILDEMINUS ## -## Ends in an error in state: 579. +## Ends in an error in state: 567. ## ## continuation_binding -> continuation_id continuation_sort kinded_args EQUAL . continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3584,7 +3493,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET TILDEMINUS ## -## Ends in an error in state: 580. +## Ends in an error in state: 568. ## ## let_expr(continuation_body) -> KWD_LET . let_(continuation_body) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## let_symbol(continuation_body) -> KWD_LET . separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt KWD_IN continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] @@ -3597,7 +3506,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELETED KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 582. +## Ends in an error in state: 570. ## ## let_symbol(continuation_body) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt . KWD_IN continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3609,7 +3518,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELET expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELETED KWD_IN TILDEMINUS ## -## Ends in an error in state: 583. +## Ends in an error in state: 571. ## ## let_symbol(continuation_body) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt KWD_IN . continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3619,9 +3528,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET KWD_CODE IDENT KWD_DELET -expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE RBRACE TILDEMINUS +expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 589. +## Ends in an error in state: 577. ## ## let_(continuation_body) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt . KWD_IN continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3631,9 +3540,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_G -expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_IN TILDEMINUS +expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_IN TILDEMINUS ## -## Ends in an error in state: 590. +## Ends in an error in state: 578. ## ## let_(continuation_body) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt KWD_IN . continuation_body [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3643,9 +3552,9 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_LET IDENT EQUAL PRIM_BEGIN_G -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION TILDEMINUS ## -## Ends in an error in state: 592. +## Ends in an error in state: 580. ## ## separated_nonempty_list(KWD_AND,let_binding) -> let_binding . [ KWD_WITH KWD_IN ] ## separated_nonempty_list(KWD_AND,let_binding) -> let_binding . KWD_AND separated_nonempty_list(KWD_AND,let_binding) [ KWD_WITH KWD_IN ] @@ -3656,9 +3565,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_AND TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_AND TILDEMINUS ## -## Ends in an error in state: 593. +## Ends in an error in state: 581. ## ## separated_nonempty_list(KWD_AND,let_binding) -> let_binding KWD_AND . separated_nonempty_list(KWD_AND,let_binding) [ KWD_WITH KWD_IN ] ## @@ -3670,7 +3579,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_AND TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF TILDEMINUS ## -## Ends in an error in state: 598. +## Ends in an error in state: 586. ## ## separated_nonempty_list(KWD_ANDWHERE,continuation_binding) -> continuation_binding . [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## separated_nonempty_list(KWD_ANDWHERE,continuation_binding) -> continuation_binding . KWD_ANDWHERE separated_nonempty_list(KWD_ANDWHERE,continuation_binding) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] @@ -3683,7 +3592,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF TILDEMINUS expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF KWD_ANDWHERE TILDEMINUS ## -## Ends in an error in state: 599. +## Ends in an error in state: 587. ## ## separated_nonempty_list(KWD_ANDWHERE,continuation_binding) -> continuation_binding KWD_ANDWHERE . separated_nonempty_list(KWD_ANDWHERE,continuation_binding) [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3695,7 +3604,7 @@ expect_test_spec: KWD_HCF KWD_WHERE IDENT EQUAL KWD_HCF KWD_ANDWHERE TILDEMINUS expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 604. +## Ends in an error in state: 592. ## ## let_symbol(expr) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt . KWD_IN expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3707,7 +3616,7 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_WITH LBRACE RBRACE TILD expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_IN TILDEMINUS ## -## Ends in an error in state: 605. +## Ends in an error in state: 593. ## ## let_symbol(expr) -> KWD_LET separated_nonempty_list(KWD_AND,symbol_binding) with_value_slots_opt KWD_IN . expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3717,9 +3626,9 @@ expect_test_spec: KWD_LET KWD_CODE IDENT KWD_DELETED KWD_IN TILDEMINUS -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE RBRACE TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_WITH LBRACE RBRACE TILDEMINUS ## -## Ends in an error in state: 608. +## Ends in an error in state: 596. ## ## let_(expr) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt . KWD_IN expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3729,9 +3638,9 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_WITH LBRACE RB -expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_IN TILDEMINUS +expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_REGION KWD_IN TILDEMINUS ## -## Ends in an error in state: 609. +## Ends in an error in state: 597. ## ## let_(expr) -> separated_nonempty_list(KWD_AND,let_binding) with_value_slots_opt KWD_IN . expr [ RPAREN KWD_WITH KWD_IN KWD_AND EOF BIGARROW ] ## @@ -3743,7 +3652,7 @@ expect_test_spec: KWD_LET IDENT EQUAL PRIM_BEGIN_GHOST_REGION KWD_IN TILDEMINUS expect_test_spec: LPAREN KWD_HCF KWD_WITH ## -## Ends in an error in state: 612. +## Ends in an error in state: 600. ## ## atomic_expr -> LPAREN expr . RPAREN [ RPAREN KWD_WITH KWD_WHERE KWD_IN KWD_ANDWHERE KWD_AND EOF BIGARROW ] ## @@ -3754,14 +3663,14 @@ expect_test_spec: LPAREN KWD_HCF KWD_WITH ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 569, spurious reduction of production expr -> inner_expr +## In state 557, spurious reduction of production expr -> inner_expr ## expect_test_spec: KWD_HCF RPAREN ## -## Ends in an error in state: 614. +## Ends in an error in state: 602. ## ## expect_test_spec -> module_ . BIGARROW module_ EOF [ # ] ## @@ -3772,15 +3681,15 @@ expect_test_spec: KWD_HCF RPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 569, spurious reduction of production expr -> inner_expr -## In state 618, spurious reduction of production module_ -> expr +## In state 557, spurious reduction of production expr -> inner_expr +## In state 606, spurious reduction of production module_ -> expr ## expect_test_spec: KWD_HCF BIGARROW TILDEMINUS ## -## Ends in an error in state: 615. +## Ends in an error in state: 603. ## ## expect_test_spec -> module_ BIGARROW . module_ EOF [ # ] ## @@ -3792,7 +3701,7 @@ expect_test_spec: KWD_HCF BIGARROW TILDEMINUS expect_test_spec: KWD_HCF BIGARROW KWD_HCF RPAREN ## -## Ends in an error in state: 616. +## Ends in an error in state: 604. ## ## expect_test_spec -> module_ BIGARROW module_ . EOF [ # ] ## @@ -3803,15 +3712,15 @@ expect_test_spec: KWD_HCF BIGARROW KWD_HCF RPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 569, spurious reduction of production expr -> inner_expr -## In state 618, spurious reduction of production module_ -> expr +## In state 557, spurious reduction of production expr -> inner_expr +## In state 606, spurious reduction of production module_ -> expr ## flambda_unit: TILDEMINUS ## -## Ends in an error in state: 620. +## Ends in an error in state: 608. ## ## flambda_unit' -> . flambda_unit [ # ] ## @@ -3823,7 +3732,7 @@ flambda_unit: TILDEMINUS flambda_unit: KWD_HCF RPAREN ## -## Ends in an error in state: 621. +## Ends in an error in state: 609. ## ## flambda_unit -> module_ . EOF [ # ] ## @@ -3834,8 +3743,8 @@ flambda_unit: KWD_HCF RPAREN ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 569, spurious reduction of production expr -> inner_expr -## In state 618, spurious reduction of production module_ -> expr +## In state 557, spurious reduction of production expr -> inner_expr +## In state 606, spurious reduction of production module_ -> expr ## From 488153b05c53e7fb523c6ce54fa0d4cf3b31e60d Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 11:51:34 -0500 Subject: [PATCH 06/19] Easy changes needed for ccasin's 2024-12-02 review --- lambda/matching.ml | 18 ++- lambda/translcore.ml | 19 +--- parsing/pprintast.ml | 103 ++++++++---------- .../typing-layouts-unboxed-records/basics.ml | 29 ++++- toplevel/genprintval.ml | 33 ++---- typing/ctype.ml | 27 +++-- typing/env.ml | 13 ++- typing/jkind.mli | 10 +- typing/oprint.ml | 18 ++- typing/outcometree.mli | 5 +- typing/parmatch.ml | 14 ++- typing/printpat.ml | 9 +- typing/printtyp.ml | 3 +- typing/tast_iterator.ml | 16 +-- typing/typecore.ml | 58 +++++----- typing/typedecl.ml | 2 +- typing/typedtree.mli | 4 +- typing/typeopt.ml | 3 +- typing/types.mli | 8 ++ utils/warnings.ml | 20 ++-- utils/warnings.mli | 8 +- 21 files changed, 224 insertions(+), 196 deletions(-) diff --git a/lambda/matching.ml b/lambda/matching.ml index 8223e03f31e..7ef6e282efb 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -2401,21 +2401,31 @@ let get_expr_args_record_unboxed_product ~scopes head (arg, _mut, _sort, _layout | _ -> assert false in + let lbl_layouts = + Array.map (fun lbl -> + Typeopt.layout_of_sort lbl.lbl_loc (Jkind.sort_of_jkind lbl.lbl_jkind) + ) all_labels + |> Array.to_list + in let rec make_args pos = if pos >= Array.length all_labels then rem else let lbl = all_labels.(pos) in jkind_layout_default_to_value_and_check_not_void head.pat_loc lbl.lbl_jkind; - let lbl_layouts = Array.map (fun lbl -> - Typeopt.layout_of_sort lbl.lbl_loc (Jkind.sort_of_jkind lbl.lbl_jkind) - ) lbl.lbl_all |> Array.to_list in let access = if Array.length all_labels = 1 then arg (* erase singleton unboxed records before lambda *) else Lprim (Punboxed_product_field (pos, lbl_layouts), [ arg ], loc) in - let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in + let str = + if Types.is_mutable lbl.lbl_mut then + fatal_error + ("Matching.get_expr_args_record_unboxed_product: " + ^ "unboxed record labels are never mutable") + else + Alias + in let sort = Jkind.sort_of_jkind lbl.lbl_jkind in let layout = Typeopt.layout_of_sort lbl.lbl_loc sort in (access, str, sort, layout) :: make_args (pos + 1) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 902668d671a..09f0a6f0d7d 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -386,23 +386,6 @@ let zero_alloc_of_application end | None, _ -> Zero_alloc_utils.Assume_info.none -(* CR layouts v5: [Punboxed_product_field] does not use special indexing for void, whereas - [lbl.lbl_pos] does, so we need to find the "normal" index. This function should be - removed, and we should just use [lbl.lbl_pos], once we remove [lbl_pos_void]. - - Asserts that this lbl is not void. *) -let lbl_idx lbl = - (* Reimplementation of OCaml 5's [Array.find_index] *) - let find_index f array = - let i = ref 0 in - while !i < (Array.length array) && not (f (Array.get array !i)) do - incr i - done; - if !i == Array.length array then None else Some !i - in - assert (lbl.lbl_pos <> lbl_pos_void); - find_index (fun { lbl_pos } -> lbl_pos = lbl.lbl_pos ) lbl.lbl_all |> Option.get - let rec transl_exp ~scopes sort e = transl_exp1 ~scopes ~in_new_scope:false sort e @@ -729,7 +712,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = (* erase singleton unboxed records before lambda *) targ else - Lprim (Punboxed_product_field (lbl_idx lbl, layouts), [targ], + Lprim (Punboxed_product_field (lbl.lbl_num, layouts), [targ], of_location ~scopes e.exp_loc) end | Texp_setfield(arg, arg_mode, id, lbl, newval) -> diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index a1bd72e467a..4f09fe078e1 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -704,16 +704,6 @@ and labeled_pattern1 ctxt (f:Format.formatter) (label, x) : unit = pattern1 ctxt f x and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with | Ppat_construct (({txt=Lident ("()"|"[]"|"true"|"false" as x);_}), None) -> @@ -737,19 +727,9 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_type li -> pp f "#%a" longident_loc li | Ppat_record (l, closed) -> - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end + record_pattern ctxt f ~unboxed:false l closed | Ppat_record_unboxed_product (l, closed) -> - begin match closed with - | Closed -> - pp f "@[<2>#{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>#{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end + record_pattern ctxt f ~unboxed:true l closed | Ppat_tuple (l, closed) -> labeled_tuple_pattern ctxt f ~unboxed:false l closed | Ppat_unboxed_tuple (l, closed) -> @@ -794,6 +774,24 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = (paren with_paren @@ pattern1 ctxt) p | _ -> paren true (pattern ctxt) f x +and record_pattern ctxt f ~unboxed l closed = + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + let hash = if unboxed then "#" else "" in + match closed with + | Closed -> + pp f "@[<2>%s{@;%a@;}@]" hash (list longident_x_pattern ~sep:";@;") l + | Open -> + pp f "@[<2>%s{@;%a;_}@]" hash (list longident_x_pattern ~sep:";@;") l + and labeled_tuple_pattern ctxt f ~unboxed l closed = let closed_flag ppf = function | Closed -> () @@ -1119,14 +1117,6 @@ and expression2 ctxt f x = | _ -> simple_expr ctxt f x and simple_expr ctxt f x = - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in if x.pexp_attributes <> [] then expression ctxt f x else match x.pexp_desc with | Pexp_construct _ when is_simple_construct (view_expr x) -> @@ -1169,13 +1159,9 @@ and simple_expr ctxt f x = (core_type ctxt) ct | Pexp_variant (l, None) -> pp f "`%a" ident_of_name l | Pexp_record (l, eo) -> - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l + record_expr ctxt f ~unboxed:false l eo | Pexp_record_unboxed_product (l, eo) -> - pp f "@[@[#{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l + record_expr ctxt f ~unboxed:true l eo | Pexp_array (mut, l) -> let punct = match mut with | Immutable -> ':' @@ -2006,7 +1992,7 @@ and type_def_list ctxt f (rf, exported, l) = (type_decl "type" rf) x (list ~sep:"@," (type_decl "and" Recursive)) xs -and record_declaration ctxt f lbls = +and record_declaration ctxt f ~unboxed lbls = let type_record_field f pld = let legacy, m = split_out_legacy_modalities pld.pld_modalities in pp f "@[<2>%a%a%a:@;%a%a@;%a@]" @@ -2017,22 +2003,9 @@ and record_declaration ctxt f lbls = optional_space_atat_modalities m (attributes ctxt) pld.pld_attributes in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls - -and record_unboxed_product_declaration ctxt f lbls = - let type_record_field f pld = - let legacy, m = split_out_legacy_modalities pld.pld_modalities in - pp f "@[<2>%a%a%a:@;%a%a@;%a@]" - mutable_flag pld.pld_mutable - optional_legacy_modalities legacy - ident_of_name pld.pld_name.txt - (core_type ctxt) pld.pld_type - optional_space_atat_modalities m - (attributes ctxt) pld.pld_attributes - in - pp f "#{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls + let hash = if unboxed then "#" else "" in + pp f "%s{@\n%a}" + hash (list type_record_field ~sep:";@\n" ) lbls and type_declaration ctxt f x = (* type_declaration has an attribute field, @@ -2070,9 +2043,9 @@ and type_declaration ctxt f x = in pp f "%t%t%a" intro priv variants xs | Ptype_abstract -> () | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + pp f "%t%t@;%a" intro priv (record_declaration ctxt ~unboxed:false) l | Ptype_record_unboxed_product l -> - pp f "%t%t@;%a" intro priv (record_unboxed_product_declaration ctxt) l + pp f "%t%t@;%a" intro priv (record_declaration ctxt ~unboxed:true) l | Ptype_open -> pp f "%t%t@;.." intro priv in let constraints f = @@ -2118,7 +2091,8 @@ and constructor_declaration ctxt f (name, vars_jkinds, args, res, attrs) = | Pcstr_tuple [] -> () | Pcstr_tuple l -> pp f "@;of@;%a" (list (modalities_type core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + | Pcstr_record l -> + pp f "@;of@;%a" (record_declaration ctxt ~unboxed:false) l ) args (attributes ctxt) attrs | Some r -> @@ -2130,7 +2104,8 @@ and constructor_declaration ctxt f (name, vars_jkinds, args, res, attrs) = (list (modalities_type core_type1 ctxt) ~sep:"@;*@;") l (core_type1 ctxt) r | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + pp f "%a@;->@;%a" (record_declaration ctxt ~unboxed:false) l + (core_type1 ctxt) r ) args (attributes ctxt) attrs @@ -2288,6 +2263,20 @@ and labeled_tuple_expr ctxt f ~unboxed x = pp f "@[%s(%a)@]" (if unboxed then "#" else "") (list (tuple_component ctxt) ~sep:",@;") x +and record_expr ctxt f ~unboxed l eo = + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + let hash = if unboxed then "#" else "" in + pp f "@[@[%s{@;%a%a@]@;}@]"(* "@[%s{%a%a}@]" *) + hash (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + and instance ctxt f x = match x with | { pmod_instance_head = head; pmod_instance_args = [] } -> pp f "%s" head diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index 7c12d0694f9..cb58cae28cf 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -124,6 +124,33 @@ type t = #{ is : #(int * int); } val add : t -> int = |}] +(* An unboxed record is not an allocation, but a regular record is *) + +type ('a, 'b) ab = { left : 'a ; right : 'b } +type ('a, 'b) ab_u = #{ left : 'a ; right : 'b } + +let f_unboxed_record (local_ left) (local_ right) = + let t = #{ left; right } in + let #{ left = left'; _ } = t in + left' +[%%expect{| +type ('a, 'b) ab = { left : 'a; right : 'b; } +type ('a, 'b) ab_u = #{ left : 'a; right : 'b; } +val f_unboxed_record : local_ 'a -> local_ 'b -> local_ 'a = +|}] + +let f_boxed_record (local_ left) (local_ right) = + let t = { left; right } in + let { left = left'; _ } = t in + left' +[%%expect{| +Line 4, characters 2-7: +4 | left' + ^^^^^ +Error: This value escapes its region. + Hint: Cannot return a local value without an "exclave_" annotation. +|}] + (* Mutable fields are not allowed *) type mut = #{ mutable i : int } @@ -131,7 +158,7 @@ type mut = #{ mutable i : int } Line 1, characters 14-29: 1 | type mut = #{ mutable i : int } ^^^^^^^^^^^^^^^ -Error: Unboxed records labels cannot be mutable +Error: Unboxed record labels cannot be mutable |}] (*********************************) diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 782edf4582b..fbaaedfb77a 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -245,9 +245,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | Outval_record_unboxed | Outval_record_mixed_block of mixed_product_shape - type outval_record_unboxed_product_rep = - | Outval_record_unboxed_product - type printing_jkind = | Print_as_value (* can interpret as a value and print *) | Print_as of string (* can't print *) @@ -520,18 +517,15 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct env path decl.type_params ty_list lbl_list pos obj rep end - | {type_kind = Type_record_unboxed_product(lbl_list, rep)} -> + | {type_kind = Type_record_unboxed_product + (lbl_list, Record_unboxed_product)} -> begin match check_depth depth obj ty with Some x -> x | None -> let pos = 0 in - let rep = - match rep with - | Record_unboxed_product -> Outval_record_unboxed_product - in tree_of_record_unboxed_product_fields depth env path decl.type_params ty_list - lbl_list pos obj rep + lbl_list pos obj end | {type_kind = Type_open} -> tree_of_extension path ty_list depth obj @@ -622,7 +616,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_record (tree_of_fields (pos = 0) pos lbl_list) and tree_of_record_unboxed_product_fields depth env path type_params ty_list - lbl_list pos obj rep = + lbl_list pos obj = let rec tree_of_fields first pos = function | [] -> [] | {ld_id; ld_type; ld_jkind} :: remainder -> @@ -635,17 +629,14 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if first then tree_of_label env path (Out_name.create name) else Oide_ident (Out_name.create name) and v = - match rep with - | Outval_record_unboxed_product -> - begin match get_and_default_jkind_for_printing ld_jkind with - | Print_as msg -> Oval_stuff msg - | Print_as_value -> - match lbl_list with - | [_] -> - (* singleton unboxed records are erased *) - tree_of_val (depth - 1) obj ty_arg - | _ -> nest tree_of_val (depth - 1) (O.field obj pos) ty_arg - end + match get_and_default_jkind_for_printing ld_jkind with + | Print_as msg -> Oval_stuff msg + | Print_as_value -> + match lbl_list with + | [_] -> + (* singleton unboxed records are erased *) + tree_of_val (depth - 1) obj ty_arg + | _ -> nest tree_of_val (depth - 1) (O.field obj pos) ty_arg in let pos = if is_void then pos else pos + 1 in (lid, v) :: tree_of_fields false pos remainder diff --git a/typing/ctype.ml b/typing/ctype.ml index 80c6c382b99..43a0e568c94 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2098,8 +2098,9 @@ let unbox_once env ty = let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in Stepped (apply ty2) | None -> begin match decl.type_kind with - | Type_record_unboxed_product ([{ld_type = arg; _}], Record_unboxed_product) -> - Stepped (apply arg) + | Type_record_unboxed_product ([_], Record_unboxed_product) -> + (* [find_unboxed_type] would have returned [Some] *) + Misc.fatal_error "Ctype.unbox_once" | Type_record_unboxed_product ((_::_::_ as lbls), Record_unboxed_product) -> Stepped_record_unboxed_product (List.map (fun ld -> apply ld.ld_type) lbls) | _ -> Final_result @@ -2107,7 +2108,9 @@ let unbox_once env ty = end end | Tpoly (ty, _) -> Stepped ty - | _ -> Final_result + | Tvar _ | Tarrow _ | Ttuple _ | Tunboxed_tuple _ | Tobject _ | Tfield _ + | Tnil | Tlink _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ -> + Final_result (* We use ty_prev to track the last type for which we found a definition, allowing us to return a type for which a definition was found even if @@ -2333,17 +2336,12 @@ let constrain_type_jkind ~fixed env ty jkind = message. *) Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) | Has_intersection -> - let product tys = + let product ~fuel tys = let num_components = List.length tys in let recur ty's_jkinds jkinds = - (* Note: here we "duplicate" the fuel, which may seem like - cheating. Fuel counts expansions, and its purpose is to guard - against infinitely expanding a recursive type. In a wide - product, we many need to expand many types shallowly, and - that's fine. *) let results = Misc.Stdlib.List.map3 - (loop ~fuel:(fuel - 1) ~expanded:false) tys ty's_jkinds jkinds + (loop ~fuel ~expanded:false) tys ty's_jkinds jkinds in Misc.Stdlib.Monad.Result.all_unit results in @@ -2378,9 +2376,14 @@ let constrain_type_jkind ~fixed env ty jkind = loop ~fuel:(fuel - 1) ~expanded:false ty (estimate_type_jkind env ty) jkind | Stepped_record_unboxed_product tys -> - product tys + product ~fuel:(fuel - 1) tys end - | Tunboxed_tuple ltys -> product (List.map snd ltys) + | Tunboxed_tuple ltys -> + (* Note: here we "duplicate" the fuel, which may seem like cheating. + Fuel counts expansions, and its purpose is to guard against + infinitely expanding a recursive type. In a wide tuple, we many + need to expand many types shallowly, and that's fine. *) + product ~fuel (List.map snd ltys) | _ -> Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) in loop ~fuel:100 ~expanded:false ty (estimate_type_jkind env ty) jkind diff --git a/typing/env.ml b/typing/env.ml index 68fdd6506e6..4ac76811b10 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1417,8 +1417,7 @@ let find_ident_label record_form id env = TycompTbl.find_same id (env_labels record_form env) let find_type p env = - let td = (find_type_data p env) in - td.tda_declaration + (find_type_data p env).tda_declaration let find_type_descrs p env = (find_type_data p env).tda_descriptions @@ -2211,7 +2210,8 @@ and store_label fun ~record_form ~check type_decl type_id lbl_id lbl env -> Builtin_attributes.warning_scope lbl.lbl_attributes (fun () -> if check && not type_decl.type_loc.Location.loc_ghost - && Warnings.is_active (Warnings.Unused_field ("", "", Unused)) + && Warnings.is_active + (Warnings.Unused_field { form = ""; field = ""; complaint = Unused }) then begin let ty_name = Ident.name type_id in let priv = type_decl.type_private in @@ -2228,9 +2228,10 @@ and store_label Option.iter (fun complaint -> if not (is_in_signature env) then + let form = record_form_to_string record_form in Location.prerr_warning - loc (Warnings.Unused_field(record_form_to_string record_form, - name, complaint))) + loc + (Warnings.Unused_field { form; field = name; complaint })) (label_usage_complaint priv mut used)) end); Builtin_attributes.mark_alerts_used lbl.lbl_attributes; @@ -2827,7 +2828,7 @@ let mark_constructor_description_used usage env cstr = | mark -> mark usage | exception Not_found -> () -let mark_label_description_used record_form usage env lbl = +let mark_label_description_used record_form usage env lbl = let ty_path = match get_desc lbl.lbl_res with | Tconstr(path, _, _) -> path diff --git a/typing/jkind.mli b/typing/jkind.mli index ee81f3c0620..aa6bf5ab3ce 100644 --- a/typing/jkind.mli +++ b/typing/jkind.mli @@ -291,9 +291,13 @@ module Builtin : sig (** We know for sure that values of types of this jkind are always immediate *) val immediate : why:History.immediate_creation_reason -> 'd t - (** This is the jkind of unboxed products. The layout will be the product of - the layouts of the input kinds, and the other components of the kind will - be the join relevant component of the inputs. *) + (** Attempt to build a jkind of unboxed products. + - If zero input kinds are given, it errors. + - If a single input kind is given, then it returns that kind. + - If two or more input kinds are given, then the layout will be the + product of the layouts of the input kinds, and the other components of + the kind will be the join relevant component of the inputs. + *) val product : why:History.product_creation_reason -> 'd t list -> 'd t end diff --git a/typing/oprint.ml b/typing/oprint.ml index c656e3e79b0..a1b75512ddf 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -585,8 +585,8 @@ and print_out_type_3 ppf = pp_close_box ppf () | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_manifest (_, _) -> () - | Otyp_record lbls -> print_record_decl ppf lbls - | Otyp_record_unboxed_product lbls -> print_record_unboxed_product_decl ppf lbls + | Otyp_record lbls -> print_record_decl ~unboxed:false ppf lbls + | Otyp_record_unboxed_product lbls -> print_record_decl ~unboxed:true ppf lbls | Otyp_module (p, fl) -> fprintf ppf "@[<1>(module %a" print_ident p; let first = ref true in @@ -608,12 +608,10 @@ and print_out_type ppf typ = print_out_type_0 ppf typ and print_simple_out_type ppf typ = print_out_type_3 ppf typ -and print_record_decl ppf lbls = - fprintf ppf "{%a@;<1 -2>}" - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls -and print_record_unboxed_product_decl ppf lbls = - fprintf ppf "#{%a@;<1 -2>}" - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls +and print_record_decl ~unboxed ppf lbls = + let hash = if unboxed then "#" else "" in + fprintf ppf "%s{%a@;<1 -2>}" + hash (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls and print_fields open_row ppf = function [] -> @@ -982,11 +980,11 @@ and print_out_type_decl kwd ppf td = | Otyp_record lbls -> fprintf ppf " =%a %a" print_private td.otype_private - print_record_decl lbls + (print_record_decl ~unboxed:false) lbls | Otyp_record_unboxed_product lbls -> fprintf ppf " =%a %a" print_private td.otype_private - print_record_unboxed_product_decl lbls + (print_record_decl ~unboxed:true) lbls | Otyp_sum constrs -> let variants fmt constrs = if constrs = [] then fprintf fmt "|" else diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 4566f02f335..b0df11dc455 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -136,7 +136,10 @@ and out_type = | Otyp_manifest of out_type * out_type | Otyp_object of { fields: (string * out_type) list; open_row:bool} | Otyp_record of (string * out_mutability * out_type * out_modality list) list - | Otyp_record_unboxed_product of (string * out_mutability * out_type * out_modality list) list + | Otyp_record_unboxed_product of + (string * out_mutability * out_type * out_modality list) list + (* INVARIANT: [out_mutability] is included for uniformity with [Otyp_record], + but it is always [Omm_immutable] *) | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of (string option * out_type) list diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 1c37c85dd5b..23dce800b91 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -600,9 +600,9 @@ let do_set_args ~erase_mutable q r = match q with make_pat (Tpat_record_unboxed_product (List.map2 (fun (lid, lbl,_) arg -> - if erase_mutable && Types.is_mutable lbl.lbl_mut - then - lid, lbl, omega + if Types.is_mutable lbl.lbl_mut then + fatal_error + "Parmatch.do_set_args: unboxed record labels are never mutable" else lid, lbl, arg) omegas args, closed)) @@ -2276,7 +2276,13 @@ let inactive ~partial pat = ldps | Tpat_record_unboxed_product (ldps,_) -> List.for_all - (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) + (fun (_, lbl, p) -> + match lbl.lbl_mut with + | Immutable -> loop p + | Mutable _ -> + fatal_error + ("Parmatch.inactive: " + ^ "unboxed record labels are never mutable")) ldps | Tpat_or (p,q,_) -> loop p && loop q diff --git a/typing/printpat.ml b/typing/printpat.ml index e40d396658a..a2a6a8d0bb8 100644 --- a/typing/printpat.ml +++ b/typing/printpat.ml @@ -72,12 +72,9 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> if Array.length lbl.lbl_all > 1 + List.length q then fprintf ppf ";@ _@ " else () in - if unboxed then - fprintf ppf "@[#{%a%t}@]" - pretty_lvals filtered_lvs elision_mark - else - fprintf ppf "@[{%a%t}@]" - pretty_lvals filtered_lvs elision_mark + let hash = if unboxed then "#" else "" in + fprintf ppf "@[%s{%a%t}@]" + hash pretty_lvals filtered_lvs elision_mark end in match v.pat_desc with diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 4964d97a63a..1b41e0ccf97 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1954,7 +1954,8 @@ let tree_of_type_decl id decl = decl.type_private, (match rep with Record_unboxed -> true | _ -> false) | Type_record_unboxed_product(lbls, Record_unboxed_product) -> - tree_of_manifest (Otyp_record_unboxed_product (List.map tree_of_label lbls)), + tree_of_manifest + (Otyp_record_unboxed_product (List.map tree_of_label lbls)), decl.type_private, false | Type_open -> diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index f8c395c1f6e..bdda77178ff 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -321,6 +321,12 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.attributes sub exp_attributes; List.iter (fun (e, loc, _) -> extra e; sub.location sub loc) exp_extra; sub.env sub exp_env; + let iter_fields fields = + Array.iter (function + | _, Kept _ -> () + | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) + fields + in match exp_desc with | Texp_ident (_, lid, _, _, _) -> iter_loc sub lid | Texp_constant _ -> () @@ -350,16 +356,10 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_variant (_, expo) -> Option.iter (fun (expr, _) -> sub.expr sub expr) expo | Texp_record { fields; extended_expression; _} -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) - fields; + iter_fields fields; Option.iter (fun (exp, _) -> sub.expr sub exp) extended_expression; | Texp_record_unboxed_product { fields; extended_expression; _} -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp) - fields; + iter_fields fields; Option.iter (sub.expr sub) extended_expression; | Texp_field (exp, lid, _, _, _) -> iter_loc sub lid; diff --git a/typing/typecore.ml b/typing/typecore.ml index c3cefcb14fd..1f8736e1c77 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2205,7 +2205,8 @@ let label_get_type_path (type rep) (record_form : rep record_form) (d : rep gen_label_description) = - match record_form with | Legacy -> Label.get_type_path d + match record_form with + | Legacy -> Label.get_type_path d | Unboxed_product -> Unboxed_label.get_type_path d (* In record-construction expressions and patterns, we have many labels @@ -2362,16 +2363,18 @@ let check_recordpat_labels loc lbl_pat_list closed record_form = else defined.(label.lbl_num) <- true in List.iter check_defined lbl_pat_list; if closed = Closed - && Warnings.is_active (Warnings.Missing_record_field_pattern ("", "")) + && Warnings.is_active + (Warnings.Missing_record_field_pattern { form = ""; unbound = "" }) then begin let undefined = ref [] in for i = 0 to Array.length all - 1 do if not defined.(i) then undefined := all.(i).lbl_name :: !undefined done; if !undefined <> [] then begin - let u = String.concat ", " (List.rev !undefined) in + let unbound = String.concat ", " (List.rev !undefined) in let form = record_form_to_string record_form in - Location.prerr_warning loc (Warnings.Missing_record_field_pattern (form, u)) + Location.prerr_warning loc + (Warnings.Missing_record_field_pattern { form; unbound }) end end @@ -2681,7 +2684,7 @@ and type_pat_aux let error = Wrong_expected_record_boxing(Pattern, P record_form, expected_ty) in raise (Error (loc, !!penv, error)) | Maybe_a_record_type -> - None, newvar (Jkind.Builtin.any ~why:Dummy_jkind) + None, newvar (Jkind.of_new_sort ~why:Record_projection) | Not_a_record_type -> let wks = record_form_to_wrong_kind_sort record_form in let error = Wrong_expected_kind(wks, Pattern, expected_ty) in @@ -5441,28 +5444,25 @@ and type_expect_ Array.map2 (fun descr def -> descr, def) label_descriptions label_definitions in - match record_form with - | Legacy -> - re { - exp_desc = Texp_record { - fields; representation; - extended_expression = opt_exp; - alloc_mode; - }; - exp_loc = loc; exp_extra = []; - exp_type = instance ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Unboxed_product -> - re { - exp_desc = Texp_record_unboxed_product { - fields; representation; - extended_expression = (Option.map fst opt_exp); - }; - exp_loc = loc; exp_extra = []; - exp_type = instance ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } + let exp_desc = + match record_form with + | Legacy -> + Texp_record { + fields; representation; + extended_expression = opt_exp; + alloc_mode; + } + | Unboxed_product -> + Texp_record_unboxed_product { + fields; representation; + extended_expression = (Option.map fst opt_exp); + } + in + re { + exp_desc; exp_loc = loc; exp_extra = []; + exp_type = instance ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env } in match desc with | Pexp_ident lid -> @@ -5938,7 +5938,9 @@ and type_expect_ ty_arg end ~post:generalize_structure in - check_project_mutability ~loc:record.exp_loc ~env label.lbl_mut rmode; + if Types.is_mutable label.lbl_mut then + fatal_error + "Typecore.type_expect_: unboxed record labels are never mutable"; let mode = Modality.Value.Const.apply label.lbl_modalities rmode in let mode = mode_cross_left_value env ty_arg mode in submode ~loc ~env mode expected_mode; diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 0fa645971bd..6ce761f1ef7 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -3502,7 +3502,7 @@ let report_error ppf = function | Duplicate_label s -> fprintf ppf "Two labels are named %a" Style.inline_code s | Unboxed_mutable_label -> - fprintf ppf "Unboxed records labels cannot be mutable" + fprintf ppf "Unboxed record labels cannot be mutable" | Recursive_abbrev (s, env, reaching_path) -> let reaching_path = Reaching_path.simplify reaching_path in Printtyp.wrap_printing_env ~error:true env @@ fun () -> diff --git a/typing/typedtree.mli b/typing/typedtree.mli index ddf253c657b..55577b25b52 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -195,8 +195,8 @@ and 'k pattern_desc = (Longident.t loc * Types.unboxed_label_description * value general_pattern) list * closed_flag -> value pattern_desc - (** { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) + (** #{ l1=P1; ...; ln=Pn } (flag = Closed) + #{ l1=P1; ...; ln=Pn; _} (flag = Open) Invariant: n > 0 *) diff --git a/typing/typeopt.ml b/typing/typeopt.ml index 1a6ecdd683c..059358314b6 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -517,7 +517,8 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty fallback_if_missing_cmi ~default:(num_nodes_visited, mk_nn Pgenval) (fun () -> value_kind env ~loc ~visited ~depth ~num_nodes_visited ld_type) | Type_record_unboxed_product (([] | _::_::_), Record_unboxed_product) -> - assert false + Misc.fatal_error + "Typeopt.value_kind: non-unary unboxed record can't have kind value" | Type_abstract _ -> num_nodes_visited, mk_nn (value_kind_of_value_jkind decl.type_jkind) diff --git a/typing/types.mli b/typing/types.mli index a056895bfcc..f2dbc5bdb16 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -911,6 +911,14 @@ type label_description = record_representation gen_label_description type unboxed_label_description = record_unboxed_product_representation gen_label_description +(** This type tracks the distinction between legacy records ([{ field }]) and unboxed + records ([#{ field }]). Note that [Legacy] includes normal boxed records, as well as + inlined and [[@@unboxed]] records. + + As a GADT, it also lets us avoid duplicating functions that handle both record forms, + such as [Env.find_label_by_name], which has type + ['rep record_form -> Longident.t -> Env.t -> 'rep gen_label_description]. +*) type _ record_form = | Legacy : record_representation record_form | Unboxed_product : record_unboxed_product_representation record_form diff --git a/utils/warnings.ml b/utils/warnings.ml index e21300fca8d..7a5b6880af8 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -55,7 +55,7 @@ type t = | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) - | Missing_record_field_pattern of string * string (* 9 *) + | Missing_record_field_pattern of { form : string ; unbound : string } (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) | Redundant_subpat (* 12 *) @@ -116,7 +116,8 @@ type t = | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) - | Unused_field of string * string * field_usage_warning (* 69 *) + | Unused_field of + { form : string; field : string; complaint : field_usage_warning }(* 69 *) | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) @@ -959,8 +960,8 @@ let message = function | Partial_match s -> "this pattern-matching is not exhaustive.\n\ Here is an example of a case that is not matched:\n" ^ s - | Missing_record_field_pattern (record_form, s) -> - "the following labels are not bound in this " ^ record_form ^ " pattern:\n" ^ s ^ + | Missing_record_field_pattern { form ; unbound } -> + "the following labels are not bound in this " ^ form ^ " pattern:\n" ^ unbound ^ "\nEither bind these labels explicitly or add '; _' to the pattern." | Non_unit_statement -> "this expression should have type unit." @@ -1168,13 +1169,14 @@ let message = function "This pattern depends on mutable state.\n\ It prevents the remaining arguments from being uncurried, which will \ cause additional closure allocations." - | Unused_field (record_form, s, Unused) -> "unused " ^ record_form ^ " field " ^ s ^ "." - | Unused_field (record_form, s, Not_read) -> - record_form ^ " field " ^ s ^ + | Unused_field { form; field; complaint = Unused } -> + "unused " ^ form ^ " field " ^ field ^ "." + | Unused_field { form; field; complaint = Not_read } -> + form ^ " field " ^ field ^ " is never read.\n\ (However, this field is used to build or mutate values.)" - | Unused_field (record_form, s, Not_mutated) -> - "mutable " ^ record_form ^ " field " ^ s ^ + | Unused_field { form; field; complaint = Not_mutated } -> + "mutable " ^ form ^ " field " ^ field ^ " is never mutated." | Missing_mli -> "Cannot find interface file." diff --git a/utils/warnings.mli b/utils/warnings.mli index e1b44eb79f8..d925ffce77d 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -57,7 +57,7 @@ type t = | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) - | Missing_record_field_pattern of string * string (* 9 *) + | Missing_record_field_pattern of { form : string ; unbound : string } (* 9 *) | Non_unit_statement (* 10 *) | Redundant_case (* 11 *) | Redundant_subpat (* 12 *) @@ -91,7 +91,8 @@ type t = | Unused_constructor of string * constructor_usage_warning (* 37 *) | Unused_extension of string * bool * constructor_usage_warning (* 38 *) | Unused_rec_flag (* 39 *) - | Name_out_of_scope of string * name_out_of_scope_warning (* 40 *) + | Name_out_of_scope of string * name_out_of_scope_warning (* 40 + Tuple of (the type name, the name/fields out of scope) *) | Ambiguous_name of string list * string list * bool * string (* 41 *) | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) @@ -120,7 +121,8 @@ type t = | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) - | Unused_field of string * string * field_usage_warning (* 69 *) + | Unused_field of + { form : string; field : string; complaint : field_usage_warning }(* 69 *) | Missing_mli (* 70 *) | Unused_tmc_attribute (* 71 *) | Tmc_breaks_tailcall (* 72 *) From d96cded22f6fad8cdd52f4df763b19afb3702db0 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 13:13:37 -0500 Subject: [PATCH 07/19] Always evaluate initial expression for functional update --- lambda/translcore.ml | 32 +++++++++---------- .../typing-layouts-unboxed-records/basics.ml | 32 +++++++++++++++++++ .../typing_misc_unboxed_records.ml | 2 +- 3 files changed, 48 insertions(+), 18 deletions(-) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 09f0a6f0d7d..c5a5987279d 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -2105,23 +2105,21 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = fields |> Array.to_list in - begin match ll with - | [l] -> l (* erase singleton unboxed records before lambda *) - | _ -> - let lam = Lprim(Pmake_unboxed_product shape, ll, of_location ~scopes loc) in - begin match opt_init_expr with - | None -> lam - | Some init_expr -> - (* CR layouts v11: if a functional update can change the kind, then - the resulting kind may be different than [init_expr_jkind] *) - let init_expr_jkind = - Jkind.Builtin.product ~why:Unboxed_record - (Array.map (fun (lbl,_) -> lbl.lbl_jkind) fields |> Array.to_list) in - let init_expr_sort = Jkind.sort_of_jkind init_expr_jkind in - let layout = layout_exp init_expr_sort init_expr in - Llet(Strict, layout, init_id, transl_exp ~scopes init_expr_sort init_expr, lam) - end - end + let lam = match ll with + | [l] -> l (* erase singleton unboxed records before lambda *) + | _ -> Lprim(Pmake_unboxed_product shape, ll, of_location ~scopes loc) + in + match opt_init_expr with + | None -> lam + | Some init_expr -> + (* CR layouts v11: if a functional update can change the kind, then + the resulting kind may be different than [init_expr_jkind] *) + let init_expr_jkind = + Jkind.Builtin.product ~why:Unboxed_record + (Array.map (fun (lbl,_) -> lbl.lbl_jkind) fields |> Array.to_list) in + let init_expr_sort = Jkind.sort_of_jkind init_expr_jkind in + let layout = layout_exp init_expr_sort init_expr in + Llet(Strict, layout, init_id, transl_exp ~scopes init_expr_sort init_expr, lam) and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = let return_layout = layout_exp return_sort e in diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index cb58cae28cf..7dd8a5b6d55 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -639,3 +639,35 @@ Line 1, characters 19-20: Error: Unbound unboxed record field "b" Hint: There is a boxed record field with this name. |}] + +(* Initial expressions for functionally updated records are always evaluated *) + +type t = #{ x : string } + +let [@warning "-23"] update_t t = + let updated = ref false in + let _ = #{ (updated := true; t) with x = "" } in + assert !updated + +let _ = update_t #{ x = "x" } +[%%expect{| +type t = #{ x : string; } +val update_t : t -> unit = +- : unit = () +|}] + +type t = #{ x : string ; y : float# ; z : unit} + +let [@warning "-23"] update_t t = + let counter = ref 0 in + let _ = #{ (incr counter; t) with x = ""; y = #0.0 ; z = ()} in + assert (!counter = 1); + let _ = #{ (incr counter; t) with y = #0.0 } in + assert (!counter = 2) + +let _ = update_t #{ x = "x" ; y = #1.0 ; z = ()} +[%%expect{| +type t = #{ x : string; y : float#; z : unit; } +val update_t : t -> unit = +- : unit = () +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml index 53097b2df98..5837a2fdf85 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml @@ -165,7 +165,7 @@ Line 1, characters 8-45: Warning 23 [useless-record-with]: all the fields are explicitly listed in this unboxed record: the 'with' clause is useless. -val r : int ref_u = #{contents = 1} +Exception: Assert_failure ("", 1, 11). |}] (* reexport *) From 98bfb556bec85f45fe46c26cb7f51625f29dd709 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 13:22:32 -0500 Subject: [PATCH 08/19] Fix reachable assert in pats_of_type --- .../tests/typing-layouts-unboxed-records/basics.ml | 13 ++++++++++++- typing/parmatch.ml | 9 +++++++-- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index 7dd8a5b6d55..60c5416e59b 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -22,7 +22,7 @@ type ('a : value & value) t = #{ x : 'a; y : string; } val f : #(int * string) t -> #(string * int) t = |}] -(* As-patterns, partial patterns *) +(* Patterns, as-patterns, partial patterns *) type t = #{ i: int; j : int } let add (#{ i; _} as r) = i + r.#j @@ -31,6 +31,17 @@ type t = #{ i : int; j : int; } val add : t -> int = |}] +let bad_match (x : t) = + match x with + | _ -> . +[%%expect{| +Line 3, characters 4-5: +3 | | _ -> . + ^ +Error: This match case could not be refuted. + Here is an example of a value that would reach it: "{ _ }" +|}] + (* Unboxed records are not subject to the mixed-block restriction *) type t = #{ f : float# ; i : int } diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 23dce800b91..9f3be586938 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -954,8 +954,13 @@ let pats_of_type env ty = labels in [make_pat (Tpat_record (fields, Closed)) ty env] - | Type_record_unboxed_product (_labels, _) -> - assert false + | Type_record_unboxed_product (labels, _) -> + let fields = + List.map (fun ld -> + mknoloc (Longident.Lident ld.lbl_name), ld, omega) + labels + in + [make_pat (Tpat_record_unboxed_product (fields, Closed)) ty env] | Type_variant _ | Type_abstract _ | Type_open -> [omega] end | Has_no_typedecl -> From a75d1fe142431655681bf9f467b54e2dffc31a0f Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 13:59:06 -0500 Subject: [PATCH 09/19] Resolve rebase conflicts (old base aded4b5150, old tip 47d58d8158) --- .../tool-toplevel/pr6468.compilers.reference | 40 ------------------- .../typing-layouts-unboxed-records/basics.ml | 2 +- .../basics_alpha.ml | 14 +++---- .../basics_from_unboxed_tuples_tests.ml | 8 ++-- typing/jkind.ml | 14 ++----- 5 files changed, 17 insertions(+), 61 deletions(-) diff --git a/testsuite/tests/tool-toplevel/pr6468.compilers.reference b/testsuite/tests/tool-toplevel/pr6468.compilers.reference index 17186e5619e..4fd188a76ff 100644 --- a/testsuite/tests/tool-toplevel/pr6468.compilers.reference +++ b/testsuite/tests/tool-toplevel/pr6468.compilers.reference @@ -7,48 +7,8 @@ Line 1, characters 11-15: Warning 21 [nonreturning-statement]: this statement never returns (or has an unsound type.) val g : unit -> int = -<<<<<<< HEAD Exception: E. Raised at f in file "//toplevel//", line 4, characters 11-18 -||||||| parent of 80bf6fd31d (Basic unboxed records) -Exception: Not_found. -Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 -Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 -Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1300, characters 8-48 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 432, characters 10-40 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Translmod.toplevel_name in file "lambda/translmod.ml", line 1599, characters 6-40 -Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 547, characters 13-28 -Called from Simplif.simplify_lets.simplif in file "lambda/simplif.ml", line 571, characters 8-28 -Re-raised at f in file "//toplevel//", line 2, characters 11-26 -======= -Exception: Not_found. -Raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1335, characters 8-48 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 435, characters 10-40 -Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1335, characters 8-48 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 435, characters 10-40 -Re-raised at Stdlib__Map.Make.find in file "map.ml", line 146, characters 10-25 -Called from Env.find_type_data in file "typing/env.ml", line 1335, characters 8-48 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Env.IdTbl.find_same_without_locks in file "typing/env.ml", line 435, characters 10-40 -Re-raised at Ident.find_same in file "typing/ident.ml", line 307, characters 6-21 -Called from Translmod.toplevel_name in file "lambda/translmod.ml", line 1599, characters 6-40 -Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 547, characters 13-28 -Called from Simplif.simplify_lets.simplif in file "lambda/simplif.ml", line 571, characters 8-28 -Re-raised at f in file "//toplevel//", line 2, characters 11-26 ->>>>>>> 80bf6fd31d (Basic unboxed records) Called from g in file "//toplevel//", line 1, characters 11-15 Called from in file "//toplevel//", line 1, characters 0-4 Called from Topeval.load_lambda in file "toplevel/byte/topeval.ml", line 87, characters 4-14 diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index 60c5416e59b..f21de6da165 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -432,7 +432,7 @@ Error: Layout mismatch in final type declaration consistency check. because of the definition of t_float64_id at line 1, characters 0-37. But the layout of 'a must overlap with value because it instantiates an unannotated type parameter of t, - defaulted to layout value. + chosen to have layout value. A good next step is to add a layout annotation on a parameter to the declaration where this error is reported. |}];; diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml index a021db9745b..9a040823855 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml @@ -51,7 +51,7 @@ type t1 : any mod non_null type t2 : value type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2};; [%%expect{| -type t1 : any mod non_null +type t1 : any_non_null type t2 Line 3, characters 32-41: 3 | type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2};; @@ -70,7 +70,7 @@ type t1 : any mod non_null type t2 : value type t3 : any & value mod non_null = #{ t1 : t1 ; t2 : t2};; [%%expect{| -type t1 : any mod non_null +type t1 : any_non_null type t2 Line 3, characters 40-49: 3 | type t3 : any & value mod non_null = #{ t1 : t1 ; t2 : t2};; @@ -86,7 +86,7 @@ type t1 : any mod non_null type t2 : value type t3 : (any mod non_null) & (value mod non_null) = #{ t1 : t1 ; t2 : t2};; [%%expect{| -type t1 : any mod non_null +type t1 : any_non_null type t2 Line 3, characters 57-66: 3 | type t3 : (any mod non_null) & (value mod non_null) = #{ t1 : t1 ; t2 : t2};; @@ -103,7 +103,7 @@ type t2 : any mod non_null type t3 : any & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; [%%expect{| type t1 : any -type t2 : any mod non_null +type t2 : any_non_null Line 3, characters 40-49: 3 | type t3 : any & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; ^^^^^^^^^ @@ -120,7 +120,7 @@ type t2 : any mod non_null type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2 };; [%%expect{| type t1 : any -type t2 : any mod non_null +type t2 : any_non_null Line 3, characters 32-41: 3 | type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2 };; ^^^^^^^^^ @@ -136,7 +136,7 @@ type t2 : any mod non_null type t3 : any & any mod non_null = #{ t1 : t1 ; t2 : t2 };; [%%expect{| type t1 : any -type t2 : any mod non_null +type t2 : any_non_null Line 3, characters 38-47: 3 | type t3 : any & any mod non_null = #{ t1 : t1 ; t2 : t2 };; ^^^^^^^^^ @@ -152,7 +152,7 @@ type t2 : any mod non_null type t3 : (any mod non_null) & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; [%%expect{| type t1 : any -type t2 : any mod non_null +type t2 : any_non_null Line 3, characters 55-64: 3 | type t3 : (any mod non_null) & (any mod non_null) = #{ t1 : t1 ; t2 : t2 };; ^^^^^^^^^ diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml index 98c0f4a39aa..4825c6d3209 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -114,7 +114,7 @@ Line 3, characters 11-15: ^^^^ Error: This type "bool" should be an instance of type "('a : value & bits64)" The layout of bool is value - because it's an enumeration variant type (all constructors are constant). + because it is the primitive type bool. But the layout of bool must be a sublayout of value & bits64 because of the definition of t6 at line 1, characters 0-37. |}] @@ -813,8 +813,10 @@ type array_record = #{ i1 : int; i2 : int; } Line 2, characters 8-33: 2 | let _ = [| #{ i1 = 1; i2 = 2 } |] ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Unboxed products are not yet supported with array primitives. - Here, layout value & value was used. +Error: Non-value layout value & value detected as sort for type array_record, + but this requires extension layouts_alpha, which is not enabled. + If you intended to use this layout, please add this flag to your build file. + Otherwise, please report this error to the Jane Street compilers team. |}] type array_init_record = #{ i1 : int; i2 : int } diff --git a/typing/jkind.ml b/typing/jkind.ml index 2f505e38852..58ca50972f0 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -1064,19 +1064,13 @@ module Builtin = struct fresh_jkind Jkind_desc.Builtin.immediate ~annotation:(mk_annot "immediate") ~why:(Immediate_creation why) -<<<<<<< HEAD let product ~why ts = - let desc, annotation = Jkind_desc.product ts in - fresh_jkind desc ~annotation ~why:(Product_creation why) -||||||| parent of 80bf6fd31d (Basic unboxed records) - let product ~why ts = - fresh_jkind (Jkind_desc.product ts) ~why:(Product_creation why) -======= - let product ~why = function + match ts with | [] -> Misc.fatal_error "Jkind.Builtin.product: empty product" | [t] -> t - | ts -> fresh_jkind (Jkind_desc.product ts) ~why:(Product_creation why) ->>>>>>> 80bf6fd31d (Basic unboxed records) + | ts -> + let desc, annotation = Jkind_desc.product ts in + fresh_jkind desc ~annotation ~why:(Product_creation why) end let add_nullability_crossing t = From 6519e06b211f1566832831cf34c32ba0481a017d Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 14:24:57 -0500 Subject: [PATCH 10/19] Track record sort in Texp_unboxed_field --- file_formats/cmt_format.ml | 2 +- lambda/translcore.ml | 7 +++---- typing/printtyped.ml | 2 +- typing/tast_iterator.ml | 2 +- typing/tast_mapper.ml | 4 ++-- typing/typecore.ml | 11 +++++++++-- typing/typedtree.ml | 3 ++- typing/typedtree.mli | 5 +++-- typing/uniqueness_analysis.ml | 4 ++-- typing/untypeast.ml | 2 +- typing/value_rec_check.ml | 2 +- 11 files changed, 26 insertions(+), 18 deletions(-) diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml index b1db2dfd632..cc98af65a38 100644 --- a/file_formats/cmt_format.ml +++ b/file_formats/cmt_format.ml @@ -217,7 +217,7 @@ let iter_on_occurrences | Texp_field (_, lid, label_desc, _, _) | Texp_setfield (_, _, lid, label_desc, _) -> add_label ~namespace:Label exp_env lid label_desc - | Texp_unboxed_field (_, lid, label_desc, _) -> + | Texp_unboxed_field (_, _, lid, label_desc, _) -> add_label ~namespace:Unboxed_label exp_env lid label_desc | Texp_new (path, lid, _, _) -> f ~namespace:Class exp_env path lid diff --git a/lambda/translcore.ml b/lambda/translcore.ml index c5a5987279d..eb5af24a6d0 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -696,18 +696,17 @@ and transl_exp0 ~in_new_scope ~scopes sort e = Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [targ], of_location ~scopes e.exp_loc) end - | Texp_unboxed_field(arg, _id, lbl, _) -> + | Texp_unboxed_field(arg, arg_sort, _id, lbl, _) -> begin match lbl.lbl_repres with | Record_unboxed_product -> - let layouts, jkinds = + let layouts, _jkinds = Array.map (fun lbl -> layout e.exp_env lbl.lbl_loc (Jkind.sort_of_jkind lbl.lbl_jkind) lbl.lbl_arg, lbl.lbl_jkind ) lbl.lbl_all |> Array.to_list |> List.split in - let arg_jkind = Jkind.Builtin.product ~why:Unboxed_record jkinds in - let targ = transl_exp ~scopes (Jkind.sort_of_jkind arg_jkind) arg in + let targ = transl_exp ~scopes arg_sort arg in if Array.length lbl.lbl_all == 1 then (* erase singleton unboxed records before lambda *) targ diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 4f7beb6e8e5..bac8679611f 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -543,7 +543,7 @@ and expression i ppf x = line i ppf "Texp_field\n"; expression i ppf e; longident i ppf li; - | Texp_unboxed_field (e, li, _, _) -> + | Texp_unboxed_field (e, _, li, _, _) -> line i ppf "Texp_unboxed_field\n"; expression i ppf e; longident i ppf li; diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index bdda77178ff..51a80982623 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -364,7 +364,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = | Texp_field (exp, lid, _, _, _) -> iter_loc sub lid; sub.expr sub exp - | Texp_unboxed_field (exp, lid, _, _) -> + | Texp_unboxed_field (exp, _, lid, _, _) -> iter_loc sub lid; sub.expr sub exp | Texp_setfield (exp1, _, lid, _, exp2) -> diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 66846e69841..1e1988cd446 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -503,8 +503,8 @@ let expr sub x = } | Texp_field (exp, lid, ld, float, ubr) -> Texp_field (sub.expr sub exp, map_loc sub lid, ld, float, ubr) - | Texp_unboxed_field (exp, lid, ld, uu) -> - Texp_unboxed_field (sub.expr sub exp, map_loc sub lid, ld, uu) + | Texp_unboxed_field (exp, sort, lid, ld, uu) -> + Texp_unboxed_field (sub.expr sub exp, sort, map_loc sub lid, ld, uu) | Texp_setfield (exp1, am, lid, ld, exp2) -> Texp_setfield ( sub.expr sub exp1, diff --git a/typing/typecore.ml b/typing/typecore.ml index 1f8736e1c77..5383f41cd51 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4080,7 +4080,7 @@ let rec is_nonexpansive exp = fields && is_nonexpansive_opt extended_expression | Texp_field(exp, _, _, _, _) -> is_nonexpansive exp - | Texp_unboxed_field(exp, _, _, _) -> is_nonexpansive exp + | Texp_unboxed_field(exp, _, _, _, _) -> is_nonexpansive exp | Texp_ifthenelse(_cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (_e1, _jkind, e2) -> is_nonexpansive e2 (* PR#4354 *) @@ -5941,12 +5941,19 @@ and type_expect_ if Types.is_mutable label.lbl_mut then fatal_error "Typecore.type_expect_: unboxed record labels are never mutable"; + let record_sort = + let jkinds = + Array.map (fun lbl -> lbl.lbl_jkind) label.lbl_all |> Array.to_list + in + let record_jkind = Jkind.Builtin.product ~why:Unboxed_record jkinds in + Jkind.sort_of_jkind record_jkind + in let mode = Modality.Value.Const.apply label.lbl_modalities rmode in let mode = mode_cross_left_value env ty_arg mode in submode ~loc ~env mode expected_mode; let uu = unique_use ~loc ~env mode (as_single_mode expected_mode) in rue { - exp_desc = Texp_unboxed_field(record, lid, label, uu); + exp_desc = Texp_unboxed_field(record, record_sort, lid, label, uu); exp_loc = loc; exp_extra = []; exp_type = ty_arg; exp_attributes = sexp.pexp_attributes; diff --git a/typing/typedtree.ml b/typing/typedtree.ml index ce3a997dd60..102cf4ecc52 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -228,7 +228,8 @@ and expression_desc = expression * Longident.t loc * label_description * texp_field_boxing * Unique_barrier.t | Texp_unboxed_field of - expression * Longident.t loc * unboxed_label_description * unique_use + expression * Jkind.sort * Longident.t loc * unboxed_label_description * + unique_use | Texp_setfield of expression * Mode.Locality.l * Longident.t loc * label_description * expression | Texp_array of mutability * Jkind.Sort.t * expression list * alloc_mode diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 55577b25b52..3a6a5afa127 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -422,8 +422,9 @@ and expression_desc = texp_field_boxing * Unique_barrier.t (** [texp_field_boxing] provides extra information depending on if the projection requires boxing. *) - | Texp_unboxed_field of expression * Longident.t loc * Types.unboxed_label_description * - unique_use + | Texp_unboxed_field of + expression * Jkind.sort * Longident.t loc * Types.unboxed_label_description * + unique_use | Texp_setfield of expression * Mode.Locality.l * Longident.t loc * Types.label_description * expression diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml index d00a597c139..b1c44424cc3 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -1438,7 +1438,7 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = | Texp_field _ -> let value, uf = check_uniqueness_exp_as_value ienv exp in UF.seq uf (Value.mark_maybe_unique value) - | Texp_unboxed_field (_, _, _, _) -> + | Texp_unboxed_field (_, _, _, _, _) -> let value, uf = check_uniqueness_exp_as_value ienv exp in UF.seq uf (Value.mark_maybe_unique value) | Texp_setfield (rcd, _, _, _, arg) -> @@ -1578,7 +1578,7 @@ and check_uniqueness_exp_as_value ienv exp : Value.t * UF.t = Paths.mark (Usage.maybe_unique unique_use occ) paths, Value.fresh in value, UF.seqs [uf; uf_read; uf_boxing]) - | Texp_unboxed_field (e, _, l, unique_use) -> ( + | Texp_unboxed_field (e, _, _, l, unique_use) -> ( let value, uf = check_uniqueness_exp_as_value ienv e in match Value.paths value with | None -> Value.fresh, uf diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 58edfc93048..a564e2a6eeb 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -595,7 +595,7 @@ let expression sub exp = Pexp_record_unboxed_product (list, Option.map (sub.expr sub) extended_expression) | Texp_field (exp, lid, _label, _, _) -> Pexp_field (sub.expr sub exp, map_loc sub lid) - | Texp_unboxed_field (exp, lid, _label, _) -> + | Texp_unboxed_field (exp, _, lid, _label, _) -> Pexp_unboxed_field (sub.expr sub exp, map_loc sub lid) | Texp_setfield (exp1, _, lid, _label, exp2) -> Pexp_setfield (sub.expr sub exp1, map_loc sub lid, diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml index 9744b4c9050..ce5ff9854f8 100644 --- a/typing/value_rec_check.ml +++ b/typing/value_rec_check.ml @@ -864,7 +864,7 @@ let rec expression : Typedtree.expression -> term_judg = G |- e.x: m *) expression e << Dereference - | Texp_unboxed_field (e, _, _, _) -> + | Texp_unboxed_field (e, _, _, _, _) -> expression e << Dereference | Texp_setinstvar (pth,_,_,e) -> (* From 1351e550a3dce703e1efb7a2808900063ea4dfb1 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 14:40:37 -0500 Subject: [PATCH 11/19] Track initial record sort in Texp_unboxed_record --- lambda/translcore.ml | 6 +----- typing/printtyped.ml | 2 +- typing/tast_iterator.ml | 2 +- typing/tast_mapper.ml | 4 +++- typing/typecore.ml | 15 +++++++++++++-- typing/typedtree.ml | 2 +- typing/typedtree.mli | 2 +- typing/uniqueness_analysis.ml | 2 +- typing/untypeast.ml | 4 +++- typing/value_rec_check.ml | 2 +- 10 files changed, 26 insertions(+), 15 deletions(-) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index eb5af24a6d0..6bc1701fc97 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -2110,13 +2110,9 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = in match opt_init_expr with | None -> lam - | Some init_expr -> + | Some (init_expr, init_expr_sort) -> (* CR layouts v11: if a functional update can change the kind, then the resulting kind may be different than [init_expr_jkind] *) - let init_expr_jkind = - Jkind.Builtin.product ~why:Unboxed_record - (Array.map (fun (lbl,_) -> lbl.lbl_jkind) fields |> Array.to_list) in - let init_expr_sort = Jkind.sort_of_jkind init_expr_jkind in let layout = layout_exp init_expr_sort init_expr in Llet(Strict, layout, init_id, transl_exp ~scopes init_expr_sort init_expr, lam) diff --git a/typing/printtyped.ml b/typing/printtyped.ml index bac8679611f..107492bc862 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -538,7 +538,7 @@ and expression i ppf x = line i ppf "representation =\n"; record_unboxed_product_representation (i+1) ppf representation; line i ppf "extended_expression =\n"; - option (i+1) expression ppf extended_expression; + option (i+1) expression ppf (Option.map fst extended_expression); | Texp_field (e, li, _, _, _) -> line i ppf "Texp_field\n"; expression i ppf e; diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 51a80982623..c31881fe92d 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -360,7 +360,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = Option.iter (fun (exp, _) -> sub.expr sub exp) extended_expression; | Texp_record_unboxed_product { fields; extended_expression; _} -> iter_fields fields; - Option.iter (sub.expr sub) extended_expression; + Option.iter (fun (exp, _) -> sub.expr sub exp) extended_expression; | Texp_field (exp, lid, _, _, _) -> iter_loc sub lid; sub.expr sub exp diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 1e1988cd446..8278890b322 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -499,7 +499,9 @@ let expr sub x = | Texp_record_unboxed_product { fields; representation; extended_expression } -> Texp_record_unboxed_product { fields = map_fields fields; representation; - extended_expression = Option.map (sub.expr sub) extended_expression + extended_expression = + Option.map + (fun (exp, sort) -> (sub.expr sub exp, sort)) extended_expression } | Texp_field (exp, lid, ld, float, ubr) -> Texp_field (sub.expr sub exp, map_loc sub lid, ld, float, ubr) diff --git a/typing/typecore.ml b/typing/typecore.ml index 5383f41cd51..4c3a37a83f1 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4078,7 +4078,7 @@ let rec is_nonexpansive exp = lbl.lbl_mut = Immutable && is_nonexpansive exp | Kept _ -> true) fields - && is_nonexpansive_opt extended_expression + && is_nonexpansive_opt (Option.map fst extended_expression) | Texp_field(exp, _, _, _, _) -> is_nonexpansive exp | Texp_unboxed_field(exp, _, _, _, _) -> is_nonexpansive exp | Texp_ifthenelse(_cond, ifso, ifnot) -> @@ -5453,9 +5453,20 @@ and type_expect_ alloc_mode; } | Unboxed_product -> + let opt_exp = match opt_exp with + | None -> None + | Some (exp, _) -> + let jkind = + Jkind.Builtin.product ~why:Unboxed_record + (Array.map (fun lbl -> lbl.lbl_jkind) label_descriptions + |> Array.to_list) + in + let sort = Jkind.sort_of_jkind jkind in + Some (exp, sort) + in Texp_record_unboxed_product { fields; representation; - extended_expression = (Option.map fst opt_exp); + extended_expression = opt_exp; } in re { diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 102cf4ecc52..d8f437a7924 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -222,7 +222,7 @@ and expression_desc = | Texp_record_unboxed_product of { fields : ( Types.unboxed_label_description * record_label_definition ) array; representation : Types.record_unboxed_product_representation; - extended_expression : expression option; + extended_expression : (expression * Jkind.sort) option; } | Texp_field of expression * Longident.t loc * label_description * texp_field_boxing * diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 3a6a5afa127..52f9b6a9e3c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -405,7 +405,7 @@ and expression_desc = | Texp_record_unboxed_product of { fields : ( Types.unboxed_label_description * record_label_definition ) array; representation : Types.record_unboxed_product_representation; - extended_expression : expression option; + extended_expression : (expression * Jkind.sort) option; } (** #{ l1=P1; ...; ln=Pn } (extended_expression = None) #{ E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml index b1c44424cc3..bfcf37796c9 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -1419,7 +1419,7 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = let value, uf_ext = match extended_expression with | None -> Value.fresh, UF.unused - | Some exp -> check_uniqueness_exp_as_value ienv exp + | Some (exp, _) -> check_uniqueness_exp_as_value ienv exp in let uf_fields = Array.map diff --git a/typing/untypeast.ml b/typing/untypeast.ml index a564e2a6eeb..5a272200c9d 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -592,7 +592,9 @@ let expression sub exp = | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) [] fields in - Pexp_record_unboxed_product (list, Option.map (sub.expr sub) extended_expression) + Pexp_record_unboxed_product + (list, + Option.map (fun (exp, _) -> sub.expr sub exp) extended_expression) | Texp_field (exp, lid, _label, _, _) -> Pexp_field (sub.expr sub exp, map_loc sub lid) | Texp_unboxed_field (exp, _, lid, _label, _) -> diff --git a/typing/value_rec_check.ml b/typing/value_rec_check.ml index ce5ff9854f8..a7713fb5d8b 100644 --- a/typing/value_rec_check.ml +++ b/typing/value_rec_check.ml @@ -790,7 +790,7 @@ let rec expression : Typedtree.expression -> term_judg = in join [ array field es; - option expression eo << Dereference + option expression (Option.map fst eo) << Dereference ] end | Texp_ifthenelse (cond, ifso, ifnot) -> From ba2f5bfcb7e7428925b0030f14ec2a632b5c7c4d Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 14:51:50 -0500 Subject: [PATCH 12/19] Add comment about dummy unboxed record jkinds --- typing/typedecl.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 6ce761f1ef7..97226aa8869 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -931,6 +931,9 @@ let transl_declaration env sdecl (id, uid) = transl_labels ~record_form:Unboxed_product ~new_var_jkind:Any ~allow_unboxed:true env None true lbls Record_unboxed_product in + (* 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 = Jkind.Builtin.product ~why:Unboxed_record jkind_ls in Ttype_record_unboxed_product lbls, From b6540b8fa1abb2f4982ba518fe5edea5c2e174ba Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 14:52:14 -0500 Subject: [PATCH 13/19] Fix shape_map for unboxed labels --- typing/typedecl.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 97226aa8869..442b3b48138 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -739,6 +739,11 @@ let shape_map_labels = Shape.Map.add_label map ld_id ld_uid) Shape.Map.empty +let shape_map_unboxed_labels = + List.fold_left (fun map { Types.ld_id; ld_uid; _} -> + Shape.Map.add_unboxed_label map ld_id ld_uid) + Shape.Map.empty + let shape_map_cstrs = List.fold_left (fun map { Types.cd_id; cd_uid; cd_args; _ } -> let cstr_shape_map = @@ -1011,9 +1016,10 @@ let transl_declaration env sdecl (id, uid) = let uid = decl.typ_type.type_uid in match decl.typ_type.type_kind with | Type_variant (cstrs, _) -> Shape.str ~uid (shape_map_cstrs cstrs) - | Type_record (labels, _) - | Type_record_unboxed_product (labels, _) -> + | Type_record (labels, _) -> Shape.str ~uid (shape_map_labels labels) + | Type_record_unboxed_product (labels, _) -> + Shape.str ~uid (shape_map_unboxed_labels labels) | Type_abstract _ | Type_open -> Shape.leaf uid in decl, typ_shape From 544f8382e8a069884b6c9e539a539da72d6d0da2 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Tue, 3 Dec 2024 16:34:51 -0500 Subject: [PATCH 14/19] Give unboxed records Algebraic separability --- typing/typedecl_separability.ml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/typing/typedecl_separability.ml b/typing/typedecl_separability.ml index c49f36b2a19..829a4573cc6 100644 --- a/typing/typedecl_separability.ml +++ b/typing/typedecl_separability.ml @@ -46,7 +46,6 @@ type type_structure = | Open | Algebraic | Unboxed of argument_to_unbox - | Unboxed_product let structure : type_definition -> type_structure = fun def -> match (def.type_kind, find_unboxed_type def) with @@ -57,7 +56,7 @@ let structure : type_definition -> type_structure = fun def -> | Some type_expr -> Synonym type_expr end | (Type_record _ | Type_variant _), None -> Algebraic - | Type_record_unboxed_product _, None -> Unboxed_product + | Type_record_unboxed_product _, None -> Algebraic | (Type_record _ | Type_record_unboxed_product _ | Type_variant _), Some ty -> let params = match def.type_kind with @@ -632,12 +631,6 @@ let check_def check_type env constructor.argument_type Sep |> msig_of_context ~decl_loc:def.type_loc ~parameters:constructor.result_type_parameter_instances - | Unboxed_product -> - (* CR layouts 7.3: we give products best_msig, as they are - not affected by the flat float array optimization. - See test [typing-layouts-unboxed-records/separability.ml]. - *) - best_msig def let compute_decl env decl = if Config.flat_float_array then check_def env decl From fa009c1c059e2846ba12e218a0103b93bd7b31b7 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Wed, 4 Dec 2024 13:34:46 -0500 Subject: [PATCH 15/19] Added unboxed records shapes tests --- .../tests/shape-index/index_unboxed_labels.ml | 33 ++++++++++++++ .../index_unboxed_labels.reference | 45 +++++++++++++++++++ testsuite/tests/shapes/unboxed_records.ml | 15 +++++++ 3 files changed, 93 insertions(+) create mode 100644 testsuite/tests/shape-index/index_unboxed_labels.ml create mode 100644 testsuite/tests/shape-index/index_unboxed_labels.reference create mode 100644 testsuite/tests/shapes/unboxed_records.ml diff --git a/testsuite/tests/shape-index/index_unboxed_labels.ml b/testsuite/tests/shape-index/index_unboxed_labels.ml new file mode 100644 index 00000000000..f08e28622d6 --- /dev/null +++ b/testsuite/tests/shape-index/index_unboxed_labels.ml @@ -0,0 +1,33 @@ +(* TEST + +flags = "-extension layouts_beta -bin-annot -bin-annot-occurrences"; +compile_only = "true"; +readonly_files = "index_unboxed_labels.ml"; +setup-ocamlc.byte-build-env; +all_modules = "index_unboxed_labels.ml"; +ocamlc.byte; +check-ocamlc.byte-output; + +program = "-quiet -index -decls index_unboxed_labels.cmt"; +output = "out_objinfo"; +ocamlobjinfo; + +check-program-output; +*) + +type t = { a: int; b: string } +type tu = #{ a : int } + +let x = { a = 42; b = "" } +let _y = x.a + +let f = function + | { a = 42; b } -> () + | _ -> () + +let x = #{ a = 42 } +let _y = x.#a + +let f = function + | #{ a = 42 } -> () + | _ -> () diff --git a/testsuite/tests/shape-index/index_unboxed_labels.reference b/testsuite/tests/shape-index/index_unboxed_labels.reference new file mode 100644 index 00000000000..80bc4ddb387 --- /dev/null +++ b/testsuite/tests/shape-index/index_unboxed_labels.reference @@ -0,0 +1,45 @@ +Indexed shapes: +Resolved: Index_unboxed_labels.4 : + a (File "index_unboxed_labels.ml", line 32, characters 7-8) +Resolved: Index_unboxed_labels.9 : + x (File "index_unboxed_labels.ml", line 29, characters 9-10) +Resolved: Index_unboxed_labels.4 : + a (File "index_unboxed_labels.ml", line 29, characters 12-13) +Resolved: Index_unboxed_labels.4 : + a (File "index_unboxed_labels.ml", line 28, characters 11-12) +Resolved: Index_unboxed_labels.2 : + b (File "index_unboxed_labels.ml", line 25, characters 14-15) +Resolved: Index_unboxed_labels.1 : + a (File "index_unboxed_labels.ml", line 25, characters 6-7) +Resolved: Index_unboxed_labels.5 : + x (File "index_unboxed_labels.ml", line 22, characters 9-10) +Resolved: Index_unboxed_labels.1 : + a (File "index_unboxed_labels.ml", line 22, characters 11-12) +Resolved: Index_unboxed_labels.2 : + b (File "index_unboxed_labels.ml", line 21, characters 18-19) +Resolved: Index_unboxed_labels.1 : + a (File "index_unboxed_labels.ml", line 21, characters 10-11) + +Uid of decls: +Index_unboxed_labels.2: + b (File "index_unboxed_labels.ml", line 18, characters 19-20) +Index_unboxed_labels.7: + f (File "index_unboxed_labels.ml", line 24, characters 4-5) +Index_unboxed_labels.1: + a (File "index_unboxed_labels.ml", line 18, characters 11-12) +Index_unboxed_labels.6: + _y (File "index_unboxed_labels.ml", line 22, characters 4-6) +Index_unboxed_labels.4: + a (File "index_unboxed_labels.ml", line 19, characters 13-14) +Index_unboxed_labels.3: + tu (File "index_unboxed_labels.ml", line 19, characters 5-7) +Index_unboxed_labels.11: + f (File "index_unboxed_labels.ml", line 31, characters 4-5) +Index_unboxed_labels.5: + x (File "index_unboxed_labels.ml", line 21, characters 4-5) +Index_unboxed_labels.0: + t (File "index_unboxed_labels.ml", line 18, characters 5-6) +Index_unboxed_labels.10: + _y (File "index_unboxed_labels.ml", line 29, characters 4-6) +Index_unboxed_labels.9: + x (File "index_unboxed_labels.ml", line 28, characters 4-5) diff --git a/testsuite/tests/shapes/unboxed_records.ml b/testsuite/tests/shapes/unboxed_records.ml new file mode 100644 index 00000000000..5425d679b22 --- /dev/null +++ b/testsuite/tests/shapes/unboxed_records.ml @@ -0,0 +1,15 @@ +(* TEST + flags = "-dshape -extension layouts_beta"; + expect; +*) + +type t = #{ a : int; b : string } +[%%expect{| +{ + "t"[type] -> {<.0> + "a"[unboxed label] -> <.1>; + "b"[unboxed label] -> <.2>; + }; + } +type t = #{ a : int; b : string; } +|}] From 35c1fcc4dd03a7ce4ec499137babce441d49981f Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Wed, 4 Dec 2024 19:52:06 -0500 Subject: [PATCH 16/19] Minor changes for ccasin's 2024-12-04 review - Exhaustive match on type_kind instead of desc - Fix ignored pat printing - Dont compute `_jkinds` --- lambda/translcore.ml | 9 +++------ testsuite/tests/typing-layouts-unboxed-records/basics.ml | 2 +- typing/ctype.ml | 9 +++++---- typing/printpat.ml | 4 ++-- 4 files changed, 11 insertions(+), 13 deletions(-) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 6bc1701fc97..8fbec899d06 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -699,13 +699,10 @@ 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 layouts, _jkinds = - Array.map (fun lbl -> - layout e.exp_env lbl.lbl_loc (Jkind.sort_of_jkind lbl.lbl_jkind) lbl.lbl_arg, - lbl.lbl_jkind - ) lbl.lbl_all - |> Array.to_list |> List.split + let lbl_layout l = + layout e.exp_env l.lbl_loc (Jkind.sort_of_jkind l.lbl_jkind) l.lbl_arg in + let layouts = Array.to_list (Array.map lbl_layout lbl.lbl_all) in let targ = transl_exp ~scopes arg_sort arg in if Array.length lbl.lbl_all == 1 then (* erase singleton unboxed records before lambda *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index f21de6da165..64e4577b7cf 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -39,7 +39,7 @@ Line 3, characters 4-5: 3 | | _ -> . ^ Error: This match case could not be refuted. - Here is an example of a value that would reach it: "{ _ }" + Here is an example of a value that would reach it: "#{ _ }" |}] (* Unboxed records are not subject to the mixed-block restriction *) diff --git a/typing/ctype.ml b/typing/ctype.ml index 43a0e568c94..ba72311b1f7 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2103,14 +2103,15 @@ let unbox_once env ty = Misc.fatal_error "Ctype.unbox_once" | Type_record_unboxed_product ((_::_::_ as lbls), Record_unboxed_product) -> Stepped_record_unboxed_product (List.map (fun ld -> apply ld.ld_type) lbls) - | _ -> Final_result + | Type_record_unboxed_product ([], _) -> + Misc.fatal_error "Ctype.unboxed_once: fieldless record" + | Type_abstract _ | Type_record _ | Type_variant _ | Type_open -> + Final_result end end end | Tpoly (ty, _) -> Stepped ty - | Tvar _ | Tarrow _ | Ttuple _ | Tunboxed_tuple _ | Tobject _ | Tfield _ - | Tnil | Tlink _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ -> - Final_result + | _ -> Final_result (* We use ty_prev to track the last type for which we found a definition, allowing us to return a type for which a definition was found even if diff --git a/typing/printpat.ml b/typing/printpat.ml index a2a6a8d0bb8..2bd783d528a 100644 --- a/typing/printpat.ml +++ b/typing/printpat.ml @@ -64,15 +64,15 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> (function | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) | _ -> true) lvs in + let hash = if unboxed then "#" else "" in begin match filtered_lvs with - | [] -> fprintf ppf "{ _ }" + | [] -> fprintf ppf "%s{ _ }" hash | (_, lbl, _) :: q -> let elision_mark ppf = (* we assume that there is no label repetitions here *) if Array.length lbl.lbl_all > 1 + List.length q then fprintf ppf ";@ _@ " else () in - let hash = if unboxed then "#" else "" in fprintf ppf "@[%s{%a%t}@]" hash pretty_lvals filtered_lvs elision_mark end From 7ed17a022d34ae4d60f1a7205aba0f7c329b9506 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Wed, 4 Dec 2024 19:55:03 -0500 Subject: [PATCH 17/19] Compute record proj/construction sorts from expression --- .../typing-layouts-unboxed-records/basics.ml | 35 +++++++++++++++++ typing/jkind.ml | 2 + typing/jkind_intf.ml | 1 + typing/typecore.ml | 38 +++++++++++++------ typing/typecore.mli | 2 + 5 files changed, 67 insertions(+), 11 deletions(-) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index 64e4577b7cf..347c9b01092 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -682,3 +682,38 @@ type t = #{ x : string; y : float#; z : unit; } val update_t : t -> unit = - : unit = () |}] + +(************************************************************) +(* Basic tests for construction/projection representability *) + +type ('a : any) t = #{ x : int; y : 'a } +[%%expect{| +type ('a : value_or_null) t = #{ x : int; y : 'a; } +|}] + +(* CR layouts v7.2: once we allow record declarations with unknown kind + (right now, ['a] in the decl above is defaulted to value), then this should + give an error saying that record projections must be representable. *) +let f : ('a : any). 'a t -> 'a = fun t -> t.#y +[%%expect{| +Line 1, characters 8-30: +1 | let f : ('a : any). 'a t -> 'a = fun t -> t.#y + ^^^^^^^^^^^^^^^^^^^^^^ +Error: The universal type variable 'a was declared to have kind any. + But it was inferred to have kind value_or_null + because of the definition of t at line 1, characters 0-40. +|}] + +(* CR layouts v7.2: once we allow record declarations with unknown kind + (right now, ['a] in the decl above is defaulted to value), then this should + give an error saying that record constructions must be representable. +*) +let f : ('a : any). 'a -> 'a t = fun a -> #{ x = 1; y = a } +[%%expect{| +Line 1, characters 8-30: +1 | let f : ('a : any). 'a -> 'a t = fun a -> #{ x = 1; y = a } + ^^^^^^^^^^^^^^^^^^^^^^ +Error: The universal type variable 'a was declared to have kind any. + But it was inferred to have kind value_or_null + because of the definition of t at line 1, characters 0-40. +|}] diff --git a/typing/jkind.ml b/typing/jkind.ml index 58ca50972f0..af015b56e64 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -1346,6 +1346,7 @@ module Format_history = struct fprintf ppf "it's the record type used in a projection" | Record_assignment -> fprintf ppf "it's the record type used in an assignment" + | Record_construction -> fprintf ppf "it's a constructed record type" | Let_binding -> fprintf ppf "it's the type of a variable bound by a `let`" | Function_argument -> fprintf ppf "we must know concretely how to pass a function argument" @@ -1890,6 +1891,7 @@ module Debug_printers = struct fprintf ppf "Label_declaration %a" Ident.print lbl | Record_projection -> fprintf ppf "Record_projection" | Record_assignment -> fprintf ppf "Record_assignment" + | Record_construction -> fprintf ppf "Record_construction" | Let_binding -> fprintf ppf "Let_binding" | Function_argument -> fprintf ppf "Function_argument" | Function_result -> fprintf ppf "Function_result" diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index 795d76f50ee..e2f1315ba0c 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -189,6 +189,7 @@ module History = struct | Label_declaration of Ident.t | Record_projection | Record_assignment + | Record_construction | Let_binding | Function_argument | Function_result diff --git a/typing/typecore.ml b/typing/typecore.ml index 4c3a37a83f1..346455a50eb 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -267,6 +267,8 @@ type error = | Exclave_returns_not_local | Unboxed_int_literals_not_supported | Function_type_not_rep of type_expr * Jkind.Violation.t + | Record_projection_not_rep of type_expr * Jkind.Violation.t + | Record_not_rep of type_expr * Jkind.Violation.t | Invalid_label_for_src_pos of arg_label | Nonoptional_call_pos_label of string | Cannot_stack_allocate of Env.locality_context option @@ -5456,13 +5458,15 @@ and type_expect_ let opt_exp = match opt_exp with | None -> None | Some (exp, _) -> - let jkind = - Jkind.Builtin.product ~why:Unboxed_record - (Array.map (fun lbl -> lbl.lbl_jkind) label_descriptions - |> Array.to_list) + let sort = + Ctype.type_sort ~why:Record_construction ~fixed:false + env ty_expected in - let sort = Jkind.sort_of_jkind jkind in - Some (exp, sort) + match sort with + | Ok sort -> Some (exp, sort) + | Error err -> + raise + (Error (loc, env, Record_not_rep(ty_expected, err))) in Texp_record_unboxed_product { fields; representation; @@ -5953,11 +5957,13 @@ and type_expect_ fatal_error "Typecore.type_expect_: unboxed record labels are never mutable"; let record_sort = - let jkinds = - Array.map (fun lbl -> lbl.lbl_jkind) label.lbl_all |> Array.to_list - in - let record_jkind = Jkind.Builtin.product ~why:Unboxed_record jkinds in - Jkind.sort_of_jkind record_jkind + Ctype.type_sort ~why:Record_projection ~fixed:false env record.exp_type + in + let record_sort = match record_sort with + | Ok sort -> sort + | Error err -> + raise + (Error (loc, env, Record_projection_not_rep(record.exp_type, err))) in let mode = Modality.Value.Const.apply label.lbl_modalities rmode in let mode = mode_cross_left_value env ty_arg mode in @@ -10645,6 +10651,16 @@ let report_error ~loc env = function "@[Function arguments and returns must be representable.@]@ %a" (Jkind.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation + | Record_projection_not_rep (ty,violation) -> + Location.errorf ~loc + "@[Record projections must be representable.@]@ %a" + (Jkind.Violation.report_with_offender + ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation + | Record_not_rep (ty,violation) -> + Location.errorf ~loc + "@[Record expressions must be representable.@]@ %a" + (Jkind.Violation.report_with_offender + ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation | Invalid_label_for_src_pos arg_label -> Location.errorf ~loc "A position argument must not be %s." diff --git a/typing/typecore.mli b/typing/typecore.mli index 4af8a308a7e..09347fd38fd 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -313,6 +313,8 @@ type error = | Exclave_returns_not_local | Unboxed_int_literals_not_supported | Function_type_not_rep of type_expr * Jkind.Violation.t + | Record_projection_not_rep of type_expr * Jkind.Violation.t + | Record_not_rep of type_expr * Jkind.Violation.t | Invalid_label_for_src_pos of arg_label | Nonoptional_call_pos_label of string | Cannot_stack_allocate of Env.locality_context option From aa57c71380de2e2c4db7d29b47b939cf0eb35bd7 Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Wed, 4 Dec 2024 21:04:31 -0500 Subject: [PATCH 18/19] Reformat unboxed records changes to fit in 80char --- lambda/matching.ml | 23 +-- lambda/translcore.ml | 6 +- parsing/ast_mapper.ml | 3 +- .../basics_alpha.ml | 9 +- .../basics_from_typing_atat_unboxed.ml | 4 +- .../basics_from_unboxed_tuples_tests.ml | 14 +- .../typing-layouts-unboxed-records/letrec.ml | 4 +- .../recursive.ml | 9 +- .../separability.ml | 4 +- .../typing-warnings.ml | 7 +- .../unboxed_records.ml | 38 +++-- .../typing-layouts-unboxed-records/unique.ml | 7 +- .../typing-layouts-unboxed-records/unused.ml | 4 +- toplevel/genprintval.ml | 4 +- typing/btype.ml | 3 +- typing/ctype.ml | 38 +++-- typing/datarepr.ml | 6 +- typing/env.ml | 59 ++++--- typing/includecore.ml | 5 +- typing/mtype.ml | 3 +- typing/parmatch.ml | 3 +- typing/patterns.ml | 3 +- typing/printtyp.ml | 6 +- typing/printtyped.ml | 3 +- typing/shape.ml | 3 +- typing/subst.ml | 6 +- typing/tast_mapper.ml | 3 +- typing/typecore.ml | 152 +++++++++++------- typing/typedecl.ml | 29 ++-- typing/typedtree.ml | 7 +- typing/typeopt.ml | 6 +- typing/types.ml | 9 +- utils/warnings.ml | 3 +- 33 files changed, 298 insertions(+), 185 deletions(-) diff --git a/lambda/matching.ml b/lambda/matching.ml index 7ef6e282efb..4e5efe20040 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -177,7 +177,8 @@ let expand_record_head h = let expand_record_unboxed_product_head h = let open Patterns.Head in match h.pat_desc with - | Record_unboxed_product [] -> fatal_error "Matching.expand_record_unboxed_product_head" + | Record_unboxed_product [] -> + fatal_error "Matching.expand_record_unboxed_product_head" | Record_unboxed_product ({ lbl_all } :: _) -> { h with pat_desc = Record_unboxed_product (Array.to_list lbl_all) } | _ -> h @@ -279,7 +280,8 @@ end = struct stop p full_view | `Record_unboxed_product ([], _) as view -> stop p view | `Record_unboxed_product (lbls, closed) -> - let full_view = `Record_unboxed_product (all_record_args lbls, closed) in + let full_view = + `Record_unboxed_product (all_record_args lbls, closed) in stop p full_view | `Or _ -> ( let orpat = General.view (simpl_under_orpat (General.erase p)) in @@ -1290,8 +1292,8 @@ let can_group discr pat = | Const_int32 _ | Const_int64 _ | Const_nativeint _ | Const_unboxed_int32 _ | Const_unboxed_int64 _ | Const_unboxed_nativeint _ ) - | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ | Record_unboxed_product _ - | Array _ | Variant _ | Lazy ) ) -> + | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ + | Record_unboxed_product _ | Array _ | Variant _ | Lazy ) ) -> false let is_or p = @@ -2391,15 +2393,17 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = in make_args 0 -let get_expr_args_record_unboxed_product ~scopes head (arg, _mut, _sort, _layout) rem = +let get_expr_args_record_unboxed_product ~scopes head + (arg, _mut, _sort, _layout) rem = let loc = head_loc ~scopes head in let all_labels = let open Patterns.Head in match head.pat_desc with - | Record_unboxed_product ({ lbl_all ; lbl_repres = Record_unboxed_product} :: _) -> - lbl_all + | Record_unboxed_product + ({ lbl_all ; lbl_repres = Record_unboxed_product} :: _) -> + lbl_all | _ -> - assert false + assert false in let lbl_layouts = Array.map (fun lbl -> @@ -2412,7 +2416,8 @@ let get_expr_args_record_unboxed_product ~scopes head (arg, _mut, _sort, _layout rem else let lbl = all_labels.(pos) in - jkind_layout_default_to_value_and_check_not_void head.pat_loc lbl.lbl_jkind; + jkind_layout_default_to_value_and_check_not_void + head.pat_loc lbl.lbl_jkind; let access = if Array.length all_labels = 1 then arg (* erase singleton unboxed records before lambda *) else diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 8fbec899d06..abaef44c174 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -631,7 +631,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = transl_record ~scopes e.exp_loc e.exp_env (Option.map transl_alloc_mode alloc_mode) fields representation extended_expression - | Texp_record_unboxed_product {fields; representation; extended_expression } -> + | Texp_record_unboxed_product + {fields; representation; extended_expression } -> transl_record_unboxed_product ~scopes e.exp_loc e.exp_env fields representation extended_expression | Texp_field(arg, id, lbl, float, ubr) -> @@ -2111,7 +2112,8 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = (* CR layouts v11: if a functional update can change the kind, then the resulting kind may be different than [init_expr_jkind] *) let layout = layout_exp init_expr_sort init_expr in - Llet(Strict, layout, init_id, transl_exp ~scopes init_expr_sort init_expr, lam) + let exp = transl_exp ~scopes init_expr_sort init_expr in + Llet(Strict, layout, init_id, exp, lam) and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = let return_layout = layout_exp return_sort e in diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 6c4a28d9649..c2132bc54bd 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -553,7 +553,8 @@ module E = struct record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) (map_opt (sub.expr sub) eo) | Pexp_record_unboxed_product (l, eo) -> - record_unboxed_product ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + record_unboxed_product ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml index 9a040823855..af39bb18f64 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml @@ -40,11 +40,12 @@ Error: because it is the type of record field bad. |}] -(***************************************************************************************) -(* The below is adapted from [testsuite/tests/typing-layouts-products/basics_alpha.ml]. +(******************************************************************************) +(* The below is adapted from + [testsuite/tests/typing-layouts-products/basics_alpha.ml]. - CR layouts v7.2: once unboxed records are in stable, fold this test back into the - original or move it to [typing-layouts-products]. *) + CR layouts v7.2: once unboxed records are in stable, fold this test back into + the original or move it to [typing-layouts-products]. *) (* [t3] is allowed for unboxed tuples, and disallowed for (un)boxed records *) type t1 : any mod non_null diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml index 0edb668fa58..34c7c5731d3 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml @@ -5,8 +5,8 @@ (* This test is adapted from [testsuite/tests/typing-unboxed-types/test.ml]. - CR layouts v7.2: once unboxed records are in stable, fold this test back into the - original or move it to [typing-layouts-products]. *) + CR layouts v7.2: once unboxed records are in stable, fold this test back into + the original or move it to [typing-layouts-products]. *) (* Check the unboxing *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml index 4825c6d3209..2c9eba167df 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -10,8 +10,8 @@ (* These tests are adapted from the tuple tests in [testsuite/tests/typing-layouts-products/basics.ml]. - CR layouts v7.2: once unboxed records are in stable, fold this test back into the - original or move it to [typing-layouts-products]. *) + CR layouts v7.2: once unboxed records are in stable, fold this test back into + the original or move it to [typing-layouts-products]. *) open Stdlib_upstream_compatible @@ -206,9 +206,11 @@ module F(X : S) = struct type take_few_input1 = #{ a : a; b : b } type take_few_input3 = #{ d : d; e : e } type take_few_input5 = #{ g : g; h : h } - type take_few_output = #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } + type take_few_output = + #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } - let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 (x3 : take_few_input3) x4 (x5 : take_few_input5) = + let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 + (x3 : take_few_input3) x4 (x5 : take_few_input5) = let #{ a; b } = x1 in let #{ d; e } = x3 in let #{ g; h } = x5 in @@ -465,8 +467,8 @@ class class_with_urecord_manipulating_method : (*******************************************) (* Test 6: Nested expansion in kind checks *) -(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and boxed - records, in the same way as below. +(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and + boxed records, in the same way as below. CR layouts v7.2: These should typecheck for all record forms. *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml index 1068fb85d72..847b2fa41a6 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml @@ -36,8 +36,8 @@ val t : bx = {bx = } (* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml]. - CR layouts v7.2: once unboxed records are in stable, fold this test back into the - original or move it to [typing-layouts-products]. *) + CR layouts v7.2: once unboxed records are in stable, fold this test back into + the original or move it to [typing-layouts-products]. *) type t = #{x: int64} let rec x = #{x = y} and y = 3L;; diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml index f6a0933dbb8..a9e00527391 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml @@ -10,8 +10,8 @@ (* CR layouts v7.2: figure out the story for recursive unboxed products. Consider that the following is allowed upstream: type t = { t : t } [@@unboxed] - We should also give good errors for infinite-size unboxed records (see the test at the - bottom of this file with a depth-100 kind). + We should also give good errors for infinite-size unboxed records (see the + test at the bottom of this file with a depth-100 kind). *) (************************************) @@ -33,8 +33,9 @@ type t : value = #{ t : t } type t = #{ t : t; } |}] -(* CR layouts v7.2: Once we support unboxed records with elements of kind [any], and - detect bad recursive unboxed records with an occurs check, this error should improve. +(* CR layouts v7.2: Once we support unboxed records with elements of kind [any], + and detect bad recursive unboxed records with an occurs check, this error + should improve. *) type bad = #{ bad : bad ; i : int} [%%expect{| diff --git a/testsuite/tests/typing-layouts-unboxed-records/separability.ml b/testsuite/tests/typing-layouts-unboxed-records/separability.ml index 23a4edc394a..9cc30e9672a 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/separability.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/separability.ml @@ -72,8 +72,8 @@ Error: This type cannot be unboxed because You should annotate it with "[@@ocaml.boxed]". |}] -(* CR layouts v12: Once we allow products containing void in unboxed GADTs, we'll have to - make sure the below fails separability checking: *) +(* CR layouts v12: Once we allow products containing void in unboxed GADTs, + we'll have to make sure the below fails separability checking: *) type t_void : void and 'a r = #{ a : 'a ; v : t_void } and bad = F : 'a r -> bad [@@unboxed] diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml index 19431efc9fb..b56729eeaed 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml @@ -31,10 +31,11 @@ external ignore_product : ('a : value & value). 'a -> unit = "%ignore" external ignore_product : ('a : value & value). 'a -> unit = "%ignore" |}] -(* This below tests are adapted from [testsuite/tests/typing-warnings/records.ml]. +(* This below tests are adapted from + [testsuite/tests/typing-warnings/records.ml]. - CR layouts v7.2: once unboxed records are in stable, fold this test back into the - original or move it to [typing-layouts-products]. *) + CR layouts v7.2: once unboxed records are in stable, fold this test back into + the original or move it to [typing-layouts-products]. *) (* Use type information *) module M1 = struct diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml index 61eb15691f2..882c107a389 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml @@ -53,7 +53,8 @@ open Stdlib_upstream_compatible type ints = #{ x : int ; y : int } -let print_floatu prefix x = Printf.printf "%s: %.2f\n" prefix (Float_u.to_float x) +let print_floatu prefix x = + Printf.printf "%s: %.2f\n" prefix (Float_u.to_float x) let print_float prefix x = Printf.printf "%s: %.2f\n" prefix x let print_int prefix x = Printf.printf "%s: %d\n" prefix x let print_ints prefix #{ x; y } = Printf.printf "%s: [%d %d]\n" prefix x y @@ -166,7 +167,8 @@ let _ = let add_two = add_t two in let add_two_after = compose add_two in let minus_four = - add_two_after (twice (fun x -> add_t x #{ i = -1; ff' = #{f = -#1.0; f' = -1.0 } })) + add_two_after + (twice (fun x -> add_t x #{ i = -1; ff' = #{f = -#1.0; f' = -1.0 } })) in minus_four pi) @@ -176,8 +178,8 @@ let _ = type int_floatu = #{ i : int ; f : float# } type floatarray_floatu = #{ fa : float array ; f : float# } -(* [go]'s closure should have an unboxed record with an [int] (immediate), a [float#] - (float64) and a [float array] (value). *) +(* [go]'s closure should have an unboxed record with an [int] (immediate), a + [float#] (float64) and a [float array] (value). *) let[@inline never] f3 bounds steps_init () = let[@inline never] rec go k = let #{ i = n; f = m } = bounds in @@ -246,7 +248,8 @@ let test3 () = let x6 = #{ i = -242; ff' = #{ f = #5.5 ; f' = 84.5 } } in let x8 = #{ i = -2; ff' = #{ f = #20.0 ; f' = 2.0 } } in - let f3_manyargs = f3_manyargs #{ x = 4; y = 8} x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in + let f3_manyargs = + f3_manyargs #{ x = 4; y = 8} x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in print_float "Test 3, 610.68: " (f3_manyargs ()); Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps @@ -408,7 +411,7 @@ let print4 prefix #{ zy = #{ z; y }; x; w } = Printf.printf "%s: [%.1f %d %.1f %s]\n" prefix z y (Float_u.to_float x) w let _ = - let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w } in + let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w} in let[@inline never] g i p1 p2 = let z = if i < 0 then @@ -423,7 +426,7 @@ let _ = (g (-1) #{ w = "a"; x = #1.0; yz = #{ y_ = 2; z_ = 3.0 } } #{ w = "a"; x = #4.0; yz = #{ y_ = 5; z_ = 6.0 } }); - let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w } in + let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w} in let[@inline never] g i p1 p2 = let z = if i < 0 then @@ -438,7 +441,7 @@ let _ = (g 0 #{ w = "a"; x = #1.0; yz = #{ y_ = 2; z_ = 3.0 } } #{ w = "b"; x = #4.0; yz = #{ y_ = 5; z_ = 6.0 } }); - let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w } in + let[@local] swap #{ w; x; yz = #{ y_; z_ }} = #{ zy = #{ z=z_; y=y_}; x; w} in let[@inline never] g i p1 p2 = let z = if i < 0 then @@ -521,14 +524,14 @@ let () = Printf.printf "Test 11: %d\n" res -(*******************************************************************************) -(* Test 12: unboxed records in closures, using projection and partial patterns *) +(******************************************************************************) +(* Test 12: unboxed records in closures using projection and partial patterns *) (* This test is adapted from test 3. *) -(* [go]'s closure should have an unboxed record with an [int] (immediate), a [float#] - (float64) and a [float array] (value). *) -let[@inline never] f3 (bounds : int_floatu) (steps_init : floatarray_floatu) () = +(* [go]'s closure should have an unboxed record with an [int] (immediate), a + [float#] (float64) and a [float array] (value). *) +let[@inline never] f3 (bounds : int_floatu) (steps_init :floatarray_floatu) () = let[@inline never] rec go k = let n = bounds.#i in let (#{ f = m; _ } : int_floatu) = bounds in @@ -596,10 +599,13 @@ let test12 () = let x2 = #{ i = 7; ff' = #{ f = #40.0 ; f' = 2.0 } } in let x4 = #{ #{ x2 with i = -23 } with ff' = #{ f = #100.0 ; f' = 9.0 } } in let x6 = #{ - #{ (Sys.opaque_identity x4) with i = -242 } with ff' = #{ f = #5.5 ; f' = 84.5 } + #{ (Sys.opaque_identity x4) with i = -242 } + with ff' = #{ f = #5.5 ; f' = 84.5 } } in - let x8 = #{ i = -2; ff' = #{ (Sys.opaque_identity x2.#ff') with f = #20.0 } } in - let f3_manyargs = f3_manyargs #{ x = 4; y = 8} x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in + let x8 = + #{ i = -2; ff' = #{ (Sys.opaque_identity x2.#ff') with f = #20.0 } } in + let f3_manyargs = + f3_manyargs #{ x = 4; y = 8} x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in print_float "Test 3, 610.68: " (f3_manyargs ()); Array.iteri (Printf.printf " Test 12, step %d: %.2f\n") steps diff --git a/testsuite/tests/typing-layouts-unboxed-records/unique.ml b/testsuite/tests/typing-layouts-unboxed-records/unique.ml index 8ca82a81c32..e9d1845bcb4 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unique.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unique.ml @@ -135,9 +135,10 @@ let [@warning "-23"] () = [%%expect{| |}] -(* CR uniqueness: this test should succeed since unboxed records have no memory address - and the first field is of type unit and thus mode-crosses uniqueness. We should fix - this by allowing multiple unique uses for values that mode-cross uniqueness. *) +(* CR uniqueness: this test should succeed since unboxed records have no memory + address and the first field is of type unit and thus mode-crosses uniqueness. + We should fix this by allowing multiple unique uses for values that + mode-cross uniqueness. *) let () = let t = mk () in unique_use2 t; diff --git a/testsuite/tests/typing-layouts-unboxed-records/unused.ml b/testsuite/tests/typing-layouts-unboxed-records/unused.ml index dbc6fa950cb..c9f53e69ea9 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unused.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/unused.ml @@ -5,8 +5,8 @@ (* Adapted from [testsuite/tests/typing-warnings/unused_types.ml]. - CR layouts v7.2: Once unboxed records are in stable, fold this test back into the - original or move it to [typing-layouts-products]. *) + CR layouts v7.2: Once unboxed records are in stable, fold this test back into + the original or move it to [typing-layouts-products]. *) module Unused_record : sig end = struct type t = #{ a : int; b : int } diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index fbaaedfb77a..01e074df1e5 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -615,8 +615,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct in Oval_record (tree_of_fields (pos = 0) pos lbl_list) - and tree_of_record_unboxed_product_fields depth env path type_params ty_list - lbl_list pos obj = + and tree_of_record_unboxed_product_fields depth env path type_params + ty_list lbl_list pos obj = let rec tree_of_fields first pos = function | [] -> [] | {ld_id; ld_type; ld_jkind} :: remainder -> diff --git a/typing/btype.ml b/typing/btype.ml index fe3d95514eb..7c6adf27251 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -134,7 +134,8 @@ let type_kind_is_abstract decl = let type_origin decl = match decl.type_kind with | Type_abstract origin -> origin - | Type_variant _ | Type_record _ | Type_record_unboxed_product _ | Type_open -> + | Type_variant _ | Type_record _ | Type_record_unboxed_product _ + | Type_open -> Definition let dummy_method = "*dummy method*" diff --git a/typing/ctype.ml b/typing/ctype.ml index ba72311b1f7..5d7e6ca8a5a 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -430,7 +430,8 @@ let in_pervasives p = let is_datatype decl= match decl.type_kind with - Type_record _ | Type_record_unboxed_product _ | Type_variant _ | Type_open -> true + | Type_record _ | Type_record_unboxed_product _ | Type_variant _ + | Type_open -> true | Type_abstract _ -> false @@ -2101,8 +2102,10 @@ let unbox_once env ty = | Type_record_unboxed_product ([_], Record_unboxed_product) -> (* [find_unboxed_type] would have returned [Some] *) Misc.fatal_error "Ctype.unbox_once" - | Type_record_unboxed_product ((_::_::_ as lbls), Record_unboxed_product) -> - Stepped_record_unboxed_product (List.map (fun ld -> apply ld.ld_type) lbls) + | Type_record_unboxed_product + ((_::_::_ as lbls), Record_unboxed_product) -> + Stepped_record_unboxed_product + (List.map (fun ld -> apply ld.ld_type) lbls) | Type_record_unboxed_product ([], _) -> Misc.fatal_error "Ctype.unboxed_once: fieldless record" | Type_abstract _ | Type_record _ | Type_variant _ | Type_open -> @@ -2184,7 +2187,8 @@ let rec estimate_type_jkind ~expand_component env ty = [type_jkind_deep] calulates a jkind from a type expression, deeply unfolding unboxed types. - This deep unfolding is necessary (for now) for declarations like the following: + This deep unfolding is necessary (for now) for declarations like the + following: type 'a t = #{ i : 'a ; j : 'a } type int_t : immediate & immediate = int t @@ -2192,8 +2196,9 @@ let rec estimate_type_jkind ~expand_component env ty = Otherwise, [int_t] will be given kind [value & value]. This function duplicates functionality from [find_unboxed_type] and - [constrain_type_jkind]. We're not to factoring out the shared logic because this - function will no longer be necessary once we have kind-polymorphic type declarations. + [constrain_type_jkind]. We're not to factoring out the shared logic because + this function will no longer be necessary once we have kind-polymorphic type + declarations. Returns (ran_out_of_fuel, best_effort_jkind). *) @@ -2207,7 +2212,8 @@ let rec type_jkind_deep env ty_prev ty fuel = match unbox_once env ty with | Stepped ty' -> type_jkind_deep env ty ty' fuel | Stepped_record_unboxed_product component_tys -> - let out_of_fuel, component_jkinds = types_jkinds_deep env component_tys fuel in + let out_of_fuel, component_jkinds = + types_jkinds_deep env component_tys fuel in out_of_fuel, Jkind.Builtin.product ~why:Unboxed_record component_jkinds | Final_result -> type_unboxed_jkind_deep env ty fuel | Missing _ -> type_unboxed_jkind_deep env ty_prev fuel @@ -2223,7 +2229,8 @@ and type_unboxed_jkind_deep env ty fuel = | Tarrow _ -> false, Jkind.for_arrow | Ttuple _ -> false, Jkind.Builtin.value ~why:Tuple | Tunboxed_tuple ltys -> - let out_of_fuel, component_jkinds = types_jkinds_deep env (List.map snd ltys) fuel in + let out_of_fuel, component_jkinds = + types_jkinds_deep env (List.map snd ltys) fuel in out_of_fuel, Jkind.Builtin.product ~why:Unboxed_tuple component_jkinds | Tconstr (p, _, _) -> begin try @@ -2372,12 +2379,13 @@ let constrain_type_jkind ~fixed env ty jkind = | Missing path -> Error (Jkind.Violation.of_ ~missing_cmi:path (Not_a_subjkind (ty's_jkind, jkind))) | Final_result -> - Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) + Error + (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) | Stepped ty -> - loop ~fuel:(fuel - 1) ~expanded:false ty - (estimate_type_jkind env ty) jkind + loop ~fuel:(fuel - 1) ~expanded:false ty + (estimate_type_jkind env ty) jkind | Stepped_record_unboxed_product tys -> - product ~fuel:(fuel - 1) tys + product ~fuel:(fuel - 1) tys end | Tunboxed_tuple ltys -> (* Note: here we "duplicate" the fuel, which may seem like cheating. @@ -2385,7 +2393,8 @@ let constrain_type_jkind ~fixed env ty jkind = infinitely expanding a recursive type. In a wide tuple, we many need to expand many types shallowly, and that's fine. *) product ~fuel (List.map snd ltys) - | _ -> Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) + | _ -> + Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) in loop ~fuel:100 ~expanded:false ty (estimate_type_jkind env ty) jkind @@ -3264,7 +3273,8 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = when equal_record_representation r r' -> mcomp_list type_pairs env tl1 tl2; mcomp_record_description type_pairs env lst lst' - | Type_record_unboxed_product (lst,r), Type_record_unboxed_product (lst',r') + | Type_record_unboxed_product (lst,r), + Type_record_unboxed_product (lst',r') when equal_record_unboxed_product_representation r r' -> mcomp_list type_pairs env tl1 tl2; mcomp_record_description type_pairs env lst lst' diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 1dfac3eb53e..cb9daeac2d6 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -221,7 +221,8 @@ let none = create_expr (Ttuple []) ~level:(-1) ~scope:Btype.generic_level ~id:(-1) (* Clearly ill-formed type *) -let dummy_label (type rep) (record_form : rep record_form) : rep gen_label_description = +let dummy_label (type rep) (record_form : rep record_form) + : rep gen_label_description = let repres : rep = match record_form with | Legacy -> Record_unboxed | Unboxed_product -> Record_unboxed_product @@ -284,7 +285,8 @@ let constructors_of_type ~current_unit ty_path decl = match decl.type_kind with | Type_variant (cstrs,rep) -> constructor_descrs ~current_unit ty_path decl cstrs rep - | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ | Type_open -> [] + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ + | Type_open -> [] let labels_of_type ty_path decl = match decl.type_kind with diff --git a/typing/env.ml b/typing/env.ml index 4ac76811b10..11ea5a292e8 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -614,7 +614,8 @@ module IdTbl = end type type_descr_kind = - (label_description, unboxed_label_description, constructor_description) type_kind + (label_description, unboxed_label_description, constructor_description) + type_kind type type_descriptions = type_descr_kind @@ -825,19 +826,22 @@ let used_labels_by_form (type rep) (record_form : rep record_form) = let find_used_label_by_uid (type rep) (record_form : rep record_form) uid = Types.Uid.Tbl.find (used_labels_by_form record_form) uid -let env_labels (type rep) (record_form : rep record_form) env : rep gen_label_description TycompTbl.t = +let env_labels (type rep) (record_form : rep record_form) env + : rep gen_label_description TycompTbl.t = match record_form with | Legacy -> env.labels | Unboxed_product -> env.unboxed_labels -let add_label (type rep) (record_form : rep record_form) env lbl_id (lbl : rep gen_label_description) = +let add_label (type rep) (record_form : rep record_form) env lbl_id + (lbl : rep gen_label_description) = match record_form with | Legacy -> { env with labels = TycompTbl.add lbl_id lbl env.labels } | Unboxed_product -> { env with unboxed_labels = TycompTbl.add lbl_id lbl env.unboxed_labels } -let comp_labels (type rep) (record_form : rep record_form) sc : rep gen_label_description list NameMap.t = +let comp_labels (type rep) (record_form : rep record_form) sc + : rep gen_label_description list NameMap.t = match record_form with | Legacy -> sc.comp_labels | Unboxed_product -> sc.comp_unboxed_labels @@ -888,7 +892,8 @@ let check_shadowing env = function let empty = { values = IdTbl.empty; constrs = TycompTbl.empty; - labels = TycompTbl.empty; unboxed_labels = TycompTbl.empty; types = IdTbl.empty; + labels = TycompTbl.empty; unboxed_labels = TycompTbl.empty; + types = IdTbl.empty; modules = IdTbl.empty; modtypes = IdTbl.empty; classes = IdTbl.empty; cltypes = IdTbl.empty; summary = Env_empty; local_constraints = Path.Map.empty; @@ -1366,7 +1371,8 @@ and find_cstr path name env = match tda.tda_descriptions with | Type_variant (cstrs, _) -> List.find (fun cstr -> cstr.cstr_name = name) cstrs - | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ | Type_open -> + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ + | Type_open -> raise Not_found @@ -2221,7 +2227,8 @@ and store_label let k = lbl.lbl_uid in if not (Types.Uid.Tbl.mem (used_labels_by_form record_form) k) then let used = label_usages () in - Types.Uid.Tbl.add (used_labels_by_form record_form) k (add_label_usage used); + Types.Uid.Tbl.add (used_labels_by_form record_form) k + (add_label_usage used); if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_') then !add_delayed_check_forward (fun () -> @@ -2272,7 +2279,8 @@ and store_type ~check id info shape env = Type_record_unboxed_product (List.map snd labels, repr), List.fold_left (fun env (lbl_id, lbl) -> - store_label ~record_form:Unboxed_product ~check info id lbl_id lbl env) + store_label ~record_form:Unboxed_product ~check info id lbl_id lbl + env) env labels | Type_abstract r -> Type_abstract r, env | Type_open -> Type_open, env @@ -3164,10 +3172,11 @@ let find_all_labels (type rep) ~(record_form : rep record_form) ~mark s env | Legacy -> TycompTbl.find_all ~mark s env.labels | Unboxed_product -> TycompTbl.find_all ~mark s env.unboxed_labels -let lookup_all_ident_labels (type rep) ~(record_form : rep record_form) ~errors ~use ~loc - usage s env = +let lookup_all_ident_labels (type rep) ~(record_form : rep record_form) ~errors + ~use ~loc usage s env = match find_all_labels ~record_form ~mark:use s env with - | [] -> may_lookup_error errors loc env (Unbound_label (Lident s, P record_form)) + | [] -> + may_lookup_error errors loc env (Unbound_label (Lident s, P record_form)) | lbls -> begin List.map (fun (lbl, use_fn) -> @@ -3373,7 +3382,8 @@ let lookup_all_dot_labels ~record_form ~errors ~use ~loc usage l s env = let (_, _, comps) = lookup_structure_components ~errors ~use ~loc l env in match NameMap.find s (comp_labels record_form comps) with | [] | exception Not_found -> - may_lookup_error errors loc env (Unbound_label (Ldot(l, s), P record_form)) + may_lookup_error errors loc env + (Unbound_label (Ldot(l, s), P record_form)) | lbls -> List.map (fun lbl -> @@ -3418,7 +3428,8 @@ let add_components slot root env0 comps locks = add_l (fun x -> `Label x) comps.comp_labels env0.labels in let unboxed_labels = - add_l (fun x -> `Unboxed_label x) comps.comp_unboxed_labels env0.unboxed_labels + add_l (fun x -> `Unboxed_label x) comps.comp_unboxed_labels + env0.unboxed_labels in let values = add_v (fun x -> `Value x) comps.comp_values env0.values @@ -3688,8 +3699,10 @@ let lookup_cltype ~errors ~use ~loc lid env = let lookup_all_labels ~errors ~use ~record_form ~loc usage lid env = match lid with - | Lident s -> lookup_all_ident_labels ~errors ~use ~record_form ~loc usage s env - | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~record_form ~loc usage l s env + | Lident s -> + lookup_all_ident_labels ~errors ~use ~record_form ~loc usage s env + | Ldot(l, s) -> + lookup_all_dot_labels ~errors ~use ~record_form ~loc usage l s env | Lapply _ -> assert false let lookup_label ~errors ~use ~record_form ~loc usage lid env = @@ -3698,7 +3711,8 @@ let lookup_label ~errors ~use ~record_form ~loc usage lid env = | (desc, use) :: _ -> use (); desc let lookup_all_labels_from_type (type rep) ~use ~(record_form : rep record_form) - ~loc usage ty_path env : (rep gen_label_description * (unit -> unit)) list = + ~loc usage ty_path env : (rep gen_label_description * (unit -> unit)) list + = match (find_type_descrs ty_path env, record_form) with | exception Not_found -> [] | ((Type_variant _ | Type_abstract _ | Type_open), _) -> [] @@ -3731,7 +3745,8 @@ let lookup_constructor ~errors ~use ~loc usage lid env = let lookup_all_constructors_from_type ~use ~loc usage ty_path env = match find_type_descrs ty_path env with | exception Not_found -> [] - | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ | Type_open -> [] + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ + | Type_open -> [] | Type_variant (cstrs, _) -> List.map (fun cstr -> @@ -3857,7 +3872,8 @@ let lookup_all_labels ?(use=true) ~record_form ~loc usage lid env = let lookup_label ?(use=true) ~record_form ~loc lid env = lookup_label ~errors:true ~use ~record_form ~loc lid env -let lookup_all_labels_from_type ?(use=true) ~record_form ~loc usage ty_path env = +let lookup_all_labels_from_type ?(use=true) ~record_form ~loc usage ty_path env + = lookup_all_labels_from_type ~use ~record_form ~loc usage ty_path env let lookup_instance_variable ?(use=true) ~loc name env = @@ -4285,7 +4301,8 @@ let report_lookup_error _loc env ppf = function | Unbound_label (lid, record_form) -> let P record_form = record_form in fprintf ppf "Unbound %s field %a" - (record_form_to_string record_form) (Style.as_inline_code !print_longident) lid; + (record_form_to_string record_form) + (Style.as_inline_code !print_longident) lid; spellcheck ppf (extract_labels record_form) env lid; let label_of_other_form = match record_form with | Legacy -> @@ -4299,8 +4316,8 @@ let report_lookup_error _loc env ppf = function in (match label_of_other_form with | Some other_form -> - Format.fprintf ppf "@\n@{Hint@}: There is %s field with this name." - other_form + Format.fprintf ppf + "@\n@{Hint@}: There is %s field with this name." other_form | None -> ()); | Unbound_class lid -> begin fprintf ppf "Unbound class %a" diff --git a/typing/includecore.ml b/typing/includecore.ml index 3c79b8836e2..e2eaca1d547 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -739,8 +739,9 @@ module Record_diffing = struct representation is if one is a flat float record with a boxed float \ field, and the other isn't." - let compare_with_representation (type rep) ~loc (record_form : rep record_form) env - params1 params2 l r (rep1 : rep) (rep2 : rep) = + let compare_with_representation (type rep) ~loc + (record_form : rep record_form) env params1 params2 l r + (rep1 : rep) (rep2 : rep) = if not (equal ~loc env params1 params2 l r) then let patch = diffing loc env params1 params2 l r in Some (Record_mismatch (Label_mismatch patch)) diff --git a/typing/mtype.ml b/typing/mtype.ml index 3f704cb1719..750c5c9c49a 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -309,7 +309,8 @@ let rec sig_make_manifest sg = match decl.type_kind with | Type_abstract _ -> { decl with type_private = Public; type_manifest = manif } - | (Type_record _ | Type_record_unboxed_product _ | Type_variant _ | Type_open) -> + | (Type_record _ | Type_record_unboxed_product _ | Type_variant _ + | Type_open) -> { decl with type_manifest = manif } in Sig_type(Ident.rename id, newdecl, rs, vis) :: sig_make_manifest rem diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 9f3be586938..27e4c91445f 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -1208,7 +1208,8 @@ let rec has_instance p = match p.pat_desc with | Tpat_unboxed_tuple labeled_ps -> has_instances (List.map (fun (_, p, _) -> p) labeled_ps) | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) - | Tpat_record_unboxed_product (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) + | Tpat_record_unboxed_product (lps,_) -> + has_instances (List.map (fun (_,_,x) -> x) lps) | Tpat_lazy p -> has_instance p diff --git a/typing/patterns.ml b/typing/patterns.ml index 1442387eaf1..b383829b0f4 100644 --- a/typing/patterns.ml +++ b/typing/patterns.ml @@ -61,7 +61,8 @@ module Simple = struct | `Record of (Longident.t loc * label_description * pattern) list * closed_flag | `Record_unboxed_product of - (Longident.t loc * unboxed_label_description * pattern) list * closed_flag + (Longident.t loc * unboxed_label_description * pattern) list + * closed_flag | `Array of mutability * Jkind.sort * pattern list | `Lazy of pattern ] diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 1b41e0ccf97..f75357288ad 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -176,7 +176,8 @@ module Namespace = struct | Some Module_type -> to_lookup Env.find_modtype_by_name | Some Class -> to_lookup Env.find_class_by_name | Some Class_type -> to_lookup Env.find_cltype_by_name - | None | Some(Value|Extension_constructor|Constructor|Label|Unboxed_label) -> + | None + | Some(Value|Extension_constructor|Constructor|Label|Unboxed_label) -> fun _ -> raise Not_found let location namespace id = @@ -188,7 +189,8 @@ module Namespace = struct | Some Module_type -> (in_printing_env @@ Env.find_modtype path).mtd_loc | Some Class -> (in_printing_env @@ Env.find_class path).cty_loc | Some Class_type -> (in_printing_env @@ Env.find_cltype path).clty_loc - | Some (Extension_constructor|Value|Constructor|Label|Unboxed_label) | None -> + | Some (Extension_constructor|Value|Constructor|Label|Unboxed_label) + | None -> Location.none ) with Not_found -> None diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 107492bc862..e89b6e3dcda 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -530,7 +530,8 @@ and expression i ppf x = record_representation (i+1) ppf representation; line i ppf "extended_expression =\n"; option (i+1) expression ppf (Option.map fst extended_expression); - | Texp_record_unboxed_product { fields; representation; extended_expression } -> + | Texp_record_unboxed_product + { fields; representation; extended_expression } -> line i ppf "Texp_record_unboxed_product\n"; let i = i+1 in line i ppf "fields =\n"; diff --git a/typing/shape.ml b/typing/shape.ml index 943f372177d..3e89f8cf17b 100644 --- a/typing/shape.ml +++ b/typing/shape.ml @@ -444,7 +444,8 @@ module Map = struct let item = Item.label id in Item.Map.add item (proj shape item) t - let add_unboxed_label t id uid = Item.Map.add (Item.unboxed_label id) (leaf uid) t + let add_unboxed_label t id uid = + Item.Map.add (Item.unboxed_label id) (leaf uid) t let add_unboxed_label_proj t id shape = let item = Item.unboxed_label id in Item.Map.add item (proj shape item) t diff --git a/typing/subst.ml b/typing/subst.ml index b63ee52467b..aba4f23965c 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -556,9 +556,11 @@ let type_declaration' copy_scope s decl = 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 + 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_record_unboxed_product + (List.map (label_declaration copy_scope s) lbls, rep) | Type_open -> Type_open end; type_manifest = diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 8278890b322..2ce51ae48dc 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -496,7 +496,8 @@ let expr sub x = Option.map (fun (exp, ubr) -> (sub.expr sub exp, ubr)) extended_expression; alloc_mode } - | Texp_record_unboxed_product { fields; representation; extended_expression } -> + | Texp_record_unboxed_product + { fields; representation; extended_expression } -> Texp_record_unboxed_product { fields = map_fields fields; representation; extended_expression = diff --git a/typing/typecore.ml b/typing/typecore.ml index 346455a50eb..5009c121983 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -89,7 +89,8 @@ type wrong_kind_sort = | List | Unit -let record_form_to_wrong_kind_sort : type rep. rep record_form -> wrong_kind_sort = +let record_form_to_wrong_kind_sort + : type rep. rep record_form -> wrong_kind_sort = function | Legacy -> Record | Unboxed_product -> Record_unboxed_product @@ -144,7 +145,8 @@ type error = | Partial_tuple_pattern_bad_type | Extra_tuple_label of string option * type_expr | Missing_tuple_label of string option * type_expr - | Label_mismatch of record_form_packed * Longident.t * Errortrace.unification_error + | Label_mismatch of + record_form_packed * Longident.t * Errortrace.unification_error | Pattern_type_clash : Errortrace.unification_error * Parsetree.pattern_desc option -> error | Or_pattern_type_clash of Ident.t * Errortrace.unification_error @@ -246,7 +248,8 @@ type error = | Unbound_existential of Ident.t list * type_expr | Missing_type_constraint | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr - | Wrong_expected_record_boxing of wrong_kind_context * record_form_packed * type_expr + | Wrong_expected_record_boxing of + wrong_kind_context * record_form_packed * type_expr | Expr_not_a_record_type of record_form_packed * type_expr | Expr_record_type_has_wrong_boxing of record_form_packed * type_expr | Submode_failed of @@ -867,7 +870,8 @@ let extract_concrete_variant env ty = let extract_label_names record_form env ty = match extract_concrete_record record_form env ty with | Record_type (_, _,fields, _) -> List.map (fun l -> l.Types.ld_id) fields - | Record_type_of_other_form | Not_a_record_type | Maybe_a_record_type -> assert false + | Record_type_of_other_form | Not_a_record_type | Maybe_a_record_type -> + assert false let has_poly_constraint spat = match spat.ppat_desc with @@ -1724,7 +1728,8 @@ let solve_Ppat_construct ~refine tps penv loc constr no_existentials end; (ty_args_ty, ty_args_gf, existential_ctyp) -let solve_Ppat_record_field ~refine loc penv label label_lid record_ty record_form = +let solve_Ppat_record_field ~refine loc penv label label_lid record_ty + record_form = with_local_level_iter ~post:generalize_structure begin fun () -> let (_, ty_arg, ty_res) = instance_label ~fixed:false label in begin try @@ -2197,7 +2202,8 @@ module Unboxed_label = NameChoice (struct let get_name lbl = lbl.lbl_name let get_type lbl = lbl.lbl_res let lookup_all_from_type loc usage path env = - Env.lookup_all_labels_from_type ~record_form:Unboxed_product ~loc usage path env + Env.lookup_all_labels_from_type ~record_form:Unboxed_product ~loc usage path + env let in_env (lbl : t) = match lbl.lbl_repres with | Record_unboxed_product -> true @@ -2239,7 +2245,9 @@ let disambiguate_label_by_ids closed ids labels : (_, _) result = type 'rep candidates = ('rep gen_label_description * (unit -> unit)) list let label_disambiguate (type rep) - ?warn ?(filter : (rep candidates -> (rep candidates, rep candidates) result) option) + ?warn + ?(filter + : (rep candidates -> (rep candidates, rep candidates) result) option) (record_form : rep record_form) usage lid env expected_type (scope : (rep candidates, _) result) : rep gen_label_description = @@ -2251,8 +2259,8 @@ let label_disambiguate (* Only issue warnings once per record constructor/pattern *) let disambiguate_sort_lid_a_list - (type rep) - (record_form : rep record_form) loc closed env usage expected_type lid_a_list = + (type rep) (record_form : rep record_form) loc closed env usage + expected_type lid_a_list = let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in let w_pr = ref false and w_amb = ref [] and w_scope = ref [] and w_scope_ty = ref "" in @@ -2266,9 +2274,12 @@ let disambiguate_sort_lid_a_list | _ -> Location.prerr_warning loc msg in let process_label lid = - let scope = Env.lookup_all_labels ~record_form ~loc:lid.loc usage lid.txt env in + let scope = + Env.lookup_all_labels ~record_form ~loc:lid.loc usage lid.txt env in let filter = disambiguate_label_by_ids closed ids in - label_disambiguate ~warn ~filter record_form usage lid env expected_type scope in + label_disambiguate ~warn ~filter record_form usage lid env expected_type + scope + in let lbl_a_list = (* If one label is qualified [{ foo = ...; M.bar = ... }], we will disambiguate all labels using one of the qualifying modules, @@ -2319,12 +2330,14 @@ let disambiguate_sort_lid_a_list if !w_pr then Location.prerr_warning loc (Warnings.Not_principal - ("this type-based " ^ (record_form_to_string record_form) ^" disambiguation")) + ("this type-based " ^ (record_form_to_string record_form) + ^ " disambiguation")) else begin match List.rev !w_amb with (_,types,ex)::_ as amb -> let paths = - List.map (fun (_,lbl,_) -> label_get_type_path record_form lbl) lbl_a_list in + List.map (fun (_,lbl,_) -> label_get_type_path record_form lbl) + lbl_a_list in let path = List.hd paths in let fst3 (x,_,_) = x in if List.for_all (compare_type_path env path) (List.tl paths) then @@ -2338,9 +2351,10 @@ let disambiguate_sort_lid_a_list | _ -> () end; (if !w_scope <> [] then - let warning = Warnings.Fields {record_form = record_form_to_string record_form; - fields = List.rev !w_scope} in - Location.prerr_warning loc (Warnings.Name_out_of_scope (!w_scope_ty, warning))); + let record_form = record_form_to_string record_form in + let warning = Warnings.Fields { record_form; fields = List.rev !w_scope} in + Location.prerr_warning loc + (Warnings.Name_out_of_scope (!w_scope_ty, warning))); (* Invariant: records are sorted in the typed tree *) List.sort (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_num lbl2.lbl_num) @@ -2675,7 +2689,8 @@ and type_pat_aux pat_env = !!penv; pat_unique_barrier = Unique_barrier.not_computed () } in - let type_record_pat (type rep) (record_form : rep record_form) lid_sp_list closed = + let type_record_pat (type rep) (record_form : rep record_form) lid_sp_list + closed = assert (lid_sp_list <> []); let expected_type, record_ty = match extract_concrete_record record_form !!penv expected_ty with @@ -2683,7 +2698,8 @@ and type_pat_aux let ty = generic_instance expected_ty in Some (p0, p, is_principal expected_ty), ty | Record_type_of_other_form -> - let error = Wrong_expected_record_boxing(Pattern, P record_form, expected_ty) in + let error = + Wrong_expected_record_boxing(Pattern, P record_form, expected_ty) in raise (Error (loc, !!penv, error)) | Maybe_a_record_type -> None, newvar (Jkind.of_new_sort ~why:Record_projection) @@ -2703,11 +2719,13 @@ and type_pat_aux let alloc_mode = simple_pat_mode mode in (label_lid, label, type_pat tps Value ~alloc_mode sarg ty_arg) in - let make_record_pat (lbl_pat_list : (_ * rep gen_label_description * _) list) = + let make_record_pat + (lbl_pat_list : (_ * rep gen_label_description * _) list) = check_recordpat_labels loc lbl_pat_list closed record_form; let pat_desc = match record_form with | Legacy -> Tpat_record (lbl_pat_list, closed) - | Unboxed_product -> Tpat_record_unboxed_product (lbl_pat_list, closed) + | Unboxed_product -> + Tpat_record_unboxed_product (lbl_pat_list, closed) in { pat_desc; pat_loc = loc; pat_extra=[]; @@ -2719,10 +2737,11 @@ and type_pat_aux in let lbl_a_list = wrap_disambiguate - ("This " ^ (record_form_to_string record_form) ^ " pattern is expected to have") + ("This " ^ (record_form_to_string record_form) ^ + " pattern is expected to have") (mk_expected expected_ty) - (disambiguate_sort_lid_a_list record_form loc false !!penv Env.Projection - expected_type) + (disambiguate_sort_lid_a_list record_form loc false !!penv + Env.Projection expected_type) lid_sp_list in let lbl_a_list = List.map type_label_pat lbl_a_list in @@ -3401,12 +3420,14 @@ let rec check_counter_example_pat | Backtrack_or -> false | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in - let type_label_pats (type rep) (fields : (_ * rep gen_label_description * _) list) - closed (record_form : rep record_form) = + let type_label_pats (type rep) + (fields : (_ * rep gen_label_description * _) list) closed + (record_form : rep record_form) = let record_ty = generic_instance expected_ty in let type_label_pat (label_lid, label, targ) k = let ty_arg = - solve_Ppat_record_field ~refine loc penv label label_lid record_ty record_form in + solve_Ppat_record_field ~refine loc penv label label_lid record_ty + record_form in check_rec targ ty_arg (fun arg -> k (label_lid, label, arg)) in match record_form with @@ -3494,7 +3515,8 @@ let rec check_counter_example_pat | _ -> k None end | Tpat_record(fields, closed) -> type_label_pats fields closed Legacy - | Tpat_record_unboxed_product(fields, closed) -> type_label_pats fields closed Unboxed_product + | Tpat_record_unboxed_product(fields, closed) -> + type_label_pats fields closed Unboxed_product | Tpat_array (mut, original_arg_sort, tpl) -> let ty_elt, arg_sort = solve_Ppat_array ~refine loc penv mut expected_ty in assert (Jkind.Sort.equate original_arg_sort arg_sort); @@ -4562,8 +4584,8 @@ let check_partial_application ~statement exp = | Texp_ident _ | Texp_constant _ | Texp_tuple _ | Texp_unboxed_tuple _ | Texp_construct _ | Texp_variant _ | Texp_record _ - | Texp_record_unboxed_product _ - | Texp_field _ | Texp_unboxed_field _ | Texp_setfield _ | Texp_array _ + | Texp_record_unboxed_product _ | Texp_unboxed_field _ + | Texp_field _ | Texp_setfield _ | Texp_array _ | Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_while _ | Texp_for _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ | Texp_assert _ @@ -5301,7 +5323,8 @@ and type_expect_ | None -> None | Some (exp, _) -> match extract_concrete_record record_form env exp.exp_type with - | Record_type (p0, p, _, _) -> Some (p0, p, is_principal exp.exp_type) + | Record_type (p0, p, _, _) -> + Some (p0, p, is_principal exp.exp_type) | Maybe_a_record_type -> None | Record_type_of_other_form -> let error = @@ -5309,7 +5332,8 @@ and type_expect_ in raise (Error (exp.exp_loc, env, error)) | Not_a_record_type -> - let error = Expr_not_a_record_type (P record_form, exp.exp_type) in + let error = + Expr_not_a_record_type (P record_form, exp.exp_type) in raise (Error (exp.exp_loc, env, error)) in match expected_opath, opt_exp_opath with @@ -5328,12 +5352,15 @@ and type_expect_ let closed = (opt_sexp = None) in let lbl_a_list = wrap_disambiguate - ("This " ^ (record_form_to_string record_form) ^ " expression is expected to have") + ("This " ^ (record_form_to_string record_form) + ^ " expression is expected to have") (mk_expected ty_record) - (disambiguate_sort_lid_a_list record_form loc closed env Env.Construct expected_type) + (disambiguate_sort_lid_a_list record_form loc closed env Env.Construct + expected_type) lid_sexp_list in - let repres_might_allocate (type rep) (record_form : rep record_form) (rep : rep) = + let repres_might_allocate (type rep) (record_form : rep record_form) + (rep : rep) = match record_form with | Legacy -> begin match rep with | Record_unboxed | Record_inlined (_, _, Variant_unboxed) -> false @@ -5347,7 +5374,8 @@ and type_expect_ in let alloc_mode, argument_mode = if List.exists - (fun (_, {lbl_repres; _}, _) -> repres_might_allocate record_form lbl_repres) + (fun (_, {lbl_repres; _}, _) -> + repres_might_allocate record_form lbl_repres) lbl_a_list then let alloc_mode, argument_mode = register_allocation expected_mode in Some alloc_mode, argument_mode @@ -5390,7 +5418,8 @@ and type_expect_ let present_indices = List.map (fun (_, lbl, _) -> lbl.lbl_num) lbl_exp_list in - let label_names = extract_label_names record_form env ty_expected in + let label_names = + extract_label_names record_form env ty_expected in let rec missing_labels n = function [] -> [] | lbl :: rem -> @@ -5399,7 +5428,9 @@ and type_expect_ else lbl :: missing_labels (n + 1) rem in let missing = missing_labels 0 label_names in - raise(Error(loc, env, Label_missing (P record_form, missing)))) + raise + (Error(loc, env, + Label_missing (P record_form, missing)))) lbl.lbl_all in None, label_definitions @@ -5410,23 +5441,23 @@ and type_expect_ unify_exp_types exp.exp_loc env ty_exp ty_res1; match matching_label lbl with | lid, _lbl, lbl_exp -> - (* do not connect result types for overridden labels *) - Overridden (lid, lbl_exp) + (* do not connect result types for overridden labels *) + Overridden (lid, lbl_exp) | exception Not_found -> begin - let _, ty_arg2, ty_res2 = instance_label ~fixed:false lbl in - unify_exp_types loc env ty_arg1 ty_arg2; - with_explanation (fun () -> - unify_exp_types loc env (instance ty_expected) ty_res2); - check_project_mutability ~loc:exp.exp_loc ~env lbl.lbl_mut mode; - let mode = Modality.Value.Const.apply lbl.lbl_modalities mode in - check_construct_mutability ~loc ~env lbl.lbl_mut argument_mode; - let argument_mode = - mode_modality lbl.lbl_modalities argument_mode - in - submode ~loc ~env mode argument_mode; - Kept (ty_arg1, lbl.lbl_mut, - unique_use ~loc ~env mode - (as_single_mode argument_mode)) + let _, ty_arg2, ty_res2 = instance_label ~fixed:false lbl in + unify_exp_types loc env ty_arg1 ty_arg2; + with_explanation (fun () -> + unify_exp_types loc env (instance ty_expected) ty_res2); + check_project_mutability ~loc:exp.exp_loc ~env lbl.lbl_mut mode; + let mode = Modality.Value.Const.apply lbl.lbl_modalities mode in + check_construct_mutability ~loc ~env lbl.lbl_mut argument_mode; + let argument_mode = + mode_modality lbl.lbl_modalities argument_mode + in + submode ~loc ~env mode argument_mode; + Kept (ty_arg1, lbl.lbl_mut, + unique_use ~loc ~env mode + (as_single_mode argument_mode)) end in let label_definitions = Array.map unify_kept lbl.lbl_all in @@ -5437,7 +5468,8 @@ and type_expect_ match lbl_exp_list with [] -> assert false | (_, lbl,_)::_ -> Array.length lbl.lbl_all in (if opt_sexp <> None && List.length lid_sexp_list = num_fields then - Location.prerr_warning loc (Warnings.Useless_record_with (record_form_to_string record_form))); + Location.prerr_warning loc + (Warnings.Useless_record_with (record_form_to_string record_form))); let label_descriptions, representation = let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in lbl_all, lbl_repres @@ -5989,7 +6021,8 @@ and type_expect_ submode ~loc:record.exp_loc ~env rmode mode_mutate_mutable; let mode = mutable_mode m0 |> mode_default in let mode = mode_modality label.lbl_modalities mode in - type_label_exp false env mode loc ty_record (lid, label, snewval) Legacy + type_label_exp false env mode loc ty_record (lid, label, snewval) + Legacy | Immutable -> raise(Error(loc, env, Label_not_mutable lid.txt)) in @@ -7223,7 +7256,8 @@ and type_function } and type_label_access - : 'rep . 'rep record_form -> _ -> _ -> _ -> _ -> _ * _ * 'rep gen_label_description * _ + : 'rep . 'rep record_form -> _ -> _ -> _ -> _ -> + _ * _ * 'rep gen_label_description * _ = fun record_form env srecord usage lid -> let mode = Value.newvar () in let record = @@ -7243,7 +7277,8 @@ and type_label_access let error = Expr_not_a_record_type (P record_form, ty_exp) in raise (Error (record.exp_loc, env, error)) in - let labels = Env.lookup_all_labels ~record_form ~loc:lid.loc usage lid.txt env in + let labels = + Env.lookup_all_labels ~record_form ~loc:lid.loc usage lid.txt env in let label = wrap_disambiguate "This expression has" (mk_expected ty_exp) (label_disambiguate record_form usage lid env expected_type) labels in @@ -7536,7 +7571,8 @@ and type_label_exp begin try unify env (instance ty_res) (instance ty_expected) with Unify err -> - raise (Error(lid.loc, env, Label_mismatch(P record_form, lid.txt, err))) + raise + (Error(lid.loc, env, Label_mismatch(P record_form, lid.txt, err))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance ty_arg in diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 442b3b48138..7c1747e97a9 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -536,8 +536,9 @@ let transl_constructor_arguments ~new_var_jkind ~unboxed let lbls, lbls' = (* CR layouts: we forbid [@@unboxed] variants from being non-value, see comment in [check_representable]. *) - transl_labels ~record_form:Legacy ~new_var_jkind ~allow_unboxed:(not unboxed) - env univars closed l (Inlined_record { unboxed }) + transl_labels ~record_form:Legacy ~new_var_jkind + ~allow_unboxed:(not unboxed) env univars closed l + (Inlined_record { unboxed }) in Types.Cstr_record lbls', Cstr_record lbls @@ -827,7 +828,8 @@ let transl_declaration env sdecl (id, uid) = ~why:(Primitive Predef.ident_or_null) in Ttype_abstract, type_kind, jkind - | (Ptype_variant _ | Ptype_record _ | Ptype_record_unboxed_product _ | Ptype_open) + | (Ptype_variant _ | Ptype_record _ | Ptype_record_unboxed_product _ + | Ptype_open) when Builtin_attributes.has_or_null_reexport sdecl.ptype_attributes -> raise (Error (sdecl.ptype_loc, Non_abstract_reexport path)) | Ptype_abstract -> @@ -914,7 +916,8 @@ let transl_declaration env sdecl (id, uid) = (* CR layouts: we forbid [@@unboxed] records from being non-value, see comment in [check_representable]. *) transl_labels ~record_form:Legacy ~new_var_jkind:Any - ~allow_unboxed:(not unbox) env None true lbls (Record { unboxed = unbox }) + ~allow_unboxed:(not unbox) env None true lbls + (Record { unboxed = unbox }) in let rep, jkind = if unbox then @@ -1103,7 +1106,8 @@ let check_constraints env sdecl (_, decl) = | Type_variant (l, _rep) -> let find_pl = function Ptype_variant pl -> pl - | Ptype_record _ | Ptype_record_unboxed_product _ | Ptype_abstract | Ptype_open -> + | Ptype_record _ | Ptype_record_unboxed_product _ | Ptype_abstract + | Ptype_open -> assert false in let pl = find_pl sdecl.ptype_kind in @@ -1148,7 +1152,8 @@ let check_constraints env sdecl (_, decl) = | Type_record_unboxed_product (l, _) -> let find_pl = function | Ptype_record_unboxed_product pl -> pl - | Ptype_record _ | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false + | Ptype_record _ | Ptype_variant _ | Ptype_abstract | Ptype_open -> + assert false in let pl = find_pl sdecl.ptype_kind in check_constraints_labels env visited l pl @@ -1183,7 +1188,8 @@ let narrow_to_manifest_jkind env loc decl = with the same constructors and labels. *) let check_kind_coherence env loc dpath decl = match decl.type_kind, decl.type_manifest with - | (Type_variant _ | Type_record _ | Type_record_unboxed_product _ | Type_open), + | (Type_variant _ | Type_record _ | Type_record_unboxed_product _ + | Type_open), Some ty -> if !Clflags.allow_illegal_crossing then begin let jkind' = Ctype.type_jkind_purely env ty in @@ -1713,7 +1719,8 @@ let update_decl_jkind env dpath decl = |> List.split in let type_jkind = Jkind.Builtin.product ~why:Unboxed_record jkinds in - let type_jkind, type_has_illegal_crossings = add_crossings type_jkind in + let type_jkind, type_has_illegal_crossings = + add_crossings type_jkind in { decl with type_kind = Type_record_unboxed_product (lbls, rep); type_jkind; type_has_illegal_crossings }, @@ -2132,8 +2139,10 @@ let check_duplicates sdecl_list = let name' = Hashtbl.find unboxed_labels cname.txt in Location.prerr_warning loc (Warnings.Duplicate_definitions - ("unboxed record label", cname.txt, name', sdecl.ptype_name.txt)) - with Not_found -> Hashtbl.add unboxed_labels cname.txt sdecl.ptype_name.txt) + ("unboxed record label", cname.txt, name', + sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add unboxed_labels cname.txt sdecl.ptype_name.txt) fl | Ptype_abstract -> () | Ptype_open -> ()) diff --git a/typing/typedtree.ml b/typing/typedtree.ml index d8f437a7924..bd35e8fb8d5 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -151,8 +151,8 @@ and 'k pattern_desc = closed_flag -> value pattern_desc | Tpat_record_unboxed_product : - (Longident.t loc * unboxed_label_description * value general_pattern) list * - closed_flag -> + (Longident.t loc * unboxed_label_description * value general_pattern) list + * closed_flag -> value pattern_desc | Tpat_array : mutability * Jkind.sort * value general_pattern list -> value pattern_desc @@ -220,7 +220,8 @@ and expression_desc = alloc_mode : alloc_mode option } | Texp_record_unboxed_product of { - fields : ( Types.unboxed_label_description * record_label_definition ) array; + fields : + ( Types.unboxed_label_description * record_label_definition ) array; representation : Types.record_unboxed_product_representation; extended_expression : (expression * Jkind.sort) option; } diff --git a/typing/typeopt.ml b/typing/typeopt.ml index 059358314b6..44c84052498 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -515,8 +515,10 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty | Type_record_unboxed_product ([{ld_type}], Record_unboxed_product) -> let depth = depth + 1 in fallback_if_missing_cmi ~default:(num_nodes_visited, mk_nn Pgenval) - (fun () -> value_kind env ~loc ~visited ~depth ~num_nodes_visited ld_type) - | Type_record_unboxed_product (([] | _::_::_), Record_unboxed_product) -> + (fun () -> + value_kind env ~loc ~visited ~depth ~num_nodes_visited ld_type) + | Type_record_unboxed_product (([] | _::_::_), + Record_unboxed_product) -> Misc.fatal_error "Typeopt.value_kind: non-unary unboxed record can't have kind value" | Type_abstract _ -> diff --git a/typing/types.ml b/typing/types.ml index 4336cf6061a..b6e7839a902 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -272,12 +272,14 @@ type type_declaration = type_has_illegal_crossings: bool; } -and type_decl_kind = (label_declaration, label_declaration, constructor_declaration) type_kind +and type_decl_kind = + (label_declaration, label_declaration, constructor_declaration) type_kind and ('lbl, 'lbl_flat, 'cstr) type_kind = Type_abstract of type_origin | Type_record of 'lbl list * record_representation - | Type_record_unboxed_product of 'lbl_flat list * record_unboxed_product_representation + | Type_record_unboxed_product of + 'lbl_flat list * record_unboxed_product_representation | Type_variant of 'cstr list * variant_representation | Type_open @@ -712,7 +714,8 @@ type 'a gen_label_description = type label_description = record_representation gen_label_description -type unboxed_label_description = record_unboxed_product_representation gen_label_description +type unboxed_label_description = + record_unboxed_product_representation gen_label_description type _ record_form = | Legacy : record_representation record_form diff --git a/utils/warnings.ml b/utils/warnings.ml index 7a5b6880af8..a5580a86ed7 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -961,7 +961,8 @@ let message = function "this pattern-matching is not exhaustive.\n\ Here is an example of a case that is not matched:\n" ^ s | Missing_record_field_pattern { form ; unbound } -> - "the following labels are not bound in this " ^ form ^ " pattern:\n" ^ unbound ^ + "the following labels are not bound in this " ^ form ^ " pattern:\n" ^ + unbound ^ "\nEither bind these labels explicitly or add '; _' to the pattern." | Non_unit_statement -> "this expression should have type unit." From c0382c6d35e4ec4593069c4b2da8a1ad15634dcf Mon Sep 17 00:00:00 2001 From: Ryan Tjoa Date: Thu, 5 Dec 2024 10:13:04 -0500 Subject: [PATCH 19/19] Compute correct sort for a functional update's initial record --- lambda/translcore.ml | 2 -- testsuite/tests/typing-layouts-unboxed-records/basics.ml | 9 +++++---- typing/jkind.ml | 5 +++-- typing/jkind_intf.ml | 2 +- typing/typecore.ml | 6 +++--- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index abaef44c174..d9c4237e5b1 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -2109,8 +2109,6 @@ and transl_record_unboxed_product ~scopes loc env fields repres opt_init_expr = match opt_init_expr with | None -> lam | Some (init_expr, init_expr_sort) -> - (* CR layouts v11: if a functional update can change the kind, then - the resulting kind may be different than [init_expr_jkind] *) let layout = layout_exp init_expr_sort init_expr in let exp = transl_exp ~scopes init_expr_sort init_expr in Llet(Strict, layout, init_id, exp, lam) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-unboxed-records/basics.ml index 347c9b01092..25dcc0afccb 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -691,9 +691,9 @@ type ('a : any) t = #{ x : int; y : 'a } type ('a : value_or_null) t = #{ x : int; y : 'a; } |}] -(* CR layouts v7.2: once we allow record declarations with unknown kind - (right now, ['a] in the decl above is defaulted to value), then this should - give an error saying that record projections must be representable. *) +(* CR layouts v7.2: once we allow record declarations with unknown kind (right + now, ['a] in the decl above is defaulted to value), then this should give an + error saying that records being projected from must be representable. *) let f : ('a : any). 'a t -> 'a = fun t -> t.#y [%%expect{| Line 1, characters 8-30: @@ -706,7 +706,8 @@ Error: The universal type variable 'a was declared to have kind any. (* CR layouts v7.2: once we allow record declarations with unknown kind (right now, ['a] in the decl above is defaulted to value), then this should - give an error saying that record constructions must be representable. + give an error saying that records used in functional updates must be + representable. *) let f : ('a : any). 'a -> 'a t = fun a -> #{ x = 1; y = a } [%%expect{| diff --git a/typing/jkind.ml b/typing/jkind.ml index af015b56e64..f7ff9386563 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -1346,7 +1346,8 @@ module Format_history = struct fprintf ppf "it's the record type used in a projection" | Record_assignment -> fprintf ppf "it's the record type used in an assignment" - | Record_construction -> fprintf ppf "it's a constructed record type" + | Record_functional_update -> + fprintf ppf "it's the record type used in a functional update" | Let_binding -> fprintf ppf "it's the type of a variable bound by a `let`" | Function_argument -> fprintf ppf "we must know concretely how to pass a function argument" @@ -1891,7 +1892,7 @@ module Debug_printers = struct fprintf ppf "Label_declaration %a" Ident.print lbl | Record_projection -> fprintf ppf "Record_projection" | Record_assignment -> fprintf ppf "Record_assignment" - | Record_construction -> fprintf ppf "Record_construction" + | Record_functional_update -> fprintf ppf "Record_functional_update" | Let_binding -> fprintf ppf "Let_binding" | Function_argument -> fprintf ppf "Function_argument" | Function_result -> fprintf ppf "Function_result" diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index e2f1315ba0c..65fb18790ee 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -189,7 +189,7 @@ module History = struct | Label_declaration of Ident.t | Record_projection | Record_assignment - | Record_construction + | Record_functional_update | Let_binding | Function_argument | Function_result diff --git a/typing/typecore.ml b/typing/typecore.ml index 5009c121983..3c402295b11 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -5491,8 +5491,8 @@ and type_expect_ | None -> None | Some (exp, _) -> let sort = - Ctype.type_sort ~why:Record_construction ~fixed:false - env ty_expected + Ctype.type_sort ~why:Record_functional_update ~fixed:false + env exp.exp_type in match sort with | Ok sort -> Some (exp, sort) @@ -10689,7 +10689,7 @@ let report_error ~loc env = function ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation | Record_projection_not_rep (ty,violation) -> Location.errorf ~loc - "@[Record projections must be representable.@]@ %a" + "@[Records being projected from must be representable.@]@ %a" (Jkind.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation | Record_not_rep (ty,violation) ->