Speed up record inclusion check. (#6289)

* Speed up record inclusion check.

Speed up record inclusion check.
Fixes #6284

Record inclusion check (between implementation and interface) is quadratic.

Example:
```res
module M : {
  type t<'a, 'b, 'c> = {x:list<('a, 'b)>, y:int, z:int}
} = {
  type t<'a, 'b, 'c> = {x:list<('a, 'c)>, y:int, z:int}
}
```

The algorithm tries to instantiate type parameters. It only reports an error if there is an inconsistency. This requires solving type equations involving many types at once.

To improve error message, the first problematic field is reported. So the type equations are checked again and again with size 1, 2, ...n where n is the number of fields. (Plus the type parameters).

This is quadratic and is problematic for types of ~1K elements.

This PR provides a fast path which just checks if there is an error, without blaming a specific field.
The fast path is linear.
Only if an error is detected, the quadratic path is take to blame precisely which field is involved.

* Add text for record inclusion.

So that there's some minimal sanity check that record type inclusion works as expected on a nontrivial case.

* Update CHANGELOG.md

* Refactor into a single function.

Author: cristianoc

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
 

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.

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}
+}

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) -> []