aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/eConstr.ml31
-rw-r--r--engine/eConstr.mli10
-rw-r--r--engine/evarutil.ml7
-rw-r--r--engine/evarutil.mli2
-rw-r--r--engine/evd.ml7
-rw-r--r--engine/evd.mli10
-rw-r--r--engine/termops.ml1
-rw-r--r--engine/termops.mli2
-rw-r--r--engine/uState.ml37
-rw-r--r--engine/uState.mli9
-rw-r--r--engine/universes.ml72
-rw-r--r--engine/universes.mli34
-rw-r--r--engine/univops.ml21
-rw-r--r--engine/univops.mli5
14 files changed, 182 insertions, 66 deletions
diff --git a/engine/eConstr.ml b/engine/eConstr.ml
index afdceae061..d303038c5d 100644
--- a/engine/eConstr.ml
+++ b/engine/eConstr.ml
@@ -645,6 +645,37 @@ let eq_constr_universes_proj env sigma m n =
let res = eq_constr' (unsafe_to_constr m) (unsafe_to_constr n) in
if res then Some !cstrs else None
+let universes_of_constr env sigma c =
+ let open Univ in
+ let open Declarations in
+ let rec aux s c =
+ match kind sigma c with
+ | Const (c, u) ->
+ begin match (Environ.lookup_constant c env).const_universes with
+ | Polymorphic_const _ ->
+ LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s
+ | Monomorphic_const (univs, _) ->
+ LSet.union s univs
+ end
+ | Ind ((mind,_), u) | Construct (((mind,_),_), u) ->
+ begin match (Environ.lookup_mind mind env).mind_universes with
+ | Cumulative_ind _ | Polymorphic_ind _ ->
+ LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s
+ | Monomorphic_ind (univs,_) ->
+ LSet.union s univs
+ end
+ | Sort u ->
+ let sort = ESorts.kind sigma u in
+ if Sorts.is_small sort then s
+ else
+ let u = Sorts.univ_of_sort sort in
+ LSet.fold LSet.add (Universe.levels u) s
+ | Evar (k, args) ->
+ let concl = Evd.evar_concl (Evd.find sigma k) in
+ fold sigma aux (aux s (of_constr concl)) c
+ | _ -> fold sigma aux s c
+ in aux LSet.empty c
+
open Context
open Environ
diff --git a/engine/eConstr.mli b/engine/eConstr.mli
index e9ef302cf6..f54c422adc 100644
--- a/engine/eConstr.mli
+++ b/engine/eConstr.mli
@@ -187,9 +187,9 @@ val whd_evar : Evd.evar_map -> constr -> constr
val eq_constr : Evd.evar_map -> t -> t -> bool
val eq_constr_nounivs : Evd.evar_map -> t -> t -> bool
-val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option
-val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option
-val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.universe_constraints option
+val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.Constraints.t option
+val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.Constraints.t option
+val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.Constraints.t option
val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool
(** {6 Iterators} *)
@@ -201,6 +201,10 @@ val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a ->
val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit
val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a
+(** Gather the universes transitively used in the term, including in the
+ type of evars appearing in it. *)
+val universes_of_constr : Environ.env -> Evd.evar_map -> t -> Univ.LSet.t
+
(** {6 Substitutions} *)
module Vars :
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 907f1b1acd..3445b744a1 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -199,9 +199,10 @@ let whd_head_evar sigma c =
let meta_counter_summary_name = "meta counter"
(* Generator of metavariables *)
-let new_meta =
- let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in
- fun () -> incr meta_ctr; !meta_ctr
+let meta_ctr, meta_counter_summary_tag =
+ Summary.ref_tag 0 ~name:meta_counter_summary_name
+
+let new_meta () = incr meta_ctr; !meta_ctr
let mk_new_meta () = EConstr.mkMeta(new_meta())
diff --git a/engine/evarutil.mli b/engine/evarutil.mli
index 5fd4634d67..9d0b973a7e 100644
--- a/engine/evarutil.mli
+++ b/engine/evarutil.mli
@@ -236,7 +236,7 @@ val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b ->
val subterm_source : Evar.t -> Evar_kinds.t Loc.located ->
Evar_kinds.t Loc.located
-val meta_counter_summary_name : string
+val meta_counter_summary_tag : int Summary.Dyn.tag
(** Deprecated *)
type type_constraint = types option
diff --git a/engine/evd.ml b/engine/evd.ml
index d57ae89ddf..e33c851f6e 100644
--- a/engine/evd.ml
+++ b/engine/evd.ml
@@ -401,7 +401,7 @@ let rename evk id (evtoid, idtoev) =
| None -> (EvMap.add evk id evtoid, Id.Map.add id evk idtoev)
| Some id' ->
if Id.Map.mem id idtoev then anomaly (str "Evar name already in use.");
- (EvMap.update evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev))
+ (EvMap.set evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev))
let reassign_name_defined evk evk' (evtoid, idtoev as names) =
let id = try Some (EvMap.find evk evtoid) with Not_found -> None in
@@ -466,9 +466,8 @@ let add d e i = add_with_name d e i
let evar_counter_summary_name = "evar counter"
(* Generator of existential names *)
-let new_untyped_evar =
- let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in
- fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
+let evar_ctr, evar_counter_summary_tag = Summary.ref_tag 0 ~name:evar_counter_summary_name
+let new_untyped_evar () = incr evar_ctr; Evar.unsafe_of_int !evar_ctr
let new_evar evd ?name evi =
let evk = new_untyped_evar () in
diff --git a/engine/evd.mli b/engine/evd.mli
index fb5a6cd16e..b28ce2a62d 100644
--- a/engine/evd.mli
+++ b/engine/evd.mli
@@ -208,7 +208,7 @@ val is_defined : evar_map -> Evar.t-> bool
val is_undefined : evar_map -> Evar.t-> bool
(** Whether an evar is not defined in an evarmap. *)
-val add_constraints : evar_map -> Univ.constraints -> evar_map
+val add_constraints : evar_map -> Univ.Constraint.t -> evar_map
(** Add universe constraints in an evar map. *)
val undefined_map : evar_map -> evar_info Evar.Map.t
@@ -316,7 +316,7 @@ val whd_sort_variable : evar_map -> constr -> constr
exception UniversesDiffer
-val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map
+val add_universe_constraints : evar_map -> Universes.Constraints.t -> evar_map
(** Add the given universe unification constraints to the evar map.
@raises UniversesDiffer in case a first-order unification fails.
@raises UniverseInconsistency
@@ -491,7 +491,7 @@ val univ_flexible_alg : rigid
type 'a in_evar_universe_context = 'a * UState.t
val evar_universe_context_set : UState.t -> Univ.ContextSet.t
-val evar_universe_context_constraints : UState.t -> Univ.constraints
+val evar_universe_context_constraints : UState.t -> Univ.Constraint.t
val evar_context_universe_context : UState.t -> Univ.UContext.t
[@@ocaml.deprecated "alias of UState.context"]
@@ -513,7 +513,7 @@ val universe_of_name : evar_map -> Id.t -> Univ.Level.t
val universe_binders : evar_map -> Universes.universe_binders
val add_constraints_context : UState.t ->
- Univ.constraints -> UState.t
+ Univ.Constraint.t -> UState.t
val normalize_evar_universe_context_variables : UState.t ->
@@ -613,7 +613,7 @@ type unsolvability_explanation = SeveralInstancesFound of int
(* This stuff is internal and should not be used. Currently a hack in
the STM relies on it. *)
-val evar_counter_summary_name : string
+val evar_counter_summary_tag : int Summary.Dyn.tag
(** {5 Deprecated functions} *)
val create_evar_defs : evar_map -> evar_map
diff --git a/engine/termops.ml b/engine/termops.ml
index 07fe902220..a71bdff31e 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -288,6 +288,7 @@ let has_no_evar sigma =
with Exit -> false
let pr_evd_level evd = UState.pr_uctx_level (Evd.evar_universe_context evd)
+let reference_of_level evd l = UState.reference_of_level (Evd.evar_universe_context evd) l
let pr_evar_universe_context ctx =
let open UState in
diff --git a/engine/termops.mli b/engine/termops.mli
index c9a530076c..c1600abe80 100644
--- a/engine/termops.mli
+++ b/engine/termops.mli
@@ -271,6 +271,8 @@ val is_Prop : Evd.evar_map -> constr -> bool
val is_Set : Evd.evar_map -> constr -> bool
val is_Type : Evd.evar_map -> constr -> bool
+val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.reference
+
(** Combinators on judgments *)
val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment
diff --git a/engine/uState.ml b/engine/uState.ml
index 4e30640e46..6131f4c033 100644
--- a/engine/uState.ml
+++ b/engine/uState.ml
@@ -22,6 +22,7 @@ type uinfo = {
type t =
{ uctx_names : Universes.universe_binders * uinfo Univ.LMap.t;
uctx_local : Univ.ContextSet.t; (** The local context of variables *)
+ uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *)
uctx_univ_variables : Universes.universe_opt_subst;
(** The local universes that are unification variables *)
uctx_univ_algebraic : Univ.LSet.t;
@@ -34,6 +35,7 @@ type t =
let empty =
{ uctx_names = UNameMap.empty, Univ.LMap.empty;
uctx_local = Univ.ContextSet.empty;
+ uctx_seff_univs = Univ.LSet.empty;
uctx_univ_variables = Univ.LMap.empty;
uctx_univ_algebraic = Univ.LSet.empty;
uctx_universes = UGraph.initial_universes;
@@ -60,6 +62,7 @@ let union ctx ctx' =
else if is_empty ctx' then ctx
else
let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
+ let seff = Univ.LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in
let names = uname_union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local)
(Univ.ContextSet.levels ctx.uctx_local) in
@@ -70,6 +73,7 @@ let union ctx ctx' =
let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
{ uctx_names = (names, names_rev);
uctx_local = local;
+ uctx_seff_univs = seff;
uctx_univ_variables =
Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
uctx_univ_algebraic =
@@ -131,7 +135,7 @@ let of_binders b =
let universe_binders ctx = fst ctx.uctx_names
let instantiate_variable l b v =
- try v := Univ.LMap.update l (Some b) !v
+ try v := Univ.LMap.set l (Some b) !v
with Not_found -> assert false
exception UniversesDiffer
@@ -236,8 +240,8 @@ let add_constraints ctx cstrs =
uctx_univ_variables = vars;
uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes }
-(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
-(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
+(* let addconstrkey = CProfile.declare_profile "add_constraints_context";; *)
+(* let add_constraints_context = CProfile.profile2 addconstrkey add_constraints_context;; *)
let add_universe_constraints ctx cstrs =
let univs, local = ctx.uctx_local in
@@ -263,13 +267,15 @@ let constrain_variables diff ctx =
in
{ ctx with uctx_local = (univs, local); uctx_univ_variables = vars }
-
-let pr_uctx_level uctx =
+let reference_of_level uctx =
let map, map_rev = uctx.uctx_names in
fun l ->
- try Id.print (Option.get (Univ.LMap.find l map_rev).uname)
+ try Libnames.Ident (Loc.tag @@ Option.get (Univ.LMap.find l map_rev).uname)
with Not_found | Option.IsNone ->
- Universes.pr_with_global_universes l
+ Universes.reference_of_level l
+
+let pr_uctx_level uctx l =
+ Libnames.pr_reference (reference_of_level uctx l)
type universe_decl =
(Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl
@@ -363,12 +369,21 @@ let check_univ_decl ~poly uctx decl =
ctx
let restrict ctx vars =
+ let vars = Univ.LSet.union vars ctx.uctx_seff_univs in
let vars = Names.Id.Map.fold (fun na l vars -> Univ.LSet.add l vars)
(fst ctx.uctx_names) vars
in
let uctx' = Univops.restrict_universe_context ctx.uctx_local vars in
{ ctx with uctx_local = uctx' }
+let demote_seff_univs entry uctx =
+ let open Entries in
+ match entry.const_entry_universes with
+ | Polymorphic_const_entry _ -> uctx
+ | Monomorphic_const_entry (univs, _) ->
+ let seff = Univ.LSet.union uctx.uctx_seff_univs univs in
+ { uctx with uctx_seff_univs = seff }
+
type rigid =
| UnivRigid
| UnivFlexible of bool (** Is substitution by an algebraic ok? *)
@@ -430,7 +445,7 @@ let emit_side_effects eff u =
let new_univ_variable ?loc rigid name
({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
- let u = Universes.new_univ_level (Global.current_dirpath ()) in
+ let u = Universes.new_univ_level () in
let ctx' = Univ.ContextSet.add_universe u ctx in
let uctx', pred =
match rigid with
@@ -550,7 +565,8 @@ let refresh_undefined_univ_variables uctx =
let initial = declare uctx.uctx_initial_universes in
let univs = declare UGraph.initial_universes in
let uctx' = {uctx_names = uctx.uctx_names;
- uctx_local = ctx';
+ uctx_local = ctx';
+ uctx_seff_univs = uctx.uctx_seff_univs;
uctx_univ_variables = vars; uctx_univ_algebraic = alg;
uctx_universes = univs;
uctx_initial_universes = initial } in
@@ -567,7 +583,8 @@ let normalize uctx =
Universes.refresh_constraints uctx.uctx_initial_universes us'
in
{ uctx_names = uctx.uctx_names;
- uctx_local = us';
+ uctx_local = us';
+ uctx_seff_univs = uctx.uctx_seff_univs; (* not sure about this *)
uctx_univ_variables = vars';
uctx_univ_algebraic = algs';
uctx_universes = universes;
diff --git a/engine/uState.mli b/engine/uState.mli
index 16fba41e06..6657d6047d 100644
--- a/engine/uState.mli
+++ b/engine/uState.mli
@@ -53,7 +53,7 @@ val algebraics : t -> Univ.LSet.t
(** The subset of unification variables that can be instantiated with algebraic
universes as they appear in inferred types only. *)
-val constraints : t -> Univ.constraints
+val constraints : t -> Univ.Constraint.t
(** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *)
val context : t -> Univ.UContext.t
@@ -68,12 +68,12 @@ val ind_univ_entry : poly:bool -> t -> Entries.inductive_universes
(** {5 Constraints handling} *)
-val add_constraints : t -> Univ.constraints -> t
+val add_constraints : t -> Univ.Constraint.t -> t
(**
@raise UniversesDiffer when universes differ
*)
-val add_universe_constraints : t -> Universes.universe_constraints -> t
+val add_universe_constraints : t -> Universes.Constraints.t -> t
(**
@raise UniversesDiffer when universes differ
*)
@@ -87,6 +87,8 @@ val universe_of_name : t -> Id.t -> Univ.Level.t
val restrict : t -> Univ.LSet.t -> t
+val demote_seff_univs : Safe_typing.private_constants Entries.definition_entry -> t -> t
+
type rigid =
| UnivRigid
| UnivFlexible of bool (** Is substitution by an algebraic ok? *)
@@ -154,3 +156,4 @@ val update_sigma_env : t -> Environ.env -> t
(** {5 Pretty-printing} *)
val pr_uctx_level : t -> Univ.Level.t -> Pp.t
+val reference_of_level : t -> Univ.Level.t -> Libnames.reference
diff --git a/engine/universes.ml b/engine/universes.ml
index 5ac1bc6857..30490ec56a 100644
--- a/engine/universes.ml
+++ b/engine/universes.ml
@@ -14,10 +14,37 @@ open Constr
open Environ
open Univ
open Globnames
-
-let pr_with_global_universes l =
- try Id.print (LMap.find l (snd (Global.global_universe_names ())))
- with Not_found -> Level.pr l
+open Nametab
+
+let reference_of_level l =
+ match Level.name l with
+ | Some (d, n as na) ->
+ let qid =
+ try Nametab.shortest_qualid_of_universe na
+ with Not_found ->
+ let name = Id.of_string_soft (string_of_int n) in
+ Libnames.make_qualid d name
+ in Libnames.Qualid (Loc.tag @@ qid)
+ | None -> Libnames.Ident (Loc.tag @@ Id.of_string_soft (Level.to_string l))
+
+let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l)
+
+(** Global universe information outside the kernel, to handle
+ polymorphic universe names in sections that have to be discharged. *)
+
+let universe_map = (Summary.ref UnivIdMap.empty ~name:"global universe info" : bool Nametab.UnivIdMap.t ref)
+
+let add_global_universe u p =
+ match Level.name u with
+ | Some n -> universe_map := Nametab.UnivIdMap.add n p !universe_map
+ | None -> ()
+
+let is_polymorphic l =
+ match Level.name l with
+ | Some n ->
+ (try Nametab.UnivIdMap.find n !universe_map
+ with Not_found -> false)
+ | None -> false
(** Local universe names of polymorphic references *)
@@ -53,12 +80,14 @@ let ubinder_obj : Globnames.global_reference * universe_binders -> Libobject.obj
rebuild_function = (fun x -> x); }
let register_universe_binders ref ubinders =
- (* Add the polymorphic (section) universes *)
let open Names in
- let ubinders = Id.Map.fold (fun id (poly,lvl) ubinders ->
- if poly then Id.Map.add id lvl ubinders
- else ubinders)
- (fst (Global.global_universe_names ())) ubinders
+ (* Add the polymorphic (section) universes *)
+ let ubinders = UnivIdMap.fold (fun lvl poly ubinders ->
+ let qid = Nametab.shortest_qualid_of_universe lvl in
+ let level = Level.make (fst lvl) (snd lvl) in
+ if poly then Id.Map.add (snd (Libnames.repr_qualid qid)) level ubinders
+ else ubinders)
+ !universe_map ubinders
in
if not (Id.Map.is_empty ubinders)
then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders))
@@ -236,14 +265,17 @@ let eq_constr_universes_proj env m n =
res, !cstrs
(* Generator of levels *)
-let new_univ_level, set_remote_new_univ_level =
+type universe_id = DirPath.t * int
+
+let new_univ_id, set_remote_new_univ_id =
RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1)
- ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n)
+ ~build:(fun n -> Global.current_dirpath (), n)
-let new_univ_level _ = new_univ_level ()
- (* Univ.Level.make db (new_univ_level ()) *)
+let new_univ_level () =
+ let dp, id = new_univ_id () in
+ Univ.Level.make dp id
-let fresh_level () = new_univ_level (Global.current_dirpath ())
+let fresh_level () = new_univ_level ()
(* TODO: remove *)
let new_univ dp = Univ.Universe.make (new_univ_level dp)
@@ -251,7 +283,7 @@ let new_Type dp = mkType (new_univ dp)
let new_Type_sort dp = Type (new_univ dp)
let fresh_universe_instance ctx =
- let init _ = new_univ_level (Global.current_dirpath ()) in
+ let init _ = new_univ_level () in
Instance.of_array (Array.init (AUContext.size ctx) init)
let fresh_instance_from_context ctx =
@@ -262,7 +294,7 @@ let fresh_instance_from_context ctx =
let fresh_instance ctx =
let ctx' = ref LSet.empty in
let init _ =
- let u = new_univ_level (Global.current_dirpath ()) in
+ let u = new_univ_level () in
ctx' := LSet.add u !ctx'; u
in
let inst = Instance.of_array (Array.init (AUContext.size ctx) init)
@@ -459,7 +491,7 @@ module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap)
let add_list_map u t map =
try
let l = LMap.find u map in
- LMap.update u (t :: l) map
+ LMap.set u (t :: l) map
with Not_found ->
LMap.add u [t] map
@@ -552,7 +584,7 @@ let normalize_univ_variable_subst subst =
let find l = Univ.LMap.find l !subst in
let update l b =
assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true);
- try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in
+ try subst := Univ.LMap.set l b !subst; b with Not_found -> assert false in
normalize_univ_variable ~find ~update
let normalize_universe_opt_subst subst =
@@ -914,8 +946,8 @@ let normalize_context_set ctx us algs =
let us = normalize_opt_subst us in
(us, algs), (ctx', Constraint.union noneqs eqs)
-(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *)
-(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *)
+(* let normalize_conkey = CProfile.declare_profile "normalize_context_set" *)
+(* let normalize_context_set a b c = CProfile.profile3 normalize_conkey normalize_context_set a b c *)
let is_trivial_leq (l,d,r) =
Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r))
diff --git a/engine/universes.mli b/engine/universes.mli
index 1401c4ee8d..1a98d969b4 100644
--- a/engine/universes.mli
+++ b/engine/universes.mli
@@ -18,6 +18,13 @@ val is_set_minimization : unit -> bool
(** Universes *)
val pr_with_global_universes : Level.t -> Pp.t
+val reference_of_level : Level.t -> Libnames.reference
+
+(** Global universe information outside the kernel, to handle
+ polymorphic universes in sections that have to be discharged. *)
+val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit
+
+val is_polymorphic : Level.t -> bool
(** Local universe name <-> level mapping *)
@@ -40,14 +47,17 @@ val universe_binders_with_opt_names : Globnames.global_reference ->
Univ.Level.t list -> univ_name_list option -> universe_binders
(** The global universe counter *)
-val set_remote_new_univ_level : Level.t RemoteCounter.installer
+type universe_id = DirPath.t * int
+
+val set_remote_new_univ_id : universe_id RemoteCounter.installer
(** Side-effecting functions creating new universe levels. *)
-val new_univ_level : DirPath.t -> Level.t
-val new_univ : DirPath.t -> Universe.t
-val new_Type : DirPath.t -> types
-val new_Type_sort : DirPath.t -> Sorts.t
+val new_univ_id : unit -> universe_id
+val new_univ_level : unit -> Level.t
+val new_univ : unit -> Universe.t
+val new_Type : unit -> types
+val new_Type_sort : unit -> Sorts.t
val new_global_univ : unit -> Universe.t in_universe_context_set
val new_sort_in_family : Sorts.family -> Sorts.t
@@ -64,21 +74,23 @@ type universe_constraint_type = ULe | UEq | ULub
type universe_constraint = Universe.t * universe_constraint_type * Universe.t
module Constraints : sig
include Set.S with type elt = universe_constraint
-
+
val pr : t -> Pp.t
end
type universe_constraints = Constraints.t
-type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option
-type 'a universe_constrained = 'a * universe_constraints
-type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints
+[@@ocaml.deprecated "Use Constraints.t"]
+
+type 'a constraint_accumulator = Constraints.t -> 'a -> 'a option
+type 'a universe_constrained = 'a * Constraints.t
+type 'a universe_constraint_function = 'a -> 'a -> Constraints.t -> Constraints.t
val subst_univs_universe_constraints : universe_subst_fn ->
- universe_constraints -> universe_constraints
+ Constraints.t -> Constraints.t
val enforce_eq_instances_univs : bool -> Instance.t universe_constraint_function
-val to_constraints : UGraph.t -> universe_constraints -> constraints
+val to_constraints : UGraph.t -> Constraints.t -> Constraint.t
(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of
{!eq_constr_univs_infer} taking kind-of-term functions, to expose
diff --git a/engine/univops.ml b/engine/univops.ml
index 9a9ae12cab..df25d87252 100644
--- a/engine/univops.ml
+++ b/engine/univops.ml
@@ -9,12 +9,25 @@
open Univ
open Constr
-let universes_of_constr c =
+let universes_of_constr env c =
+ let open Declarations in
let rec aux s c =
match kind c with
- | Const (_, u) | Ind (_, u) | Construct (_, u) ->
- LSet.fold LSet.add (Instance.levels u) s
- | Sort u when not (Sorts.is_small u) ->
+ | Const (c, u) ->
+ begin match (Environ.lookup_constant c env).const_universes with
+ | Polymorphic_const _ ->
+ LSet.fold LSet.add (Instance.levels u) s
+ | Monomorphic_const (univs, _) ->
+ LSet.union s univs
+ end
+ | Ind ((mind,_), u) | Construct (((mind,_),_), u) ->
+ begin match (Environ.lookup_mind mind env).mind_universes with
+ | Cumulative_ind _ | Polymorphic_ind _ ->
+ LSet.fold LSet.add (Instance.levels u) s
+ | Monomorphic_ind (univs,_) ->
+ LSet.union s univs
+ end
+ | Sort u when not (Sorts.is_small u) ->
let u = Sorts.univ_of_sort u in
LSet.fold LSet.add (Universe.levels u) s
| _ -> Constr.fold aux s c
diff --git a/engine/univops.mli b/engine/univops.mli
index 9af568bcb3..30fcc43681 100644
--- a/engine/univops.mli
+++ b/engine/univops.mli
@@ -9,7 +9,8 @@
open Constr
open Univ
-(** Shrink a universe context to a restricted set of variables *)
+(** The universes of monomorphic constants appear. *)
+val universes_of_constr : Environ.env -> constr -> LSet.t
-val universes_of_constr : constr -> LSet.t
+(** Shrink a universe context to a restricted set of variables *)
val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-28 23:16:29 +0000