diff --git a/CHANGELOG.md b/CHANGELOG.md index 2ec3e6bac6..ef02d87d2e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,8 +24,8 @@ #### :bug: Bug Fix - Fix issue where uncurried type internals leak in type error. https://github.com/rescript-lang/rescript-compiler/pull/6264 -- Improve error messages for untagged variant definitions https://github.com/rescript-lang/rescript-compiler/pull/6290 - +- Improve error messages for untagged variant definition. https://github.com/rescript-lang/rescript-compiler/pull/6290 +- Fix type checking performance issue for large records. https://github.com/rescript-lang/rescript-compiler/pull/6289 # 11.0.0-beta.1 diff --git a/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected b/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected new file mode 100644 index 0000000000..7f3f6db28a --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected @@ -0,0 +1,22 @@ + + We've found a bug for you! + /.../fixtures/RecordInclusion.res:3:5-5:1 + + 1 │ module M : { + 2 │ type t<'a, 'b, 'c> = {x:int, y:list<('a, 'b)>, z:int} + 3 │ } = { + 4 │  type t<'a, 'b, 'c> = {x:int, y:list<('a, 'c)>, z:int} + 5 │ } + 6 │ + + Signature mismatch: + ... + Type declarations do not match: + type t<'a, 'b, 'c> = {x: int, y: list<('a, 'c)>, z: int} + is not included in + type t<'a, 'b, 'c> = {x: int, y: list<('a, 'b)>, z: int} + /.../fixtures/RecordInclusion.res:2:3-55: + Expected declaration + /.../fixtures/RecordInclusion.res:4:3-55: + Actual declaration + The types for field y are not equal. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/RecordInclusion.res b/jscomp/build_tests/super_errors/fixtures/RecordInclusion.res new file mode 100644 index 0000000000..c8d366ca7c --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/RecordInclusion.res @@ -0,0 +1,5 @@ +module M : { + type t<'a, 'b, 'c> = {x:int, y:list<('a, 'b)>, z:int} +} = { + type t<'a, 'b, 'c> = {x:int, y:list<('a, 'c)>, z:int} +} diff --git a/jscomp/ml/includecore.ml b/jscomp/ml/includecore.ml index 8bf9770c9d..2b8039f46e 100644 --- a/jscomp/ml/includecore.ml +++ b/jscomp/ml/includecore.ml @@ -236,39 +236,53 @@ and compare_variants ~loc env params1 params2 n else compare_variants ~loc env params1 params2 (n+1) rem1 rem2 end - -and compare_records ~loc env params1 params2 n - (labels1 : Types.label_declaration list) - (labels2 : Types.label_declaration list) = - match labels1, labels2 with - [], [] -> [] - | [], l::_ -> [Field_missing (true, l.Types.ld_id)] - | l::_, [] -> [Field_missing (false, l.Types.ld_id)] - | ld1::rem1, ld2::rem2 -> - 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 begin - Builtin_attributes.check_deprecated_mutable_inclusion - ~def:ld1.ld_loc - ~use:ld2.ld_loc - loc - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id); - let field_mismatch = !Builtin_attributes.check_bs_attributes_inclusion - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id) in - match field_mismatch with - | Some (a,b) -> [Field_names (n,a,b)] - | None -> - if Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2) - then (* add arguments to the parameters, cf. PR#7378 *) - compare_records ~loc env - (ld1.ld_type::params1) (ld2.ld_type::params2) - (n+1) - rem1 rem2 +and compare_records ~loc env params1_ params2_ n_ + (labels1_ : Types.label_declaration list) + (labels2_ : Types.label_declaration list) = + (* First try a fast path that checks if all the fields at once are consistent. + When that fails, try a slow path that blames the first inconsistent field *) + let rec aux ~fast params1 params2 n labels1 labels2 = + match labels1, labels2 with + [], [] -> + if fast then + if Ctype.equal env true params1 params2 then + [] + else + aux ~fast:false params1_ params2_ n_ labels1_ labels2_ else - [Field_type ld1.ld_id] - end + [] + | [], l::_ -> [Field_missing (true, l.Types.ld_id)] + | l::_, [] -> [Field_missing (false, l.Types.ld_id)] + | ld1::rem1, ld2::rem2 -> + 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 begin + Builtin_attributes.check_deprecated_mutable_inclusion + ~def:ld1.ld_loc + ~use:ld2.ld_loc + loc + ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id); + let field_mismatch = !Builtin_attributes.check_bs_attributes_inclusion + ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id) in + match field_mismatch with + | Some (a,b) -> [Field_names (n,a,b)] + | None -> + let current_field_consistent = + if fast then true + else Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2) in + if current_field_consistent + then (* add arguments to the parameters, cf. PR#7378 *) + aux ~fast + (ld1.ld_type::params1) (ld2.ld_type::params2) + (n+1) + rem1 rem2 + else + [Field_type ld1.ld_id] + end in + aux ~fast:true params1_ params2_ n_ labels1_ labels2_ + let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = Builtin_attributes.check_deprecated_inclusion @@ -324,8 +338,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; compare_variants ~loc env decl1.type_params decl2.type_params 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - let err = compare_records ~loc env decl1.type_params decl2.type_params - 1 labels1 labels2 in + let err = compare_records ~loc env decl1.type_params decl2.type_params 1 labels1 labels2 in if err <> [] || rep1 = rep2 then err else [Record_representation (rep1, rep2)] | (Type_open, Type_open) -> []