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..cc98af65a38 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..4e5efe20040 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -174,6 +174,15 @@ 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 +252,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 +278,11 @@ 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 +337,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 +436,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 +463,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 +480,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 +498,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 +1279,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 +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 _ | Array _ - | Variant _ | Lazy ) ) -> + | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ + | Record_unboxed_product _ | Array _ | Variant _ | Lazy ) ) -> false let is_or p = @@ -2274,6 +2307,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 +2393,50 @@ 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 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 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 + 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) + 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 +2449,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 +3855,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 +3939,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 +3953,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 +4317,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..d9c4237e5b1 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -631,6 +631,10 @@ 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 +697,21 @@ 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, arg_sort, _id, lbl, _) -> + begin match lbl.lbl_repres with + | Record_unboxed_product -> + 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 *) + targ + else + Lprim (Punboxed_product_field (lbl.lbl_num, 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 +2075,44 @@ 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 + 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, init_expr_sort) -> + 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) + 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/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 ec25b54ad67..b04728903bd 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,14 @@ 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 +652,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..6976ac419e4 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,6 +3070,9 @@ 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 @@ -3715,6 +3722,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 +3917,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..4f09fe078e1 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -727,22 +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) -> - 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 + record_pattern ctxt f ~unboxed:false l closed + | Ppat_record_unboxed_product (l, closed) -> + 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) -> @@ -779,7 +766,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 @@ -787,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 -> () @@ -1104,6 +1109,8 @@ 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 @@ -1152,17 +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) -> - 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 + record_expr ctxt f ~unboxed:false l eo + | Pexp_record_unboxed_product (l, eo) -> + record_expr ctxt f ~unboxed:true l eo | Pexp_array (mut, l) -> let punct = match mut with | Immutable -> ':' @@ -1993,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@]" @@ -2004,8 +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 + 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, @@ -2043,7 +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_declaration ctxt ~unboxed:true) l | Ptype_open -> pp f "%t%t@;.." intro priv in let constraints f = @@ -2089,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 -> @@ -2101,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 @@ -2259,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/parsing/printast.ml b/parsing/printast.ml index d5b48938cf7..ca734e1ced4 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..5c232c039af 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -845,6 +845,20 @@ result: 7 - : unit = () |}] +(*******************) +(* Unboxed records *) + +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 = +|}] + (***************) (* Modal kinds *) 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; } +|}] 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..25dcc0afccb --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics.ml @@ -0,0 +1,720 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +open Stdlib_upstream_compatible + +(**************************************************************************) +(* Basic examples: construction, functional updates, projection, matching *) + +(* 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 = +|}] + +(* Patterns, 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 = +|}] + +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 } +[%%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". +|}] + +;; +#{ 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 } +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"} +|}] + +;; +#{ i1 = 1 };; +[%%expect{| +- : m_record = #{i1 = 1} +|}] + +(* 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 = +|}] + +(* 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 } +[%%expect{| +Line 1, characters 14-29: +1 | type mut = #{ mutable i : int } + ^^^^^^^^^^^^^^^ +Error: Unboxed record labels cannot be mutable +|}] + +(*********************************) +(* Parameterized unboxed records *) + +(* 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; } +|}];; + +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 s = r_bad t1 +and r_bad = #{ y : float#; z : s t2 } +[%%expect{| +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. +|}] + +(* 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 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 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" +|}] + +(**********************) +(* 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 +end = struct + type t = #{ s : string } +end +[%%expect{| +module M : sig type t end +|}] + +(*************************************) +(* Types that mode cross externality *) + +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, + 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. +|}];; + +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; +} +|}];; + +(* We don't yet have syntax for setting an unboxed record field. + However, the below, using a boxed set field, will never work. *) + +type r = #{ i : int } +let f = #{ i = 1 } +[%%expect{| +type r = #{ i : int; } +val f : r = #{i = 1} +|}] + +let () = f.i <- 2 +[%%expect{| +Line 1, characters 9-10: +1 | let () = f.i <- 2 + ^ +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 + 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. +|}];; + +(*****************************************************) +(* 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. +|}] + +(* 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 = () +|}] + +(************************************************************) +(* 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 records being projected from 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 records used in functional updates 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/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..af39bb18f64 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml @@ -0,0 +1,165 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) + +(*****************************) +(* 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 +type t2 : value +type t3 : any mod non_null = #{ t1 : t1 ; t2 : t2};; +[%%expect{| +type t1 : any_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. +|}] + +(* 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};; +[%%expect{| +type t1 : any_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_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_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_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_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_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..34c7c5731d3 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml @@ -0,0 +1,153 @@ +(* TEST + flags = "-extension layouts_beta"; + expect; +*) +(* 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]. *) + +(* 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. +|}];; + +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{| +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..2c9eba167df --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml @@ -0,0 +1,1015 @@ +(* 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]. + + 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 + +(**********************************************************) +(* 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) = #{ so : string option ; t1 : t1 } +[%%expect{| +type t1 = #{ f : float#; b : bool; } +type t2 = #{ so : string option; t1 : 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 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. +|}] + +(* 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 +|}] + +(***************************************************) +(* 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 tuple_term = ("hi", #{ i = 1; i2 = 2 }) +[%%expect{| +type record = #{ i : int; i2 : int; } +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 + 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". +|}] + +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. + + CR layouts v7.2: These should typecheck for all record forms. +*) +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 record 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: 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 } +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/letrec.ml b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml new file mode 100644 index 00000000000..847b2fa41a6 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/letrec.ml @@ -0,0 +1,88 @@ +(* 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]. + + 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;; +[%%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/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 new file mode 100644 index 00000000000..a9e00527391 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml @@ -0,0 +1,197 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_beta"; + { + 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; } +|}] + +(* 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: +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; } +|}] + +(****************************) +(* 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..9cc30e9672a --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/separability.ml @@ -0,0 +1,103 @@ +(* 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 } +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{| +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 } +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] +[%%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]". +|}] + +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 +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. +|}] + +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 new file mode 100644 index 00000000000..b56729eeaed --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml @@ -0,0 +1,831 @@ +(* 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]. + + 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 + 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..5837a2fdf85 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml @@ -0,0 +1,305 @@ +(* TEST + flags = "-extension layouts_beta"; + { + 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 #{u:int};; +#{u=3};; +[%%expect{| +type u = private #{ 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 };; +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 = +val fst : int = 2 +val snd : string = "" +|}];; + +(* 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. + +Exception: Assert_failure ("", 1, 11). +|}] + +(* 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 } +[%%expect{| +type d = #{ x : int; y : int; } +|}] + +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 + [@@unboxed] may not be used on unboxed records. +|}] + +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..882c107a389 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml @@ -0,0 +1,612 @@ +(* 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; + } +*) + +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_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 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 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 11: %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 ; _ } = 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 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 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 new file mode 100644 index 00000000000..4e713daf31b --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference @@ -0,0 +1,99 @@ +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 new file mode 100644 index 00000000000..75e6f993887 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference @@ -0,0 +1,4 @@ +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 new file mode 100644 index 00000000000..75e6f993887 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference @@ -0,0 +1,4 @@ +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/unique.ml b/testsuite/tests/typing-layouts-unboxed-records/unique.ml new file mode 100644 index 00000000000..e9d1845bcb4 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unique.ml @@ -0,0 +1,157 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha -extension unique"; + { + expect; + } +*) + +(* 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 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 mk : unit -> t @ unique = +|}] + +(* Can access different fields *) +let () = + let t = mk () in + unique_use t.#x; + unique_use t.#y +[%%expect{| +|}] + +let () = + let #{ x ; y } = mk () in + unique_use x; + unique_use y +[%%expect{| +|}] + +(* Cannot access the same field twice *) +let () = + let t = mk () in + unique_use t.#x; + unique_use t.#x +[%%expect{| +Line 4, characters 13-17: +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 | unique_use t.#x; + ^^^^ + +|}] + +let () = + let #{ x ; y = _ } = mk () in + unique_use x; + unique_use x +[%%expect{| +Line 4, characters 13-14: +4 | unique_use x + ^ +Error: This value is used here, but it has already been used as unique: +Line 3, characters 13-14: +3 | unique_use x; + ^ + +|}] + +(* A functional update to a field allows a field to be reused *) +let () = + let t = mk () in + unique_use t.#x; + let t = #{ t with x = "fresh" } in + unique_use t.#x +[%%expect{| +|}] + +(* But not a functional update to a different field *) +let () = + let t = mk () in + unique_use t.#x; + let t = #{ t with y = "fresh" } in + 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 | 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{| +|}] + +(* 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; + ^ + +|}] 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..c9f53e69ea9 --- /dev/null +++ b/testsuite/tests/typing-layouts-unboxed-records/unused.ml @@ -0,0 +1,111 @@ +(* TEST + flags = " -w +A -strict-sequence -extension layouts_beta"; + expect; +*) + +(* 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 } + 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_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_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..01e074df1e5 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 *) @@ -517,6 +517,16 @@ 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, Record_unboxed_product)} -> + begin match check_depth depth obj ty with + Some x -> x + | None -> + let pos = 0 in + tree_of_record_unboxed_product_fields depth + env path decl.type_params ty_list + lbl_list pos obj + end | {type_kind = Type_open} -> tree_of_extension path ty_list depth obj with @@ -605,6 +615,34 @@ 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 = + 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 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 + 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..7c6adf27251 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -134,7 +134,9 @@ 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 +346,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..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_variant _ | Type_open -> true + | Type_record _ | Type_record_unboxed_product _ | Type_variant _ + | Type_open -> true | Type_abstract _ -> false @@ -713,6 +714,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 +1484,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 +2080,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 +2093,24 @@ 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 ([_], 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 ([], _) -> + 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 @@ -2103,7 +2127,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 +2180,79 @@ 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,34 +2344,12 @@ 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 ~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 - (fun (_, ty) -> loop ~fuel ~expanded:false ty) - ltys ty's_jkinds jkinds + (loop ~fuel ~expanded:false) tys ty's_jkinds jkinds in Misc.Stdlib.Monad.Result.all_unit results in @@ -2294,9 +2365,36 @@ 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 - | _ -> Error (Jkind.Violation.of_ (Not_a_subjkind (ty's_jkind, jkind))) + 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 ~fuel:(fuel - 1) tys + end + | 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 @@ -3175,6 +3273,11 @@ 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..cb9daeac2d6 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -221,20 +221,25 @@ 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 +285,21 @@ 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..11ea5a292e8 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,8 @@ 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 +625,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 +668,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 +748,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 +770,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 +818,34 @@ 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 +873,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 +885,15 @@ 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 +1173,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 +1371,9 @@ 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,8 +1419,8 @@ 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 @@ -1476,6 +1518,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 +1942,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 +2007,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 +2210,14 @@ 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 { form = ""; field = ""; complaint = Unused }) then begin let ty_name = Ident.name type_id in let priv = type_decl.type_private in @@ -2166,9 +2225,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 + 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 @@ -2176,8 +2235,10 @@ and store_label ~check type_decl type_id lbl_id lbl env = 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(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; @@ -2186,9 +2247,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 +2272,15 @@ 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 +2824,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 +2836,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 +2952,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 +3166,22 @@ 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 +3378,16 @@ 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 +3427,10 @@ 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 +3453,7 @@ let add_components slot root env0 comps locks = summary = Env_open(env0.summary, root); constrs; labels; + unboxed_labels; values; types; modtypes; @@ -3616,27 +3697,39 @@ 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 +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_abstract _ | Type_open -> [] + | Type_record _ | Type_record_unboxed_product _ | Type_abstract _ + | Type_open -> [] | Type_variant (cstrs, _) -> List.map (fun cstr -> @@ -3699,9 +3793,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 +3863,18 @@ 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 +4037,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 +4185,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 +4298,27 @@ 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" + | 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 env 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/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..e2eaca1d547 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,54 @@ 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 +960,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 +1272,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 +1319,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..f7ff9386563 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -1065,8 +1065,12 @@ module Builtin = struct ~why:(Immediate_creation why) let product ~why ts = - let desc, annotation = Jkind_desc.product ts in - fresh_jkind desc ~annotation ~why:(Product_creation why) + match ts with + | [] -> Misc.fatal_error "Jkind.Builtin.product: empty product" + | [t] -> t + | ts -> + let desc, annotation = Jkind_desc.product ts in + fresh_jkind desc ~annotation ~why:(Product_creation why) end let add_nullability_crossing t = @@ -1342,6 +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_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" @@ -1506,6 +1512,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 @@ -1885,6 +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_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" @@ -1988,6 +1996,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.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/jkind_intf.ml b/typing/jkind_intf.ml index 2d098c24e55..65fb18790ee 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_functional_update | Let_binding | Function_argument | Function_result @@ -307,7 +308,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..750c5c9c49a 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,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_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..a1b75512ddf 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 -> @@ -583,7 +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 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 @@ -605,9 +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_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 [] -> @@ -976,7 +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_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 bfb431dc2cf..b0df11dc455 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,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 + (* 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 de72ed0b18a..27e4c91445f 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 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)) + 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,13 @@ let pats_of_type env ty = labels in [make_pat (Tpat_record (fields, Closed)) ty env] + | 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 -> @@ -1171,6 +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_lazy p -> has_instance p @@ -2091,6 +2130,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 +2280,16 @@ 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) -> + 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 in diff --git a/typing/patterns.ml b/typing/patterns.ml index 87ef2197c21..b383829b0f4 100644 --- a/typing/patterns.ml +++ b/typing/patterns.ml @@ -60,6 +60,9 @@ 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 +108,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 +130,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 +156,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 +183,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 +225,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 +244,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 +275,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..2bd783d528a 100644 --- a/typing/printpat.ml +++ b/typing/printpat.ml @@ -59,6 +59,24 @@ 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 + let hash = if unboxed then "#" else "" in + begin match filtered_lvs with + | [] -> 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 + fprintf ppf "@[%s{%a%t}@]" + hash 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 +107,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 +170,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..f75357288ad 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,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) -> + | None + | Some(Value|Extension_constructor|Constructor|Label|Unboxed_label) -> fun _ -> raise Not_found let location namespace id = @@ -186,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) | None -> + | Some (Extension_constructor|Value|Constructor|Label|Unboxed_label) + | None -> Location.none ) with Not_found -> None @@ -1868,6 +1872,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 +1893,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 +1955,11 @@ 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..e89b6e3dcda 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,24 @@ 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 (Option.map fst 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 +703,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 +1139,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 +1200,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..3e89f8cf17b 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,12 @@ 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..aba4f23965c 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,16 @@ 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..c31881fe92d 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 @@ -318,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 _ -> () @@ -347,14 +356,17 @@ 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; _} -> + iter_fields fields; Option.iter (fun (exp, _) -> sub.expr sub exp) 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..2ce51ae48dc 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,24 @@ 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 + (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) + | 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 b4b3c5c1922..3c402295b11 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,17 @@ 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 +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 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 +182,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 +248,10 @@ 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 + | 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 * @@ -257,6 +270,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 @@ -815,20 +830,28 @@ 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 + | Record_type_of_other_form | 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 _}) -> + Record_type_of_other_form + | _, 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,10 +867,11 @@ 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 + | 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 @@ -1342,6 +1366,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 +1440,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 +1728,15 @@ 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 +2044,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 +2187,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 +2195,28 @@ 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 +2242,25 @@ 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 +2269,17 @@ 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 +2329,15 @@ 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 +2350,11 @@ let disambiguate_sort_lid_a_list loc closed env usage expected_type lid_a_list = amb | _ -> () end; - if !w_scope <> [] then + (if !w_scope <> [] then + 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, List.rev !w_scope, true)); + (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 +2367,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,15 +2379,18 @@ 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 { 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 - Location.prerr_warning loc (Warnings.Missing_record_field_pattern u) + 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; unbound }) end end @@ -2404,7 +2481,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 +2689,64 @@ 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 + | 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.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 + 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 +2965,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 +3227,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 +3420,24 @@ 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 +3514,9 @@ 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 +4094,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 (Option.map fst 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,6 +4584,7 @@ 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_unboxed_field _ | Texp_field _ | Texp_setfield _ | Texp_array _ | Texp_list_comprehension _ | Texp_array_comprehension _ | Texp_while _ | Texp_for _ | Texp_instvar _ @@ -4566,7 +4686,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 +5283,234 @@ 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) + | 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 + 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 + | 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)) + 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 + let exp_desc = + match record_form with + | Legacy -> + Texp_record { + fields; representation; + extended_expression = opt_exp; + alloc_mode; + } + | Unboxed_product -> + let opt_exp = match opt_exp with + | None -> None + | Some (exp, _) -> + let sort = + Ctype.type_sort ~why:Record_functional_update ~fixed:false + env exp.exp_type + in + 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; + extended_expression = 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 -> let path, (actual_mode : Env.actual_mode), desc, kind = @@ -5568,179 +5917,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 +5970,46 @@ 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 + if Types.is_mutable label.lbl_mut then + fatal_error + "Typecore.type_expect_: unboxed record labels are never mutable"; + let record_sort = + 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 + 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, record_sort, 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) @@ -5802,6 +6022,7 @@ and type_expect_ 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 | Immutable -> raise(Error(loc, env, Label_not_mutable lid.txt)) in @@ -7034,7 +7255,10 @@ 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 +7266,22 @@ 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 + | 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 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 +7543,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 +7571,8 @@ 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 @@ -9808,11 +10041,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 +10169,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 +10538,46 @@ 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 -> + | 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 record type." + 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) -> @@ -10424,6 +10687,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 + "@[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) -> + 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 ec9cf902837..09347fd38fd 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,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 - | Expr_not_a_record_type of 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 * @@ -310,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 diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 21072183491..7c1747e97a9 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 @@ -85,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 @@ -436,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 @@ -452,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 @@ -530,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 ~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 @@ -624,6 +631,8 @@ let verify_unboxed_attr unboxed_attr sdecl = | [{pld_mutable = Mutable}] -> bad "it is mutable" | [{pld_mutable = Immutable}] -> () end + | 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" @@ -731,6 +740,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 = @@ -766,6 +780,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 +828,9 @@ 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, @@ -899,8 +915,9 @@ 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 @@ -915,6 +932,20 @@ 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 ~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, + Type_record_unboxed_product(lbls', Record_unboxed_product), jkind | Ptype_open -> Ttype_open, Type_open, Jkind.Builtin.value ~why:Extensible_variant in @@ -988,7 +1019,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, _) -> Shape.str ~uid (shape_map_labels 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 @@ -1072,7 +1106,9 @@ 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 +1142,18 @@ 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 +1188,9 @@ 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 +1708,24 @@ 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 +2105,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 +2132,18 @@ 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 @@ -3439,6 +3519,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 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 () -> @@ -3540,6 +3622,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 +3785,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 +3815,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..13693ebd5a7 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 @@ -121,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 diff --git a/typing/typedecl_separability.ml b/typing/typedecl_separability.ml index e76c182e654..829a4573cc6 100644 --- a/typing/typedecl_separability.ml +++ b/typing/typedecl_separability.ml @@ -48,28 +48,26 @@ type type_structure = | Unboxed of argument_to_unbox 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 -> Algebraic + | (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 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..bd35e8fb8d5 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,18 @@ 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 * Jkind.sort) option; + } | Texp_field of expression * Longident.t loc * label_description * texp_field_boxing * Unique_barrier.t + | Texp_unboxed_field of + 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 @@ -737,6 +750,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 +933,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 +966,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 +991,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 +1101,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..52f9b6a9e3c 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,29 @@ 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 * Jkind.sort) 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 * 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 @@ -987,6 +1015,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 a86f57dc5a3..1d1eeb2bf4c 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1399,7 +1399,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..44c84052498 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,15 @@ 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) -> + 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.ml b/typing/types.ml index 5364405ca1b..b6e7839a902 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -272,11 +272,14 @@ 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 +316,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 +683,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 +695,46 @@ 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 +742,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 +757,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..f2dbc5bdb16 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,27 @@ 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 + +(** 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 + +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..bfcf37796c9 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..5a272200c9d 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,19 @@ 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 (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, _) -> + 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..a7713fb5d8b 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 (Option.map fst 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..a5580a86ed7 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 { form : string ; unbound : 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,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 * 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 *) @@ -155,7 +160,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 +960,9 @@ 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 { 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." @@ -985,8 +991,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 +1040,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 +1170,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 (s, Unused) -> "unused record field " ^ s ^ "." - | Unused_field (s, Not_read) -> - "record 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 (s, Not_mutated) -> - "mutable record 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 a9cd239ec2f..d925ffce77d 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 { form : string ; unbound : 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,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 * string list * bool (* 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 *) @@ -116,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 * 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 *)