aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/eConstr.ml61
-rw-r--r--engine/eConstr.mli20
-rw-r--r--engine/evarutil.ml177
-rw-r--r--engine/evarutil.mli13
-rw-r--r--engine/evd.ml9
-rw-r--r--engine/evd.mli10
-rw-r--r--engine/ftactic.mli4
-rw-r--r--engine/logic_monad.ml1
-rw-r--r--engine/logic_monad.mli1
-rw-r--r--engine/proofview.ml39
-rw-r--r--engine/proofview.mli39
-rw-r--r--engine/termops.ml13
-rw-r--r--engine/termops.mli12
-rw-r--r--engine/uState.ml59
-rw-r--r--engine/uState.mli9
-rw-r--r--engine/universes.ml161
-rw-r--r--engine/universes.mli45
-rw-r--r--engine/univops.ml21
-rw-r--r--engine/univops.mli5
19 files changed, 519 insertions, 180 deletions
diff --git a/engine/eConstr.ml b/engine/eConstr.ml
index afdceae061..9ac16b5b48 100644
--- a/engine/eConstr.ml
+++ b/engine/eConstr.ml
@@ -150,6 +150,8 @@ type rel_declaration = (constr, types) Context.Rel.Declaration.pt
type named_context = (constr, types) Context.Named.pt
type rel_context = (constr, types) Context.Rel.pt
+type 'a puniverses = 'a * EInstance.t
+
let in_punivs a = (a, EInstance.empty)
let mkProp = of_kind (Sort (ESorts.make Sorts.prop))
@@ -645,6 +647,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
@@ -662,6 +695,10 @@ let cast_rel_context :
type a b. (a,b) eq -> (a, a) Rel.pt -> (b, b) Rel.pt =
fun Refl x -> x
+let cast_rec_decl :
+ type a b. (a,b) eq -> (a, a) Constr.prec_declaration -> (b, b) Constr.prec_declaration =
+ fun Refl x -> x
+
let cast_named_decl :
type a b. (a,b) eq -> (a, a) Named.Declaration.pt -> (b, b) Named.Declaration.pt =
fun Refl x -> x
@@ -737,6 +774,20 @@ let rec isArity sigma c =
| Sort _ -> true
| _ -> false
+type arity = rel_context * ESorts.t
+
+let destArity sigma =
+ let open Context.Rel.Declaration in
+ let rec prodec_rec l c =
+ match kind sigma c with
+ | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c
+ | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c
+ | Cast (c,_,_) -> prodec_rec l c
+ | Sort s -> l,s
+ | _ -> anomaly ~label:"destArity" (Pp.str "not an arity.")
+ in
+ prodec_rec []
+
let mkProd_or_LetIn decl c =
let open Context.Rel.Declaration in
match decl with
@@ -770,6 +821,7 @@ let it_mkLambda_or_LetIn t ctx = List.fold_left (fun c d -> mkLambda_or_LetIn d
let push_rel d e = push_rel (cast_rel_decl unsafe_eq d) e
let push_rel_context d e = push_rel_context (cast_rel_context unsafe_eq d) e
+let push_rec_types d e = push_rec_types (cast_rec_decl unsafe_eq d) e
let push_named d e = push_named (cast_named_decl unsafe_eq d) e
let push_named_context d e = push_named_context (cast_named_context unsafe_eq d) e
let push_named_context_val d e = push_named_context_val (cast_named_decl unsafe_eq d) e
@@ -784,6 +836,15 @@ let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e)
let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e)
let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_val n e)
+let map_rel_context_in_env f env sign =
+ let rec aux env acc = function
+ | d::sign ->
+ aux (push_rel d env) (Context.Rel.Declaration.map_constr (f env) d :: acc) sign
+ | [] ->
+ acc
+ in
+ aux env [] (List.rev sign)
+
let fresh_global ?loc ?rigid ?names env sigma reference =
let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in
evd, of_constr t
diff --git a/engine/eConstr.mli b/engine/eConstr.mli
index e9ef302cf6..6fa338c73d 100644
--- a/engine/eConstr.mli
+++ b/engine/eConstr.mli
@@ -56,6 +56,8 @@ sig
val is_empty : t -> bool
end
+type 'a puniverses = 'a * EInstance.t
+
(** {5 Destructors} *)
val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_term
@@ -144,7 +146,11 @@ val isFix : Evd.evar_map -> t -> bool
val isCoFix : Evd.evar_map -> t -> bool
val isCase : Evd.evar_map -> t -> bool
val isProj : Evd.evar_map -> t -> bool
+
+type arity = rel_context * ESorts.t
+val destArity : Evd.evar_map -> types -> arity
val isArity : Evd.evar_map -> t -> bool
+
val isVarId : Evd.evar_map -> Id.t -> t -> bool
val isRelN : Evd.evar_map -> int -> t -> bool
@@ -187,9 +193,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 +207,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 :
@@ -241,6 +251,7 @@ end
val push_rel : rel_declaration -> env -> env
val push_rel_context : rel_context -> env -> env
+val push_rec_types : (t, t) Constr.prec_declaration -> env -> env
val push_named : named_declaration -> env -> env
val push_named_context : named_context -> env -> env
@@ -256,6 +267,9 @@ val lookup_rel : int -> env -> rel_declaration
val lookup_named : variable -> env -> named_declaration
val lookup_named_val : variable -> named_context_val -> named_declaration
+val map_rel_context_in_env :
+ (env -> constr -> constr) -> env -> rel_context -> rel_context
+
(* XXX Missing Sigma proxy *)
val fresh_global :
?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env ->
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 907f1b1acd..f82ffccdc3 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())
@@ -256,22 +257,6 @@ let make_pure_subst evi args =
* we have the property that u and phi(t) are convertible in env.
*)
-let csubst_subst (k, s) c =
- (** Safe because this is a substitution *)
- let c = EConstr.Unsafe.to_constr c in
- let rec subst n c = match Constr.kind c with
- | Rel m ->
- if m <= n then c
- else if m - n <= k then EConstr.Unsafe.to_constr (Int.Map.find (k - m + n) s)
- else mkRel (m - k)
- | _ -> Constr.map_with_binders succ subst n c
- in
- let c = if k = 0 then c else subst 0 c in
- EConstr.of_constr c
-
-let subst2 subst vsubst c =
- csubst_subst subst (EConstr.Vars.replace_vars vsubst c)
-
let next_ident_away id avoid =
let avoid id = Id.Set.mem id avoid in
next_ident_away_from id avoid
@@ -281,19 +266,79 @@ let next_name_away na avoid =
let id = match na with Name id -> id | Anonymous -> default_non_dependent_ident in
next_ident_away_from id avoid
-type csubst = int * EConstr.t Int.Map.t
-
-let empty_csubst = (0, Int.Map.empty)
+type subst_val =
+| SRel of int
+| SVar of Id.t
+
+type csubst = {
+ csubst_len : int;
+ (** Cardinal of [csubst_rel] *)
+ csubst_var : Constr.t Id.Map.t;
+ (** A mapping of variables to variables. We use the more general
+ [Constr.t] to share allocations, but all values are of shape [Var _]. *)
+ csubst_rel : Constr.t Int.Map.t;
+ (** A contiguous mapping of integers to variables. Same remark for values. *)
+ csubst_rev : subst_val Id.Map.t;
+ (** Reverse mapping of the substitution *)
+}
+(** This type represent a name substitution for the named and De Bruijn parts of
+ a environment. For efficiency we also store the reverse substitution.
+ Invariant: all identifiers in the codomain of [csubst_var] and [csubst_rel]
+ must be pairwise distinct. *)
+
+let empty_csubst = {
+ csubst_len = 0;
+ csubst_rel = Int.Map.empty;
+ csubst_var = Id.Map.empty;
+ csubst_rev = Id.Map.empty;
+}
+
+let csubst_subst { csubst_len = k; csubst_var = v; csubst_rel = s } c =
+ (** Safe because this is a substitution *)
+ let c = EConstr.Unsafe.to_constr c in
+ let rec subst n c = match Constr.kind c with
+ | Rel m ->
+ if m <= n then c
+ else if m - n <= k then Int.Map.find (k - m + n) s
+ else mkRel (m - k)
+ | Var id ->
+ begin try Id.Map.find id v with Not_found -> c end
+ | _ -> Constr.map_with_binders succ subst n c
+ in
+ let c = if k = 0 && Id.Map.is_empty v then c else subst 0 c in
+ EConstr.of_constr c
type ext_named_context =
- csubst * (Id.t * EConstr.constr) list *
- Id.Set.t * EConstr.named_context
-
-let push_var id (n, s) =
- let s = Int.Map.add n (EConstr.mkVar id) s in
- (succ n, s)
-
-let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) =
+ csubst * Id.Set.t * EConstr.named_context
+
+let push_var id { csubst_len = n; csubst_var = v; csubst_rel = s; csubst_rev = r } =
+ let s = Int.Map.add n (Constr.mkVar id) s in
+ let r = Id.Map.add id (SRel n) r in
+ { csubst_len = succ n; csubst_var = v; csubst_rel = s; csubst_rev = r }
+
+(** Post-compose the substitution with the generator [src ↦ tgt] *)
+let update_var src tgt subst =
+ let cur =
+ try Some (Id.Map.find src subst.csubst_rev)
+ with Not_found -> None
+ in
+ match cur with
+ | None ->
+ (** Missing keys stand for identity substitution [src ↦ src] *)
+ let csubst_var = Id.Map.add src (Constr.mkVar tgt) subst.csubst_var in
+ let csubst_rev = Id.Map.add tgt (SVar src) subst.csubst_rev in
+ { subst with csubst_var; csubst_rev }
+ | Some bnd ->
+ let csubst_rev = Id.Map.add tgt bnd (Id.Map.remove src subst.csubst_rev) in
+ match bnd with
+ | SRel m ->
+ let csubst_rel = Int.Map.add m (Constr.mkVar tgt) subst.csubst_rel in
+ { subst with csubst_rel; csubst_rev }
+ | SVar id ->
+ let csubst_var = Id.Map.add id (Constr.mkVar tgt) subst.csubst_var in
+ { subst with csubst_var; csubst_rev }
+
+let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) =
let open EConstr in
let open Vars in
let map_decl f d =
@@ -329,18 +374,17 @@ let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) =
binding named [id], we will keep [id0] (the name given
by the user) and rename [id0] into [id] in the named
context. Unless [id] is a section variable. *)
- let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in
- let vsubst = (id0,mkVar id)::vsubst in
- let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (subst2 subst vsubst) in
+ let subst = update_var id0 id subst in
+ let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in
let nc = List.map (replace_var_named_declaration id0 id) nc in
- (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc)
+ (push_var id0 subst, Id.Set.add id avoid, d :: nc)
| _ ->
(* spiwack: if [id0] is a section variable renaming it is
incorrect. We revert to a less robust behaviour where
the new binder has name [id]. Which amounts to the same
behaviour than when [id=id0]. *)
- let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (subst2 subst vsubst) in
- (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc)
+ let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (csubst_subst subst) in
+ (push_var id subst, Id.Set.add id avoid, d :: nc)
let push_rel_context_to_named_context env sigma typ =
(* compute the instances relative to the named context and rel_context *)
@@ -349,17 +393,17 @@ let push_rel_context_to_named_context env sigma typ =
let ids = List.map get_id (named_context env) in
let inst_vars = List.map mkVar ids in
if List.is_empty (Environ.rel_context env) then
- (named_context_val env, typ, inst_vars, empty_csubst, [])
+ (named_context_val env, typ, inst_vars, empty_csubst)
else
let avoid = List.fold_right Id.Set.add ids Id.Set.empty in
let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
(* move the rel context to a named context and extend the named instance *)
(* with vars of the rel context *)
(* We do keep the instances corresponding to local definition (see above) *)
- let (subst, vsubst, _, env) =
+ let (subst, _, env) =
Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc)
- (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) in
- (val_of_named_context env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
+ (rel_context env) ~init:(empty_csubst, avoid, named_context env) in
+ (val_of_named_context env, csubst_subst subst typ, inst_rels@inst_vars, subst)
(*------------------------------------*
* Entry points to define new evars *
@@ -424,8 +468,8 @@ let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?prin
(* [new_evar] declares a new existential in an env env with type typ *)
(* Converting the env into the sign of the evar to define *)
let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
- let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env evd typ in
- let map c = subst2 subst vsubst c in
+ let sign,typ',instance,subst = push_rel_context_to_named_context env evd typ in
+ let map c = csubst_subst subst c in
let candidates = Option.map (fun l -> List.map map l) candidates in
let instance =
match filter with
@@ -691,6 +735,55 @@ let undefined_evars_of_evar_info evd evi =
(undefined_evars_of_named_context evd
(named_context_of_val evi.evar_hyps)))
+type undefined_evars_cache = {
+ mutable cache : (EConstr.named_declaration * Evar.Set.t) ref Id.Map.t;
+}
+
+let create_undefined_evars_cache () = { cache = Id.Map.empty; }
+
+let cached_evar_of_hyp cache sigma decl accu = match cache with
+| None ->
+ let fold c acc =
+ let evs = undefined_evars_of_term sigma c in
+ Evar.Set.union evs acc
+ in
+ NamedDecl.fold_constr fold decl accu
+| Some cache ->
+ let id = NamedDecl.get_id decl in
+ let r =
+ try Id.Map.find id cache.cache
+ with Not_found ->
+ (** Dummy value *)
+ let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in
+ let () = cache.cache <- Id.Map.add id r cache.cache in
+ r
+ in
+ let (decl', evs) = !r in
+ let evs =
+ if NamedDecl.equal (==) decl decl' then snd !r
+ else
+ let fold c acc =
+ let evs = undefined_evars_of_term sigma c in
+ Evar.Set.union evs acc
+ in
+ let evs = NamedDecl.fold_constr fold decl Evar.Set.empty in
+ let () = r := (decl, evs) in
+ evs
+ in
+ Evar.Set.fold Evar.Set.add evs accu
+
+let filtered_undefined_evars_of_evar_info ?cache sigma evi =
+ let evars_of_named_context cache accu nc =
+ let fold decl accu = cached_evar_of_hyp cache sigma (EConstr.of_named_decl decl) accu in
+ Context.Named.fold_outside fold nc ~init:accu
+ in
+ let accu = match evi.evar_body with
+ | Evar_empty -> Evar.Set.empty
+ | Evar_defined b -> evars_of_term b
+ in
+ let accu = Evar.Set.union (undefined_evars_of_term sigma (EConstr.of_constr evi.evar_concl)) accu in
+ evars_of_named_context cache accu (evar_filtered_context evi)
+
(* spiwack: this is a more complete version of
{!Termops.occur_evar}. The latter does not look recursively into an
[evar_map]. If unification only need to check superficially, tactics
diff --git a/engine/evarutil.mli b/engine/evarutil.mli
index 5fd4634d67..923bf49a9c 100644
--- a/engine/evarutil.mli
+++ b/engine/evarutil.mli
@@ -133,6 +133,12 @@ val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t
val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t
val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t
+type undefined_evars_cache
+
+val create_undefined_evars_cache : unit -> undefined_evars_cache
+
+val filtered_undefined_evars_of_evar_info : ?cache:undefined_evars_cache -> evar_map -> evar_info -> Evar.Set.t
+
(** [occur_evar_upto sigma k c] returns [true] if [k] appears in
[c]. It looks up recursively in [sigma] for the value of existential
variables. *)
@@ -216,14 +222,13 @@ val empty_csubst : csubst
val csubst_subst : csubst -> constr -> constr
type ext_named_context =
- csubst * (Id.t * constr) list *
- Id.Set.t * named_context
+ csubst * Id.Set.t * named_context
val push_rel_decl_to_named_context :
evar_map -> rel_declaration -> ext_named_context -> ext_named_context
val push_rel_context_to_named_context : Environ.env -> evar_map -> types ->
- named_context_val * types * constr list * csubst * (Id.t*constr) list
+ named_context_val * types * constr list * csubst
val generalize_evar_over_rels : evar_map -> existential -> types * constr list
@@ -236,7 +241,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..0e94721589 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
@@ -856,7 +855,7 @@ let normalize_universe evd =
let normalize_universe_instance evd l =
let vars = ref (UState.subst evd.universes) in
- let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
+ let normalize = Universes.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
Univ.Instance.subst_fn normalize l
let normalize_sort evars s =
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/ftactic.mli b/engine/ftactic.mli
index c108c0c2ea..65ee929c8c 100644
--- a/engine/ftactic.mli
+++ b/engine/ftactic.mli
@@ -39,10 +39,10 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic
(** {5 Focussing} *)
-val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t
+val nf_enter : (Proofview.Goal.t -> 'a t) -> 'a t
(** Enter a goal. The resulting tactic is focussed. *)
-val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t
+val enter : (Proofview.Goal.t -> 'a t) -> 'a t
(** Enter a goal, without evar normalization. The resulting tactic is
focussed. *)
diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml
index 9dc5d473b9..3674bb9432 100644
--- a/engine/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -107,7 +107,6 @@ struct
let print_debug s = make (fun _ -> Feedback.msg_info s)
let print_info s = make (fun _ -> Feedback.msg_info s)
let print_warning s = make (fun _ -> Feedback.msg_warning s)
- let print_error s = make (fun _ -> Feedback.msg_error s)
let print_notice s = make (fun _ -> Feedback.msg_notice s)
let run = fun x ->
diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli
index 8c8f9fe935..50b4abd8bd 100644
--- a/engine/logic_monad.mli
+++ b/engine/logic_monad.mli
@@ -61,7 +61,6 @@ module NonLogical : sig
val print_warning : Pp.t -> unit t
val print_notice : Pp.t -> unit t
val print_info : Pp.t -> unit t
- val print_error : Pp.t -> unit t
(** [Pervasives.raise]. Except that exceptions are wrapped with
{!Exception}. *)
diff --git a/engine/proofview.ml b/engine/proofview.ml
index 3b945c87f9..c41b0b0dc5 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -634,32 +634,42 @@ let shelve_goals l =
InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >>
Shelf.modify (fun gls -> gls @ l)
-(** [contained_in_info e evi] checks whether the evar [e] appears in
- the hypotheses, the conclusion or the body of the evar_info
- [evi]. Note: since we want to use it on goals, the body is actually
- supposed to be empty. *)
-let contained_in_info sigma e evi =
- Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi))
-
(** [depends_on sigma src tgt] checks whether the goal [src] appears
as an existential variable in the definition of the goal [tgt] in
[sigma]. *)
let depends_on sigma src tgt =
let evi = Evd.find sigma tgt in
- contained_in_info sigma src evi
+ Evar.Set.mem src (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi))
+
+let unifiable_delayed g l =
+ CList.exists (fun (tgt, lazy evs) -> not (Evar.equal g tgt) && Evar.Set.mem g evs) l
+
+let free_evars sigma l =
+ let cache = Evarutil.create_undefined_evars_cache () in
+ let map ev =
+ (** Computes the set of evars appearing in the hypotheses, the conclusion or
+ the body of the evar_info [evi]. Note: since we want to use it on goals,
+ the body is actually supposed to be empty. *)
+ let evi = Evd.find sigma ev in
+ let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in
+ (ev, fevs)
+ in
+ List.map map l
(** [unifiable sigma g l] checks whether [g] appears in another
subgoal of [l]. The list [l] may contain [g], but it does not
affect the result. *)
let unifiable sigma g l =
- CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l
+ let l = free_evars sigma l in
+ unifiable_delayed g l
(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)]
where [u] is composed of the unifiable goals, i.e. the goals on
whose definition other goals of [l] depend, and [n] are the
non-unifiable goals. *)
let partition_unifiable sigma l =
- CList.partition (fun g -> unifiable sigma g l) l
+ let fevs = free_evars sigma l in
+ CList.partition (fun g -> unifiable_delayed g fevs) l
(** Shelves the unifiable goals under focus, i.e. the goals which
appear in other goals under focus (the unfocused goals are not
@@ -1013,14 +1023,14 @@ let catchable_exception = function
module Goal = struct
- type 'a t = {
+ type t = {
env : Environ.env;
sigma : Evd.evar_map;
concl : EConstr.constr ;
self : Evar.t ; (* for compatibility with old-style definitions *)
}
- let assume (gl : 'a t) = (gl :> [ `NF ] t)
+ let assume (gl : t) = (gl : t)
let env {env} = env
let sigma {sigma} = sigma
@@ -1076,7 +1086,7 @@ module Goal = struct
end
end
- let enter_one f =
+ let enter_one ?(__LOC__=__LOC__) f =
let open Proof in
Comb.get >>= function
| [goal] -> begin
@@ -1087,7 +1097,8 @@ module Goal = struct
let (e, info) = CErrors.push e in
tclZERO ~info e
end
- | _ -> assert false (* unsatisfied not-exactly-one-goal precondition *)
+ | _ ->
+ CErrors.anomaly Pp.(str __LOC__ ++ str " enter_one")
let goals =
Pv.get >>= fun step ->
diff --git a/engine/proofview.mli b/engine/proofview.mli
index 59728a2fd1..721ce507d4 100644
--- a/engine/proofview.mli
+++ b/engine/proofview.mli
@@ -461,56 +461,49 @@ end
module Goal : sig
- (** Type of goals.
-
- The first parameter type is a phantom argument indicating whether the data
- contained in the goal has been normalized w.r.t. the current sigma. If it
- is the case, it is flagged [ `NF ]. You may still access the un-normalized
- data using {!assume} if you known you do not rely on the assumption of
- being normalized, at your own risk.
-
- *)
- type 'a t
+ (** Type of goals. *)
+ type t
(** Assume that you do not need the goal to be normalized. *)
- val assume : 'a t -> [ `NF ] t
+ val assume : t -> t
+ [@@ocaml.deprecated "Normalization is enforced by EConstr, [assume] is not needed anymore"]
(** Normalises the argument goal. *)
- val normalize : 'a t -> [ `NF ] t tactic
+ val normalize : t -> t tactic
(** [concl], [hyps], [env] and [sigma] given a goal [gl] return
respectively the conclusion of [gl], the hypotheses of [gl], the
environment of [gl] (i.e. the global environment and the
hypotheses) and the current evar map. *)
- val concl : 'a t -> constr
- val hyps : 'a t -> named_context
- val env : 'a t -> Environ.env
- val sigma : 'a t -> Evd.evar_map
- val extra : 'a t -> Evd.Store.t
+ val concl : t -> constr
+ val hyps : t -> named_context
+ val env : t -> Environ.env
+ val sigma : t -> Evd.evar_map
+ val extra : t -> Evd.Store.t
(** [nf_enter t] applies the goal-dependent tactic [t] in each goal
independently, in the manner of {!tclINDEPENDENT} except that
the current goal is also given as an argument to [t]. The goal
is normalised with respect to evars. *)
- val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic
+ val nf_enter : (t -> unit tactic) -> unit tactic
(** Like {!nf_enter}, but does not normalize the goal beforehand. *)
- val enter : ([ `LZ ] t -> unit tactic) -> unit tactic
+ val enter : (t -> unit tactic) -> unit tactic
(** Like {!enter}, but assumes exactly one goal under focus, raising *)
(** a fatal error otherwise. *)
- val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic
+ val enter_one : ?__LOC__:string -> (t -> 'a tactic) -> 'a tactic
(** Recover the list of current goals under focus, without evar-normalization.
FIXME: encapsulate the level in an existential type. *)
- val goals : [ `LZ ] t tactic list tactic
+ val goals : t tactic list tactic
(** [unsolved g] is [true] if [g] is still unsolved in the current
proof state. *)
- val unsolved : 'a t -> bool tactic
+ val unsolved : t -> bool tactic
(** Compatibility: avoid if possible *)
- val goal : [ `NF ] t -> Evar.t
+ val goal : t -> Evar.t
end
diff --git a/engine/termops.ml b/engine/termops.ml
index 07fe902220..40b3d0d8b6 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
@@ -1462,6 +1463,18 @@ let prod_applist sigma c l =
| _ -> anomaly (Pp.str "Not enough prod's.") in
app [] c l
+let prod_applist_assum sigma n c l =
+ let open EConstr in
+ let rec app n subst c l =
+ if Int.equal n 0 then
+ if l == [] then Vars.substl subst c
+ else anomaly (Pp.str "Not enough arguments.")
+ else match EConstr.kind sigma c, l with
+ | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l
+ | LetIn(_,b,_,c), _ -> app (n-1) (Vars.substl subst b::subst) c l
+ | _ -> anomaly (Pp.str "Not enough prod/let's.") in
+ app n [] c l
+
(* Combinators on judgments *)
let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
diff --git a/engine/termops.mli b/engine/termops.mli
index c9a530076c..a3559a693b 100644
--- a/engine/termops.mli
+++ b/engine/termops.mli
@@ -159,8 +159,18 @@ val eta_reduce_head : Evd.evar_map -> constr -> constr
(** Flattens application lists *)
val collapse_appl : Evd.evar_map -> constr -> constr
+(** [prod_applist] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *)
val prod_applist : Evd.evar_map -> constr -> constr list -> constr
+(** In [prod_applist_assum n c args], [c] is supposed to have the
+ form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it
+ returns [c] with the assumptions of [Γ] instantiated by [args] and
+ the local definitions of [Γ] expanded.
+ Note that [n] counts both let-ins and prods, while the length of [args]
+ only counts prods. In other words, varying [n] changes how many
+ trailing let-ins are expanded. *)
+val prod_applist_assum : Evd.evar_map -> int -> constr -> constr list -> constr
+
(** Remove recursively the casts around a term i.e.
[strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
val strip_outer_cast : Evd.evar_map -> constr -> constr
@@ -271,6 +281,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..4b650c9c94 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
@@ -197,14 +201,18 @@ let process_universe_constraints ctx cstrs =
| None -> user_err Pp.(str "Algebraic universe on the right")
| Some r' ->
if Univ.Level.is_small r' then
- let levels = Univ.Universe.levels l in
- let fold l' local =
- let l = Univ.Universe.make l' in
- if Univ.Level.is_small l' || is_local l' then
- equalize_variables false l l' r r' local
- else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None))
- in
- Univ.LSet.fold fold levels local
+ if not (Univ.Universe.is_levels l)
+ then
+ raise (Univ.UniverseInconsistency (Univ.Le, l, r, None))
+ else
+ let levels = Univ.Universe.levels l in
+ let fold l' local =
+ let l = Univ.Universe.make l' in
+ if Univ.Level.is_small l' || is_local l' then
+ equalize_variables false l l' r r' local
+ else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None))
+ in
+ Univ.LSet.fold fold levels local
else
Univ.enforce_leq l r local
end
@@ -236,8 +244,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 +271,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 +373,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 +449,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
@@ -501,7 +520,7 @@ let is_sort_variable uctx s =
| _ -> None
let subst_univs_context_with_def def usubst (ctx, cst) =
- (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
+ (Univ.LSet.diff ctx def, Universes.subst_univs_constraints usubst cst)
let normalize_variables uctx =
let normalized_variables, undef, def, subst =
@@ -550,7 +569,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 +587,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..3a00f0fd1d 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))
@@ -152,6 +181,30 @@ let enforce_eq_instances_univs strict x y c =
(fun x y -> Constraints.add (Universe.make x, d, Universe.make y))
ax ay c
+let enforce_univ_constraint (u,d,v) =
+ match d with
+ | Eq -> enforce_eq u v
+ | Le -> enforce_leq u v
+ | Lt -> enforce_leq (super u) v
+
+let subst_univs_level fn l =
+ try Some (fn l)
+ with Not_found -> None
+
+let subst_univs_constraint fn (u,d,v as c) cstrs =
+ let u' = subst_univs_level fn u in
+ let v' = subst_univs_level fn v in
+ match u', v' with
+ | None, None -> Constraint.add c cstrs
+ | Some u, None -> enforce_univ_constraint (u,d,Universe.make v) cstrs
+ | None, Some v -> enforce_univ_constraint (Universe.make u,d,v) cstrs
+ | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs
+
+let subst_univs_constraints subst csts =
+ Constraint.fold
+ (fun c cstrs -> subst_univs_constraint subst c cstrs)
+ csts Constraint.empty
+
let subst_univs_universe_constraint fn (u,d,v) =
let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in
if Universe.equal u' v' then None
@@ -236,14 +289,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 +307,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 +318,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 +515,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
@@ -487,13 +543,60 @@ let choose_canonical ctx flexible algs s =
let canon = LSet.choose algs in
canon, (global, rigid, LSet.remove canon flexible)
+let level_subst_of f =
+ fun l ->
+ try let u = f l in
+ match Universe.level u with
+ | None -> l
+ | Some l -> l
+ with Not_found -> l
+
+let subst_univs_fn_constr f c =
+ let changed = ref false in
+ let fu = Univ.subst_univs_universe f in
+ let fi = Univ.Instance.subst_fn (level_subst_of f) in
+ let rec aux t =
+ match kind t with
+ | Sort (Sorts.Type u) ->
+ let u' = fu u in
+ if u' == u then t else
+ (changed := true; mkSort (Sorts.sort_of_univ u'))
+ | Const (c, u) ->
+ let u' = fi u in
+ if u' == u then t
+ else (changed := true; mkConstU (c, u'))
+ | Ind (i, u) ->
+ let u' = fi u in
+ if u' == u then t
+ else (changed := true; mkIndU (i, u'))
+ | Construct (c, u) ->
+ let u' = fi u in
+ if u' == u then t
+ else (changed := true; mkConstructU (c, u'))
+ | _ -> map aux t
+ in
+ let c' = aux c in
+ if !changed then c' else c
+
+let subst_univs_constr subst c =
+ if Univ.is_empty_subst subst then c
+ else
+ let f = Univ.make_subst subst in
+ subst_univs_fn_constr f c
+
+let subst_univs_constr =
+ if Flags.profile then
+ let subst_univs_constr_key = CProfile.declare_profile "subst_univs_constr" in
+ CProfile.profile2 subst_univs_constr_key subst_univs_constr
+ else subst_univs_constr
+
let subst_univs_fn_puniverses lsubst (c, u as cu) =
let u' = Instance.subst_fn lsubst u in
if u' == u then cu else (c, u')
let nf_evars_and_universes_opt_subst f subst =
let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in
- let lsubst = Univ.level_subst_of subst in
+ let lsubst = level_subst_of subst in
let rec aux c =
match kind c with
| Evar (evk, args) ->
@@ -552,7 +655,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 =
@@ -573,7 +676,7 @@ let normalize_opt_subst ctx =
in !ectx
type universe_opt_subst = Universe.t option universe_map
-
+
let make_opt_subst s =
fun x ->
(match Univ.LMap.find x s with
@@ -582,8 +685,7 @@ let make_opt_subst s =
let subst_opt_univs_constr s =
let f = make_opt_subst s in
- Vars.subst_univs_fn_constr f
-
+ subst_univs_fn_constr f
let normalize_univ_variables ctx =
let ctx = normalize_opt_subst ctx in
@@ -914,8 +1016,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))
@@ -1001,14 +1103,3 @@ let solve_constraints_system levels level_bounds level_min =
done;
done;
v
-
-
-(** Operations for universe_info_ind *)
-
-(** Given a universe context representing constraints of an inductive
- this function produces a UInfoInd.t that with the trivial subtyping relation. *)
-let univ_inf_ind_from_universe_context univcst =
- let freshunivs = Instance.of_array
- (Array.map (fun _ -> new_univ_level ())
- (Instance.to_array (UContext.instance univcst)))
- in CumulativityInfo.from_universe_context univcst freshunivs
diff --git a/engine/universes.mli b/engine/universes.mli
index 1401c4ee8d..cb6e2ba1b6 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
@@ -142,6 +154,11 @@ val extend_context : 'a in_universe_context_set -> ContextSet.t ->
module UF : Unionfind.PartitionSig with type elt = Level.t
+val level_subst_of : universe_subst_fn -> universe_level_subst_fn
+val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t
+
+val subst_univs_constr : universe_subst -> constr -> constr
+
type universe_opt_subst = Universe.t option universe_map
val make_opt_subst : universe_opt_subst -> universe_subst_fn
@@ -204,9 +221,3 @@ val pr_universe_opt_subst : universe_opt_subst -> Pp.t
val solve_constraints_system : Universe.t option array -> Universe.t array -> Universe.t array ->
Universe.t array
-
-(** Operations for universe_info_ind *)
-
-(** Given a universe context representing constraints of an inductive
- this function produces a UInfoInd.t that with the trivial subtyping relation. *)
-val univ_inf_ind_from_universe_context : UContext.t -> CumulativityInfo.t
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-05-04 05:32:59 +0000