aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/cClosure.ml36
-rw-r--r--kernel/cooking.ml54
-rw-r--r--kernel/csymtable.ml2
-rw-r--r--kernel/declarations.ml1
-rw-r--r--kernel/declareops.ml3
-rw-r--r--kernel/declareops.mli2
-rw-r--r--kernel/environ.ml31
-rw-r--r--kernel/indtypes.ml8
-rw-r--r--kernel/mod_typing.ml4
-rw-r--r--kernel/names.mli9
-rw-r--r--kernel/nativecode.ml6
-rw-r--r--kernel/nativelambda.ml2
-rw-r--r--kernel/opaqueproof.ml2
-rw-r--r--kernel/opaqueproof.mli2
-rw-r--r--kernel/pre_env.ml52
-rw-r--r--kernel/pre_env.mli16
-rw-r--r--kernel/term_typing.ml29
-rw-r--r--kernel/univ.ml34
-rw-r--r--kernel/univ.mli13
-rw-r--r--kernel/vars.ml43
-rw-r--r--kernel/vars.mli6
21 files changed, 159 insertions, 196 deletions
diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml
index 11616da7b3..b1181157e1 100644
--- a/kernel/cClosure.ml
+++ b/kernel/cClosure.ml
@@ -258,7 +258,7 @@ type 'a infos_cache = {
i_repr : 'a infos -> constr -> 'a;
i_env : env;
i_sigma : existential -> constr option;
- i_rels : constr option array;
+ i_rels : (Context.Rel.Declaration.t * Pre_env.lazy_val) Range.t;
i_tab : 'a KeyTable.t }
and 'a infos = {
@@ -282,13 +282,16 @@ let ref_value_cache ({i_cache = cache} as infos) ref =
let body =
match ref with
| RelKey n ->
- let len = Array.length cache.i_rels in
- let i = n - 1 in
- let () = if i < 0 || len <= i then raise Not_found in
- begin match Array.unsafe_get cache.i_rels i with
- | None -> raise Not_found
- | Some t -> lift n t
- end
+ let open Context.Rel.Declaration in
+ let i = n - 1 in
+ let (d, _) =
+ try Range.get cache.i_rels i
+ with Invalid_argument _ -> raise Not_found
+ in
+ begin match d with
+ | LocalAssum _ -> raise Not_found
+ | LocalDef (_, t, _) -> lift n t
+ end
| VarKey id -> assoc_defined id cache.i_env
| ConstKey cst -> constant_value_in cache.i_env cst
in
@@ -303,26 +306,13 @@ let ref_value_cache ({i_cache = cache} as infos) ref =
let evar_value cache ev =
cache.i_sigma ev
-let defined_rels flags env =
-(* if red_local_const (snd flags) then*)
- let ctx = rel_context env in
- let len = List.length ctx in
- let ans = Array.make len None in
- let open Context.Rel.Declaration in
- let iter i = function
- | LocalAssum _ -> ()
- | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b)
- in
- let () = List.iteri iter ctx in
- ans
-(* else (0,[])*)
-
let create mk_cl flgs env evars =
+ let open Pre_env in
let cache =
{ i_repr = mk_cl;
i_env = env;
i_sigma = evars;
- i_rels = defined_rels flgs env;
+ i_rels = (Environ.pre_env env).env_rel_context.env_rel_map;
i_tab = KeyTable.create 17 }
in { i_flags = flgs; i_cache = cache }
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 7b921d35be..23a578d993 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -168,38 +168,47 @@ let on_body ml hy f = function
{ Opaqueproof.modlist = ml; abstract = hy } o)
let expmod_constr_subst cache modlist subst c =
+ let subst = Univ.make_instance_subst subst in
let c = expmod_constr cache modlist c in
Vars.subst_univs_level_constr subst c
-let cook_constr { Opaqueproof.modlist ; abstract } c =
+let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c =
let cache = RefTable.create 13 in
- let expmod = expmod_constr_subst cache modlist (pi2 abstract) in
- let hyps = Context.Named.map expmod (pi1 abstract) in
+ let expmod = expmod_constr_subst cache modlist subst in
+ let hyps = Context.Named.map expmod vars in
abstract_constant_body (expmod c) hyps
-let lift_univs cb subst =
+let lift_univs cb subst auctx0 =
match cb.const_universes with
- | Monomorphic_const ctx -> subst, (Monomorphic_const ctx)
- | Polymorphic_const auctx ->
- if (Univ.LMap.is_empty subst) then
- subst, (Polymorphic_const auctx)
+ | Monomorphic_const ctx ->
+ assert (AUContext.is_empty auctx0);
+ subst, (Monomorphic_const ctx)
+ | Polymorphic_const auctx ->
+ (** Given a named instance [subst := u₀ ... uₙ₋₁] together with an abstract
+ context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length,
+ and another abstract context relative to the former context
+ [auctx := 0 ... m - 1 |= C'{u₀, ..., uₙ₋₁, 0, ..., m - 1}],
+ construct the lifted abstract universe context
+ [0 ... n - 1 n ... n + m - 1 |=
+ C{0, ... n - 1} ∪
+ C'{0, ..., n - 1, n, ..., n + m - 1} ]
+ together with the instance
+ [u₀ ... uₙ₋₁ Var(0) ... Var (m - 1)].
+ *)
+ if (Univ.Instance.is_empty subst) then
+ (** Still need to take the union for the constraints between globals *)
+ subst, (Polymorphic_const (AUContext.union auctx0 auctx))
else
- let len = Univ.LMap.cardinal subst in
- let rec gen_subst i acc =
- if i < 0 then acc
- else
- let acc = Univ.LMap.add (Level.var i) (Level.var (i + len)) acc in
- gen_subst (pred i) acc
- in
- let subst = gen_subst (Univ.AUContext.size auctx - 1) subst in
- let auctx' = Univ.subst_univs_level_abstract_universe_context subst auctx in
- subst, (Polymorphic_const auctx')
+ let ainst = Univ.make_abstract_instance auctx in
+ let subst = Instance.append subst ainst in
+ let auctx' = Univ.subst_univs_level_abstract_universe_context (Univ.make_instance_subst subst) auctx in
+ subst, (Polymorphic_const (AUContext.union auctx0 auctx'))
let cook_constant ~hcons env { from = cb; info } =
let { Opaqueproof.modlist; abstract } = info in
let cache = RefTable.create 13 in
let abstract, usubst, abs_ctx = abstract in
- let usubst, univs = lift_univs cb usubst in
+ let usubst, univs = lift_univs cb usubst abs_ctx in
let expmod = expmod_constr_subst cache modlist usubst in
let hyps = Context.Named.map expmod abstract in
let map c =
@@ -234,13 +243,6 @@ let cook_constant ~hcons env { from = cb; info } =
proj_eta = etab, etat;
proj_type = ty'; proj_body = c' }
in
- let univs =
- match univs with
- | Monomorphic_const ctx ->
- assert (AUContext.is_empty abs_ctx); univs
- | Polymorphic_const auctx ->
- Polymorphic_const (AUContext.union abs_ctx auctx)
- in
{
cook_body = body;
cook_type = typ;
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 2ffe36fcf7..712c66f11d 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -198,7 +198,7 @@ and slot_for_fv env fv =
let rv = Pre_env.lookup_rel_val i env in
begin match force_lazy_val rv with
| None ->
- env.env_rel_context |> Context.Rel.lookup i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel
+ env |> Pre_env.lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel
| Some (v, _) -> v
end
| FVuniv_var idu ->
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index 7f4b85fd05..5b9e1a1414 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -74,6 +74,7 @@ type typing_flags = {
check_guarded : bool; (** If [false] then fixed points and co-fixed
points are assumed to be total. *)
check_universes : bool; (** If [false] universe constraints are not checked *)
+ conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *)
}
(* some contraints are in constant_constraints, some other may be in
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
index d8768a0fc5..9eed9efcbd 100644
--- a/kernel/declareops.ml
+++ b/kernel/declareops.ml
@@ -15,9 +15,10 @@ module RelDecl = Context.Rel.Declaration
(** Operations concernings types in [Declarations] :
[constant_body], [mutual_inductive_body], [module_body] ... *)
-let safe_flags = {
+let safe_flags oracle = {
check_guarded = true;
check_universes = true;
+ conv_oracle = oracle;
}
(** {6 Arities } *)
diff --git a/kernel/declareops.mli b/kernel/declareops.mli
index 198831848e..0eed11f49c 100644
--- a/kernel/declareops.mli
+++ b/kernel/declareops.mli
@@ -67,7 +67,7 @@ val inductive_is_cumulative : mutual_inductive_body -> bool
(** {6 Kernel flags} *)
(** A default, safe set of flags for kernel type-checking *)
-val safe_flags : typing_flags
+val safe_flags : Conv_oracle.oracle -> typing_flags
(** {6 Hash-consing} *)
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 1afab453ac..93dc2f9a72 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -37,8 +37,10 @@ type env = Pre_env.env
let pre_env env = env
let env_of_pre_env env = env
-let oracle env = env.env_conv_oracle
-let set_oracle env o = { env with env_conv_oracle = o }
+let oracle env = env.env_typing_flags.conv_oracle
+let set_oracle env o =
+ let env_typing_flags = { env.env_typing_flags with conv_oracle = o } in
+ { env with env_typing_flags }
let empty_named_context_val = empty_named_context_val
@@ -58,18 +60,17 @@ let deactivated_guard env = not (typing_flags env).check_guarded
let universes env = env.env_stratification.env_universes
let named_context env = env.env_named_context.env_named_ctx
let named_context_val env = env.env_named_context
-let rel_context env = env.env_rel_context
+let rel_context env = env.env_rel_context.env_rel_ctx
let opaque_tables env = env.indirect_pterms
let set_opaque_tables env indirect_pterms = { env with indirect_pterms }
let empty_context env =
- match env.env_rel_context, env.env_named_context.env_named_ctx with
+ match env.env_rel_context.env_rel_ctx, env.env_named_context.env_named_ctx with
| [], [] -> true
| _ -> false
(* Rel context *)
-let lookup_rel n env =
- Context.Rel.lookup n env.env_rel_context
+let lookup_rel = lookup_rel
let evaluable_rel n env =
is_local_def (lookup_rel n env)
@@ -86,13 +87,12 @@ let push_rec_types (lna,typarray,_) env =
let fold_rel_context f env ~init =
let rec fold_right env =
- match env.env_rel_context with
- | [] -> init
- | rd::rc ->
+ match match_rel_context_val env.env_rel_context with
+ | None -> init
+ | Some (rd, _, rc) ->
let env =
{ env with
env_rel_context = rc;
- env_rel_val = List.tl env.env_rel_val;
env_nb_rel = env.env_nb_rel - 1 } in
f env rd (fold_right env)
in fold_right env
@@ -142,16 +142,21 @@ let evaluable_named id env =
let reset_with_named_context ctxt env =
{ env with
env_named_context = ctxt;
- env_rel_context = Context.Rel.empty;
- env_rel_val = [];
+ env_rel_context = empty_rel_context_val;
env_nb_rel = 0 }
let reset_context = reset_with_named_context empty_named_context_val
let pop_rel_context n env =
+ let rec skip n ctx =
+ if Int.equal n 0 then ctx
+ else match match_rel_context_val ctx with
+ | None -> invalid_arg "List.skipn"
+ | Some (_, _, ctx) -> skip (pred n) ctx
+ in
let ctxt = env.env_rel_context in
{ env with
- env_rel_context = List.skipn n ctxt;
+ env_rel_context = skip n ctxt;
env_nb_rel = env.env_nb_rel - n }
let fold_named_context f env ~init =
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 1f2ae0b6cc..b117f8714b 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -879,9 +879,13 @@ let abstract_inductive_universes iu =
match iu with
| Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx)
| Polymorphic_ind_entry ctx ->
- let (inst, auctx) = Univ.abstract_universes ctx in (inst, Polymorphic_ind auctx)
+ let (inst, auctx) = Univ.abstract_universes ctx in
+ let inst = Univ.make_instance_subst inst in
+ (inst, Polymorphic_ind auctx)
| Cumulative_ind_entry cumi ->
- let (inst, acumi) = Univ.abstract_cumulativity_info cumi in (inst, Cumulative_ind acumi)
+ let (inst, acumi) = Univ.abstract_cumulativity_info cumi in
+ let inst = Univ.make_instance_subst inst in
+ (inst, Cumulative_ind acumi)
let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr recargs =
let ntypes = Array.length inds in
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index f7e755f005..b7eb481ee3 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -94,8 +94,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv =
let ctx = Univ.ContextSet.of_context ctx in
c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst ctx
| Polymorphic_const uctx ->
- let subst, ctx = Univ.abstract_universes ctx in
- let c = Vars.subst_univs_level_constr subst c in
+ let inst, ctx = Univ.abstract_universes ctx in
+ let c = Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in
let () =
if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then
error_incorrect_with_constraint lab
diff --git a/kernel/names.mli b/kernel/names.mli
index 709ebeb7fd..b1e8efd8d1 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -40,19 +40,16 @@ sig
(** Hash over identifiers. *)
val is_valid : string -> bool
- (** Check that a string may be converted to an identifier.
- @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
+ (** Check that a string may be converted to an identifier. *)
val of_bytes : bytes -> t
val of_string : string -> t
(** Converts a string into an identifier.
- @raise UserError if the string is invalid as an identifier.
- @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
+ @raise UserError if the string is invalid as an identifier. *)
val of_string_soft : string -> t
(** Same as {!of_string} except that any string made of supported UTF-8 characters is accepted.
- @raise UserError if the string is invalid as an UTF-8 string.
- @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
+ @raise UserError if the string is invalid as an UTF-8 string. *)
val to_string : t -> string
(** Converts a identifier into an string. *)
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index c558e9ed03..ffe19510a6 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -1830,7 +1830,7 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
in
let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in
let auxdefs = List.fold_right get_named_val fv_named auxdefs in
- let lvl = Context.Rel.length env.env_rel_context in
+ let lvl = Context.Rel.length env.env_rel_context.env_rel_ctx in
let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in
let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in
let aux_name = fresh_lname Anonymous in
@@ -1838,8 +1838,8 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
and compile_rel env sigma univ auxdefs n =
let open Context.Rel.Declaration in
- let decl = Context.Rel.lookup n env.env_rel_context in
- let n = Context.Rel.length env.env_rel_context - n in
+ let decl = Pre_env.lookup_rel n env in
+ let n = List.length env.env_rel_context.env_rel_ctx - n in
match decl with
| LocalDef (_,t,_) ->
let code = lambda_of_constr env sigma t in
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
index 160a90dc2f..b333b0fb9c 100644
--- a/kernel/nativelambda.ml
+++ b/kernel/nativelambda.ml
@@ -639,7 +639,7 @@ let optimize lam =
let lambda_of_constr env sigma c =
set_global_env env;
let env = Renv.make () in
- let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context in
+ let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context.env_rel_ctx in
Renv.push_rels env (Array.of_list ids);
let lam = lambda_of_constr env sigma c in
(* if Flags.vm_draw_opt () then begin
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
index 45a62d55a1..c2fcfbfd6a 100644
--- a/kernel/opaqueproof.ml
+++ b/kernel/opaqueproof.ml
@@ -16,7 +16,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t *
type cooking_info = {
modlist : work_list;
- abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t }
+ abstract : Context.Named.t * Univ.Instance.t * Univ.AUContext.t }
type proofterm = (constr * Univ.ContextSet.t) Future.computation
type opaque =
| Indirect of substitution list * DirPath.t * int (* subst, lib, index *)
diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli
index 20d76ce238..c8339e6eb3 100644
--- a/kernel/opaqueproof.mli
+++ b/kernel/opaqueproof.mli
@@ -49,7 +49,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t *
type cooking_info = {
modlist : work_list;
- abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t }
+ abstract : Context.Named.t * Univ.Instance.t * Univ.AUContext.t }
(* The type has two caveats:
1) cook_constr is defined after
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index c5254b453a..3ef15105ae 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -67,15 +67,18 @@ type named_context_val = {
env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
}
+type rel_context_val = {
+ env_rel_ctx : Context.Rel.t;
+ env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t;
+}
+
type env = {
env_globals : globals; (* globals = constants + inductive types + modules + module-types *)
env_named_context : named_context_val; (* section variables *)
- env_rel_context : Context.Rel.t;
- env_rel_val : lazy_val list;
+ env_rel_context : rel_context_val;
env_nb_rel : int;
env_stratification : stratification;
env_typing_flags : typing_flags;
- env_conv_oracle : Conv_oracle.oracle;
retroknowledge : Retroknowledge.retroknowledge;
indirect_pterms : Opaqueproof.opaquetab;
}
@@ -85,6 +88,11 @@ let empty_named_context_val = {
env_named_map = Id.Map.empty;
}
+let empty_rel_context_val = {
+ env_rel_ctx = [];
+ env_rel_map = Range.empty;
+}
+
let empty_env = {
env_globals = {
env_constants = Cmap_env.empty;
@@ -92,14 +100,12 @@ let empty_env = {
env_modules = MPmap.empty;
env_modtypes = MPmap.empty};
env_named_context = empty_named_context_val;
- env_rel_context = Context.Rel.empty;
- env_rel_val = [];
+ env_rel_context = empty_rel_context_val;
env_nb_rel = 0;
env_stratification = {
env_universes = UGraph.initial_universes;
env_engagement = PredicativeSet };
- env_typing_flags = Declareops.safe_flags;
- env_conv_oracle = Conv_oracle.empty;
+ env_typing_flags = Declareops.safe_flags Conv_oracle.empty;
retroknowledge = Retroknowledge.initial_retroknowledge;
indirect_pterms = Opaqueproof.empty_opaquetab }
@@ -108,21 +114,39 @@ let empty_env = {
let nb_rel env = env.env_nb_rel
+let push_rel_context_val d ctx = {
+ env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx;
+ env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map;
+}
+
+let match_rel_context_val ctx = match ctx.env_rel_ctx with
+| [] -> None
+| decl :: rem ->
+ let (_, lval) = Range.hd ctx.env_rel_map in
+ let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in
+ Some (decl, lval, ctx)
+
let push_rel d env =
- let rval = ref VKnone in
{ env with
- env_rel_context = Context.Rel.add d env.env_rel_context;
- env_rel_val = rval :: env.env_rel_val;
+ env_rel_context = push_rel_context_val d env.env_rel_context;
env_nb_rel = env.env_nb_rel + 1 }
+let lookup_rel n env =
+ try fst (Range.get env.env_rel_context.env_rel_map (n - 1))
+ with Invalid_argument _ -> raise Not_found
+
let lookup_rel_val n env =
- try List.nth env.env_rel_val (n - 1)
- with Failure _ -> raise Not_found
+ try snd (Range.get env.env_rel_context.env_rel_map (n - 1))
+ with Invalid_argument _ -> raise Not_found
+
+let rel_skipn n ctx = {
+ env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx;
+ env_rel_map = Range.skipn n ctx.env_rel_map;
+}
let env_of_rel n env =
{ env with
- env_rel_context = Util.List.skipn n env.env_rel_context;
- env_rel_val = Util.List.skipn n env.env_rel_val;
+ env_rel_context = rel_skipn n env.env_rel_context;
env_nb_rel = env.env_nb_rel - n
}
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 054ae17437..335ca1057f 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -45,15 +45,18 @@ type named_context_val = private {
env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
}
+type rel_context_val = private {
+ env_rel_ctx : Context.Rel.t;
+ env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t;
+}
+
type env = {
env_globals : globals;
env_named_context : named_context_val;
- env_rel_context : Context.Rel.t;
- env_rel_val : lazy_val list;
+ env_rel_context : rel_context_val;
env_nb_rel : int;
env_stratification : stratification;
env_typing_flags : typing_flags;
- env_conv_oracle : Conv_oracle.oracle;
retroknowledge : Retroknowledge.retroknowledge;
indirect_pterms : Opaqueproof.opaquetab;
}
@@ -64,8 +67,15 @@ val empty_env : env
(** Rel context *)
+val empty_rel_context_val : rel_context_val
+val push_rel_context_val :
+ Context.Rel.Declaration.t -> rel_context_val -> rel_context_val
+val match_rel_context_val :
+ rel_context_val -> (Context.Rel.Declaration.t * lazy_val * rel_context_val) option
+
val nb_rel : env -> int
val push_rel : Context.Rel.Declaration.t -> env -> env
+val lookup_rel : int -> env -> Context.Rel.Declaration.t
val lookup_rel_val : int -> env -> lazy_val
val env_of_rel : int -> env -> env
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 2e4426d621..5f501bff10 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -232,6 +232,7 @@ let abstract_constant_universes = function
Univ.empty_level_subst, Monomorphic_const uctx
| Polymorphic_const_entry uctx ->
let sbst, auctx = Univ.abstract_universes uctx in
+ let sbst = Univ.make_instance_subst sbst in
sbst, Polymorphic_const auctx
let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
@@ -300,21 +301,29 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
let { const_entry_type = typ; const_entry_opaque = opaque } = c in
let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
let (body, ctx), side_eff = Future.join body in
- let poly, univsctx = match c.const_entry_universes with
- | Monomorphic_const_entry univs -> false, univs
- | Polymorphic_const_entry univs -> true, Univ.ContextSet.of_context univs
- in
- let ctx = Univ.ContextSet.union univsctx ctx in
let body, ctx, _ = match trust with
| Pure -> body, ctx, []
| SideEffects _ -> inline_side_effects env body ctx side_eff
in
- let env = push_context_set ~strict:(not poly) ctx env in
- let ctx = if poly
- then Polymorphic_const_entry (Univ.ContextSet.to_context ctx)
- else Monomorphic_const_entry ctx
+ let env, usubst, univs = match c.const_entry_universes with
+ | Monomorphic_const_entry univs ->
+ let ctx = Univ.ContextSet.union univs ctx in
+ let env = push_context_set ~strict:true ctx env in
+ env, Univ.empty_level_subst, Monomorphic_const ctx
+ | Polymorphic_const_entry uctx ->
+ (** Ensure not to generate internal constraints in polymorphic mode.
+ The only way for this to happen would be that either the body
+ contained deferred universes, or that it contains monomorphic
+ side-effects. The first property is ruled out by upper layers,
+ and the second one is ensured by the fact we currently
+ unconditionally export side-effects from polymorphic definitions,
+ i.e. [trust] is always [Pure]. *)
+ let () = assert (Univ.ContextSet.is_empty ctx) in
+ let env = push_context ~strict:false uctx env in
+ let sbst, auctx = Univ.abstract_universes uctx in
+ let sbst = Univ.make_instance_subst sbst in
+ env, sbst, Polymorphic_const auctx
in
- let usubst, univs = abstract_constant_universes ctx in
let j = infer env body in
let typ = match typ with
| None ->
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 8cf9028fb1..f72f6f26a9 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -686,12 +686,6 @@ let enforce_leq u v c =
let enforce_leq_level u v c =
if Level.equal u v then c else Constraint.add (u,Le,v) 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
-
(* Miscellaneous functions to remove or test local univ assumed to
occur in a universe *)
@@ -718,14 +712,6 @@ type universe_level_subst = universe_level universe_map
(** A full substitution might involve algebraic universes *)
type universe_subst = universe universe_map
-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
-
module Instance : sig
type t = Level.t array
@@ -1128,24 +1114,6 @@ let subst_univs_universe fn ul =
List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u))
substs nosubst
-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,make v) cstrs
- | None, Some v -> enforce_univ_constraint (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 make_instance_subst i =
let arr = Instance.to_array i in
Array.fold_left_i (fun i acc l ->
@@ -1168,7 +1136,7 @@ let abstract_universes ctx =
(UContext.constraints ctx)
in
let ctx = UContext.make (instance, cstrs) in
- subst, ctx
+ instance, ctx
let abstract_cumulativity_info (univcst, substcst) =
let instance, univcst = abstract_universes univcst in
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 4593944395..63bef1b81b 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -238,8 +238,6 @@ type universe_level_subst_fn = Level.t -> Level.t
type universe_subst = Universe.t universe_map
type universe_level_subst = Level.t universe_map
-val level_subst_of : universe_subst_fn -> universe_level_subst_fn
-
(** {6 Universe instances} *)
module Instance :
@@ -461,18 +459,21 @@ val is_empty_subst : universe_subst -> bool
val make_subst : universe_subst -> universe_subst_fn
val subst_univs_universe : universe_subst_fn -> Universe.t -> Universe.t
-val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t
+(** Only user in the kernel is template polymorphism. Ideally we get rid of
+ this code if it goes away. *)
(** Substitution of instances *)
val subst_instance_instance : Instance.t -> Instance.t -> Instance.t
val subst_instance_universe : Instance.t -> Universe.t -> Universe.t
val make_instance_subst : Instance.t -> universe_level_subst
-val make_inverse_instance_subst : Instance.t -> universe_level_subst
+(** Creates [u(0) ↦ 0; ...; u(n-1) ↦ n - 1] out of [u(0); ...; u(n - 1)] *)
-val abstract_universes : UContext.t -> universe_level_subst * AUContext.t
+val make_inverse_instance_subst : Instance.t -> universe_level_subst
-val abstract_cumulativity_info : CumulativityInfo.t -> universe_level_subst * ACumulativityInfo.t
+val abstract_universes : UContext.t -> Instance.t * AUContext.t
+val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativityInfo.t
+(** TODO: move universe abstraction out of the kernel *)
val make_abstract_instance : AUContext.t -> Instance.t
diff --git a/kernel/vars.ml b/kernel/vars.ml
index eae917b5a2..b3b3eff628 100644
--- a/kernel/vars.ml
+++ b/kernel/vars.ml
@@ -235,49 +235,6 @@ let subst_vars subst c = substn_vars 1 subst c
(** Universe substitutions *)
open Constr
-let subst_univs_fn_puniverses fn =
- let f = Univ.Instance.subst_fn fn in
- fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u')
-
-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 (Univ.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_level_constr subst c =
if Univ.is_empty_level_subst subst then c
else
diff --git a/kernel/vars.mli b/kernel/vars.mli
index 964de4e958..b74d25260f 100644
--- a/kernel/vars.mli
+++ b/kernel/vars.mli
@@ -129,12 +129,6 @@ val subst_var : Id.t -> constr -> constr
open Univ
-val subst_univs_fn_constr : universe_subst_fn -> constr -> constr
-val subst_univs_fn_puniverses : universe_level_subst_fn ->
- 'a puniverses -> 'a puniverses
-
-val subst_univs_constr : universe_subst -> constr -> constr
-
(** Level substitutions for polymorphism. *)
val subst_univs_level_constr : universe_level_subst -> constr -> constr
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 11:26:33 +0000