aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/byterun/coq_interp.c63
-rw-r--r--kernel/cbytecodes.ml2
-rw-r--r--kernel/cemitcodes.ml78
-rw-r--r--kernel/entries.mli2
-rw-r--r--kernel/fast_typeops.ml464
-rw-r--r--kernel/fast_typeops.mli24
-rw-r--r--kernel/kernel.mllib1
-rw-r--r--kernel/names.ml9
-rw-r--r--kernel/names.mli1
-rw-r--r--kernel/nativevalues.ml8
-rw-r--r--kernel/opaqueproof.ml2
-rw-r--r--kernel/pre_env.ml3
-rw-r--r--kernel/safe_typing.ml19
-rw-r--r--kernel/safe_typing.mli9
-rw-r--r--kernel/term_typing.ml123
-rw-r--r--kernel/term_typing.mli13
-rw-r--r--kernel/typeops.ml561
-rw-r--r--kernel/typeops.mli18
-rw-r--r--kernel/vars.ml9
-rw-r--r--kernel/vars.mli4
20 files changed, 527 insertions, 886 deletions
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index 5dec3b785c..af89712d5e 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -891,25 +891,58 @@ value coq_interprete
Instruct(PROJ){
+ do_proj:
print_instr("PROJ");
if (Is_accu (accu)) {
- value block;
- /* Skip over the index of projected field */
- pc++;
- /* Create atom */
- Alloc_small(block, 2, ATOM_PROJ_TAG);
- Field(block, 0) = Field(coq_global_data, *pc);
- Field(block, 1) = accu;
- accu = block;
- /* Create accumulator */
- Alloc_small(block, 2, Accu_tag);
- Code_val(block) = accumulate;
- Field(block, 1) = accu;
- accu = block;
+ *--sp = accu; // Save matched block on stack
+ accu = Field(accu, 1); // Save atom to accu register
+ switch (Tag_val(accu)) {
+ case ATOM_COFIX_TAG: // We are forcing a cofix
+ {
+ mlsize_t i, nargs;
+ sp -= 2;
+ // Push the current instruction as the return address
+ sp[0] = (value)(pc - 1);
+ sp[1] = coq_env;
+ coq_env = Field(accu, 0); // Pointer to suspension
+ accu = sp[2]; // Save accumulator to accu register
+ sp[2] = Val_long(coq_extra_args); // Push number of args for return
+ nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom)
+ // Push arguments to stack
+ CHECK_STACK(nargs + 1);
+ sp -= nargs;
+ for (i = 0; i < nargs; ++i) sp[i] = Field(accu, i + 2);
+ *--sp = accu; // Last argument is the pointer to the suspension
+ coq_extra_args = nargs;
+ pc = Code_val(coq_env); // Trigger evaluation
+ goto check_stack;
+ }
+ case ATOM_COFIXEVALUATED_TAG:
+ {
+ accu = Field(accu, 1);
+ ++sp;
+ goto do_proj;
+ }
+ default:
+ {
+ value block;
+ /* Skip over the index of projected field */
+ ++pc;
+ /* Create atom */
+ Alloc_small(accu, 2, ATOM_PROJ_TAG);
+ Field(accu, 0) = Field(coq_global_data, *pc++);
+ Field(accu, 1) = *sp++;
+ /* Create accumulator */
+ Alloc_small(block, 2, Accu_tag);
+ Code_val(block) = accumulate;
+ Field(block, 1) = accu;
+ accu = block;
+ }
+ }
} else {
- accu = Field(accu, *pc++);
+ accu = Field(accu, *pc);
+ pc += 2;
}
- pc++;
Next;
}
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index 810c346990..94ca4c72dd 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -299,7 +299,7 @@ and pp_bytecodes c =
| Ksequence (l1, l2) :: c ->
pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c
| i :: c ->
- tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c
+ pp_instr i ++ fnl () ++ pp_bytecodes c
(*spiwack: moved this type in this file because I needed it for
retroknowledge which can't depend from cbytegen *)
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index ad7a41a347..40c1e027d4 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -24,33 +24,45 @@ type reloc_info =
type patch = reloc_info * int
let patch_char4 buff pos c1 c2 c3 c4 =
- String.unsafe_set buff pos c1;
- String.unsafe_set buff (pos + 1) c2;
- String.unsafe_set buff (pos + 2) c3;
- String.unsafe_set buff (pos + 3) c4
+ Bytes.unsafe_set buff pos c1;
+ Bytes.unsafe_set buff (pos + 1) c2;
+ Bytes.unsafe_set buff (pos + 2) c3;
+ Bytes.unsafe_set buff (pos + 3) c4
let patch buff (pos, n) =
patch_char4 buff pos
(Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16))
(Char.unsafe_chr (n asr 24))
+(* val patch_int : emitcodes -> ((\*pos*\)int * int) list -> emitcodes *)
let patch_int buff patches =
(* copy code *before* patching because of nested evaluations:
the code we are patching might be called (and thus "concurrently" patched)
and results in wrong results. Side-effects... *)
- let buff = String.copy buff in
+ let buff = Bytes.of_string buff in
let () = List.iter (fun p -> patch buff p) patches in
- buff
+ (* Note: we follow the apporach suggested by Gabriel Scherer in
+ PR#136 here, and use unsafe as we own buff.
+
+ The crux of the question that avoids defining emitcodes just as a
+ Byte.t is the call to hcons in to_memory below. Even if disabling
+ this optimization has no visible time impact, test data shows
+ that the optimization is indeed triggered quite often so we
+ choose ugliness over altering the semantics.
+
+ Handle with care.
+ *)
+ Bytes.unsafe_to_string buff
(* Buffering of bytecode *)
-let out_buffer = ref(String.create 1024)
+let out_buffer = ref(Bytes.create 1024)
and out_position = ref 0
let out_word b1 b2 b3 b4 =
let p = !out_position in
- if p >= String.length !out_buffer then begin
- let len = String.length !out_buffer in
+ if p >= Bytes.length !out_buffer then begin
+ let len = Bytes.length !out_buffer in
let new_len =
if len <= Sys.max_string_length / 2
then 2 * len
@@ -58,8 +70,8 @@ let out_word b1 b2 b3 b4 =
if len = Sys.max_string_length
then invalid_arg "String.create" (* Pas la bonne exception .... *)
else Sys.max_string_length in
- let new_buffer = String.create new_len in
- String.blit !out_buffer 0 new_buffer 0 len;
+ let new_buffer = Bytes.create new_len in
+ Bytes.blit !out_buffer 0 new_buffer 0 len;
out_buffer := new_buffer
end;
patch_char4 !out_buffer p (Char.unsafe_chr b1)
@@ -94,10 +106,10 @@ let extend_label_table needed =
let backpatch (pos, orig) =
let displ = (!out_position - orig) asr 2 in
- !out_buffer.[pos] <- Char.unsafe_chr displ;
- !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
- !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
- !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+ Bytes.set !out_buffer pos @@ Char.unsafe_chr displ;
+ Bytes.set !out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8);
+ Bytes.set !out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16);
+ Bytes.set !out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24)
let define_label lbl =
if lbl >= Array.length !label_table then extend_label_table lbl;
@@ -262,41 +274,44 @@ let emit_instr = function
| Kstop ->
out opSTOP
-(* Emission of a list of instructions. Include some peephole optimization. *)
+(* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *)
-let rec emit = function
- | [] -> ()
+let rec emit insns remaining = match insns with
+ | [] ->
+ (match remaining with
+ [] -> ()
+ | (first::rest) -> emit first rest)
(* Peephole optimizations *)
| Kpush :: Kacc n :: c ->
if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
- emit c
+ emit c remaining
| Kpush :: Kenvacc n :: c ->
if n >= 1 && n <= 4
then out(opPUSHENVACC1 + n - 1)
else (out opPUSHENVACC; out_int n);
- emit c
+ emit c remaining
| Kpush :: Koffsetclosure ofs :: c ->
if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2
then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
else (out opPUSHOFFSETCLOSURE; out_int ofs);
- emit c
+ emit c remaining
| Kpush :: Kgetglobal id :: c ->
- out opPUSHGETGLOBAL; slot_for_getglobal id; emit c
+ out opPUSHGETGLOBAL; slot_for_getglobal id; emit c remaining
| Kpush :: Kconst (Const_b0 i) :: c ->
if i >= 0 && i <= 3
then out (opPUSHCONST0 + i)
else (out opPUSHCONSTINT; out_int i);
- emit c
+ emit c remaining
| Kpush :: Kconst const :: c ->
out opPUSHGETGLOBAL; slot_for_const const;
- emit c
+ emit c remaining
| Kpop n :: Kjump :: c ->
- out opRETURN; out_int n; emit c
+ out opRETURN; out_int n; emit c remaining
| Ksequence(c1,c2)::c ->
- emit c1; emit c2;emit c
+ emit c1 (c2::c::remaining)
(* Default case *)
| instr :: c ->
- emit_instr instr; emit c
+ emit_instr instr; emit c remaining
(* Initialization *)
@@ -305,7 +320,7 @@ let init () =
label_table := Array.make 16 (Label_undefined []);
reloc_info := []
-type emitcodes = string
+type emitcodes = String.t
let length = String.length
@@ -367,11 +382,10 @@ let repr_body_code = function
let to_memory (init_code, fun_code, fv) =
init();
- emit init_code;
- emit fun_code;
- let code = String.create !out_position in
- String.unsafe_blit !out_buffer 0 code 0 !out_position;
+ emit init_code [];
+ emit fun_code [];
(** Later uses of this string are all purely functional *)
+ let code = Bytes.sub_string !out_buffer 0 !out_position in
let code = CString.hcons code in
let reloc = List.rev !reloc_info in
Array.iter (fun lbl ->
diff --git a/kernel/entries.mli b/kernel/entries.mli
index 77081947ec..1e07c96909 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -113,5 +113,3 @@ type side_effect = {
from_env : Declarations.structure_body CEphemeron.key;
eff : side_eff;
}
-
-type side_effects = side_effect list
diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml
deleted file mode 100644
index dce4e93076..0000000000
--- a/kernel/fast_typeops.ml
+++ /dev/null
@@ -1,464 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open CErrors
-open Util
-open Names
-open Univ
-open Term
-open Vars
-open Declarations
-open Environ
-open Reduction
-open Inductive
-open Type_errors
-
-module RelDecl = Context.Rel.Declaration
-module NamedDecl = Context.Named.Declaration
-
-let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y
-
-let conv_leq_vecti env v1 v2 =
- Array.fold_left2_i
- (fun i _ t1 t2 ->
- try conv_leq false env t1 t2
- with NotConvertible -> raise (NotConvertibleVect i))
- ()
- v1
- v2
-
-let check_constraints cst env =
- if Environ.check_constraints cst env then ()
- else error_unsatisfied_constraints env cst
-
-(* This should be a type (a priori without intention to be an assumption) *)
-let type_judgment env c t =
- match kind_of_term(whd_all env t) with
- | Sort s -> {utj_val = c; utj_type = s }
- | _ -> error_not_type env (make_judge c t)
-
-let check_type env c t =
- match kind_of_term(whd_all env t) with
- | Sort s -> s
- | _ -> error_not_type env (make_judge c t)
-
-(* This should be a type intended to be assumed. The error message is *)
-(* not as useful as for [type_judgment]. *)
-let assumption_of_judgment env t ty =
- try let _ = check_type env t ty in t
- with TypeError _ ->
- error_assumption env (make_judge t ty)
-
-(************************************************)
-(* Incremental typing rules: builds a typing judgment given the *)
-(* judgments for the subterms. *)
-
-(*s Type of sorts *)
-
-(* Prop and Set *)
-
-let judge_of_prop = mkSort type1_sort
-
-let judge_of_prop_contents _ = judge_of_prop
-
-(* Type of Type(i). *)
-
-let judge_of_type u =
- let uu = Universe.super u in
- mkType uu
-
-(*s Type of a de Bruijn index. *)
-
-let judge_of_relative env n =
- try
- env |> lookup_rel n |> RelDecl.get_type |> lift n
- with Not_found ->
- error_unbound_rel env n
-
-(* Type of variables *)
-let judge_of_variable env id =
- try named_type id env
- with Not_found ->
- error_unbound_var env id
-
-(* Management of context of variables. *)
-
-(* Checks if a context of variables can be instantiated by the
- variables of the current env *)
-(* TODO: check order? *)
-let check_hyps_inclusion env f c sign =
- Context.Named.fold_outside
- (fun decl () ->
- let id = NamedDecl.get_id decl in
- let ty1 = NamedDecl.get_type decl in
- try
- let ty2 = named_type id env in
- if not (eq_constr ty2 ty1) then raise Exit
- with Not_found | Exit ->
- error_reference_variables env id (f c))
- sign
- ~init:()
-
-(* Instantiation of terms on real arguments. *)
-
-(* Make a type polymorphic if an arity *)
-
-(* Type of constants *)
-
-
-let type_of_constant_knowing_parameters_arity env t paramtyps =
- match t with
- | RegularArity t -> t
- | TemplateArity (sign,ar) ->
- let ctx = List.rev sign in
- let ctx,s = instantiate_universes env ctx ar paramtyps in
- mkArity (List.rev ctx,s)
-
-let type_of_constant_knowing_parameters env cst paramtyps =
- let ty, cu = constant_type env cst in
- type_of_constant_knowing_parameters_arity env ty paramtyps, cu
-
-let judge_of_constant_knowing_parameters env (kn,u as cst) args =
- let cb = lookup_constant kn env in
- let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
- let ty, cu = type_of_constant_knowing_parameters env cst args in
- let () = check_constraints cu env in
- ty
-
-let judge_of_constant env cst =
- judge_of_constant_knowing_parameters env cst [||]
-
-(* Type of a lambda-abstraction. *)
-
-(* [judge_of_abstraction env name var j] implements the rule
-
- env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s
- -----------------------------------------------------------------------
- env |- [name:typ]j.uj_val : (name:typ)j.uj_type
-
- Since all products are defined in the Calculus of Inductive Constructions
- and no upper constraint exists on the sort $s$, we don't need to compute $s$
-*)
-
-let judge_of_abstraction env name var ty =
- mkProd (name, var, ty)
-
-(* Type of an application. *)
-
-let make_judgev c t =
- Array.map2 make_judge c t
-
-let judge_of_apply env func funt argsv argstv =
- let len = Array.length argsv in
- let rec apply_rec i typ =
- if Int.equal i len then typ
- else
- (match kind_of_term (whd_all env typ) with
- | Prod (_,c1,c2) ->
- let arg = argsv.(i) and argt = argstv.(i) in
- (try
- let () = conv_leq false env argt c1 in
- apply_rec (i+1) (subst1 arg c2)
- with NotConvertible ->
- error_cant_apply_bad_type env
- (i+1,c1,argt)
- (make_judge func funt)
- (make_judgev argsv argstv))
-
- | _ ->
- error_cant_apply_not_functional env
- (make_judge func funt)
- (make_judgev argsv argstv))
- in apply_rec 0 funt
-
-(* Type of product *)
-
-let sort_of_product env domsort rangsort =
- match (domsort, rangsort) with
- (* Product rule (s,Prop,Prop) *)
- | (_, Prop Null) -> rangsort
- (* Product rule (Prop/Set,Set,Set) *)
- | (Prop _, Prop Pos) -> rangsort
- (* Product rule (Type,Set,?) *)
- | (Type u1, Prop Pos) ->
- if is_impredicative_set env then
- (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
- rangsort
- else
- (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
- Type (Universe.sup Universe.type0 u1)
- (* Product rule (Prop,Type_i,Type_i) *)
- | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2)
- (* Product rule (Prop,Type_i,Type_i) *)
- | (Prop Null, Type _) -> rangsort
- (* Product rule (Type_i,Type_i,Type_i) *)
- | (Type u1, Type u2) -> Type (Universe.sup u1 u2)
-
-(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
-
- env |- typ1:s1 env, name:typ1 |- typ2 : s2
- -------------------------------------------------------------------------
- s' >= (s1,s2), env |- (name:typ)j.uj_val : s'
-
- where j.uj_type is convertible to a sort s2
-*)
-let judge_of_product env name s1 s2 =
- let s = sort_of_product env s1 s2 in
- mkSort s
-
-(* Type of a type cast *)
-
-(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule
-
- env |- c:typ1 env |- typ2:s env |- typ1 <= typ2
- ---------------------------------------------------------------------
- env |- c:typ2
-*)
-
-let judge_of_cast env c ct k expected_type =
- try
- match k with
- | VMcast ->
- vm_conv CUMUL env ct expected_type
- | DEFAULTcast ->
- default_conv ~l2r:false CUMUL env ct expected_type
- | REVERTcast ->
- default_conv ~l2r:true CUMUL env ct expected_type
- | NATIVEcast ->
- let sigma = Nativelambda.empty_evars in
- Nativeconv.native_conv CUMUL sigma env ct expected_type
- with NotConvertible ->
- error_actual_type env (make_judge c ct) expected_type
-
-(* Inductive types. *)
-
-(* The type is parametric over the uniform parameters whose conclusion
- is in Type; to enforce the internal constraints between the
- parameters and the instances of Type occurring in the type of the
- constructors, we use the level variables _statically_ assigned to
- the conclusions of the parameters as mediators: e.g. if a parameter
- has conclusion Type(alpha), static constraints of the form alpha<=v
- exist between alpha and the Type's occurring in the constructor
- types; when the parameters is finally instantiated by a term of
- conclusion Type(u), then the constraints u<=alpha is computed in
- the App case of execute; from this constraints, the expected
- dynamic constraints of the form u<=v are enforced *)
-
-let judge_of_inductive_knowing_parameters env (ind,u as indu) args =
- let (mib,mip) as spec = lookup_mind_specif env ind in
- check_hyps_inclusion env mkIndU indu mib.mind_hyps;
- let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters
- env (spec,u) args
- in
- check_constraints cst env;
- t
-
-let judge_of_inductive env (ind,u as indu) =
- let (mib,mip) = lookup_mind_specif env ind in
- check_hyps_inclusion env mkIndU indu mib.mind_hyps;
- let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in
- check_constraints cst env;
- t
-
-(* Constructors. *)
-
-let judge_of_constructor env (c,u as cu) =
- let _ =
- let ((kn,_),_) = c in
- let mib = lookup_mind kn env in
- check_hyps_inclusion env mkConstructU cu mib.mind_hyps in
- let specif = lookup_mind_specif env (inductive_of_constructor c) in
- let t,cst = constrained_type_of_constructor cu specif in
- let () = check_constraints cst env in
- t
-
-(* Case. *)
-
-let check_branch_types env (ind,u) c ct lft explft =
- try conv_leq_vecti env lft explft
- with
- NotConvertibleVect i ->
- error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i)
- | Invalid_argument _ ->
- error_number_branches env (make_judge c ct) (Array.length explft)
-
-let judge_of_case env ci p pt c ct lf lft =
- let (pind, _ as indspec) =
- try find_rectype env ct
- with Not_found -> error_case_not_inductive env (make_judge c ct) in
- let _ = check_case_info env pind ci in
- let (bty,rslty) =
- type_case_branches env indspec (make_judge p pt) c in
- let () = check_branch_types env pind c ct lft bty in
- rslty
-
-let judge_of_projection env p c ct =
- let pb = lookup_projection p env in
- let (ind,u), args =
- try find_rectype env ct
- with Not_found -> error_case_not_inductive env (make_judge c ct)
- in
- assert(eq_mind pb.proj_ind (fst ind));
- let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
- substl (c :: List.rev args) ty
-
-
-(* Fixpoints. *)
-
-(* Checks the type of a general (co)fixpoint, i.e. without checking *)
-(* the specific guard condition. *)
-
-let type_fixpoint env lna lar vdef vdeft =
- let lt = Array.length vdeft in
- assert (Int.equal (Array.length lar) lt);
- try
- conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar)
- with NotConvertibleVect i ->
- error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar
-
-(************************************************************************)
-(************************************************************************)
-
-(* The typing machine. *)
- (* ATTENTION : faudra faire le typage du contexte des Const,
- Ind et Constructsi un jour cela devient des constructions
- arbitraires et non plus des variables *)
-let rec execute env cstr =
- let open Context.Rel.Declaration in
- match kind_of_term cstr with
- (* Atomic terms *)
- | Sort (Prop c) ->
- judge_of_prop_contents c
-
- | Sort (Type u) ->
- judge_of_type u
-
- | Rel n ->
- judge_of_relative env n
-
- | Var id ->
- judge_of_variable env id
-
- | Const c ->
- judge_of_constant env c
-
- | Proj (p, c) ->
- let ct = execute env c in
- judge_of_projection env p c ct
-
- (* Lambda calculus operators *)
- | App (f,args) ->
- let argst = execute_array env args in
- let ft =
- match kind_of_term f with
- | Ind ind when Environ.template_polymorphic_pind ind env ->
- (* Template sort-polymorphism of inductive types *)
- let args = Array.map (fun t -> lazy t) argst in
- judge_of_inductive_knowing_parameters env ind args
- | Const cst when Environ.template_polymorphic_pconstant cst env ->
- (* Template sort-polymorphism of constants *)
- let args = Array.map (fun t -> lazy t) argst in
- judge_of_constant_knowing_parameters env cst args
- | _ ->
- (* Full or no sort-polymorphism *)
- execute env f
- in
-
- judge_of_apply env f ft args argst
-
- | Lambda (name,c1,c2) ->
- let _ = execute_is_type env c1 in
- let env1 = push_rel (LocalAssum (name,c1)) env in
- let c2t = execute env1 c2 in
- judge_of_abstraction env name c1 c2t
-
- | Prod (name,c1,c2) ->
- let vars = execute_is_type env c1 in
- let env1 = push_rel (LocalAssum (name,c1)) env in
- let vars' = execute_is_type env1 c2 in
- judge_of_product env name vars vars'
-
- | LetIn (name,c1,c2,c3) ->
- let c1t = execute env c1 in
- let _c2s = execute_is_type env c2 in
- let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in
- let env1 = push_rel (LocalDef (name,c1,c2)) env in
- let c3t = execute env1 c3 in
- subst1 c1 c3t
-
- | Cast (c,k,t) ->
- let ct = execute env c in
- let _ts = execute_type env t in
- let _ = judge_of_cast env c ct k t in
- t
-
- (* Inductive types *)
- | Ind ind ->
- judge_of_inductive env ind
-
- | Construct c ->
- judge_of_constructor env c
-
- | Case (ci,p,c,lf) ->
- let ct = execute env c in
- let pt = execute env p in
- let lft = execute_array env lf in
- judge_of_case env ci p pt c ct lf lft
-
- | Fix ((vn,i as vni),recdef) ->
- let (fix_ty,recdef') = execute_recdef env recdef i in
- let fix = (vni,recdef') in
- check_fix env fix; fix_ty
-
- | CoFix (i,recdef) ->
- let (fix_ty,recdef') = execute_recdef env recdef i in
- let cofix = (i,recdef') in
- check_cofix env cofix; fix_ty
-
- (* Partial proofs: unsupported by the kernel *)
- | Meta _ ->
- anomaly (Pp.str "the kernel does not support metavariables")
-
- | Evar _ ->
- anomaly (Pp.str "the kernel does not support existential variables")
-
-and execute_is_type env constr =
- let t = execute env constr in
- check_type env constr t
-
-and execute_type env constr =
- let t = execute env constr in
- type_judgment env constr t
-
-and execute_recdef env (names,lar,vdef) i =
- let lart = execute_array env lar in
- let lara = Array.map2 (assumption_of_judgment env) lar lart in
- let env1 = push_rec_types (names,lara,vdef) env in
- let vdeft = execute_array env1 vdef in
- let () = type_fixpoint env1 names lara vdef vdeft in
- (lara.(i),(names,lara,vdef))
-
-and execute_array env = Array.map (execute env)
-
-(* Derived functions *)
-let infer env constr =
- let t = execute env constr in
- make_judge constr t
-
-let infer =
- if Flags.profile then
- let infer_key = Profile.declare_profile "Fast_infer" in
- Profile.profile2 infer_key (fun b c -> infer b c)
- else (fun b c -> infer b c)
-
-let infer_type env constr =
- execute_type env constr
-
-let infer_v env cv =
- let jv = execute_array env cv in
- make_judgev cv jv
diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli
deleted file mode 100644
index 41cff607e7..0000000000
--- a/kernel/fast_typeops.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-open Term
-open Environ
-open Declarations
-
-(** {6 Typing functions (not yet tagged as safe) }
-
- They return unsafe judgments that are "in context" of a set of
- (local) universe variables (the ones that appear in the term)
- and associated constraints. In case of polymorphic definitions,
- these variables and constraints will be generalized.
- *)
-
-
-val infer : env -> constr -> unsafe_judgment
-val infer_v : env -> constr array -> unsafe_judgment array
-val infer_type : env -> types -> unsafe_type_judgment
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 15f213ce9c..4c540a6d73 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -32,7 +32,6 @@ Type_errors
Modops
Inductive
Typeops
-Fast_typeops
Indtypes
Cooking
Term_typing
diff --git a/kernel/names.ml b/kernel/names.ml
index 1f138581cc..ee8d838da1 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -50,17 +50,20 @@ struct
| None -> true
| Some _ -> false
+ let of_bytes s =
+ let s = Bytes.to_string s in
+ check_soft s;
+ String.hcons s
+
let of_string s =
let () = check_soft s in
- let s = String.copy s in
String.hcons s
let of_string_soft s =
let () = check_soft ~warn:false s in
- let s = String.copy s in
String.hcons s
- let to_string id = String.copy id
+ let to_string id = id
let print id = str id
diff --git a/kernel/names.mli b/kernel/names.mli
index 6b0a80625b..be9b9422b7 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -43,6 +43,7 @@ sig
(** Check that a string may be converted to an identifier.
@raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *)
+ val of_bytes : bytes -> t
val of_string : string -> t
(** Converts a string into an identifier.
@raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters.
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
index 8093df3044..965ed67b07 100644
--- a/kernel/nativevalues.ml
+++ b/kernel/nativevalues.ml
@@ -491,12 +491,12 @@ let str_encode expr =
let str_decode s =
let mshl_expr_len = String.length s / 2 in
let mshl_expr = Buffer.create mshl_expr_len in
- let buf = String.create 2 in
+ let buf = Bytes.create 2 in
for i = 0 to mshl_expr_len - 1 do
- String.blit s (2*i) buf 0 2;
- Buffer.add_char mshl_expr (bin_of_hex buf)
+ Bytes.blit_string s (2*i) buf 0 2;
+ Buffer.add_char mshl_expr (bin_of_hex (Bytes.to_string buf))
done;
- Marshal.from_string (Buffer.contents mshl_expr) 0
+ Marshal.from_bytes (Buffer.to_bytes mshl_expr) 0
(** Retroknowledge, to be removed when we switch to primitive integers *)
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
index 130f1eb039..f147ea3433 100644
--- a/kernel/opaqueproof.ml
+++ b/kernel/opaqueproof.ml
@@ -136,7 +136,7 @@ let dump (otab,_) =
let disch_table = Array.make n a_discharge in
let f2t_map = ref FMap.empty in
Int.Map.iter (fun n (d,cu) ->
- let c, u = Future.split2 ~greedy:true cu in
+ let c, u = Future.split2 cu in
Future.sink u;
Future.sink c;
opaque_table.(n) <- c;
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 72de2f1a61..d14a254d32 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -157,7 +157,8 @@ let map_named_val f ctxt =
(accu, d')
in
let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in
- { env_named_ctx = ctx; env_named_map = map }
+ if map == ctxt.env_named_map then ctxt
+ else { env_named_ctx = ctx; env_named_map = map }
let push_named d env =
(* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index ae3679dddb..caaaff1b89 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -71,7 +71,7 @@ module NamedDecl = Context.Named.Declaration
- [env] : the underlying environment (cf Environ)
- [modpath] : the current module name
- [modvariant] :
- * NONE before coqtop initialization (or when -notop is used)
+ * NONE before coqtop initialization
* LIBRARY at toplevel of a compilation or a regular coqtop session
* STRUCT (params,oldsenv) : inside a local module, with
module parameters [params] and earlier environment [oldsenv]
@@ -208,19 +208,19 @@ let get_opaque_body env cbo =
Opaqueproof.force_constraints (Environ.opaque_tables env) opaque)
type private_constant = Entries.side_effect
-type private_constants = private_constant list
+type private_constants = Term_typing.side_effects
type private_constant_role = Term_typing.side_effect_role =
| Subproof
| Schema of inductive * string
-let empty_private_constants = []
-let add_private x xs = x :: xs
-let concat_private xs ys = xs @ ys
+let empty_private_constants = Term_typing.empty_seff
+let add_private = Term_typing.add_seff
+let concat_private = Term_typing.concat_seff
let mk_pure_proof = Term_typing.mk_pure_proof
let inline_private_constants_in_constr = Term_typing.inline_side_effects
let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects
-let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x)
+let side_effects_of_private_constants = Term_typing.uniq_seff
let private_con_of_con env c =
let cbo = Environ.lookup_constant c env.env in
@@ -250,7 +250,7 @@ let universes_of_private eff =
| Entries.SEsubproof (c, cb, e) ->
if cb.const_polymorphic then acc
else Univ.ContextSet.of_context cb.const_universes :: acc)
- [] eff
+ [] (Term_typing.uniq_seff eff)
let env_of_safe_env senv = senv.env
let env_of_senv = env_of_safe_env
@@ -796,7 +796,10 @@ type compiled_library = {
type native_library = Nativecode.global list
let get_library_native_symbols senv dir =
- DPMap.find dir senv.native_symbols
+ try DPMap.find dir senv.native_symbols
+ with Not_found -> CErrors.user_err ~hdr:"get_library_native_symbols"
+ Pp.((str "Linker error in the native compiler. Are you using Require inside a nested Module declaration?") ++ fnl () ++
+ (str "This use case is not supported, but disabling the native compiler may help."))
(** FIXME: MS: remove?*)
let current_modpath senv = senv.modpath
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 15ebc7d880..efeb98bd25 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -47,11 +47,18 @@ type private_constant_role =
| Schema of inductive * string
val side_effects_of_private_constants :
- private_constants -> Entries.side_effects
+ private_constants -> Entries.side_effect list
+(** Return the list of individual side-effects in the order of their
+ creation. *)
val empty_private_constants : private_constants
val add_private : private_constant -> private_constants -> private_constants
+(** Add a constant to a list of private constants. The former must be more
+ recent than all constants appearing in the latter, i.e. one should not
+ create a dependency cycle. *)
val concat_private : private_constants -> private_constants -> private_constants
+(** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in
+ [e1] must be more recent than those of [e2]. *)
val private_con_of_con : safe_environment -> constant -> private_constant
val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index d8774944e4..2eb2c040e1 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -20,33 +20,12 @@ open Declarations
open Environ
open Entries
open Typeops
-open Fast_typeops
module RelDecl = Context.Rel.Declaration
module NamedDecl = Context.Named.Declaration
-let constrain_type env j poly subst = function
- | `None ->
- if not poly then (* Old-style polymorphism *)
- make_polymorphic_if_constant_for_ind env j
- else RegularArity (Vars.subst_univs_level_constr subst j.uj_type)
- | `Some t ->
- let tj = infer_type env t in
- let _ = judge_of_cast env j DEFAULTcast tj in
- assert (eq_constr t tj.utj_val);
- RegularArity (Vars.subst_univs_level_constr subst t)
- | `SomeWJ (t, tj) ->
- let tj = infer_type env t in
- let _ = judge_of_cast env j DEFAULTcast tj in
- assert (eq_constr t tj.utj_val);
- RegularArity (Vars.subst_univs_level_constr subst t)
-
-let map_option_typ = function None -> `None | Some x -> `Some x
-
(* Insertion of constants and parameters in environment. *)
-let mk_pure_proof c = (c, Univ.ContextSet.empty), []
-
let equal_eff e1 e2 =
let open Entries in
match e1, e2 with
@@ -58,13 +37,54 @@ let equal_eff e1 e2 =
cl1 cl2
| _ -> false
-let rec uniq_seff = function
- | [] -> []
- | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs)
-(* The list of side effects is in reverse order (most recent first).
- * To keep the "topological" order between effects we have to uniq-ize from
- * the tail *)
-let uniq_seff l = List.rev (uniq_seff (List.rev l))
+module SideEffects :
+sig
+ type t
+ val repr : t -> side_effect list
+ val empty : t
+ val add : side_effect -> t -> t
+ val concat : t -> t -> t
+end =
+struct
+
+let compare_seff e1 e2 = match e1, e2 with
+| SEsubproof (c1, _, _), SEsubproof (c2, _, _) -> Constant.CanOrd.compare c1 c2
+| SEscheme (cl1, _), SEscheme (cl2, _) ->
+ let cmp (_, c1, _, _) (_, c2, _, _) = Constant.CanOrd.compare c1 c2 in
+ CList.compare cmp cl1 cl2
+| SEsubproof _, SEscheme _ -> -1
+| SEscheme _, SEsubproof _ -> 1
+
+module SeffOrd = struct
+type t = side_effect
+let compare e1 e2 = compare_seff e1.eff e2.eff
+end
+
+module SeffSet = Set.Make(SeffOrd)
+
+type t = { seff : side_effect list; elts : SeffSet.t }
+(** Invariant: [seff] is a permutation of the elements of [elts] *)
+
+let repr eff = eff.seff
+let empty = { seff = []; elts = SeffSet.empty }
+let add x es =
+ if SeffSet.mem x es.elts then es
+ else { seff = x :: es.seff; elts = SeffSet.add x es.elts }
+let concat xes yes =
+ List.fold_right add xes.seff yes
+
+end
+
+type side_effects = SideEffects.t
+
+let uniq_seff_rev = SideEffects.repr
+let uniq_seff l = List.rev (SideEffects.repr l)
+
+let empty_seff = SideEffects.empty
+let add_seff = SideEffects.add
+let concat_seff = SideEffects.concat
+
+let mk_pure_proof c = (c, Univ.ContextSet.empty), empty_seff
let inline_side_effects env body ctx side_eff =
let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } =
@@ -77,8 +97,7 @@ let inline_side_effects env body ctx side_eff =
let cbl = List.filter not_exists cbl in
let cname c =
let name = string_of_con c in
- for i = 0 to String.length name - 1 do
- if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done;
+ let name = String.map (fun c -> if c == '.' || c == '#' then '_' else c) name in
Name (id_of_string name) in
let rec sub c i x = match kind_of_term x with
| Const (c', _) when eq_constant c c' -> mkRel i
@@ -118,7 +137,7 @@ let inline_side_effects env body ctx side_eff =
t, ctx, (mb,List.length cbl) :: sl
in
(* CAVEAT: we assure a proper order *)
- List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff)
+ List.fold_left handle_sideff (body,ctx,[]) (uniq_seff_rev side_eff)
(* Given the list of signatures of side effects, checks if they match.
* I.e. if they are ordered descendants of the current revstruct *)
@@ -185,6 +204,10 @@ let infer_declaration ~trust env kn dcl =
let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in
Undef nl, RegularArity t, None, poly, univs, false, ctx
+ (** Definition [c] is opaque (Qed), non polymorphic and with a specified type,
+ so we delay the typing and hash consing of its body.
+ Remark: when the universe quantification is given explicitly, we could
+ delay even in the polymorphic case. *)
| DefinitionEntry ({ const_entry_type = Some typ;
const_entry_opaque = true;
const_entry_polymorphic = false} as c) ->
@@ -192,19 +215,20 @@ let infer_declaration ~trust env kn dcl =
let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
let tyj = infer_type env typ in
let proofterm =
- Future.chain ~greedy:true ~pure:true body (fun ((body,uctx),side_eff) ->
+ Future.chain ~pure:true body (fun ((body,uctx),side_eff) ->
let body, uctx, signatures =
inline_side_effects env body uctx side_eff in
let valid_signatures = check_signatures trust signatures in
- let env' = push_context_set uctx env in
+ let env = push_context_set uctx env in
let j =
- let body,env',ectx = skip_trusted_seff valid_signatures body env' in
- let j = infer env' body in
+ let body,env,ectx = skip_trusted_seff valid_signatures body env in
+ let j = infer env body in
unzip ectx j in
let j = hcons_j j in
let subst = Univ.LMap.empty in
- let _typ = constrain_type env' j c.const_entry_polymorphic subst
- (`SomeWJ (typ,tyj)) in
+ let _ = judge_of_cast env j DEFAULTcast tyj in
+ assert (eq_constr typ tyj.utj_val);
+ let _typ = RegularArity (Vars.subst_univs_level_constr subst typ) in
feedback_completion_typecheck feedback_id;
j.uj_val, uctx) in
let def = OpaqueDef (Opaqueproof.create proofterm) in
@@ -212,6 +236,7 @@ let infer_declaration ~trust env kn dcl =
c.const_entry_universes,
c.const_entry_inline_code, c.const_entry_secctx
+ (** Other definitions have to be processed immediately. *)
| DefinitionEntry c ->
let { const_entry_type = typ; const_entry_opaque = opaque } = c in
let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
@@ -224,7 +249,17 @@ let infer_declaration ~trust env kn dcl =
let usubst, univs =
Univ.abstract_universes abstract (Univ.ContextSet.to_context ctx) in
let j = infer env body in
- let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in
+ let typ = match typ with
+ | None ->
+ if not c.const_entry_polymorphic then (* Old-style polymorphism *)
+ make_polymorphic_if_constant_for_ind env j
+ else RegularArity (Vars.subst_univs_level_constr usubst j.uj_type)
+ | Some t ->
+ let tj = infer_type env t in
+ let _ = judge_of_cast env j DEFAULTcast tj in
+ assert (eq_constr t tj.utj_val);
+ RegularArity (Vars.subst_univs_level_constr usubst t)
+ in
let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in
let def =
if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty)))
@@ -384,7 +419,7 @@ let constant_entry_of_side_effect cb u =
| Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty
| _ -> assert false in
DefinitionEntry {
- const_entry_body = Future.from_val (pt, []);
+ const_entry_body = Future.from_val (pt, empty_seff);
const_entry_secctx = None;
const_entry_feedback = None;
const_entry_type =
@@ -417,8 +452,8 @@ let export_side_effects mb env ce =
let { const_entry_body = body } = c in
let _, eff = Future.force body in
let ce = DefinitionEntry { c with
- const_entry_body = Future.chain ~greedy:true ~pure:true body
- (fun (b_ctx, _) -> b_ctx, []) } in
+ const_entry_body = Future.chain ~pure:true body
+ (fun (b_ctx, _) -> b_ctx, empty_seff) } in
let not_exists (c,_,_,_) =
try ignore(Environ.lookup_constant c env); false
with Not_found -> true in
@@ -430,7 +465,7 @@ let export_side_effects mb env ce =
let cbl = List.filter not_exists cbl in
if cbl = [] then acc, sl
else cbl :: acc, (mb,List.length cbl) :: sl in
- let seff, signatures = List.fold_left aux ([],[]) (uniq_seff eff) in
+ let seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in
let trusted = check_signatures mb signatures in
let push_seff env = function
| kn, cb, `Nothing, _ ->
@@ -499,10 +534,10 @@ let translate_local_def mb env id centry =
let translate_mind env kn mie = Indtypes.check_inductive env kn mie
let inline_entry_side_effects env ce = { ce with
- const_entry_body = Future.chain ~greedy:true ~pure:true
+ const_entry_body = Future.chain ~pure:true
ce.const_entry_body (fun ((body, ctx), side_eff) ->
let body, ctx',_ = inline_side_effects env body ctx side_eff in
- (body, ctx'), []);
+ (body, ctx'), empty_seff);
}
let inline_side_effects env body side_eff =
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index fcd95576c0..075389ea53 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -12,6 +12,8 @@ open Environ
open Declarations
open Entries
+type side_effects
+
val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry ->
constant_def * types * constant_universes
@@ -29,7 +31,16 @@ val inline_entry_side_effects :
{!Entries.const_entry_body} field. It is meant to get a term out of a not
yet type checked proof. *)
-val uniq_seff : side_effects -> side_effects
+val empty_seff : side_effects
+val add_seff : side_effect -> side_effects -> side_effects
+val concat_seff : side_effects -> side_effects -> side_effects
+(** [concat_seff e1 e2] adds the side-effects of [e1] to [e2], i.e. effects in
+ [e1] must be more recent than those of [e2]. *)
+val uniq_seff : side_effects -> side_effect list
+(** Return the list of individual side-effects in the order of their
+ creation. *)
+
+val equal_eff : side_effect -> side_effect -> bool
val translate_constant :
structure_body -> env -> constant -> side_effects constant_entry ->
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 24018ab31a..7d9a2aac09 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -14,11 +14,9 @@ open Term
open Vars
open Declarations
open Environ
-open Entries
open Reduction
open Inductive
open Type_errors
-open Context.Rel.Declaration
module RelDecl = Context.Rel.Declaration
module NamedDecl = Context.Named.Declaration
@@ -38,61 +36,46 @@ let check_constraints cst env =
if Environ.check_constraints cst env then ()
else error_unsatisfied_constraints env cst
-(* This should be a type (a priori without intension to be an assumption) *)
-let type_judgment env j =
- match kind_of_term(whd_all env j.uj_type) with
- | Sort s -> {utj_val = j.uj_val; utj_type = s }
- | _ -> error_not_type env j
+(* This should be a type (a priori without intention to be an assumption) *)
+let check_type env c t =
+ match kind_of_term(whd_all env t) with
+ | Sort s -> s
+ | _ -> error_not_type env (make_judge c t)
-(* This should be a type intended to be assumed. The error message is *)
-(* not as useful as for [type_judgment]. *)
-let assumption_of_judgment env j =
- try (type_judgment env j).utj_val
+(* This should be a type intended to be assumed. The error message is
+ not as useful as for [type_judgment]. *)
+let check_assumption env t ty =
+ try let _ = check_type env t ty in t
with TypeError _ ->
- error_assumption env j
+ error_assumption env (make_judge t ty)
(************************************************)
-(* Incremental typing rules: builds a typing judgement given the *)
-(* judgements for the subterms. *)
+(* Incremental typing rules: builds a typing judgment given the *)
+(* judgments for the subterms. *)
(*s Type of sorts *)
(* Prop and Set *)
-let judge_of_prop =
- { uj_val = mkProp;
- uj_type = mkSort type1_sort }
-
-let judge_of_set =
- { uj_val = mkSet;
- uj_type = mkSort type1_sort }
-
-let judge_of_prop_contents = function
- | Null -> judge_of_prop
- | Pos -> judge_of_set
+let type1 = mkSort type1_sort
(* Type of Type(i). *)
-let judge_of_type u =
+let type_of_type u =
let uu = Universe.super u in
- { uj_val = mkType u;
- uj_type = mkType uu }
+ mkType uu
(*s Type of a de Bruijn index. *)
-let judge_of_relative env n =
+let type_of_relative env n =
try
- let typ = RelDecl.get_type (lookup_rel n env) in
- { uj_val = mkRel n;
- uj_type = lift n typ }
+ env |> lookup_rel n |> RelDecl.get_type |> lift n
with Not_found ->
error_unbound_rel env n
(* Type of variables *)
-let judge_of_variable env id =
- try
- let ty = named_type id env in
- make_judge (mkVar id) ty
+let type_of_variable env id =
+ try named_type id env
with Not_found ->
error_unbound_var env id
@@ -101,7 +84,7 @@ let judge_of_variable env id =
(* Checks if a context of variables can be instantiated by the
variables of the current env.
Order does not have to be checked assuming that all names are distinct *)
-let check_hyps_inclusion env c sign =
+let check_hyps_inclusion env f c sign =
Context.Named.fold_outside
(fun d1 () ->
let open Context.Named.Declaration in
@@ -117,7 +100,7 @@ let check_hyps_inclusion env c sign =
| LocalDef _, LocalAssum _ -> raise NotConvertible
| LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1);
with Not_found | NotConvertible | Option.Heterogeneous ->
- error_reference_variables env id c)
+ error_reference_variables env id (f c))
sign
~init:()
@@ -125,35 +108,9 @@ let check_hyps_inclusion env c sign =
(* Make a type polymorphic if an arity *)
-let extract_level env p =
- let _,c = dest_prod_assum env p in
- match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None
-
-let extract_context_levels env l =
- let fold l = function
- | LocalAssum (_,p) -> extract_level env p :: l
- | LocalDef _ -> l
- in
- List.fold_left fold [] l
-
-let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} =
- let params, ccl = dest_prod_assum env t in
- match kind_of_term ccl with
- | Sort (Type u) ->
- let ind, l = decompose_app (whd_all env c) in
- if isInd ind && List.is_empty l then
- let mis = lookup_mind_specif env (fst (destInd ind)) in
- let nparams = Inductive.inductive_params mis in
- let paramsl = CList.lastn nparams params in
- let param_ccls = extract_context_levels env paramsl in
- let s = { template_param_levels = param_ccls; template_level = u} in
- TemplateArity (params,s)
- else RegularArity t
- | _ ->
- RegularArity t
-
(* Type of constants *)
+
let type_of_constant_type_knowing_parameters env t paramtyps =
match t with
| RegularArity t -> t
@@ -162,49 +119,28 @@ let type_of_constant_type_knowing_parameters env t paramtyps =
let ctx,s = instantiate_universes env ctx ar paramtyps in
mkArity (List.rev ctx,s)
-let type_of_constant_knowing_parameters env cst paramtyps =
- let cb = lookup_constant (fst cst) env in
- let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+let type_of_constant_knowing_parameters env (kn,u as cst) args =
+ let cb = lookup_constant kn env in
+ let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
let ty, cu = constant_type env cst in
- type_of_constant_type_knowing_parameters env ty paramtyps, cu
+ let ty = type_of_constant_type_knowing_parameters env ty args in
+ let () = check_constraints cu env in
+ ty
-let type_of_constant_knowing_parameters_in env cst paramtyps =
- let cb = lookup_constant (fst cst) env in
- let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+let type_of_constant_knowing_parameters_in env (kn,u as cst) args =
+ let cb = lookup_constant kn env in
+ let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
let ty = constant_type_in env cst in
- type_of_constant_type_knowing_parameters env ty paramtyps
-
-let type_of_constant_type env t =
- type_of_constant_type_knowing_parameters env t [||]
+ type_of_constant_type_knowing_parameters env ty args
let type_of_constant env cst =
type_of_constant_knowing_parameters env cst [||]
let type_of_constant_in env cst =
- let cb = lookup_constant (fst cst) env in
- let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
- let ar = constant_type_in env cst in
- type_of_constant_type_knowing_parameters env ar [||]
-
-let judge_of_constant_knowing_parameters env (kn,u as cst) args =
- let c = mkConstU cst in
- let ty, cu = type_of_constant_knowing_parameters env cst args in
- let () = check_constraints cu env in
- make_judge c ty
-
-let judge_of_constant env cst =
- judge_of_constant_knowing_parameters env cst [||]
-
-let type_of_projection env (p,u) =
- let cst = Projection.constant p in
- let cb = lookup_constant cst env in
- match cb.const_proj with
- | Some pb ->
- if cb.const_polymorphic then
- Vars.subst_instance_constr u pb.proj_type
- else pb.proj_type
- | None -> raise (Invalid_argument "type_of_projection: not a projection")
+ type_of_constant_knowing_parameters_in env cst [||]
+let type_of_constant_type env t =
+ type_of_constant_type_knowing_parameters env t [||]
(* Type of a lambda-abstraction. *)
@@ -218,40 +154,36 @@ let type_of_projection env (p,u) =
and no upper constraint exists on the sort $s$, we don't need to compute $s$
*)
-let judge_of_abstraction env name var j =
- { uj_val = mkLambda (name, var.utj_val, j.uj_val);
- uj_type = mkProd (name, var.utj_val, j.uj_type) }
-
-(* Type of let-in. *)
-
-let judge_of_letin env name defj typj j =
- { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ;
- uj_type = subst1 defj.uj_val j.uj_type }
+let type_of_abstraction env name var ty =
+ mkProd (name, var, ty)
(* Type of an application. *)
-let judge_of_apply env funj argjv =
- let rec apply_rec n typ = function
- | [] ->
- { uj_val = mkApp (j_val funj, Array.map j_val argjv);
- uj_type = typ }
- | hj::restjl ->
- (match kind_of_term (whd_all env typ) with
- | Prod (_,c1,c2) ->
- (try
- let () = conv_leq false env hj.uj_type c1 in
- apply_rec (n+1) (subst1 hj.uj_val c2) restjl
- with NotConvertible ->
- error_cant_apply_bad_type env
- (n,c1, hj.uj_type)
- funj argjv)
-
- | _ ->
- error_cant_apply_not_functional env funj argjv)
- in
- apply_rec 1
- funj.uj_type
- (Array.to_list argjv)
+let make_judgev c t =
+ Array.map2 make_judge c t
+
+let type_of_apply env func funt argsv argstv =
+ let len = Array.length argsv in
+ let rec apply_rec i typ =
+ if Int.equal i len then typ
+ else
+ (match kind_of_term (whd_all env typ) with
+ | Prod (_,c1,c2) ->
+ let arg = argsv.(i) and argt = argstv.(i) in
+ (try
+ let () = conv_leq false env argt c1 in
+ apply_rec (i+1) (subst1 arg c2)
+ with NotConvertible ->
+ error_cant_apply_bad_type env
+ (i+1,c1,argt)
+ (make_judge func funt)
+ (make_judgev argsv argstv))
+
+ | _ ->
+ error_cant_apply_not_functional env
+ (make_judge func funt)
+ (make_judgev argsv argstv))
+ in apply_rec 0 funt
(* Type of product *)
@@ -284,10 +216,9 @@ let sort_of_product env domsort rangsort =
where j.uj_type is convertible to a sort s2
*)
-let judge_of_product env name t1 t2 =
- let s = sort_of_product env t1.utj_type t2.utj_type in
- { uj_val = mkProd (name, t1.utj_val, t2.utj_val);
- uj_type = mkSort s }
+let type_of_product env name s1 s2 =
+ let s = sort_of_product env s1 s2 in
+ mkSort s
(* Type of a type cast *)
@@ -298,29 +229,20 @@ let judge_of_product env name t1 t2 =
env |- c:typ2
*)
-let judge_of_cast env cj k tj =
- let expected_type = tj.utj_val in
+let check_cast env c ct k expected_type =
try
- let c, cst =
- match k with
- | VMcast ->
- mkCast (cj.uj_val, k, expected_type),
- Reduction.vm_conv CUMUL env cj.uj_type expected_type
- | DEFAULTcast ->
- mkCast (cj.uj_val, k, expected_type),
- default_conv ~l2r:false CUMUL env cj.uj_type expected_type
- | REVERTcast ->
- cj.uj_val,
- default_conv ~l2r:true CUMUL env cj.uj_type expected_type
- | NATIVEcast ->
- let sigma = Nativelambda.empty_evars in
- mkCast (cj.uj_val, k, expected_type),
- Nativeconv.native_conv CUMUL sigma env cj.uj_type expected_type
- in
- { uj_val = c;
- uj_type = expected_type }
+ match k with
+ | VMcast ->
+ vm_conv CUMUL env ct expected_type
+ | DEFAULTcast ->
+ default_conv ~l2r:false CUMUL env ct expected_type
+ | REVERTcast ->
+ default_conv ~l2r:true CUMUL env ct expected_type
+ | NATIVEcast ->
+ let sigma = Nativelambda.empty_evars in
+ Nativeconv.native_conv CUMUL sigma env ct expected_type
with NotConvertible ->
- error_actual_type env cj expected_type
+ error_actual_type env (make_judge c ct) expected_type
(* Inductive types. *)
@@ -336,83 +258,78 @@ let judge_of_cast env cj k tj =
the App case of execute; from this constraints, the expected
dynamic constraints of the form u<=v are enforced *)
-let judge_of_inductive_knowing_parameters env (ind,u as indu) args =
- let c = mkIndU indu in
+let type_of_inductive_knowing_parameters env (ind,u as indu) args =
let (mib,mip) as spec = lookup_mind_specif env ind in
- check_hyps_inclusion env c mib.mind_hyps;
+ check_hyps_inclusion env mkIndU indu mib.mind_hyps;
let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters
env (spec,u) args
in
- check_constraints cst env;
- make_judge c t
+ check_constraints cst env;
+ t
-let judge_of_inductive env (ind,u as indu) =
- let c = mkIndU indu in
- let (mib,mip) as spec = lookup_mind_specif env ind in
- check_hyps_inclusion env c mib.mind_hyps;
- let t,cst = Inductive.constrained_type_of_inductive env (spec,u) in
- check_constraints cst env;
- (make_judge c t)
+let type_of_inductive env (ind,u as indu) =
+ let (mib,mip) = lookup_mind_specif env ind in
+ check_hyps_inclusion env mkIndU indu mib.mind_hyps;
+ let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in
+ check_constraints cst env;
+ t
(* Constructors. *)
-let judge_of_constructor env (c,u as cu) =
- let constr = mkConstructU cu in
- let _ =
+let type_of_constructor env (c,u as cu) =
+ let () =
let ((kn,_),_) = c in
let mib = lookup_mind kn env in
- check_hyps_inclusion env constr mib.mind_hyps in
+ check_hyps_inclusion env mkConstructU cu mib.mind_hyps
+ in
let specif = lookup_mind_specif env (inductive_of_constructor c) in
let t,cst = constrained_type_of_constructor cu specif in
let () = check_constraints cst env in
- (make_judge constr t)
+ t
(* Case. *)
-let check_branch_types env (ind,u) cj (lfj,explft) =
- try conv_leq_vecti env (Array.map j_type lfj) explft
+let check_branch_types env (ind,u) c ct lft explft =
+ try conv_leq_vecti env lft explft
with
NotConvertibleVect i ->
- error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i)
+ error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i)
| Invalid_argument _ ->
- error_number_branches env cj (Array.length explft)
+ error_number_branches env (make_judge c ct) (Array.length explft)
-let judge_of_case env ci pj cj lfj =
+let type_of_case env ci p pt c ct lf lft =
let (pind, _ as indspec) =
- try find_rectype env cj.uj_type
- with Not_found -> error_case_not_inductive env cj in
+ try find_rectype env ct
+ with Not_found -> error_case_not_inductive env (make_judge c ct) in
let () = check_case_info env pind ci in
let (bty,rslty) =
- type_case_branches env indspec pj cj.uj_val in
- let () = check_branch_types env pind cj (lfj,bty) in
- ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
- Array.map j_val lfj);
- uj_type = rslty })
+ type_case_branches env indspec (make_judge p pt) c in
+ let () = check_branch_types env pind c ct lft bty in
+ rslty
-let judge_of_projection env p cj =
+let type_of_projection env p c ct =
let pb = lookup_projection p env in
let (ind,u), args =
- try find_rectype env cj.uj_type
- with Not_found -> error_case_not_inductive env cj
+ try find_rectype env ct
+ with Not_found -> error_case_not_inductive env (make_judge c ct)
in
- assert(eq_mind pb.proj_ind (fst ind));
- let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
- let ty = substl (cj.uj_val :: List.rev args) ty in
- {uj_val = mkProj (p,cj.uj_val);
- uj_type = ty}
+ assert(eq_mind pb.proj_ind (fst ind));
+ let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
+ substl (c :: List.rev args) ty
+
(* Fixpoints. *)
(* Checks the type of a general (co)fixpoint, i.e. without checking *)
(* the specific guard condition. *)
-let type_fixpoint env lna lar vdefj =
- let lt = Array.length vdefj in
+let check_fixpoint env lna lar vdef vdeft =
+ let lt = Array.length vdeft in
assert (Int.equal (Array.length lar) lt);
try
- conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar)
+ conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar)
with NotConvertibleVect i ->
- error_ill_typed_rec_body env i lna vdefj lar
+ error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar
(************************************************************************)
(************************************************************************)
@@ -422,95 +339,96 @@ let type_fixpoint env lna lar vdefj =
Ind et Constructsi un jour cela devient des constructions
arbitraires et non plus des variables *)
let rec execute env cstr =
+ let open Context.Rel.Declaration in
match kind_of_term cstr with
(* Atomic terms *)
| Sort (Prop c) ->
- judge_of_prop_contents c
+ type1
| Sort (Type u) ->
- judge_of_type u
+ type_of_type u
| Rel n ->
- judge_of_relative env n
+ type_of_relative env n
| Var id ->
- judge_of_variable env id
+ type_of_variable env id
| Const c ->
- judge_of_constant env c
+ type_of_constant env c
| Proj (p, c) ->
- let cj = execute env c in
- judge_of_projection env p cj
+ let ct = execute env c in
+ type_of_projection env p c ct
(* Lambda calculus operators *)
| App (f,args) ->
- let jl = execute_array env args in
- let j =
+ let argst = execute_array env args in
+ let ft =
match kind_of_term f with
- | Ind ind when Environ.template_polymorphic_pind ind env ->
- (* Sort-polymorphism of inductive types *)
- let args = Array.map (fun j -> lazy j.uj_type) jl in
- judge_of_inductive_knowing_parameters env ind args
- | Const cst when Environ.template_polymorphic_pconstant cst env ->
- (* Sort-polymorphism of constant *)
- let args = Array.map (fun j -> lazy j.uj_type) jl in
- judge_of_constant_knowing_parameters env cst args
- | _ ->
- (* No sort-polymorphism *)
- execute env f
+ | Ind ind when Environ.template_polymorphic_pind ind env ->
+ (* Template sort-polymorphism of inductive types *)
+ let args = Array.map (fun t -> lazy t) argst in
+ type_of_inductive_knowing_parameters env ind args
+ | Const cst when Environ.template_polymorphic_pconstant cst env ->
+ (* Template sort-polymorphism of constants *)
+ let args = Array.map (fun t -> lazy t) argst in
+ type_of_constant_knowing_parameters env cst args
+ | _ ->
+ (* Full or no sort-polymorphism *)
+ execute env f
in
- judge_of_apply env j jl
+
+ type_of_apply env f ft args argst
| Lambda (name,c1,c2) ->
- let varj = execute_type env c1 in
- let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in
- let j' = execute env1 c2 in
- judge_of_abstraction env name varj j'
+ let _ = execute_is_type env c1 in
+ let env1 = push_rel (LocalAssum (name,c1)) env in
+ let c2t = execute env1 c2 in
+ type_of_abstraction env name c1 c2t
| Prod (name,c1,c2) ->
- let varj = execute_type env c1 in
- let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in
- let varj' = execute_type env1 c2 in
- judge_of_product env name varj varj'
+ let vars = execute_is_type env c1 in
+ let env1 = push_rel (LocalAssum (name,c1)) env in
+ let vars' = execute_is_type env1 c2 in
+ type_of_product env name vars vars'
| LetIn (name,c1,c2,c3) ->
- let j1 = execute env c1 in
- let j2 = execute_type env c2 in
- let _ = judge_of_cast env j1 DEFAULTcast j2 in
- let env1 = push_rel (LocalDef (name,j1.uj_val,j2.utj_val)) env in
- let j' = execute env1 c3 in
- judge_of_letin env name j1 j2 j'
+ let c1t = execute env c1 in
+ let _c2s = execute_is_type env c2 in
+ let () = check_cast env c1 c1t DEFAULTcast c2 in
+ let env1 = push_rel (LocalDef (name,c1,c2)) env in
+ let c3t = execute env1 c3 in
+ subst1 c1 c3t
| Cast (c,k,t) ->
- let cj = execute env c in
- let tj = execute_type env t in
- judge_of_cast env cj k tj
+ let ct = execute env c in
+ let _ts = (check_type env t (execute env t)) in
+ let () = check_cast env c ct k t in
+ t
(* Inductive types *)
| Ind ind ->
- judge_of_inductive env ind
+ type_of_inductive env ind
| Construct c ->
- judge_of_constructor env c
+ type_of_constructor env c
| Case (ci,p,c,lf) ->
- let cj = execute env c in
- let pj = execute env p in
- let lfj = execute_array env lf in
- judge_of_case env ci pj cj lfj
+ let ct = execute env c in
+ let pt = execute env p in
+ let lft = execute_array env lf in
+ type_of_case env ci p pt c ct lf lft
| Fix ((vn,i as vni),recdef) ->
let (fix_ty,recdef') = execute_recdef env recdef i in
let fix = (vni,recdef') in
- check_fix env fix;
- make_judge (mkFix fix) fix_ty
+ check_fix env fix; fix_ty
| CoFix (i,recdef) ->
let (fix_ty,recdef') = execute_recdef env recdef i in
let cofix = (i,recdef') in
- check_cofix env cofix;
- (make_judge (mkCoFix cofix) fix_ty)
+ check_cofix env cofix; fix_ty
(* Partial proofs: unsupported by the kernel *)
| Meta _ ->
@@ -519,53 +437,158 @@ let rec execute env cstr =
| Evar _ ->
anomaly (Pp.str "the kernel does not support existential variables")
-and execute_type env constr =
- let j = execute env constr in
- type_judgment env j
+and execute_is_type env constr =
+ let t = execute env constr in
+ check_type env constr t
and execute_recdef env (names,lar,vdef) i =
- let larj = execute_array env lar in
- let lara = Array.map (assumption_of_judgment env) larj in
+ let lart = execute_array env lar in
+ let lara = Array.map2 (check_assumption env) lar lart in
let env1 = push_rec_types (names,lara,vdef) env in
- let vdefj = execute_array env1 vdef in
- let vdefv = Array.map j_val vdefj in
- let () = type_fixpoint env1 names lara vdefj in
- (lara.(i),(names,lara,vdefv))
+ let vdeft = execute_array env1 vdef in
+ let () = check_fixpoint env1 names lara vdef vdeft in
+ (lara.(i),(names,lara,vdef))
and execute_array env = Array.map (execute env)
(* Derived functions *)
let infer env constr =
- let j = execute env constr in
- assert (eq_constr j.uj_val constr);
- j
+ let t = execute env constr in
+ make_judge constr t
+
+let infer =
+ if Flags.profile then
+ let infer_key = Profile.declare_profile "Fast_infer" in
+ Profile.profile2 infer_key (fun b c -> infer b c)
+ else (fun b c -> infer b c)
+
+let assumption_of_judgment env {uj_val=c; uj_type=t} =
+ check_assumption env c t
-(* let infer_key = Profile.declare_profile "infer" *)
-(* let infer = Profile.profile2 infer_key infer *)
+let type_judgment env {uj_val=c; uj_type=t} =
+ let s = check_type env c t in
+ {utj_val = c; utj_type = s }
let infer_type env constr =
- let j = execute_type env constr in
- j
+ let t = execute env constr in
+ let s = check_type env constr t in
+ {utj_val = constr; utj_type = s}
let infer_v env cv =
let jv = execute_array env cv in
- jv
+ make_judgev cv jv
(* Typing of several terms. *)
let infer_local_decl env id = function
- | LocalDefEntry c ->
- let j = infer env c in
- LocalDef (Name id, j.uj_val, j.uj_type)
- | LocalAssumEntry c ->
- let j = infer env c in
- LocalAssum (Name id, assumption_of_judgment env j)
+ | Entries.LocalDefEntry c ->
+ let t = execute env c in
+ RelDecl.LocalDef (Name id, c, t)
+ | Entries.LocalAssumEntry c ->
+ let t = execute env c in
+ RelDecl.LocalAssum (Name id, check_assumption env c t)
let infer_local_decls env decls =
let rec inferec env = function
| (id, d) :: l ->
let (env, l) = inferec env l in
let d = infer_local_decl env id d in
- (push_rel d env, Context.Rel.add d l)
- | [] -> (env, Context.Rel.empty) in
+ (push_rel d env, Context.Rel.add d l)
+ | [] -> (env, Context.Rel.empty)
+ in
inferec env decls
+
+let judge_of_prop = make_judge mkProp type1
+let judge_of_set = make_judge mkSet type1
+let judge_of_type u = make_judge (mkType u) (type_of_type u)
+
+let judge_of_prop_contents = function
+ | Null -> judge_of_prop
+ | Pos -> judge_of_set
+
+let judge_of_relative env k = make_judge (mkRel k) (type_of_relative env k)
+
+let judge_of_variable env x = make_judge (mkVar x) (type_of_variable env x)
+
+let judge_of_constant env cst = make_judge (mkConstU cst) (type_of_constant env cst)
+let judge_of_constant_knowing_parameters env cst args =
+ make_judge (mkConstU cst) (type_of_constant_knowing_parameters env cst args)
+
+let judge_of_projection env p cj =
+ make_judge (mkProj (p,cj.uj_val)) (type_of_projection env p cj.uj_val cj.uj_type)
+
+let dest_judgev v =
+ Array.map j_val v, Array.map j_type v
+
+let judge_of_apply env funj argjv =
+ let args, argtys = dest_judgev argjv in
+ make_judge (mkApp (funj.uj_val, args)) (type_of_apply env funj.uj_val funj.uj_type args argtys)
+
+let judge_of_abstraction env x varj bodyj =
+ make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val))
+ (type_of_abstraction env x varj.utj_val bodyj.uj_type)
+
+let judge_of_product env x varj outj =
+ make_judge (mkProd (x, varj.utj_val, outj.utj_val))
+ (mkSort (sort_of_product env varj.utj_type outj.utj_type))
+
+let judge_of_letin env name defj typj j =
+ make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val))
+ (subst1 defj.uj_val j.uj_type)
+
+let judge_of_cast env cj k tj =
+ let () = check_cast env cj.uj_val cj.uj_type k tj.utj_val in
+ let c = match k with | REVERTcast -> cj.uj_val | _ -> mkCast (cj.uj_val, k, tj.utj_val) in
+ make_judge c tj.utj_val
+
+let judge_of_inductive env indu =
+ make_judge (mkIndU indu) (type_of_inductive env indu)
+
+let judge_of_constructor env cu =
+ make_judge (mkConstructU cu) (type_of_constructor env cu)
+
+let judge_of_case env ci pj cj lfj =
+ let lf, lft = dest_judgev lfj in
+ make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft))
+ (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft)
+
+let type_of_projection_constant env (p,u) =
+ let cst = Projection.constant p in
+ let cb = lookup_constant cst env in
+ match cb.const_proj with
+ | Some pb ->
+ if cb.const_polymorphic then
+ Vars.subst_instance_constr u pb.proj_type
+ else pb.proj_type
+ | None -> raise (Invalid_argument "type_of_projection: not a projection")
+
+(* Instantiation of terms on real arguments. *)
+
+(* Make a type polymorphic if an arity *)
+
+let extract_level env p =
+ let _,c = dest_prod_assum env p in
+ match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None
+
+let extract_context_levels env l =
+ let fold l = function
+ | RelDecl.LocalAssum (_,p) -> extract_level env p :: l
+ | RelDecl.LocalDef _ -> l
+ in
+ List.fold_left fold [] l
+
+let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} =
+ let params, ccl = dest_prod_assum env t in
+ match kind_of_term ccl with
+ | Sort (Type u) ->
+ let ind, l = decompose_app (whd_all env c) in
+ if isInd ind && List.is_empty l then
+ let mis = lookup_mind_specif env (fst (destInd ind)) in
+ let nparams = Inductive.inductive_params mis in
+ let paramsl = CList.lastn nparams params in
+ let param_ccls = extract_context_levels env paramsl in
+ let s = { template_param_levels = param_ccls; template_level = u} in
+ TemplateArity (params,s)
+ else RegularArity t
+ | _ ->
+ RegularArity t
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 81fd1427d0..007acae604 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -15,7 +15,7 @@ open Declarations
(** {6 Typing functions (not yet tagged as safe) }
- They return unsafe judgments that are "in context" of a set of
+ They return unsafe judgments that are "in context" of a set of
(local) universe variables (the ones that appear in the term)
and associated constraints. In case of polymorphic definitions,
these variables and constraints will be generalized.
@@ -91,9 +91,6 @@ val judge_of_cast :
val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment
-(* val judge_of_inductive_knowing_parameters : *)
-(* env -> inductive -> unsafe_judgment array -> unsafe_judgment *)
-
val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment
(** {6 Type of Cases. } *)
@@ -101,24 +98,15 @@ val judge_of_case : env -> case_info
-> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
-> unsafe_judgment
-(** Typecheck general fixpoint (not checking guard conditions) *)
-val type_fixpoint : env -> Name.t array -> types array
- -> unsafe_judgment array -> unit
-
-val type_of_constant : env -> pconstant -> types constrained
-
val type_of_constant_type : env -> constant_type -> types
-val type_of_projection : env -> Names.projection puniverses -> types
+val type_of_projection_constant : env -> Names.projection puniverses -> types
val type_of_constant_in : env -> pconstant -> types
val type_of_constant_type_knowing_parameters :
env -> constant_type -> types Lazy.t array -> types
-val type_of_constant_knowing_parameters :
- env -> pconstant -> types Lazy.t array -> types constrained
-
val type_of_constant_knowing_parameters_in :
env -> pconstant -> types Lazy.t array -> types
@@ -127,4 +115,4 @@ val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
constant_type
(** Check that hyps are included in env and fails with error otherwise *)
-val check_hyps_inclusion : env -> constr -> Context.Named.t -> unit
+val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Context.Named.t -> unit
diff --git a/kernel/vars.ml b/kernel/vars.ml
index b27e27fdac..4affb5f9fb 100644
--- a/kernel/vars.ml
+++ b/kernel/vars.ml
@@ -181,6 +181,15 @@ let subst_of_rel_context_instance sign l =
let adjust_subst_to_rel_context sign l =
List.rev (subst_of_rel_context_instance sign l)
+let adjust_rel_to_rel_context sign n =
+ let rec aux sign =
+ let open RelDecl in
+ match sign with
+ | LocalAssum _ :: sign' -> let (n',p) = aux sign' in (n'+1,p)
+ | LocalDef (_,c,_)::sign' -> let (n',p) = aux sign' in (n'+1,if n'<n then p+1 else p)
+ | [] -> (0,n)
+ in snd (aux sign)
+
(* (thin_val sigma) removes identity substitutions from sigma *)
let rec thin_val = function
diff --git a/kernel/vars.mli b/kernel/vars.mli
index 574d50eccb..f7535e6d8f 100644
--- a/kernel/vars.mli
+++ b/kernel/vars.mli
@@ -73,6 +73,10 @@ val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl
(** For compatibility: returns the substitution reversed *)
val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list
+(** Take an index in an instance of a context and returns its index wrt to
+ the full context (e.g. 2 in [x:A;y:=b;z:C] is 3, i.e. a reference to z) *)
+val adjust_rel_to_rel_context : Context.Rel.t -> int -> int
+
(** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an]
for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-03 06:02:51 +0000