4 files changed, 85 insertions, 31 deletions

diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml
index 4da5f0f383..1d8861cbc0 100644
--- a/kernel/cClosure.ml
+++ b/kernel/cClosure.ml
@@ -1051,7 +1051,12 @@ let norm_val info tab v =
 
 let inject c = mk_clos (subs_id 0) c
 
-let whd_stack infos tab m stk =
+let whd_stack infos tab m stk = match m.norm with
+| Whnf | Norm ->
+  (** No need to perform [kni] nor to unlock updates because
+      every head subterm of [m] is [Whnf] or [Norm] *)
+  knh infos m stk
+| Red | Cstr ->
   let k = kni infos tab m stk in
   let () = if !share then ignore (fapp_stack k) in (* to unlock Zupdates! *)
   k
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 8ca596d482..f4af313867 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -648,25 +648,24 @@ let check_leq univs u u' =
 
 let check_sort_cmp_universes env pb s0 s1 univs =
   let open Sorts in
-  match (s0,s1) with
+  if not (type_in_type env) then
+    match (s0,s1) with
     | (Prop c1, Prop c2) when is_cumul pb ->
       begin match c1, c2 with
-      | Null, _ | _, Pos -> () (* Prop <= Set *)
-      | _ -> raise NotConvertible
+        | Null, _ | _, Pos -> () (* Prop <= Set *)
+        | _ -> raise NotConvertible
       end
     | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible
     | (Prop c1, Type u) ->
-	if not (type_in_type env) then
-	let u0 = univ_of_sort s0 in
-	(match pb with
-	| CUMUL -> check_leq univs u0 u
-	| CONV -> check_eq univs u0 u)
+      let u0 = univ_of_sort s0 in
+      (match pb with
+       | CUMUL -> check_leq univs u0 u
+       | CONV -> check_eq univs u0 u)
     | (Type u, Prop c) -> raise NotConvertible
     | (Type u1, Type u2) ->
-        if not (type_in_type env) then
-	(match pb with
-	| CUMUL -> check_leq univs u1 u2
-	| CONV -> check_eq univs u1 u2)
+      (match pb with
+       | CUMUL -> check_leq univs u1 u2
+       | CONV -> check_eq univs u1 u2)
 
 let checked_sort_cmp_universes env pb s0 s1 univs =
   check_sort_cmp_universes env pb s0 s1 univs; univs
@@ -699,25 +698,25 @@ let infer_leq (univs, cstrs as cuniv) u u' =
 
 let infer_cmp_universes env pb s0 s1 univs =
   let open Sorts in
-  match (s0,s1) with
+  if type_in_type env then univs
+  else
+    match (s0,s1) with
     | (Prop c1, Prop c2) when is_cumul pb ->
       begin match c1, c2 with
-      | Null, _ | _, Pos -> univs (* Prop <= Set *)
-      | _ -> raise NotConvertible
+        | Null, _ | _, Pos -> univs (* Prop <= Set *)
+        | _ -> raise NotConvertible
       end
     | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible
     | (Prop c1, Type u) ->
       let u0 = univ_of_sort s0 in
-	(match pb with
-	| CUMUL -> infer_leq univs u0 u
-	| CONV -> infer_eq univs u0 u)
+      (match pb with
+       | CUMUL -> infer_leq univs u0 u
+       | CONV -> infer_eq univs u0 u)
     | (Type u, Prop c) -> raise NotConvertible
     | (Type u1, Type u2) ->
-        if not (type_in_type env) then
-	(match pb with
-	| CUMUL -> infer_leq univs u1 u2
-	| CONV -> infer_eq univs u1 u2)
-        else univs
+      (match pb with
+       | CUMUL -> infer_leq univs u1 u2
+       | CONV -> infer_eq univs u1 u2)
 
 let infer_convert_instances ~flex u u' (univs,cstrs) =
   let cstrs' =
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
index e6b27077ba..4a9467de52 100644
--- a/kernel/uGraph.ml
+++ b/kernel/uGraph.ml
@@ -503,7 +503,7 @@ let insert_edge strict ucan vcan g =
     let () = cleanup_universes g in
     raise e
 
