Fix #11101 by making `occur ty ty` succeed (#11109)

4 files changed, 43 insertions, 2 deletions

diff --git a/Changes b/Changes
index fcc914131a..e5ecde104c 100644
--- a/Changes
+++ b/Changes
@@ -491,6 +491,10 @@ OCaml 4.14.0
 - #11025, #11036: Do not pass -no-pie to the C compiler on musl/arm64
   (omni, Kate Deplaix and Antonio Nuno Monteiro, review by Xavier Leroy)
 
+- #11101, #11109: A recursive type constraint fails on 4.14
+  (Jacques Garrigue, report and review by Florian Angeletti)
+
+
 OCaml 4.13 maintenance branch
 -----------------------------
 
diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml
index 34a9d09039..6b6290b595 100644
--- a/testsuite/tests/typing-misc/constraints.ml
+++ b/testsuite/tests/typing-misc/constraints.ml
@@ -295,3 +295,37 @@ Error: The class constraints are not consistent.
        Type int * int is not compatible with type float * float
        Type int is not compatible with type float
 |}]
+
+(* #11101 *)
+type ('node,'self) extension = < node: 'node; self: 'self > as 'self
+type 'ext node = < > constraint 'ext = ('ext node, 'self) extension;;
+[%%expect{|
+type ('node, 'a) extension = 'a constraint 'a = < node : 'node; self : 'a >
+type 'a node = <  >
+  constraint 'a = ('a node, < node : 'a node; self : 'b > as 'b) extension
+|}, Principal{|
+type ('node, 'a) extension = < node : 'node; self : 'b > as 'b
+  constraint 'a = < node : 'node; self : 'a >
+type 'a node = <  >
+  constraint 'a = ('a node, < node : 'a node; self : 'b > as 'b) extension
+|}]
+
+class type ['node] extension =
+  object ('self)
+    method clone : 'self
+    method node : 'node
+  end
+type 'ext node = < >
+  constraint 'ext = 'ext node #extension ;;
+[%%expect{|
+class type ['node] extension =
+  object ('a) method clone : 'a method node : 'node end
+type 'a node = <  > constraint 'a = < clone : 'a; node : 'a node; .. >
+|}]
+
+module Raise: sig val default_extension: 'a node extension as 'a end = struct
+  let default_extension = failwith "Default_extension failure"
+end;;
+[%%expect{|
+Exception: Failure "Default_extension failure".
+|}]
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 3c646fd152..c3fbb4a5c3 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1772,7 +1772,8 @@ let occur env ty0 ty =
   try
     while
       type_changed := false;
-      occur_rec env allow_recursive TypeSet.empty ty0 ty;
+      if not (eq_type ty0 ty) then
+        occur_rec env allow_recursive TypeSet.empty ty0 ty;
       !type_changed
     do () (* prerr_endline "changed" *) done;
     merge type_changed old
@@ -2702,7 +2703,7 @@ and unify3 env t1 t1' t2 t2' =
   | _ ->
     begin match !umode with
     | Expression ->
-        occur_for Unify !env t1' t2';
+        occur_for Unify !env t1' t2;
         link_type t1' t2
     | Pattern ->
         add_type_equality t1' t2'
diff --git a/typing/types.ml b/typing/types.ml
index 739c7f18af..81febbf3fb 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -720,6 +720,7 @@ let log_type ty =
 let link_type ty ty' =
   let ty = repr ty in
   let ty' = repr ty' in
+  if ty == ty' then () else begin
   log_type ty;
   let desc = ty.desc in
   Transient_expr.set_desc ty (Tlink ty');
@@ -736,6 +737,7 @@ let link_type ty ty' =
       | None, None   -> ()
       end
   | _ -> ()
+  end
   (* ; assert (check_memorized_abbrevs ()) *)
   (*  ; check_expans [] ty' *)
 (* TODO: consider eliminating set_type_desc, replacing it with link types *)