From b28ab119d9e6c929b753868140f0a2db72642a3d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Dec 2024 12:08:24 +0100 Subject: [PATCH 1/9] AST cleanup: explicit representation for optional record fields in types. --- compiler/ml/ast_mapper_to0.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index d8e12e9c6f..853b12d46a 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -468,8 +468,7 @@ let default_mapper = ~mut:pld_mutable ~loc:(this.location this pld_loc) ~attrs: - (Parsetree0.add_optional_attr ~optional:pld_optional - (this.attributes this pld_attributes))); + (Parsetree0.add_optional_attr ~optional:pld_optional (this.attributes this pld_attributes))); cases = (fun this l -> List.map (this.case this) l); case = (fun this {pc_lhs; pc_guard; pc_rhs} -> From 1b38363f605f30804062a9613513575d5f5fcd8c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Dec 2024 13:39:31 +0100 Subject: [PATCH 2/9] Clean up Record_optional_labels Clean up Record_optional_labels: determine whether a field is optional directly. --- analysis/src/CreateInterface.ml | 15 ++---- .../gentype/TranslateSignatureFromTypes.ml | 5 +- compiler/gentype/TranslateTypeDeclarations.ml | 40 ++++++++-------- compiler/ml/ast_mapper_to0.ml | 3 +- compiler/ml/ctype.ml | 6 +-- compiler/ml/datarepr.ml | 2 + compiler/ml/includecore.ml | 21 +++------ compiler/ml/includecore.mli | 1 + compiler/ml/matching.ml | 2 +- compiler/ml/parmatch.ml | 9 +--- compiler/ml/predef.ml | 2 +- compiler/ml/printtyped.ml | 3 +- compiler/ml/rec_check.ml | 2 +- compiler/ml/record_coercion.ml | 11 ++--- compiler/ml/translcore.ml | 14 +++--- compiler/ml/typecore.ml | 29 +++--------- compiler/ml/typedecl.ml | 8 +--- compiler/ml/types.ml | 7 +-- compiler/ml/types.mli | 3 +- .../expected/OptionalImplIntf.res.expected | 29 ++++++++++++ .../OptionalInlineImplIntf.res.expected | 29 ++++++++++++ .../fixtures/OptionalImplIntf.res | 5 ++ .../fixtures/OptionalInlineImplIntf.res | 5 ++ tests/tests/src/record_regression.mjs | 46 +++++++------------ 24 files changed, 154 insertions(+), 143 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/OptionalImplIntf.res.expected create mode 100644 tests/build_tests/super_errors/expected/OptionalInlineImplIntf.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/OptionalImplIntf.res create mode 100644 tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index a3c19666c1..6bd41899d6 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -145,12 +145,7 @@ let printSignature ~extractor ~signature = let rec processSignature ~indent (signature : Types.signature) : unit = match signature with | Sig_type - ( propsId, - { - type_params; - type_kind = Type_record (labelDecls, recordRepresentation); - }, - _ ) + (propsId, {type_params; type_kind = Type_record (labelDecls, _)}, _) :: Sig_value (makeId (* make *), makeValueDesc) :: rest when Ident.name propsId = "props" @@ -174,13 +169,9 @@ let printSignature ~extractor ~signature = labelDecl.ld_type in let lblName = labelDecl.ld_id |> Ident.name in + let _ = 10 in let lbl = - let optLbls = - match recordRepresentation with - | Record_optional_labels optLbls -> optLbls - | _ -> [] - in - if List.mem lblName optLbls then Asttypes.Optional lblName + if labelDecl.ld_optional then Asttypes.Optional lblName else Labelled lblName in {retType with desc = Tarrow (lbl, propType, mkFunType rest, Cok)} diff --git a/compiler/gentype/TranslateSignatureFromTypes.ml b/compiler/gentype/TranslateSignatureFromTypes.ml index 1b0e4625be..2a12d6e350 100644 --- a/compiler/gentype/TranslateSignatureFromTypes.ml +++ b/compiler/gentype/TranslateSignatureFromTypes.ml @@ -12,9 +12,8 @@ let translate_type_declaration_from_types ~config ~output_file_relative Log_.item "Translate Types.type_declaration %s\n" type_name; let declaration_kind = match type_kind with - | Type_record (label_declarations, record_representation) -> - TranslateTypeDeclarations.RecordDeclarationFromTypes - (label_declarations, record_representation) + | Type_record (label_declarations, _) -> + TranslateTypeDeclarations.RecordDeclarationFromTypes label_declarations | Type_variant constructor_declarations when not (TranslateTypeDeclarations.has_some_gadt_leaf diff --git a/compiler/gentype/TranslateTypeDeclarations.ml b/compiler/gentype/TranslateTypeDeclarations.ml index 08b8075603..2768bdf343 100644 --- a/compiler/gentype/TranslateTypeDeclarations.ml +++ b/compiler/gentype/TranslateTypeDeclarations.ml @@ -1,8 +1,7 @@ open GenTypeCommon type declaration_kind = - | RecordDeclarationFromTypes of - Types.label_declaration list * Types.record_representation + | RecordDeclarationFromTypes of Types.label_declaration list | GeneralDeclaration of Typedtree.core_type option | GeneralDeclarationFromTypes of Types.type_expr option (** As the above, but from Types not Typedtree *) @@ -86,16 +85,12 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in {CodeItem.import_types; export_from_type_declaration} in - let translate_label_declarations ?(inline = false) ~record_representation - label_declarations = - let is_optional l = - match record_representation with - | Types.Record_optional_labels lbls -> List.mem l lbls - | _ -> false - in + let translate_label_declarations ?(inline = false) label_declarations = let field_translations = label_declarations - |> List.map (fun {Types.ld_id; ld_mutable; ld_type; ld_attributes} -> + |> List.map + (fun + {Types.ld_id; ld_mutable; ld_optional; ld_type; ld_attributes} -> let name = rename_record_field ~attributes:ld_attributes ~name:(ld_id |> Ident.name) @@ -107,6 +102,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in ( name, mutability, + ld_optional, ld_type |> TranslateTypeExprFromTypes.translate_type_expr_from_types ~config ~type_env, @@ -114,7 +110,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in let dependencies = field_translations - |> List.map (fun (_, _, {TranslateTypeExprFromTypes.dependencies}, _) -> + |> List.map + (fun (_, _, _, {TranslateTypeExprFromTypes.dependencies}, _) -> dependencies) |> List.concat in @@ -122,10 +119,15 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver field_translations |> List.map (fun - (name, mutable_, {TranslateTypeExprFromTypes.type_}, doc_string) -> + ( name, + mutable_, + optional_, + {TranslateTypeExprFromTypes.type_}, + doc_string ) + -> let optional, type1 = match type_ with - | Option type1 when is_optional name -> (Optional, type1) + | Option type1 when optional_ -> (Optional, type1) | _ -> (Mandatory, type_) in {mutable_; name_js = name; optional; type_ = type1; doc_string}) @@ -216,10 +218,9 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in {translation with type_} |> handle_general_declaration |> return_type_declaration - | RecordDeclarationFromTypes (label_declarations, record_representation), None - -> + | RecordDeclarationFromTypes label_declarations, None -> let {TranslateTypeExprFromTypes.dependencies; type_} = - label_declarations |> translate_label_declarations ~record_representation + label_declarations |> translate_label_declarations in let import_types = dependencies @@ -250,8 +251,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver | Cstr_record label_declarations -> [ label_declarations - |> translate_label_declarations ~inline:true - ~record_representation:Types.Record_regular; + |> translate_label_declarations ~inline:true; ] in let arg_types = @@ -334,8 +334,8 @@ let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env in let declaration_kind = match typ_type.type_kind with - | Type_record (label_declarations, record_representation) -> - RecordDeclarationFromTypes (label_declarations, record_representation) + | Type_record (label_declarations, _) -> + RecordDeclarationFromTypes label_declarations | Type_variant constructor_declarations -> VariantDeclarationFromTypes constructor_declarations | Type_abstract -> GeneralDeclaration typ_manifest diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 853b12d46a..d8e12e9c6f 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -468,7 +468,8 @@ let default_mapper = ~mut:pld_mutable ~loc:(this.location this pld_loc) ~attrs: - (Parsetree0.add_optional_attr ~optional:pld_optional (this.attributes this pld_attributes))); + (Parsetree0.add_optional_attr ~optional:pld_optional + (this.attributes this pld_attributes))); cases = (fun this l -> List.map (this.case this) l); case = (fun this {pc_lhs; pc_guard; pc_rhs} -> diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index ec3d3f96e0..6fdf4789ec 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3721,8 +3721,8 @@ let rec subtype_rec env trace t1 t2 cstrs = (_, _, {type_kind = Type_record (fields2, repr2)}) ) -> let same_repr = match (repr1, repr2) with - | ( (Record_regular | Record_optional_labels _), - (Record_regular | Record_optional_labels _) ) -> + | ( (Record_regular | Record_optional_labels), + (Record_regular | Record_optional_labels) ) -> true (* handled in the fields checks *) | Record_unboxed b1, Record_unboxed b2 -> b1 = b2 | Record_inlined _, Record_inlined _ -> repr1 = repr2 @@ -3731,7 +3731,7 @@ let rec subtype_rec env trace t1 t2 cstrs = in if same_repr then let violation, tl1, tl2 = - Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 + Record_coercion.check_record_fields fields1 fields2 in if violation then (trace, t1, t2, !univar_pairs) :: cstrs else subtype_list env trace tl1 tl2 cstrs diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 1153a82bdb..78b3f6e0da 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -232,6 +232,7 @@ let dummy_label = lbl_res = none; lbl_arg = none; lbl_mut = Immutable; + lbl_optional = false; lbl_pos = -1; lbl_all = [||]; lbl_repres = Record_regular; @@ -251,6 +252,7 @@ let label_descrs ty_res lbls repres priv = lbl_res = ty_res; lbl_arg = l.ld_type; lbl_mut = l.ld_mutable; + lbl_optional = l.ld_optional; lbl_pos = num; lbl_all = all_labels; lbl_repres = repres; diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 0703e06ddc..b1db9e5f16 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -147,6 +147,7 @@ type type_mismatch = | Variance | Field_type of Ident.t | Field_mutable of Ident.t + | Field_optional of Ident.t | Field_arity of Ident.t | Field_names of int * string * string | Field_missing of bool * Ident.t @@ -168,6 +169,8 @@ let report_type_mismatch0 first second decl ppf err = | Field_type s -> pr "The types for field %s are not equal" (Ident.name s) | Field_mutable s -> pr "The mutability of field %s is different" (Ident.name s) + | Field_optional s -> + pr "The optional attribute of field %s is different" (Ident.name s) | Field_arity s -> pr "The arities for field %s differ" (Ident.name s) | Field_names (n, name1, name2) -> pr "Fields number %i have different names, %s and %s" n name1 name2 @@ -175,21 +178,8 @@ let report_type_mismatch0 first second decl ppf err = pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl - | Record_representation (rep1, rep2) -> ( - let default () = pr "Their internal representations differ" in - match (rep1, rep2) with - | Record_optional_labels lbls1, Record_optional_labels lbls2 -> ( - let only_in_lhs = - Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) - in - let only_in_rhs = - Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l)) - in - match (only_in_lhs, only_in_rhs) with - | Some l, _ -> pr "@optional label %s only in %s" l second - | _, Some l -> pr "@optional label %s only in %s" l first - | None, None -> default ()) - | _ -> default ()) + | Record_representation (_rep1, _rep2) -> + pr "Their internal representations differ" | Unboxed_representation b -> pr "Their internal representations differ:@ %s %s %s" (if b then second else first) @@ -280,6 +270,7 @@ and compare_records ~loc env params1_ params2_ n_ if Ident.name ld1.ld_id <> Ident.name ld2.ld_id then [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)] else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] + else if ld1.ld_optional <> ld2.ld_optional then [Field_optional ld1.ld_id] else ( Builtin_attributes.check_deprecated_mutable_inclusion ~def:ld1.ld_loc ~use:ld2.ld_loc loc ld1.ld_attributes ld2.ld_attributes diff --git a/compiler/ml/includecore.mli b/compiler/ml/includecore.mli index 20ed150639..aec316d449 100644 --- a/compiler/ml/includecore.mli +++ b/compiler/ml/includecore.mli @@ -29,6 +29,7 @@ type type_mismatch = | Variance | Field_type of Ident.t | Field_mutable of Ident.t + | Field_optional of Ident.t | Field_arity of Ident.t | Field_names of int * string * string | Field_missing of bool * Ident.t diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 0b6b6f1f3e..ef95f7b0d9 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1530,7 +1530,7 @@ let make_record_matching loc all_labels def = function let access = match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> + | Record_regular | Record_optional_labels -> Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) | Record_inlined _ -> Lprim diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 64fcb67787..a8434cfd19 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -526,24 +526,19 @@ let all_record_args lbls = in List.iter (fun ((id, lbl, pat) as x) -> - let lbl_is_optional () = - match lbl.lbl_repres with - | Record_optional_labels labels -> List.mem lbl.lbl_name labels - | _ -> false - in let x = match pat.pat_desc with | Tpat_construct ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, _, [({pat_desc = Tpat_constant _} as c)] ) - when lbl_is_optional () -> + when lbl.lbl_optional -> (id, lbl, c) | Tpat_construct ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, _, [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] ) - when lbl_is_optional () -> ( + when lbl.lbl_optional -> ( let cdecl = Ast_untagged_variants .constructor_declaration_from_constructor_description diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 7cc92ddd58..e27662e9d9 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -316,7 +316,7 @@ let common_initial_env add_type add_extension empty_env = ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil)); }; ], - Record_optional_labels [Ident.name ident_dict_magic_field_name] ); + Record_optional_labels ); } and decl_uncurried = let tvar1, tvar2 = (newgenvar (), newgenvar ()) in diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index cc5df3479a..9ad321000a 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -130,8 +130,7 @@ let record_representation i ppf = function | Record_regular -> line i ppf "Record_regular\n" | Record_float_unused -> assert false - | Record_optional_labels lbls -> - line i ppf "Record_optional_labels %s\n" (lbls |> String.concat ", ") + | Record_optional_labels -> line i ppf "Record_optional_labels\n" | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i | Record_extension -> line i ppf "Record_extension\n" diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 9296ad086b..59f9db5cf8 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -261,7 +261,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = match rep with | Record_unboxed _ -> fun x -> x | Record_float_unused -> assert false - | Record_optional_labels _ | Record_regular | Record_inlined _ + | Record_optional_labels | Record_regular | Record_inlined _ | Record_extension -> Use.guard in diff --git a/compiler/ml/record_coercion.ml b/compiler/ml/record_coercion.ml index 9a0c4eb747..0f2fbc96d6 100644 --- a/compiler/ml/record_coercion.ml +++ b/compiler/ml/record_coercion.ml @@ -1,18 +1,13 @@ -let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list) +let check_record_fields (fields1 : Types.label_declaration list) (fields2 : Types.label_declaration list) = - let field_is_optional id repr = - match repr with - | Some (Types.Record_optional_labels lbls) -> List.mem (Ident.name id) lbls - | _ -> false - in let violation = ref false in let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) = match Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) with | Some ld1 -> - if field_is_optional ld1.ld_id repr1 <> field_is_optional ld2.ld_id repr2 - then (* optional field can't be modified *) + if ld1.ld_optional <> ld2.ld_optional then + (* optional field can't be modified *) violation := true; let get_as (({txt}, payload) : Parsetree.attribute) = if txt = "as" then Ast_payload.is_single_string payload else None diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 27b8152d44..942550e1d9 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -923,7 +923,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let targ = transl_exp arg in match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> + | Record_regular | Record_optional_labels -> Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) | Record_inlined _ -> Lprim @@ -938,7 +938,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let access = match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> + | Record_regular | Record_optional_labels -> Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) @@ -1171,7 +1171,7 @@ and transl_record loc env fields repres opt_init_expr = || size < 20 && match repres with - | Record_optional_labels _ -> false + | Record_optional_labels -> false | _ -> true (* TODO: More strategies 3 + 2 * List.length lbl_expr_list >= size (density) @@ -1188,7 +1188,7 @@ and transl_record loc env fields repres opt_init_expr = let access = match repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> + | Record_regular | Record_optional_labels -> Pfield (i, Lambda.fld_record lbl) | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl) | Record_unboxed _ -> assert false @@ -1214,7 +1214,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_regular -> Lconst (Const_block (Lambda.blk_record fields mut Record_regular, cl)) - | Record_optional_labels _ -> + | Record_optional_labels -> Lconst (Const_block (Lambda.blk_record fields mut Record_optional, cl)) | Record_inlined {tag; name; num_nonconsts; optional_labels; attrs} -> @@ -1234,7 +1234,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_regular -> Lprim (Pmakeblock (Lambda.blk_record fields mut Record_regular), ll, loc) - | Record_optional_labels _ -> + | Record_optional_labels -> Lprim ( Pmakeblock (Lambda.blk_record fields mut Record_optional), ll, @@ -1277,7 +1277,7 @@ and transl_record loc env fields repres opt_init_expr = let upd = match repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> + | Record_regular | Record_optional_labels -> Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index c5d1a7f8f7..1945651b22 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -297,18 +297,7 @@ let extract_concrete_variant env ty = | p0, p, {type_kind = Type_open} -> (p0, p, []) | _ -> raise Not_found -let has_optional_labels ld = - match ld.lbl_repres with - | Record_optional_labels _ -> true - | Record_inlined {optional_labels} -> optional_labels <> [] - | _ -> false - -let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> - Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false +let label_is_optional ld = ld.lbl_optional let check_optional_attr env ld attrs loc = let check_redundant () = @@ -960,7 +949,7 @@ module Label = NameChoice (struct lbl with lbl_name = name; lbl_pos = Array.length lbl.lbl_all; - lbl_repres = Record_optional_labels [name]; + lbl_repres = Record_optional_labels; } in let lbl_all_list = Array.to_list lbl.lbl_all @ [l] in @@ -981,7 +970,8 @@ let disambiguate_label_by_ids closed ids labels = in let mandatory_labels_are_present num_ids lbl = (* check that all mandatory labels are present *) - if has_optional_labels lbl then ( + let has_optional_labels = Ext_array.exists lbl.lbl_all label_is_optional in + if has_optional_labels then ( let mandatory_lbls = ref 0 in Ext_array.iter lbl.lbl_all (fun l -> if not (label_is_optional l) then incr mandatory_lbls); @@ -2645,15 +2635,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp _ ) -> (label_descriptions, representation) | [], Some representation when lid_sexp_list = [] -> - let optional_labels = - match representation with - | Record_optional_labels optional_labels -> optional_labels - | Record_inlined {optional_labels} -> optional_labels - | _ -> [] - in let filter_missing (ld : Types.label_declaration) = - let name = Ident.name ld.ld_id in - if List.mem name optional_labels then None else Some name + if ld.ld_optional then None else Some (Ident.name ld.ld_id) in let labels_missing = fields |> List.filter_map filter_missing in if labels_missing <> [] then @@ -2668,7 +2651,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } )); ([||], representation) | [], _ -> - if fields = [] && repr_opt <> None then ([||], Record_optional_labels []) + if fields = [] && repr_opt <> None then ([||], Record_optional_labels) else raise (Error (loc, env, Empty_record_literal)) in let labels_missing = ref [] in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 070968b337..321df0f36d 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -630,16 +630,12 @@ let transl_declaration ~type_record_as_object env sdecl id = match lbls_opt with | Some (lbls, lbls') -> check_duplicates sdecl.ptype_loc lbls StringSet.empty; - let optional_labels = - Ext_list.filter_map lbls (fun lbl -> - if lbl.ld_optional then Some lbl.ld_name.txt else None) - in + let optional = Ext_list.exists lbls (fun lbl -> lbl.ld_optional) in ( Ttype_record lbls, Type_record ( lbls', if unbox then Record_unboxed false - else if optional_labels <> [] then - Record_optional_labels optional_labels + else if optional then Record_optional_labels else Record_regular ), sdecl ) | None -> diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index e31bdab72f..986fe737cd 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -157,7 +157,7 @@ and record_representation = attrs: Parsetree.attributes; } | Record_extension (* Inlined record under extension *) - | Record_optional_labels of string list (* List of optional labels *) + | Record_optional_labels and label_declaration = { ld_id: Ident.t; @@ -298,6 +298,7 @@ type label_description = { lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_optional: bool; (* Is this an optional field? *) lbl_pos: int; (* Position in block *) mutable lbl_all: label_description array; (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) @@ -310,9 +311,9 @@ let same_record_representation x y = match x with | Record_regular -> y = Record_regular | Record_float_unused -> y = Record_float_unused - | Record_optional_labels lbls -> ( + | Record_optional_labels -> ( match y with - | Record_optional_labels lbls2 -> lbls = lbls2 + | Record_optional_labels -> true | _ -> false) | Record_inlined {tag; name; num_nonconsts; optional_labels} -> ( match y with diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index f8d7addcdb..3be0b67ec8 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -285,7 +285,7 @@ and record_representation = attrs: Parsetree.attributes; } | Record_extension (* Inlined record under extension *) - | Record_optional_labels of string list (* List of optional labels *) + | Record_optional_labels and label_declaration = { ld_id: Ident.t; @@ -423,6 +423,7 @@ type label_description = { lbl_res: type_expr; (* Type of the result *) lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_optional: bool; (* Is this an optional field? *) lbl_pos: int; (* Position in block *) mutable lbl_all: label_description array; (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) diff --git a/tests/build_tests/super_errors/expected/OptionalImplIntf.res.expected b/tests/build_tests/super_errors/expected/OptionalImplIntf.res.expected new file mode 100644 index 0000000000..550812989f --- /dev/null +++ b/tests/build_tests/super_errors/expected/OptionalImplIntf.res.expected @@ -0,0 +1,29 @@ + + We've found a bug for you! + /.../fixtures/OptionalImplIntf.res:3:5-5:1 + + 1 │ module M: { + 2 │ type t = {x?: int} + 3 │ } = { + 4 │  type t = {x: int} + 5 │ } + 6 │ + + Signature mismatch: + Modules do not match: + { + type t = {x: int} +} + is not included in + { + type t = {x?: int} +} + Type declarations do not match: + type t = {x: int} + is not included in + type t = {x?: int} + /.../fixtures/OptionalImplIntf.res:2:3-20: + Expected declaration + /.../fixtures/OptionalImplIntf.res:4:3-19: + Actual declaration + The optional attribute of field x is different. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/OptionalInlineImplIntf.res.expected b/tests/build_tests/super_errors/expected/OptionalInlineImplIntf.res.expected new file mode 100644 index 0000000000..32e03447c6 --- /dev/null +++ b/tests/build_tests/super_errors/expected/OptionalInlineImplIntf.res.expected @@ -0,0 +1,29 @@ + + We've found a bug for you! + /.../fixtures/OptionalInlineImplIntf.res:3:5-5:1 + + 1 │ module M: { + 2 │ type t = A({x?: int}) + 3 │ } = { + 4 │  type t = A({x: int}) + 5 │ } + 6 │ + + Signature mismatch: + Modules do not match: + { + type t = A({x: int}) +} + is not included in + { + type t = A({x?: int}) +} + Type declarations do not match: + type t = A({x: int}) + is not included in + type t = A({x?: int}) + /.../fixtures/OptionalInlineImplIntf.res:2:3-23: + Expected declaration + /.../fixtures/OptionalInlineImplIntf.res:4:3-22: + Actual declaration + The optional attribute of field x is different. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/OptionalImplIntf.res b/tests/build_tests/super_errors/fixtures/OptionalImplIntf.res new file mode 100644 index 0000000000..ed5206a555 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/OptionalImplIntf.res @@ -0,0 +1,5 @@ +module M: { + type t = {x?: int} +} = { + type t = {x: int} +} diff --git a/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res b/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res new file mode 100644 index 0000000000..ed5206a555 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res @@ -0,0 +1,5 @@ +module M: { + type t = {x?: int} +} = { + type t = {x: int} +} diff --git a/tests/tests/src/record_regression.mjs b/tests/tests/src/record_regression.mjs index f936ef2908..95a511a9fa 100644 --- a/tests/tests/src/record_regression.mjs +++ b/tests/tests/src/record_regression.mjs @@ -171,36 +171,24 @@ function inlinedRecord(ir) { let x1 = ir.x1; let x0 = ir.x0; if (x1 !== undefined) { - switch (x1) { - case "x1" : - let x2 = ir.x2; - if (x2 !== undefined) { - return [ - x0, - "x1", - x2, - ir.x3 - ]; - } - break; - case "xx1" : - let x2$1 = ir.x2; - if (x2$1 !== undefined) { - return [ - x0, - "xx1", - x2$1, - ir.x3 - ]; - } - break; + if (x1 === "x1") { + let x2 = ir.x2; + if (x2 !== undefined) { + return [ + x0, + "x1", + x2, + ir.x3 + ]; + } + } - let x2$2 = ir.x2; - if (x2$2 !== undefined) { + let x2$1 = ir.x2; + if (x2$1 !== undefined) { return [ x0, x1, - x2$2, + x2$1, ir.x3 ]; } else { @@ -212,12 +200,12 @@ function inlinedRecord(ir) { ]; } } - let x2$3 = ir.x2; - if (x2$3 !== undefined) { + let x2$2 = ir.x2; + if (x2$2 !== undefined) { return [ x0, "n/a", - x2$3, + x2$2, ir.x3 ]; } else { From 27678d52a2b845153e37ec4fe3a5c4f8d2a78f3d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Dec 2024 15:25:39 +0100 Subject: [PATCH 3/9] changelog --- CHANGELOG.md | 2 ++ .../super_errors/fixtures/OptionalInlineImplIntf.res | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2d1196006f..4132fef41e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,8 @@ - Use latest compiler for tests. https://github.com/rescript-lang/rescript/pull/7186 - Added infra to modernise AST: theres' Parsetree, Parsetree0 (legacy), and conversion functions to keep compatibility with PPX. https://github.com/rescript-lang/rescript/pull/7185 - Ast cleanup: remove exp object and exp unreachable. https://github.com/rescript-lang/rescript/pull/7189 +- Ast cleanup: explicit representation for optional record fields in types. https://github.com/rescript-lang/rescript/pull/7190 https://github.com/rescript-lang/rescript/pull/7191 + # 12.0.0-alpha.5 diff --git a/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res b/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res index ed5206a555..b2927829aa 100644 --- a/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res +++ b/tests/build_tests/super_errors/fixtures/OptionalInlineImplIntf.res @@ -1,5 +1,5 @@ module M: { - type t = {x?: int} + type t = A({x?: int}) } = { - type t = {x: int} + type t = A({x: int}) } From 6cc73435746a36b138f1db0c2d2c78a216e9b1ca Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 4 Dec 2024 15:50:20 +0100 Subject: [PATCH 4/9] Clean up Record_inlined. There's now no global set of optional fields stored anywhere, but optional is attached to each field. --- compiler/core/js_dump.ml | 25 ++++++++++--------------- compiler/core/lam_compile.ml | 2 +- compiler/ml/datarepr.ml | 8 -------- compiler/ml/lambda.ml | 12 +++++------- compiler/ml/lambda.mli | 4 +--- compiler/ml/printlambda.ml | 2 +- compiler/ml/translcore.ml | 12 ++++++------ compiler/ml/types.ml | 7 ++----- compiler/ml/types.mli | 1 - 9 files changed, 26 insertions(+), 47 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 792a4d3c86..b029e1faee 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -794,28 +794,23 @@ and expression_desc cxt ~(level : int) f x : cxt = let untagged = Ast_untagged_variants.process_untagged p.attrs in let objs = let tails = - Ext_list.combine_array_append p.fields el - (if !Js_config.debug then [(name_symbol, E.str p.name)] else []) - (fun i -> Js_op.Lit i) - in - let is_optional (pname : Js_op.property_name) = - match pname with - | Lit n -> Ext_list.mem_string p.optional_labels n - | Symbol_name -> false + Ext_list.combine_array p.fields el (fun (i, opt) -> (Js_op.Lit i, opt)) in + (* let is_optional (pname : Js_op.property_name) = + match pname with + | Lit n -> Ext_list.mem_string p.optional_labels n + | Symbol_name -> false + in *) let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with | None -> L.tag | Some s -> s in let tails = - match p.optional_labels with - | [] -> tails - | _ -> - Ext_list.filter_map tails (fun (f, x) -> - match x.expression_desc with - | Undefined _ when is_optional f -> None - | _ -> Some (f, x)) + Ext_list.filter_map tails (fun ((f, optional), x) -> + match x.expression_desc with + | Undefined _ when optional -> None + | _ -> Some (f, x)) in if untagged then tails else diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 22b3ffa2b8..10cd225128 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -427,7 +427,7 @@ let compile output_prefix = (match tag_info with | Blk_record {fields = xs} -> Fld_record_set xs.(i) | Blk_record_inlined xs -> - Fld_record_inline_set xs.fields.(i) + Fld_record_inline_set (fst xs.fields.(i)) | Blk_constructor p -> ( let is_cons = p.name = Literals.cons in match (is_cons, i) with diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 78b3f6e0da..9e37269deb 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -128,13 +128,6 @@ let constructor_descrs ty_path decl cstrs = describe_constructors idx_const (idx_nonconst + 1) rem ) in let cstr_name = Ident.name cd_id in - let optional_labels = - match cd_args with - | Cstr_tuple _ -> [] - | Cstr_record lbls -> - Ext_list.filter_map lbls (fun {ld_id; ld_optional} -> - if ld_optional then Some ld_id.name else None) - in let existentials, cstr_args, cstr_inlined = let representation = if decl.type_unboxed.unboxed then Record_unboxed true @@ -144,7 +137,6 @@ let constructor_descrs ty_path decl cstrs = tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; - optional_labels; attrs = cd_attributes; } in diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index fcd1dc86ca..56b9a8c4cf 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -28,8 +28,7 @@ type tag_info = name: string; num_nonconst: int; tag: int; - optional_labels: string list; - fields: string array; + fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; attrs: Parsetree.attributes; } @@ -104,16 +103,15 @@ let blk_record_ext fields mutable_flag = in Blk_record_ext {fields = all_labels_info; mutable_flag} -let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs - mutable_flag = +let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag = let fields = Array.map (fun ((lbl : label), _) -> - Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, + lbl.lbl_optional )) fields in - Blk_record_inlined - {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs} + Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; attrs} let ref_tag_info : tag_info = Blk_record diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 7f506ac62d..0f9f4198f7 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -32,8 +32,7 @@ type tag_info = name: string; num_nonconst: int; tag: int; - optional_labels: string list; - fields: string array; + fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; attrs: Parsetree.attributes; } @@ -81,7 +80,6 @@ val blk_record_inlined : (Types.label_description * Typedtree.record_label_definition) array -> string -> int -> - string list -> tag:int -> attrs:Parsetree.attributes -> mutable_flag -> diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 4512355c34..0a6b4be480 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -104,7 +104,7 @@ let print_taginfo ppf = function | Blk_lazy_general -> fprintf ppf "lazy_general" | Blk_module_export _ -> fprintf ppf "module/exports" | Blk_record_inlined {fields = ss} -> - fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss)) + fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) let primitive ppf = function | Pidentity -> fprintf ppf "id" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 942550e1d9..924ea39978 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1217,11 +1217,11 @@ and transl_record loc env fields repres opt_init_expr = | Record_optional_labels -> Lconst (Const_block (Lambda.blk_record fields mut Record_optional, cl)) - | Record_inlined {tag; name; num_nonconsts; optional_labels; attrs} -> + | Record_inlined {tag; name; num_nonconsts; attrs} -> Lconst (Const_block - ( Lambda.blk_record_inlined fields name num_nonconsts - optional_labels ~tag ~attrs mut, + ( Lambda.blk_record_inlined fields name num_nonconsts ~tag + ~attrs mut, cl )) | Record_unboxed _ -> Lconst @@ -1240,11 +1240,11 @@ and transl_record loc env fields repres opt_init_expr = ll, loc ) | Record_float_unused -> assert false - | Record_inlined {tag; name; num_nonconsts; optional_labels; attrs} -> + | Record_inlined {tag; name; num_nonconsts; attrs} -> Lprim ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts - optional_labels ~tag ~attrs mut), + (Lambda.blk_record_inlined fields name num_nonconsts ~tag + ~attrs mut), ll, loc ) | Record_unboxed _ -> ( diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 986fe737cd..25c4b67eb6 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -153,7 +153,6 @@ and record_representation = tag: int; name: string; num_nonconsts: int; - optional_labels: string list; attrs: Parsetree.attributes; } | Record_extension (* Inlined record under extension *) @@ -315,12 +314,10 @@ let same_record_representation x y = match y with | Record_optional_labels -> true | _ -> false) - | Record_inlined {tag; name; num_nonconsts; optional_labels} -> ( + | Record_inlined {tag; name; num_nonconsts} -> ( match y with | Record_inlined y -> - tag = y.tag && name = y.name - && num_nonconsts = y.num_nonconsts - && optional_labels = y.optional_labels + tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts | _ -> false) | Record_extension -> y = Record_extension | Record_unboxed x -> ( diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 3be0b67ec8..83aeace4ec 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -281,7 +281,6 @@ and record_representation = tag: int; name: string; num_nonconsts: int; - optional_labels: string list; attrs: Parsetree.attributes; } | Record_extension (* Inlined record under extension *) From 864ceb91963ace8af421c7f83b084d9eea0aed05 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Dec 2024 08:17:33 +0100 Subject: [PATCH 5/9] Update CreateInterface.ml --- analysis/src/CreateInterface.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index 6bd41899d6..ebb936867f 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -169,7 +169,6 @@ let printSignature ~extractor ~signature = labelDecl.ld_type in let lblName = labelDecl.ld_id |> Ident.name in - let _ = 10 in let lbl = if labelDecl.ld_optional then Asttypes.Optional lblName else Labelled lblName From 32c07325bfe40a94dcda9f0e219c4fef897a373e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Dec 2024 08:19:04 +0100 Subject: [PATCH 6/9] Update js_dump.ml --- compiler/core/js_dump.ml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index b029e1faee..bebacfa2c5 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -796,11 +796,6 @@ and expression_desc cxt ~(level : int) f x : cxt = let tails = Ext_list.combine_array p.fields el (fun (i, opt) -> (Js_op.Lit i, opt)) in - (* let is_optional (pname : Js_op.property_name) = - match pname with - | Lit n -> Ext_list.mem_string p.optional_labels n - | Symbol_name -> false - in *) let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with | None -> L.tag From 5d051e9f25b93a86646148a033f2bcd1ff38a083 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Dec 2024 08:54:34 +0100 Subject: [PATCH 7/9] Remove Record_optional_labels entirely. --- compiler/ml/ctype.ml | 3 +-- compiler/ml/matching.ml | 2 +- compiler/ml/predef.ml | 2 +- compiler/ml/printtyped.ml | 1 - compiler/ml/rec_check.ml | 4 +--- compiler/ml/translcore.ml | 33 +++++++++++++-------------------- compiler/ml/typecore.ml | 4 ++-- compiler/ml/typedecl.ml | 2 +- compiler/ml/types.ml | 5 ----- compiler/ml/types.mli | 1 - 10 files changed, 20 insertions(+), 37 deletions(-) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 6fdf4789ec..18832f7bb2 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3721,8 +3721,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (_, _, {type_kind = Type_record (fields2, repr2)}) ) -> let same_repr = match (repr1, repr2) with - | ( (Record_regular | Record_optional_labels), - (Record_regular | Record_optional_labels) ) -> + | Record_regular, Record_regular -> true (* handled in the fields checks *) | Record_unboxed b1, Record_unboxed b2 -> b1 = b2 | Record_inlined _, Record_inlined _ -> repr1 = repr2 diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index ef95f7b0d9..8ff391dbbf 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1530,7 +1530,7 @@ let make_record_matching loc all_labels def = function let access = match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels -> + | Record_regular -> Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) | Record_inlined _ -> Lprim diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index e27662e9d9..d9a5deae72 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -316,7 +316,7 @@ let common_initial_env add_type add_extension empty_env = ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil)); }; ], - Record_optional_labels ); + Record_regular ); } and decl_uncurried = let tvar1, tvar2 = (newgenvar (), newgenvar ()) in diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 9ad321000a..874f390ec0 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -130,7 +130,6 @@ let record_representation i ppf = function | Record_regular -> line i ppf "Record_regular\n" | Record_float_unused -> assert false - | Record_optional_labels -> line i ppf "Record_optional_labels\n" | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i | Record_extension -> line i ppf "Record_extension\n" diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 59f9db5cf8..889056073e 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -261,9 +261,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = match rep with | Record_unboxed _ -> fun x -> x | Record_float_unused -> assert false - | Record_optional_labels | Record_regular | Record_inlined _ - | Record_extension -> - Use.guard + | Record_regular | Record_inlined _ | Record_extension -> Use.guard in let field env = function | _, Kept _ -> Use.empty diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 924ea39978..0c8258fb0a 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -923,7 +923,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let targ = transl_exp arg in match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels -> + | Record_regular -> Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) | Record_inlined _ -> Lprim @@ -938,8 +938,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let access = match lbl.lbl_repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) + | Record_regular -> Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) | Record_unboxed _ -> assert false @@ -1159,6 +1158,7 @@ and transl_record loc env fields repres opt_init_expr = else lambda | _ -> ( let size = Array.length fields in + let optional = Ext_array.exists fields (fun (ld, _) -> ld.lbl_optional) in (* Determine if there are "enough" fields (only relevant if this is a functional-style record update *) let no_init = @@ -1167,12 +1167,7 @@ and transl_record loc env fields repres opt_init_expr = | _ -> false in if - no_init - || size < 20 - && - match repres with - | Record_optional_labels -> false - | _ -> true + no_init || (size < 20 && not optional) (* TODO: More strategies 3 + 2 * List.length lbl_expr_list >= size (density) *) @@ -1188,8 +1183,7 @@ and transl_record loc env fields repres opt_init_expr = let access = match repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels -> - Pfield (i, Lambda.fld_record lbl) + | Record_regular -> Pfield (i, Lambda.fld_record lbl) | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl) | Record_unboxed _ -> assert false | Record_extension -> @@ -1213,10 +1207,10 @@ and transl_record loc env fields repres opt_init_expr = | Record_float_unused -> assert false | Record_regular -> Lconst - (Const_block (Lambda.blk_record fields mut Record_regular, cl)) - | Record_optional_labels -> - Lconst - (Const_block (Lambda.blk_record fields mut Record_optional, cl)) + (Const_block + ( Lambda.blk_record fields mut + (if optional then Record_optional else Record_regular), + cl )) | Record_inlined {tag; name; num_nonconsts; attrs} -> Lconst (Const_block @@ -1233,10 +1227,9 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_regular -> Lprim - (Pmakeblock (Lambda.blk_record fields mut Record_regular), ll, loc) - | Record_optional_labels -> - Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_optional), + ( Pmakeblock + (Lambda.blk_record fields mut + (if optional then Record_optional else Record_regular)), ll, loc ) | Record_float_unused -> assert false @@ -1277,7 +1270,7 @@ and transl_record loc env fields repres opt_init_expr = let upd = match repres with | Record_float_unused -> assert false - | Record_regular | Record_optional_labels -> + | Record_regular -> Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 1945651b22..b8481997a2 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -949,7 +949,7 @@ module Label = NameChoice (struct lbl with lbl_name = name; lbl_pos = Array.length lbl.lbl_all; - lbl_repres = Record_optional_labels; + lbl_repres = Record_regular; } in let lbl_all_list = Array.to_list lbl.lbl_all @ [l] in @@ -2651,7 +2651,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } )); ([||], representation) | [], _ -> - if fields = [] && repr_opt <> None then ([||], Record_optional_labels) + if fields = [] && repr_opt <> None then ([||], Record_regular) else raise (Error (loc, env, Empty_record_literal)) in let labels_missing = ref [] in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 321df0f36d..25af79d146 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -635,7 +635,7 @@ let transl_declaration ~type_record_as_object env sdecl id = Type_record ( lbls', if unbox then Record_unboxed false - else if optional then Record_optional_labels + else if optional then Record_regular else Record_regular ), sdecl ) | None -> diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 25c4b67eb6..5b14935bc3 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -156,7 +156,6 @@ and record_representation = attrs: Parsetree.attributes; } | Record_extension (* Inlined record under extension *) - | Record_optional_labels and label_declaration = { ld_id: Ident.t; @@ -310,10 +309,6 @@ let same_record_representation x y = match x with | Record_regular -> y = Record_regular | Record_float_unused -> y = Record_float_unused - | Record_optional_labels -> ( - match y with - | Record_optional_labels -> true - | _ -> false) | Record_inlined {tag; name; num_nonconsts} -> ( match y with | Record_inlined y -> diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 83aeace4ec..9f3ac3397a 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -284,7 +284,6 @@ and record_representation = attrs: Parsetree.attributes; } | Record_extension (* Inlined record under extension *) - | Record_optional_labels and label_declaration = { ld_id: Ident.t; From 9b6e3c8143872813038a1c02fc64daa2a5ee13c7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Dec 2024 14:48:32 +0100 Subject: [PATCH 8/9] Completely remove record_repr from lambda. --- compiler/core/js_dump.ml | 23 ++++++++----------- .../core/js_pass_flatten_and_mark_dead.ml | 5 ++-- compiler/core/lam_compile.ml | 2 +- compiler/core/lam_convert.ml | 3 +-- compiler/core/lam_util.ml | 2 +- compiler/ml/lambda.ml | 19 +++++---------- compiler/ml/lambda.mli | 6 +---- compiler/ml/printlambda.ml | 2 +- compiler/ml/translcore.ml | 13 ++--------- tests/tests/src/record_regression.mjs | 3 ++- 10 files changed, 26 insertions(+), 52 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index bebacfa2c5..d0ccc08f12 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -759,24 +759,19 @@ and expression_desc cxt ~(level : int) f x : cxt = Ext_list.map_combine fields el (fun x -> Js_op.Lit (Ext_ident.convert x)) )) (*name convention of Record is slight different from modules*) - | Caml_block (el, mutable_flag, _, Blk_record {fields; record_repr}) -> ( + | Caml_block (el, mutable_flag, _, Blk_record {fields}) -> if Array.length fields <> 0 - && Ext_array.for_alli fields (fun i v -> string_of_int i = v) + && Ext_array.for_alli fields (fun i (v, _) -> string_of_int i = v) then expression_desc cxt ~level f (Array (el, mutable_flag)) else - match record_repr with - | Record_regular -> - expression_desc cxt ~level f - (Object (None, Ext_list.combine_array fields el (fun i -> Js_op.Lit i))) - | Record_optional -> - let fields = - Ext_list.array_list_filter_map fields el (fun f x -> - match x.expression_desc with - | Undefined _ -> None - | _ -> Some (Js_op.Lit f, x)) - in - expression_desc cxt ~level f (Object (None, fields))) + let fields = + Ext_list.array_list_filter_map fields el (fun (f, opt) x -> + match x.expression_desc with + | Undefined _ when opt -> None + | _ -> Some (Js_op.Lit f, x)) + in + expression_desc cxt ~level f (Object (None, fields)) | Caml_block (el, _, _, Blk_poly_var _) -> ( match el with | [tag; value] -> diff --git a/compiler/core/js_pass_flatten_and_mark_dead.ml b/compiler/core/js_pass_flatten_and_mark_dead.ml index 23c34f23eb..830f0ddde3 100644 --- a/compiler/core/js_pass_flatten_and_mark_dead.ml +++ b/compiler/core/js_pass_flatten_and_mark_dead.ml @@ -207,9 +207,8 @@ let subst_map (substitution : J.expression Hash_ident.t) = match Ext_list.nth_opt fields i with | None -> Printf.sprintf "%d" i | Some x -> x) - | Blk_record {fields} -> - Ext_array.get_or fields i (fun _ -> - Printf.sprintf "%d" i) + | Blk_record {fields} -> ( + try fst fields.(i) with _ -> Printf.sprintf "%d" i) | _ -> Printf.sprintf "%d" i) in (i + 1, E.var match_id :: e, (match_id, v') :: acc)) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 10cd225128..4db63e7711 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -425,7 +425,7 @@ let compile output_prefix = S.exp (Js_of_lam_block.set_field (match tag_info with - | Blk_record {fields = xs} -> Fld_record_set xs.(i) + | Blk_record {fields = xs} -> Fld_record_set (fst xs.(i)) | Blk_record_inlined xs -> Fld_record_inline_set (fst xs.fields.(i)) | Blk_constructor p -> ( diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 74131236ab..7c877cefb1 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -34,9 +34,8 @@ let lam_extension_id loc (head : Lam.t) = let lazy_block_info : Lam_tag_info.t = Blk_record { - fields = [|Literals.lazy_done; Literals.lazy_val|]; + fields = [|(Literals.lazy_done, false); (Literals.lazy_val, false)|]; mutable_flag = Mutable; - record_repr = Record_regular; } (** A conservative approach to avoid packing exceptions diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 44cd7c029d..7ea859f6be 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -198,7 +198,7 @@ let field_flatten_get | Fld_record {name} -> let found = ref None in for i = 0 to Array.length fields - 1 do - if fields.(i) = name then found := Ext_list.nth_opt ls i done; + if fst(fields.(i)) = name then found := Ext_list.nth_opt ls i done; (match !found with | Some c -> Lam.const c | None -> lam()) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 56b9a8c4cf..63c5880ef1 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -15,8 +15,6 @@ type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS -type record_repr = Record_regular | Record_optional - type tag_info = | Blk_constructor of { name: string; @@ -35,9 +33,8 @@ type tag_info = | Blk_tuple | Blk_poly_var of string | Blk_record of { - fields: string array; + fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; - record_repr: record_repr; } | Blk_module of string list | Blk_module_export of Ident.t list @@ -87,12 +84,13 @@ let find_name (attr : Parsetree.attribute) = Some s | _ -> None -let blk_record (fields : (label * _) array) mut record_repr = +let blk_record (fields : (label * _) array) mut = let all_labels_info = Ext_array.map fields (fun (lbl, _) -> - Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, + lbl.lbl_optional )) in - Blk_record {fields = all_labels_info; mutable_flag = mut; record_repr} + Blk_record {fields = all_labels_info; mutable_flag = mut} let blk_record_ext fields mutable_flag = let all_labels_info = @@ -114,12 +112,7 @@ let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag = Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; attrs} let ref_tag_info : tag_info = - Blk_record - { - fields = [|"contents"|]; - mutable_flag = Mutable; - record_repr = Record_regular; - } + Blk_record {fields = [|("contents", false)|]; mutable_flag = Mutable} type field_dbg_info = | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 0f9f4198f7..cd0c26537f 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -19,8 +19,6 @@ open Asttypes type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS -type record_repr = Record_regular | Record_optional - type tag_info = | Blk_constructor of { name: string; @@ -39,9 +37,8 @@ type tag_info = | Blk_tuple | Blk_poly_var of string | Blk_record of { - fields: string array; + fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; - record_repr: record_repr; } | Blk_module of string list | Blk_module_export of Ident.t list @@ -68,7 +65,6 @@ val mutable_flag_of_tag_info : tag_info -> mutable_flag val blk_record : (Types.label_description * Typedtree.record_label_definition) array -> mutable_flag -> - record_repr -> tag_info val blk_record_ext : diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 0a6b4be480..6d4d0cebfe 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -97,7 +97,7 @@ let print_taginfo ppf = function fprintf ppf "%s/%i" name num_nonconst | Blk_poly_var name -> fprintf ppf "`%s" name | Blk_record {fields = ss} -> - fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss)) + fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) | Blk_some -> fprintf ppf "some" | Blk_some_not_nested -> fprintf ppf "some_not_nested" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 0c8258fb0a..f84d38f92e 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1206,11 +1206,7 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular -> - Lconst - (Const_block - ( Lambda.blk_record fields mut - (if optional then Record_optional else Record_regular), - cl )) + Lconst (Const_block (Lambda.blk_record fields mut, cl)) | Record_inlined {tag; name; num_nonconsts; attrs} -> Lconst (Const_block @@ -1226,12 +1222,7 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim - ( Pmakeblock - (Lambda.blk_record fields mut - (if optional then Record_optional else Record_regular)), - ll, - loc ) + Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) | Record_float_unused -> assert false | Record_inlined {tag; name; num_nonconsts; attrs} -> Lprim diff --git a/tests/tests/src/record_regression.mjs b/tests/tests/src/record_regression.mjs index 95a511a9fa..78f03d9172 100644 --- a/tests/tests/src/record_regression.mjs +++ b/tests/tests/src/record_regression.mjs @@ -55,7 +55,8 @@ newrecord$4.aa = undefined; function setAA(ao) { return { - aa: ao + aa: ao, + bb: undefined }; } From c02def3b2106d9011fe45b70d2a4f6e30b6fd37c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Thu, 5 Dec 2024 20:07:47 +0100 Subject: [PATCH 9/9] Fix change to test. --- compiler/ml/ctype.ml | 1 + compiler/ml/parmatch.ml | 9 ++++-- tests/tests/src/record_regression.mjs | 46 +++++++++++++++++---------- 3 files changed, 37 insertions(+), 19 deletions(-) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 18832f7bb2..14ae92491b 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -2046,6 +2046,7 @@ and mcomp_record_description type_pairs env = if Ident.name l1.ld_id = Ident.name l2.ld_id && l1.ld_mutable = l2.ld_mutable + && l1.ld_optional = l2.ld_optional then iter xs ys else raise (Unify []) | [], [] -> () diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index a8434cfd19..ad1c5b2d2a 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -526,19 +526,24 @@ let all_record_args lbls = in List.iter (fun ((id, lbl, pat) as x) -> + let lbl_is_optional () = + match lbl.lbl_repres with + | Record_inlined _ -> false + | _ -> lbl.lbl_optional + in let x = match pat.pat_desc with | Tpat_construct ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, _, [({pat_desc = Tpat_constant _} as c)] ) - when lbl.lbl_optional -> + when lbl_is_optional () -> (id, lbl, c) | Tpat_construct ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, _, [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] ) - when lbl.lbl_optional -> ( + when lbl_is_optional () -> ( let cdecl = Ast_untagged_variants .constructor_declaration_from_constructor_description diff --git a/tests/tests/src/record_regression.mjs b/tests/tests/src/record_regression.mjs index 78f03d9172..e939411629 100644 --- a/tests/tests/src/record_regression.mjs +++ b/tests/tests/src/record_regression.mjs @@ -172,24 +172,36 @@ function inlinedRecord(ir) { let x1 = ir.x1; let x0 = ir.x0; if (x1 !== undefined) { - if (x1 === "x1") { - let x2 = ir.x2; - if (x2 !== undefined) { - return [ - x0, - "x1", - x2, - ir.x3 - ]; - } - + switch (x1) { + case "x1" : + let x2 = ir.x2; + if (x2 !== undefined) { + return [ + x0, + "x1", + x2, + ir.x3 + ]; + } + break; + case "xx1" : + let x2$1 = ir.x2; + if (x2$1 !== undefined) { + return [ + x0, + "xx1", + x2$1, + ir.x3 + ]; + } + break; } - let x2$1 = ir.x2; - if (x2$1 !== undefined) { + let x2$2 = ir.x2; + if (x2$2 !== undefined) { return [ x0, x1, - x2$1, + x2$2, ir.x3 ]; } else { @@ -201,12 +213,12 @@ function inlinedRecord(ir) { ]; } } - let x2$2 = ir.x2; - if (x2$2 !== undefined) { + let x2$3 = ir.x2; + if (x2$3 !== undefined) { return [ x0, "n/a", - x2$2, + x2$3, ir.x3 ]; } else {