-let add_universe vlev strict g =
+let add_universe_gen vlev g =
   try
     let _arcv = UMap.find vlev g.entries in
       raise AlreadyDeclared
@@ -520,8 +520,14 @@ let add_universe vlev strict g =
     }
     in
     let entries = UMap.add vlev (Canonical v) g.entries in
-    let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in
-    insert_edge strict (get_set_arc g) v g
+    { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v
+
+let add_universe vlev strict g =
+  let g, v = add_universe_gen vlev g in
+  insert_edge strict (get_set_arc g) v g
+
+let add_universe_unconstrained vlev g =
+  fst (add_universe_gen vlev g)
 
 exception Found_explanation of explanation
 
@@ -696,6 +702,9 @@ let enforce_univ_lt u v g =
     error_inconsistency Lt u v (get_explanation false v u g)
 
 let empty_universes =
+  { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 }
+
+let initial_universes =
   let set_arc = Canonical {
     univ = Level.set;
     ltle = LMap.empty;
@@ -718,9 +727,6 @@ let empty_universes =
   let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in
   enforce_univ_lt Level.prop Level.set empty
 
-(* Prop = Set is forbidden here. *)
-let initial_universes = empty_universes
-
 let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries
 
 let enforce_constraint cst g =
@@ -780,6 +786,42 @@ let constraints_of_universes g =
   let csts = UMap.fold constraints_of g.entries Constraint.empty in
   csts, UF.partition uf
 
+(* domain g.entries = kept + removed *)
+let constraints_for ~kept g =
+  (* rmap: partial map from canonical universes to kept universes *)
+  let rmap, csts = LSet.fold (fun u (rmap,csts) ->
+      let arcu = repr g u in
+      if LSet.mem arcu.univ kept then
+        LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts
+      else
+        match LMap.find arcu.univ rmap with
+        | v -> rmap, enforce_eq_level u v csts
+        | exception Not_found -> LMap.add arcu.univ u rmap, csts)
+      kept (LMap.empty,Constraint.empty)
+  in
+  let rec add_from u csts todo = match todo with
+    | [] -> csts
+    | (v,strict)::todo ->
+      let v = repr g v in
+      (match LMap.find v.univ rmap with
+       | v ->
+         let d = if strict then Lt else Le in
+         let csts = Constraint.add (u,d,v) csts in
+         add_from u csts todo
+       | exception Not_found ->
+         (* v is not equal to any kept universe *)
+         let todo = LMap.fold (fun v' strict' todo ->
+             (v',strict || strict') :: todo)
+             v.ltle todo
+         in
+         add_from u csts todo)
+  in
+  LSet.fold (fun u csts ->
+      let arc = repr g u in
+      LMap.fold (fun v strict csts -> add_from u csts [v,strict])
+        arc.ltle csts)
+    kept csts
+
 (** [sort_universes g] builds a totally ordered universe graph.  The
     output graph should imply the input graph (and the implication
     will be strict most of the time), but is not necessarily minimal.
diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli
index cca2eb472b..e6dd629e45 100644
--- a/kernel/uGraph.mli
+++ b/kernel/uGraph.mli
@@ -49,13 +49,15 @@ exception AlreadyDeclared
 
 val add_universe : Level.t -> bool -> t -> t
 
+(** Add a universe without (Prop,Set) <= u *)
+val add_universe_unconstrained : Level.t -> t -> t
+
 (** {6 Pretty-printing of universes. } *)
 
 val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t
 
 (** The empty graph of universes *)
 val empty_universes : t
-[@@ocaml.deprecated "Use UGraph.initial_universes"]
 
 val sort_universes : t -> t
 
@@ -64,6 +66,12 @@ val sort_universes : t -> t
    of the universes into equivalence classes. *)
 val constraints_of_universes : t -> Constraint.t * LSet.t list
 
+(** [constraints_for ~kept g] returns the constraints about the
+   universes [kept] in [g] up to transitivity.
+
+    eg if [g] is [a <= b <= c] then [constraints_for ~kept:{a, c} g] is [a <= c]. *)
+val constraints_for : kept:LSet.t -> t -> Constraint.t
+
 val check_subtype : AUContext.t check_function
 (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of
     [ctx1]. *)