Merge PR #6747: Relax conversion of constructors according to the pCuIC model

4 files changed, 36 insertions, 5 deletions

diff --git a/checker/reduction.ml b/checker/reduction.ml
index 67d00b21d..97255dd49 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -201,7 +201,9 @@ let convert_constructors
     if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then
       convert_universes univs u1 u2
     else
-      convert_inductive_instances CONV cumi u1 u2 univs
+      (** By invariant, both constructors have a common supertype,
+          so they are convertible _at that type_. *)
+      ()
 
 (* Convertibility of sorts *)
 
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index e9be1b35d..b3e689414 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -269,8 +269,9 @@ let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u
     if not (Int.equal num_cnstr_args nargs) then
       cmp_instances u1 u2 s
     else
-      let csts = get_cumulativity_constraints CONV cumi u1 u2 in
-      cmp_cumul csts s
+      (** By invariant, both constructors have a common supertype,
+          so they are convertible _at that type_. *)
+      s
 
 let convert_constructors ctor nargs u1 u2 (s, check) =
   convert_constructors_gen (check.compare_instances ~flex:false) check.compare_cumul_instances
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 0a63985bf..fe2e86a48 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -530,8 +530,15 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
                 UnifFailure (evd, NotSameHead)
               else
                 begin
-                  let evd' = check_leq_inductives evd cumi u u' in
-                  Success (check_leq_inductives evd' cumi u' u)
+                  (** Both constructors should be liftable to the same supertype
+                      at which we compare them, but we don't have access to that type in
+                      untyped unification. We hence try to enforce that one is lower
+                      than the other, also unifying more universes in the process.
+                      If this fails we just leave the universes as is, as in conversion. *)
+                  try Success (check_leq_inductives evd cumi u u')
+                  with Univ.UniverseInconsistency _ ->
+                    try Success (check_leq_inductives evd cumi u' u)
+                    with Univ.UniverseInconsistency e -> Success evd
                 end
             end
         in
diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v
index e05762477..4dda36042 100644
--- a/test-suite/success/cumulativity.v
+++ b/test-suite/success/cumulativity.v
@@ -134,3 +134,24 @@ Definition withparams_co@{i i' j|i < i', i' < j} : withparams@{i j} -> withparam
 
 Fail Definition withparams_not_irr@{i i' j|i' < i, i' < j} : withparams@{i j} -> withparams@{i' j}
   := fun x => x.
+
+(** Cumulative constructors *)
+
+
+Record twotys@{u v w} : Type@{w} :=
+  twoconstr { fstty : Type@{u}; sndty : Type@{v} }.
+
+Monomorphic Universes i j k l.
+
+Monomorphic Constraint i < j.
+Monomorphic Constraint j < k.
+Monomorphic Constraint k < l.
+
+Parameter Tyi : Type@{i}.
+
+Definition checkcumul :=
+  eq_refl _ : @eq twotys@{k k l} (twoconstr@{i j k} Tyi Tyi) (twoconstr@{j i k} Tyi Tyi).
+
+(* They can only be compared at the highest type *)
+Fail Definition checkcumul' :=
+  eq_refl _ : @eq twotys@{i k l} (twoconstr@{i j k} Tyi Tyi) (twoconstr@{j i k} Tyi Tyi).