diff --git a/jscomp/gentype/TranslateTypeDeclarations.ml b/jscomp/gentype/TranslateTypeDeclarations.ml index 08b8075603..e675e54561 100644 --- a/jscomp/gentype/TranslateTypeDeclarations.ml +++ b/jscomp/gentype/TranslateTypeDeclarations.ml @@ -90,7 +90,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver label_declarations = let is_optional l = match record_representation with - | Types.Record_optional_labels lbls -> List.mem l lbls + | Types.Record_regular {has_optional = true; optional_labels = lbls} -> + List.mem l lbls | _ -> false in let field_translations = @@ -251,7 +252,9 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver [ label_declarations |> translate_label_declarations ~inline:true - ~record_representation:Types.Record_regular; + ~record_representation: + (Types.Record_regular + {has_optional = false; optional_labels = []}); ] in let arg_types = diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index 9adf2b55a7..ca9dda6b93 100644 --- a/jscomp/ml/ctype.ml +++ b/jscomp/ml/ctype.ml @@ -3670,7 +3670,7 @@ let rec subtype_rec env trace t1 t2 cstrs = else (trace, t1, t2, !univar_pairs)::cstrs | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {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/jscomp/ml/datarepr.ml b/jscomp/ml/datarepr.ml index 227fb63d24..efe624f464 100644 --- a/jscomp/ml/datarepr.ml +++ b/jscomp/ml/datarepr.ml @@ -216,7 +216,7 @@ let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; - lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; + lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular {has_optional = false; optional_labels = []}; lbl_private = Public; lbl_loc = Location.none; lbl_attributes = []; diff --git a/jscomp/ml/includecore.ml b/jscomp/ml/includecore.ml index d68d0546eb..89fe253450 100644 --- a/jscomp/ml/includecore.ml +++ b/jscomp/ml/includecore.ml @@ -166,7 +166,7 @@ let report_type_mismatch0 first second decl ppf err = | Record_representation (rep1, rep2) -> let default () = pr "Their internal representations differ" in ( match rep1, rep2 with - | Record_optional_labels lbls1, Record_optional_labels lbls2 -> + | Record_regular {has_optional=true;optional_labels=lbls1}, Record_regular {has_optional=true;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 = diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml index d1fe30cc50..cb1a99c8a9 100644 --- a/jscomp/ml/matching.ml +++ b/jscomp/ml/matching.ml @@ -1596,8 +1596,7 @@ let make_record_matching loc all_labels def = function let lbl = all_labels.(pos) in 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 (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml index 5b514ac36e..8049c2f0f3 100644 --- a/jscomp/ml/printtyped.ml +++ b/jscomp/ml/printtyped.ml @@ -144,10 +144,9 @@ let arg_label i ppf = function ;; let record_representation i ppf = let open Types in 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_regular {has_optional=false} -> line i ppf "Record_regular\n" + | Record_regular {has_optional=true; optional_labels} -> + line i ppf "Record_optional_labels %s\n" (optional_labels |> String.concat ", ") | 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/jscomp/ml/rec_check.ml b/jscomp/ml/rec_check.ml index a31f7f555a..33ee33c1b2 100644 --- a/jscomp/ml/rec_check.ml +++ b/jscomp/ml/rec_check.ml @@ -255,8 +255,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = let use = match rep with | Record_unboxed _ -> fun x -> x - | Record_float_unused -> assert false - | Record_optional_labels _ | Record_regular | Record_inlined _ | Record_extension + | Record_regular _ | Record_inlined _ | Record_extension -> Use.guard in diff --git a/jscomp/ml/record_coercion.ml b/jscomp/ml/record_coercion.ml index 338749e524..2c768188ef 100644 --- a/jscomp/ml/record_coercion.ml +++ b/jscomp/ml/record_coercion.ml @@ -2,7 +2,7 @@ let check_record_fields ?repr1 ?repr2 (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 + | Some (Types.Record_regular {has_optional = true; optional_labels = lbls}) -> List.mem (Ident.name id) lbls | _ -> false in let violation = ref false in diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml index d73468ced0..cd7a9b0841 100644 --- a/jscomp/ml/translcore.ml +++ b/jscomp/ml/translcore.ml @@ -933,8 +933,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_field (arg, _, lbl) -> ( 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 _ -> @@ -952,8 +951,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_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) @@ -1191,7 +1189,7 @@ and transl_record loc env fields repres opt_init_expr = functional-style record update *) let no_init = match opt_init_expr with None -> true | _ -> false in if - no_init || (size < 20 && (match repres with Record_optional_labels _ -> false | _ -> true)) + no_init || (size < 20 && (match repres with Record_regular {has_optional=true} -> false | _ -> true)) (* TODO: More strategies 3 + 2 * List.length lbl_expr_list >= size (density) *) @@ -1206,8 +1204,7 @@ and transl_record loc env fields repres opt_init_expr = | Kept _ -> let access = match repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> + | Record_regular _ -> Pfield (i, Lambda.fld_record lbl) | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl) @@ -1231,13 +1228,9 @@ and transl_record loc env fields repres opt_init_expr = if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - | Record_float_unused -> assert false - | Record_regular -> + | Record_regular {has_optional} -> 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 has_optional then Record_optional else Record_regular), cl)) | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> Lconst (Const_block @@ -1249,17 +1242,11 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> raise Not_constant with Not_constant -> ( match repres with - | Record_regular -> - Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_regular), - ll, - loc ) - | Record_optional_labels _ -> + | Record_regular {has_optional}-> Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_optional), + ( Pmakeblock (Lambda.blk_record fields mut (if has_optional then Record_optional else Record_regular)), ll, loc ) - | Record_float_unused -> assert false | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> Lprim ( Pmakeblock @@ -1296,8 +1283,7 @@ and transl_record loc env fields repres opt_init_expr = | Overridden (_lid, 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/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index fc502f263e..75f680244a 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -311,13 +311,13 @@ let extract_concrete_variant env ty = let has_optional_labels ld = match ld.lbl_repres with - | Record_optional_labels _ -> true + | Record_regular {has_optional} -> has_optional | 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_regular {has_optional = true; optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name | _ -> false @@ -2293,7 +2293,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty | (_, { lbl_all = label_descriptions; lbl_repres = representation}, _) :: _, _ -> label_descriptions, representation | [], Some (representation) when lid_sexp_list = [] -> let optional_labels = match representation with - | Record_optional_labels optional_labels -> optional_labels + | Record_regular {optional_labels} | Record_inlined {optional_labels} -> optional_labels | _ -> [] in let filter_missing (ld : Types.label_declaration) = @@ -2309,7 +2309,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty [||], representation | [], _ -> if fields = [] && repr_opt <> None then - [||], Record_optional_labels [] + [||], Record_regular {has_optional = false; optional_labels = []} else raise(Error(loc, env, Empty_record_literal)) in let labels_missing = ref [] in diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index d47ef99230..1b37346566 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -549,9 +549,10 @@ let transl_declaration ~type_record_as_object env sdecl id = in Ttype_record lbls, Type_record(lbls', if unbox then Record_unboxed false - else if optional_labels <> [] then - Record_optional_labels optional_labels - else Record_regular), sdecl + else Record_regular { + has_optional = optional_labels <> []; + optional_labels = optional_labels + }), sdecl | None -> (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *) type_record_as_object := true; diff --git a/jscomp/ml/types.ml b/jscomp/ml/types.ml index 8ed317f1d1..68e5b226f1 100644 --- a/jscomp/ml/types.ml +++ b/jscomp/ml/types.ml @@ -150,14 +150,15 @@ and type_kind = | Type_open and record_representation = - | Record_regular (* All fields are boxed / tagged *) - | Record_float_unused (* Was: all fields are floats. Now: unused *) + | Record_regular of { + has_optional: bool; (* true if optional_labels is non-empty. Needed for convinience to match on Record_regular with optional labels only *) + optional_labels : string list + } (* All fields are boxed / tagged *) | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) | Record_inlined of (* Inlined record *) - { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes} + { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes } | Record_extension (* Inlined record under extension *) - | Record_optional_labels of string list (* List of optional labels *) - + and label_declaration = { ld_id: Ident.t; @@ -310,11 +311,10 @@ type label_description = } 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_regular {optional_labels} -> ( match y with - | Record_optional_labels lbls2 -> lbls = lbls2 + | Record_regular y -> + optional_labels = y.optional_labels | _ -> false) | Record_inlined {tag; name; num_nonconsts; optional_labels} -> ( match y with diff --git a/jscomp/ml/types.mli b/jscomp/ml/types.mli index 7d8e1c46f0..c57e10abee 100644 --- a/jscomp/ml/types.mli +++ b/jscomp/ml/types.mli @@ -297,13 +297,14 @@ and type_kind = | Type_open and record_representation = - | Record_regular (* All fields are boxed / tagged *) - | Record_float_unused (* Was: all fields are floats. Now: unused *) + | Record_regular of { + has_optional: bool; (* true if optional_labels is non-empty. Needed for convinience to match on Record_regular with optional labels only *) + optional_labels : string list + } (* All fields are boxed / tagged *) | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) | Record_inlined of (* Inlined record *) { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes } | Record_extension (* Inlined record under extension *) - | Record_optional_labels of string list (* List of optional labels *) and label_declaration = {