aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/byterun/coq_interp.c24
-rw-r--r--kernel/byterun/coq_values.c2
-rw-r--r--kernel/cooking.ml10
-rw-r--r--kernel/entries.ml2
-rw-r--r--kernel/environ.mli6
-rw-r--r--kernel/indTyping.ml77
-rw-r--r--kernel/inferCumulativity.ml24
-rw-r--r--kernel/inferCumulativity.mli4
-rw-r--r--kernel/kernel.mllib2
-rw-r--r--kernel/safe_typing.ml11
-rw-r--r--kernel/safe_typing.mli2
11 files changed, 58 insertions, 106 deletions
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index 754b977f89..606cce0127 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -17,6 +17,8 @@
#include <signal.h>
#include <stdint.h>
#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/version.h>
#include <math.h>
#include "coq_gc.h"
#include "coq_instruct.h"
@@ -203,11 +205,13 @@ if (sp - num_args < coq_stack_threshold) { \
*sp = swap_accu_sp_tmp__; \
}while(0)
+#if OCAML_VERSION < 41000
/* For signal handling, we hijack some code from the caml runtime */
extern intnat volatile caml_signals_are_pending;
extern intnat volatile caml_pending_signals[];
extern void caml_process_pending_signals(void);
+#endif
/* The interpreter itself */
@@ -506,11 +510,27 @@ value coq_interprete
print_instr("check_stack");
CHECK_STACK(0);
/* We also check for signals */
+#if OCAML_VERSION >= 41000
+ {
+ value res = caml_process_pending_actions_exn();
+ if (Is_exception_result(res)) {
+ /* If there is an asynchronous exception, we reset the vm */
+ coq_sp = coq_stack_high;
+ caml_raise(Extract_exception(res));
+ }
+ }
+#else
if (caml_signals_are_pending) {
/* If there's a Ctrl-C, we reset the vm */
- if (caml_pending_signals[SIGINT]) { coq_sp = coq_stack_high; }
+ intnat sigint = caml_pending_signals[SIGINT];
+ if (sigint) { coq_sp = coq_stack_high; }
caml_process_pending_signals();
+ if (sigint) {
+ caml_failwith("Coq VM: Fatal error: SIGINT signal detected "
+ "but no exception was raised");
+ }
}
+#endif
Next;
Instruct(ENSURESTACKCAPACITY) {
@@ -1743,7 +1763,7 @@ value coq_interprete
#ifndef THREADED_CODE
default:
/*fprintf(stderr, "%d\n", *pc);*/
- failwith("Coq VM: Fatal error: bad opcode");
+ caml_failwith("Coq VM: Fatal error: bad opcode");
}
}
#endif
diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c
index 3613bc07a6..bbe91da628 100644
--- a/kernel/byterun/coq_values.c
+++ b/kernel/byterun/coq_values.c
@@ -40,7 +40,7 @@ value coq_closure_arity(value clos) {
c++;
if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos));
else {
- if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity");
+ if (Wosize_val(clos) != 2) caml_failwith("Coq Values : coq_closure_arity");
return Val_int(1);
}
}
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 9d7387c7ad..261a3510d6 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -315,10 +315,6 @@ let refresh_polymorphic_type_of_inductive (_,mip) =
let ctx = List.rev mip.mind_arity_ctxt in
mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true
-let dummy_variance = let open Entries in function
- | Monomorphic_entry _ -> assert false
- | Polymorphic_entry (_,uctx) -> Array.make (Univ.UContext.size uctx) Univ.Variance.Irrelevant
-
let cook_inductive { Opaqueproof.modlist; abstract } mib =
let open Entries in
let (section_decls, subst, abs_uctx) = abstract in
@@ -333,10 +329,6 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib =
let auctx = Univ.AUContext.repr auctx in
subst, Polymorphic_entry (nas, auctx)
in
- let variance = match mib.mind_variance with
- | None -> None
- | Some _ -> Some (dummy_variance ind_univs)
- in
let cache = RefTable.create 13 in
let discharge c = Vars.subst_univs_level_constr subst (expmod_constr cache modlist c) in
let inds =
@@ -363,7 +355,7 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib =
mind_entry_params = params';
mind_entry_inds = inds';
mind_entry_private = mib.mind_private;
- mind_entry_variance = variance;
+ mind_entry_cumulative = Option.has_some mib.mind_variance;
mind_entry_universes = ind_univs
}
diff --git a/kernel/entries.ml b/kernel/entries.ml
index b50c3ebbc3..8d930b521c 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -50,7 +50,7 @@ type mutual_inductive_entry = {
mind_entry_params : Constr.rel_context;
mind_entry_inds : one_inductive_entry list;
mind_entry_universes : universes_entry;
- mind_entry_variance : Univ.Variance.t array option;
+ mind_entry_cumulative : bool;
(* universe constraints and the constraints for subtyping of
inductive types in the block. *)
mind_entry_private : bool option;
diff --git a/kernel/environ.mli b/kernel/environ.mli
index 257bd43083..bd5a000c2b 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -296,7 +296,13 @@ val add_constraints : Univ.Constraint.t -> env -> env
(** Check constraints are satifiable in the environment. *)
val check_constraints : Univ.Constraint.t -> env -> bool
val push_context : ?strict:bool -> Univ.UContext.t -> env -> env
+(* [push_context ?(strict=false) ctx env] pushes the universe context to the environment.
+ @raise UGraph.AlreadyDeclared if one of the universes is already declared.
+*)
val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env
+(* [push_context_set ?(strict=false) ctx env] pushes the universe context set
+ to the environment. It does not fail if one of the universes is already declared. *)
+
val push_constraints_to_env : 'a Univ.constrained -> env -> env
val push_subgraph : Univ.ContextSet.t -> env -> env
diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml
index c91cb39fe2..d9ccf81619 100644
--- a/kernel/indTyping.ml
+++ b/kernel/indTyping.ml
@@ -61,64 +61,6 @@ let mind_check_names mie =
(************************************************************************)
-(************************** Cumulativity checking************************)
-(************************************************************************)
-
-(* Check arities and constructors *)
-let check_subtyping_arity_constructor env subst arcn numparams is_arity =
- let numchecked = ref 0 in
- let basic_check ev tp =
- if !numchecked < numparams then () else Reduction.conv_leq ev tp (subst tp);
- numchecked := !numchecked + 1
- in
- let check_typ typ typ_env =
- match typ with
- | LocalAssum (_, typ') ->
- begin
- try
- basic_check typ_env typ'; Environ.push_rel typ typ_env
- with Reduction.NotConvertible ->
- CErrors.anomaly ~label:"bad inductive subtyping relation"
- Pp.(str "Invalid subtyping relation")
- end
- | _ -> CErrors.anomaly Pp.(str "")
- in
- let typs, codom = Reduction.dest_prod env arcn in
- let last_env = Context.Rel.fold_outside check_typ typs ~init:env in
- if not is_arity then basic_check last_env codom else ()
-
-let check_cumulativity univs variances env_ar params data =
- let uctx = match univs with
- | Monomorphic_entry _ -> raise (InductiveError BadUnivs)
- | Polymorphic_entry (_,uctx) -> uctx
- in
- let instance = UContext.instance uctx in
- if Instance.length instance != Array.length variances then raise (InductiveError BadUnivs);
- let numparams = Context.Rel.nhyps params in
- let new_levels = Array.init (Instance.length instance)
- (fun i -> Level.(make (UGlobal.make DirPath.empty i)))
- in
- let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap)
- LMap.empty (Instance.to_array instance) new_levels
- in
- let dosubst = Vars.subst_univs_level_constr lmap in
- let instance_other = Instance.of_array new_levels in
- let constraints_other = Univ.subst_univs_level_constraints lmap (UContext.constraints uctx) in
- let uctx_other = Univ.UContext.make (instance_other, constraints_other) in
- let env = Environ.push_context uctx_other env_ar in
- let subtyp_constraints =
- Univ.enforce_leq_variance_instances variances
- instance instance_other
- Constraint.empty
- in
- let env = Environ.add_constraints subtyp_constraints env in
- (* process individual inductive types: *)
- List.iter (fun (arity,lc) ->
- check_subtyping_arity_constructor env dosubst arity numparams true;
- Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc)
- data
-
-(************************************************************************)
(************************** Type checking *******************************)
(************************************************************************)
@@ -351,8 +293,14 @@ let typecheck_inductive env (mie:mutual_inductive_entry) =
let env_univs =
match mie.mind_entry_universes with
| Monomorphic_entry ctx ->
- let env = if has_template_poly then set_universes_lbound env Univ.Level.prop else env in
- push_context_set ctx env
+ if has_template_poly then
+ (* For that particular case, we typecheck the inductive in an environment
+ where the universes introduced by the definition are only [>= Prop] *)
+ let env = set_universes_lbound env Univ.Level.prop in
+ push_context_set ~strict:false ctx env
+ else
+ (* In the regular case, all universes are [> Set] *)
+ push_context_set ~strict:true ctx env
| Polymorphic_entry (_, ctx) -> push_context ctx env
in
@@ -389,11 +337,8 @@ let typecheck_inductive env (mie:mutual_inductive_entry) =
data, Some None
in
- let () = match mie.mind_entry_variance with
- | None -> ()
- | Some variances ->
- check_cumulativity mie.mind_entry_universes variances env_ar params (List.map pi1 data)
- in
+ (* TODO pass only the needed bits *)
+ let variance = InferCumulativity.infer_inductive env mie in
(* Abstract universes *)
let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in
@@ -408,4 +353,4 @@ let typecheck_inductive env (mie:mutual_inductive_entry) =
Environ.push_rel_context ctx env
in
- env_ar_par, univs, mie.mind_entry_variance, record, params, Array.of_list data
+ env_ar_par, univs, variance, record, params, Array.of_list data
diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml
index 550c81ed82..77abe6b410 100644
--- a/kernel/inferCumulativity.ml
+++ b/kernel/inferCumulativity.ml
@@ -216,19 +216,11 @@ let infer_inductive env mie =
let open Entries in
let params = mie.mind_entry_params in
let entries = mie.mind_entry_inds in
- let variances =
- match mie.mind_entry_variance with
- | None -> None
- | Some _ ->
- let uctx = match mie.mind_entry_universes with
- | Monomorphic_entry _ -> assert false
- | Polymorphic_entry (_,uctx) -> uctx
- in
- try Some (infer_inductive_core env params entries uctx)
- with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant)
- in
- { mie with mind_entry_variance = variances }
-
-let dummy_variance = let open Entries in function
- | Monomorphic_entry _ -> assert false
- | Polymorphic_entry (_,uctx) -> Array.make (UContext.size uctx) Irrelevant
+ if not mie.mind_entry_cumulative then None
+ else
+ let uctx = match mie.mind_entry_universes with
+ | Monomorphic_entry _ -> assert false
+ | Polymorphic_entry (_,uctx) -> uctx
+ in
+ try Some (infer_inductive_core env params entries uctx)
+ with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant)
diff --git a/kernel/inferCumulativity.mli b/kernel/inferCumulativity.mli
index a234e334d1..2bddfe21e2 100644
--- a/kernel/inferCumulativity.mli
+++ b/kernel/inferCumulativity.mli
@@ -9,6 +9,4 @@
(************************************************************************)
val infer_inductive : Environ.env -> Entries.mutual_inductive_entry ->
- Entries.mutual_inductive_entry
-
-val dummy_variance : Entries.universes_entry -> Univ.Variance.t array
+ Univ.Variance.t array option
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 2b83c2d868..f1e994b337 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -42,9 +42,9 @@ Type_errors
Modops
Inductive
Typeops
+InferCumulativity
IndTyping
Indtypes
-InferCumulativity
Cooking
Term_typing
Subtyping
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 759feda9ab..ee101400d6 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -331,13 +331,13 @@ type constraints_addition =
| Now of Univ.ContextSet.t
| Later of Univ.ContextSet.t Future.computation
-let push_context_set poly cst senv =
+let push_context_set ~strict cst senv =
if Univ.ContextSet.is_empty cst then senv
else
let sections = Option.map (Section.push_constraints cst) senv.sections
in
{ senv with
- env = Environ.push_context_set ~strict:(not poly) cst senv.env;
+ env = Environ.push_context_set ~strict cst senv.env;
univ = Univ.ContextSet.union cst senv.univ;
sections }
@@ -346,7 +346,7 @@ let add_constraints cst senv =
| Later fc ->
{senv with future_cst = fc :: senv.future_cst}
| Now cst ->
- push_context_set false cst senv
+ push_context_set ~strict:true cst senv
let add_constraints_list cst senv =
List.fold_left (fun acc c -> add_constraints c acc) senv cst
@@ -547,7 +547,7 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv =
else
(* Delayed constraints from opaque body are added by [add_constant_aux] *)
let cst = constraints_of_sfb sfb in
- List.fold_left (fun senv cst -> push_context_set false cst senv) senv cst
+ List.fold_left (fun senv cst -> push_context_set ~strict:true cst senv) senv cst
in
let env' = match sfb, gn with
| SFBconst cb, C con -> Environ.add_constant con cb senv.env
@@ -998,7 +998,7 @@ let close_section senv =
let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in
let senv = { senv with env; revstruct; sections; univ; objlabels; } in
(* Second phase: replay the discharged section contents *)
- let senv = push_context_set false cstrs senv in
+ let senv = push_context_set ~strict:true cstrs senv in
let modlist = Section.replacement_context env0 sections0 in
let cooking_info seg =
let { abstr_ctx; abstr_subst; abstr_uctx } = seg in
@@ -1015,7 +1015,6 @@ let close_section senv =
| `Inductive (ind, mib) ->
let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in
let mie = Cooking.cook_inductive info mib in
- let mie = InferCumulativity.infer_inductive senv.env mie in
let _, senv = add_mind (MutInd.label ind) mie senv in
senv
in
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 0b7ca26e09..92bbd264fa 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -113,7 +113,7 @@ val add_modtype :
(** Adding universe constraints *)
val push_context_set :
- bool -> Univ.ContextSet.t -> safe_transformer0
+ strict:bool -> Univ.ContextSet.t -> safe_transformer0
val add_constraints :
Univ.Constraint.t -> safe_transformer0
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-08 10:01:01 +0000