aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/constr.ml67
-rw-r--r--kernel/constr.mli3
-rw-r--r--kernel/declarations.ml2
-rw-r--r--kernel/declareops.ml2
-rw-r--r--kernel/entries.ml6
-rw-r--r--kernel/environ.ml68
-rw-r--r--kernel/environ.mli13
-rw-r--r--kernel/indtypes.ml14
-rw-r--r--kernel/indtypes.mli13
-rw-r--r--kernel/nativeconv.ml5
-rw-r--r--kernel/nativelib.ml1
-rw-r--r--kernel/reduction.ml81
-rw-r--r--kernel/safe_typing.ml18
-rw-r--r--kernel/safe_typing.mli9
-rw-r--r--kernel/sorts.ml10
-rw-r--r--kernel/sorts.mli4
-rw-r--r--kernel/term_typing.ml10
-rw-r--r--kernel/typeops.ml3
-rw-r--r--kernel/typeops.mli3
-rw-r--r--kernel/univ.ml47
-rw-r--r--kernel/univ.mli10
-rw-r--r--kernel/vconv.ml2
22 files changed, 287 insertions, 104 deletions
diff --git a/kernel/constr.ml b/kernel/constr.ml
index d7f35da10d..704e6de6b8 100644
--- a/kernel/constr.ml
+++ b/kernel/constr.ml
@@ -1338,3 +1338,70 @@ type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt
type rel_context = rel_declaration list
type named_context = named_declaration list
type compacted_context = compacted_declaration list
+
+(* Sorts and sort family *)
+
+let debug_print_fix pr_constr ((t,i),(lna,tl,bl)) =
+ let open Pp in
+ let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
+ hov 1
+ (str"fix " ++ int i ++ spc() ++ str"{" ++
+ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
+ Name.print na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
+ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
+ str"}")
+
+let pr_puniverses p u =
+ if Univ.Instance.is_empty u then p
+ else Pp.(p ++ str"(*" ++ Univ.Instance.pr Univ.Level.pr u ++ str"*)")
+
+(* Minimalistic constr printer, typically for debugging *)
+
+let rec debug_print c =
+ let open Pp in
+ match kind c with
+ | Rel n -> str "#"++int n
+ | Meta n -> str "Meta(" ++ int n ++ str ")"
+ | Var id -> Id.print id
+ | Sort s -> Sorts.debug_print s
+ | Cast (c,_, t) -> hov 1
+ (str"(" ++ debug_print c ++ cut() ++
+ str":" ++ debug_print t ++ str")")
+ | Prod (Name(id),t,c) -> hov 1
+ (str"forall " ++ Id.print id ++ str":" ++ debug_print t ++ str"," ++
+ spc() ++ debug_print c)
+ | Prod (Anonymous,t,c) -> hov 0
+ (str"(" ++ debug_print t ++ str " ->" ++ spc() ++
+ debug_print c ++ str")")
+ | Lambda (na,t,c) -> hov 1
+ (str"fun " ++ Name.print na ++ str":" ++
+ debug_print t ++ str" =>" ++ spc() ++ debug_print c)
+ | LetIn (na,b,t,c) -> hov 0
+ (str"let " ++ Name.print na ++ str":=" ++ debug_print b ++
+ str":" ++ brk(1,2) ++ debug_print t ++ cut() ++
+ debug_print c)
+ | App (c,l) -> hov 1
+ (str"(" ++ debug_print c ++ spc() ++
+ prlist_with_sep spc debug_print (Array.to_list l) ++ str")")
+ | Evar (e,l) -> hov 1
+ (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++
+ prlist_with_sep spc debug_print (Array.to_list l) ++str"}")
+ | Const (c,u) -> str"Cst(" ++ pr_puniverses (Constant.debug_print c) u ++ str")"
+ | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i) u ++ str")"
+ | Construct (((sp,i),j),u) ->
+ str"Constr(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")"
+ | Proj (p,c) -> str"Proj(" ++ Constant.debug_print (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ debug_print c ++ str")"
+ | Case (_ci,p,c,bl) -> v 0
+ (hv 0 (str"<"++debug_print p++str">"++ cut() ++ str"Case " ++
+ debug_print c ++ str"of") ++ cut() ++
+ prlist_with_sep (fun _ -> brk(1,2)) debug_print (Array.to_list bl) ++
+ cut() ++ str"end")
+ | Fix f -> debug_print_fix debug_print f
+ | CoFix(i,(lna,tl,bl)) ->
+ let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
+ hov 1
+ (str"cofix " ++ int i ++ spc() ++ str"{" ++
+ v 0 (prlist_with_sep spc (fun (na,ty,bd) ->
+ Name.print na ++ str":" ++ debug_print ty ++
+ cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++
+ str"}")
diff --git a/kernel/constr.mli b/kernel/constr.mli
index 8753c20eac..1be1f63ff7 100644
--- a/kernel/constr.mli
+++ b/kernel/constr.mli
@@ -590,3 +590,6 @@ val case_info_hash : case_info -> int
(*********************************************************************)
val hcons : constr -> constr
+
+val debug_print : constr -> Pp.t
+val debug_print_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index 61fcb4832a..c1b38b4156 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -66,6 +66,8 @@ type typing_flags = {
check_universes : bool; (** If [false] universe constraints are not checked *)
conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *)
share_reduction : bool; (** Use by-need reduction algorithm *)
+ enable_VM : bool; (** If [false], all VM conversions fall back to interpreted ones *)
+ enable_native_compiler : bool; (** If [false], all native conversions fall back to VM ones *)
}
(* some contraints are in constant_constraints, some other may be in
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
index d995786d97..3ed599c538 100644
--- a/kernel/declareops.ml
+++ b/kernel/declareops.ml
@@ -22,6 +22,8 @@ let safe_flags oracle = {
check_universes = true;
conv_oracle = oracle;
share_reduction = true;
+ enable_VM = true;
+ enable_native_compiler = true;
}
(** {6 Arities } *)
diff --git a/kernel/entries.ml b/kernel/entries.ml
index c5bcd74072..58bb782f15 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -30,8 +30,8 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1];
type inductive_universes =
| Monomorphic_ind_entry of Univ.ContextSet.t
- | Polymorphic_ind_entry of Univ.UContext.t
- | Cumulative_ind_entry of Univ.CumulativityInfo.t
+ | Polymorphic_ind_entry of Name.t array * Univ.UContext.t
+ | Cumulative_ind_entry of Name.t array * Univ.CumulativityInfo.t
type one_inductive_entry = {
mind_entry_typename : Id.t;
@@ -60,7 +60,7 @@ type 'a const_entry_body = 'a proof_output Future.computation
type constant_universes_entry =
| Monomorphic_const_entry of Univ.ContextSet.t
- | Polymorphic_const_entry of Univ.UContext.t
+ | Polymorphic_const_entry of Name.t array * Univ.UContext.t
type 'a in_constant_universes_entry = 'a * constant_universes_entry
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 3b7e3ae544..f61dd0c101 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -350,9 +350,6 @@ let map_universes f env =
{ env with env_stratification =
{ s with env_universes = f s.env_universes } }
-let set_universes env u =
- { env with env_stratification = { env.env_stratification with env_universes = u } }
-
let add_constraints c env =
if Univ.Constraint.is_empty c then env
else map_universes (UGraph.merge_constraints c) env
@@ -405,19 +402,12 @@ let add_constant_key kn cb linkinfo env =
let add_constant kn cb env =
add_constant_key kn cb no_link_info env
-let constraints_of cb u =
- match cb.const_universes with
- | Monomorphic_const _ -> Univ.Constraint.empty
- | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx
-
(* constant_type gives the type of a constant *)
let constant_type env (kn,u) =
let cb = lookup_constant kn env in
- match cb.const_universes with
- | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty
- | Polymorphic_const _ctx ->
- let csts = constraints_of cb u in
- (subst_instance_constr u cb.const_type, csts)
+ let uctx = Declareops.constant_polymorphic_context cb in
+ let csts = Univ.AUContext.instantiate u uctx in
+ (subst_instance_constr u cb.const_type, csts)
type const_evaluation_result = NoBody | Opaque
@@ -425,20 +415,24 @@ exception NotEvaluableConst of const_evaluation_result
let constant_value_and_type env (kn, u) =
let cb = lookup_constant kn env in
- if Declareops.constant_is_polymorphic cb then
- let cst = constraints_of cb u in
- let b' = match cb.const_body with
- | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body))
- | OpaqueDef _ -> None
- | Undef _ -> None
- in
- b', subst_instance_constr u cb.const_type, cst
- else
- let b' = match cb.const_body with
- | Def l_body -> Some (Mod_subst.force_constr l_body)
- | OpaqueDef _ -> None
- | Undef _ -> None
- in b', cb.const_type, Univ.Constraint.empty
+ let uctx = Declareops.constant_polymorphic_context cb in
+ let cst = Univ.AUContext.instantiate u uctx in
+ let b' = match cb.const_body with
+ | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body))
+ | OpaqueDef _ -> None
+ | Undef _ -> None
+ in
+ b', subst_instance_constr u cb.const_type, cst
+
+let body_of_constant_body env cb =
+ let otab = opaque_tables env in
+ match cb.const_body with
+ | Undef _ ->
+ None
+ | Def c ->
+ Some (Mod_subst.force_constr c, Declareops.constant_polymorphic_context cb)
+ | OpaqueDef o ->
+ Some (Opaqueproof.force_proof otab o, Declareops.constant_polymorphic_context cb)
(* These functions should be called under the invariant that [env]
already contains the constraints corresponding to the constant
@@ -447,9 +441,7 @@ let constant_value_and_type env (kn, u) =
(* constant_type gives the type of a constant *)
let constant_type_in env (kn,u) =
let cb = lookup_constant kn env in
- if Declareops.constant_is_polymorphic cb then
- subst_instance_constr u cb.const_type
- else cb.const_type
+ subst_instance_constr u cb.const_type
let constant_value_in env (kn,u) =
let cb = lookup_constant kn env in
@@ -694,6 +686,22 @@ let is_polymorphic env r =
| IndRef ind -> polymorphic_ind ind env
| ConstructRef cstr -> polymorphic_ind (inductive_of_constructor cstr) env
+let is_template_polymorphic env r =
+ let open Names.GlobRef in
+ match r with
+ | VarRef _id -> false
+ | ConstRef _c -> false
+ | IndRef ind -> template_polymorphic_ind ind env
+ | ConstructRef cstr -> template_polymorphic_ind (inductive_of_constructor cstr) env
+
+let is_type_in_type env r =
+ let open Names.GlobRef in
+ match r with
+ | VarRef _id -> false
+ | ConstRef c -> type_in_type_constant c env
+ | IndRef ind -> type_in_type_ind ind env
+ | ConstructRef cstr -> type_in_type_ind (inductive_of_constructor cstr) env
+
(*spiwack: the following functions assemble the pieces of the retroknowledge
note that the "consistent" register function is available in the module
Safetyping, Environ only synchronizes the proactive and the reactive parts*)
diff --git a/kernel/environ.mli b/kernel/environ.mli
index 43bfe7c2fb..c285f907fc 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -155,11 +155,6 @@ val named_body : variable -> env -> constr option
val fold_named_context :
(env -> Constr.named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
-val set_universes : env -> UGraph.t -> env
-(** This is used to update universes during a proof for the sake of
- evar map-unaware functions, eg [Typing] calling
- [Typeops.check_hyps_inclusion]. *)
-
(** Recurrence on [named_context] starting from younger decl *)
val fold_named_context_reverse :
('a -> Constr.named_declaration -> 'a) -> init:'a -> env -> 'a
@@ -211,6 +206,12 @@ val constant_value_and_type : env -> Constant.t puniverses ->
polymorphic *)
val constant_context : env -> Constant.t -> Univ.AUContext.t
+(** Returns the body of the constant if it has any, and the polymorphic context
+ it lives in. For monomorphic constant, the latter is empty, and for
+ polymorphic constants, the term contains De Bruijn universe variables that
+ need to be instantiated. *)
+val body_of_constant_body : env -> constant_body -> (Constr.constr * Univ.AUContext.t) option
+
(* These functions should be called under the invariant that [env]
already contains the constraints corresponding to the constant
application. *)
@@ -320,6 +321,8 @@ val apply_to_hyp : named_context_val -> variable ->
val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declaration) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val
val is_polymorphic : env -> Names.GlobRef.t -> bool
+val is_template_polymorphic : env -> GlobRef.t -> bool
+val is_type_in_type : env -> GlobRef.t -> bool
open Retroknowledge
(** functions manipulating the retroknowledge
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 0346026aa4..20c90bc05a 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -268,8 +268,8 @@ let typecheck_inductive env mie =
let env' =
match mie.mind_entry_universes with
| Monomorphic_ind_entry ctx -> push_context_set ctx env
- | Polymorphic_ind_entry ctx -> push_context ctx env
- | Cumulative_ind_entry cumi -> push_context (Univ.CumulativityInfo.univ_context cumi) env
+ | Polymorphic_ind_entry (_, ctx) -> push_context ctx env
+ | Cumulative_ind_entry (_, cumi) -> push_context (Univ.CumulativityInfo.univ_context cumi) env
in
let env_params = check_context env' mie.mind_entry_params in
let paramsctxt = mie.mind_entry_params in
@@ -407,7 +407,7 @@ let typecheck_inductive env mie =
match mie.mind_entry_universes with
| Monomorphic_ind_entry _ -> ()
| Polymorphic_ind_entry _ -> ()
- | Cumulative_ind_entry cumi -> check_subtyping cumi paramsctxt env_arities inds
+ | Cumulative_ind_entry (_, cumi) -> check_subtyping cumi paramsctxt env_arities inds
in (env_arities, env_ar_par, paramsctxt, inds)
(************************************************************************)
@@ -851,12 +851,12 @@ let compute_projections (kn, i as ind) mib =
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
+ | Polymorphic_ind_entry (nas, ctx) ->
+ let (inst, auctx) = Univ.abstract_universes nas 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
+ | Cumulative_ind_entry (nas, cumi) ->
+ let (inst, acumi) = Univ.abstract_cumulativity_info nas cumi in
let inst = Univ.make_instance_subst inst in
(inst, Cumulative_ind acumi)
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index cb09cfa827..a827c17683 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -34,6 +34,19 @@ type inductive_error =
exception InductiveError of inductive_error
+val infos_and_sort : env -> constr -> Univ.Universe.t
+
+val check_subtyping_arity_constructor : env -> (constr -> constr) -> types -> int -> bool -> unit
+
+val check_positivity : chkpos:bool ->
+ Names.MutInd.t ->
+ Environ.env ->
+ (Constr.constr, Constr.types) Context.Rel.pt ->
+ Declarations.recursivity_kind ->
+ ('a * Names.Id.t list * Constr.types array *
+ (('b, 'c) Context.Rel.pt * 'd))
+ array -> Int.t * Declarations.recarg Rtree.t array
+
(** The following function does checks on inductive declarations. *)
val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
index 054b6a2d17..f5d7ab3c9d 100644
--- a/kernel/nativeconv.ml
+++ b/kernel/nativeconv.ml
@@ -14,7 +14,8 @@ open Nativelib
open Reduction
open Util
open Nativevalues
-open Nativecode
+open Nativecode
+open Environ
(** This module implements the conversion test by compiling to OCaml code *)
@@ -142,7 +143,7 @@ let warn_no_native_compiler =
strbrk " falling back to VM conversion test.")
let native_conv_gen pb sigma env univs t1 t2 =
- if not Coq_config.native_compiler then begin
+ if not (typing_flags env).Declarations.enable_native_compiler then begin
warn_no_native_compiler ();
Vconv.vm_conv_gen pb env univs t1 t2
end
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
index d294f2060e..833e4082f0 100644
--- a/kernel/nativelib.ml
+++ b/kernel/nativelib.ml
@@ -66,7 +66,6 @@ let warn_native_compiler_failed =
CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print
let call_compiler ?profile:(profile=false) ml_filename =
- let () = assert Coq_config.native_compiler in
let load_path = !get_load_paths () in
let load_path = List.map (fun dn -> dn / output_dir) load_path in
let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 18697d07e5..5515ff9767 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -68,7 +68,7 @@ type lft_constr_stack_elt =
Zlapp of (lift * fconstr) array
| Zlproj of Projection.Repr.t * lift
| Zlfix of (lift * fconstr) * lft_constr_stack
- | Zlcase of case_info * lift * fconstr * fconstr array
+ | Zlcase of case_info * lift * constr * constr array * fconstr subs
and lft_constr_stack = lft_constr_stack_elt list
let rec zlapp v = function
@@ -102,7 +102,7 @@ let pure_stack lfts stk =
let (lfx,pa) = pure_rec l a in
(l, Zlfix((lfx,fx),pa)::pstk)
| (ZcaseT(ci,p,br,e),(l,pstk)) ->
- (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk))
+ (l,Zlcase(ci,l,p,br,e)::pstk))
in
snd (pure_rec lfts stk)
@@ -288,31 +288,13 @@ let conv_table_key infos k1 k2 cuniv =
| RelKey n, RelKey n' when Int.equal n n' -> cuniv
| _ -> raise NotConvertible
-let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
- let rec cmp_rec pstk1 pstk2 cuniv =
- match (pstk1,pstk2) with
- | (z1::s1, z2::s2) ->
- let cu1 = cmp_rec s1 s2 cuniv in
- (match (z1,z2) with
- | (Zlapp a1,Zlapp a2) ->
- Array.fold_right2 f a1 a2 cu1
- | (Zlproj (c1,_l1),Zlproj (c2,_l2)) ->
- if not (Projection.Repr.equal c1 c2) then
- raise NotConvertible
- else cu1
- | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
- let cu2 = f fx1 fx2 cu1 in
- cmp_rec a1 a2 cu2
- | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) ->
- if not (fmind ci1.ci_ind ci2.ci_ind) then
- raise NotConvertible;
- let cu2 = f (l1,p1) (l2,p2) cu1 in
- Array.fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2
- | _ -> assert false)
- | _ -> cuniv in
- if compare_stack_shape stk1 stk2 then
- cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv
- else raise NotConvertible
+exception IrregularPatternShape
+
+let rec skip_pattern n c =
+ if Int.equal n 0 then c
+ else match kind c with
+ | Lambda (_, _, c) -> skip_pattern (pred n) c
+ | _ -> raise IrregularPatternShape
type conv_tab = {
cnv_inf : clos_infos;
@@ -611,10 +593,31 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
| FProd _ | FEvar _), _ -> raise NotConvertible
and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv =
- compare_stacks
- (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv)
- (eq_ind)
- lft1 stk1 lft2 stk2 cuniv
+ let f (l1, t1) (l2, t2) cuniv = ccnv CONV l2r infos l1 l2 t1 t2 cuniv in
+ let rec cmp_rec pstk1 pstk2 cuniv =
+ match (pstk1,pstk2) with
+ | (z1::s1, z2::s2) ->
+ let cu1 = cmp_rec s1 s2 cuniv in
+ (match (z1,z2) with
+ | (Zlapp a1,Zlapp a2) ->
+ Array.fold_right2 f a1 a2 cu1
+ | (Zlproj (c1,_l1),Zlproj (c2,_l2)) ->
+ if not (Projection.Repr.equal c1 c2) then
+ raise NotConvertible
+ else cu1
+ | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
+ let cu2 = f fx1 fx2 cu1 in
+ cmp_rec a1 a2 cu2
+ | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) ->
+ if not (eq_ind ci1.ci_ind ci2.ci_ind) then
+ raise NotConvertible;
+ let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in
+ convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2
+ | _ -> assert false)
+ | _ -> cuniv in
+ if compare_stack_shape stk1 stk2 then
+ cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv
+ else raise NotConvertible
and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
let lv1 = Array.length v1 in
@@ -629,6 +632,22 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
fold 0 cuniv
else raise NotConvertible
+and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv =
+ (** Skip comparison of the pattern types. We know that the two terms are
+ living in a common type, thus this check is useless. *)
+ let fold n c1 c2 cuniv = match skip_pattern n c1, skip_pattern n c2 with
+ | (c1, c2) ->
+ let lft1 = el_liftn n lft1 in
+ let lft2 = el_liftn n lft2 in
+ let e1 = subs_liftn n e1 in
+ let e2 = subs_liftn n e2 in
+ ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv
+ | exception IrregularPatternShape ->
+ (** Might happen due to a shape invariant that is not enforced *)
+ ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv
+ in
+ Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv
+
let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 =
let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in
let infos = create_clos_infos ~evars reds env in
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 12f9592ab7..df10398b2f 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -194,6 +194,18 @@ let set_engagement c senv =
let set_typing_flags c senv =
{ senv with env = Environ.set_typing_flags c senv.env }
+let set_share_reduction b senv =
+ let flags = Environ.typing_flags senv.env in
+ set_typing_flags { flags with share_reduction = b } senv
+
+let set_VM b senv =
+ let flags = Environ.typing_flags senv.env in
+ set_typing_flags { flags with enable_VM = b } senv
+
+let set_native_compiler b senv =
+ let flags = Environ.typing_flags senv.env in
+ set_typing_flags { flags with enable_native_compiler = b } senv
+
(** Check that the engagement [c] expected by a library matches
the current (initial) one *)
let check_engagement env expected_impredicative_set =
@@ -670,7 +682,7 @@ let constant_entry_of_side_effect cb u =
| Monomorphic_const uctx ->
Monomorphic_const_entry uctx
| Polymorphic_const auctx ->
- Polymorphic_const_entry (Univ.AUContext.repr auctx)
+ Polymorphic_const_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx)
in
let pt =
match cb.const_body, u with
@@ -1049,6 +1061,8 @@ type compiled_library = {
comp_natsymbs : Nativecode.symbols
}
+let module_of_library lib = lib.comp_mod
+
type native_library = Nativecode.global list
let get_library_native_symbols senv dir =
@@ -1190,7 +1204,7 @@ loaded by side-effect once and for all (like it is done in OCaml).
Would this be correct with respect to undo's and stuff ?
*)
-let set_strategy e k l = { e with env =
+let set_strategy k l e = { e with env =
(Environ.set_oracle e.env
(Conv_oracle.set_strategy (Environ.oracle e.env) k l)) }
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 26fa91adbd..7af773e3bc 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -137,6 +137,11 @@ val add_constraints :
(** Setting the type theory flavor *)
val set_engagement : Declarations.engagement -> safe_transformer0
val set_typing_flags : Declarations.typing_flags -> safe_transformer0
+val set_share_reduction : bool -> safe_transformer0
+val set_VM : bool -> safe_transformer0
+val set_native_compiler : bool -> safe_transformer0
+
+val check_engagement : Environ.env -> Declarations.set_predicativity -> unit
(** {6 Interactive module functions } *)
@@ -174,6 +179,8 @@ type compiled_library
type native_library = Nativecode.global list
+val module_of_library : compiled_library -> Declarations.module_body
+
val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.symbols
val start_library : DirPath.t -> ModPath.t safe_transformer
@@ -217,4 +224,4 @@ val register :
val register_inline : Constant.t -> safe_transformer0
val set_strategy :
- safe_environment -> Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_environment
+ Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_transformer0
diff --git a/kernel/sorts.ml b/kernel/sorts.ml
index a7bb08f5b6..566dce04c6 100644
--- a/kernel/sorts.ml
+++ b/kernel/sorts.ml
@@ -102,3 +102,13 @@ module Hsorts =
end)
let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ
+
+let debug_print = function
+ | Set -> Pp.(str "Set")
+ | Prop -> Pp.(str "Prop")
+ | Type u -> Pp.(str "Type(" ++ Univ.Universe.pr u ++ str ")")
+
+let pr_sort_family = function
+ | InSet -> Pp.(str "Set")
+ | InProp -> Pp.(str "Prop")
+ | InType -> Pp.(str "Type")
diff --git a/kernel/sorts.mli b/kernel/sorts.mli
index cac6229b91..6c5ce4df80 100644
--- a/kernel/sorts.mli
+++ b/kernel/sorts.mli
@@ -41,3 +41,7 @@ end
val univ_of_sort : t -> Univ.Universe.t
val sort_of_univ : Univ.Universe.t -> t
+
+val debug_print : t -> Pp.t
+
+val pr_sort_family : family -> Pp.t
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index fb1b3e236c..35fa871b4e 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -68,8 +68,8 @@ let feedback_completion_typecheck =
let abstract_constant_universes = function
| Monomorphic_const_entry uctx ->
Univ.empty_level_subst, Monomorphic_const uctx
- | Polymorphic_const_entry uctx ->
- let sbst, auctx = Univ.abstract_universes uctx in
+ | Polymorphic_const_entry (nas, uctx) ->
+ let sbst, auctx = Univ.abstract_universes nas uctx in
let sbst = Univ.make_instance_subst sbst in
sbst, Polymorphic_const auctx
@@ -78,7 +78,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
| ParameterEntry (ctx,(t,uctx),nl) ->
let env = match uctx with
| Monomorphic_const_entry uctx -> push_context_set ~strict:true uctx env
- | Polymorphic_const_entry uctx -> push_context ~strict:false uctx env
+ | Polymorphic_const_entry (_, uctx) -> push_context ~strict:false uctx env
in
let j = infer env t in
let usubst, univs = abstract_constant_universes uctx in
@@ -150,7 +150,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
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 ->
+ | Polymorphic_const_entry (nas, 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
@@ -160,7 +160,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
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, auctx = Univ.abstract_universes nas uctx in
let sbst = Univ.make_instance_subst sbst in
env, sbst, Polymorphic_const auctx
in
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 1bb2d3c79c..c8fd83c8a9 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -91,7 +91,8 @@ let type_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 f c sign =
+let check_hyps_inclusion env ?evars f c sign =
+ let conv env a b = conv env ?evars a b in
Context.Named.fold_outside
(fun d1 () ->
let open Context.Named.Declaration in
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index d24002065b..4193324136 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -116,4 +116,5 @@ val constr_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t
(** {6 Miscellaneous. } *)
(** Check that hyps are included in env and fails with error otherwise *)
-val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Constr.named_context -> unit
+val check_hyps_inclusion : env -> ?evars:((existential->constr option) * UGraph.t) ->
+ ('a -> constr) -> 'a -> Constr.named_context -> unit
diff --git a/kernel/univ.ml b/kernel/univ.ml
index d09b54e7ec..0edf750997 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -937,17 +937,30 @@ let hcons_universe_context = UContext.hcons
module AUContext =
struct
- include UContext
+ type t = Names.Name.t array constrained
let repr (inst, cst) =
- (Array.mapi (fun i _l -> Level.var i) inst, cst)
+ (Array.init (Array.length inst) (fun i -> Level.var i), cst)
- let pr f ?variance ctx = pr f ?variance (repr ctx)
+ let pr f ?variance ctx = UContext.pr f ?variance (repr ctx)
let instantiate inst (u, cst) =
assert (Array.length u = Array.length inst);
subst_instance_constraints inst cst
+ let names (nas, _) = nas
+
+ let hcons (univs, cst) =
+ (Array.map Names.Name.hcons univs, hcons_constraints cst)
+
+ let empty = ([||], Constraint.empty)
+
+ let is_empty (nas, cst) = Array.is_empty nas && Constraint.is_empty cst
+
+ let union (nas, cst) (nas', cst') = (Array.append nas nas', Constraint.union cst cst')
+
+ let size (nas, _) = Array.length nas
+
end
let hcons_abstract_universe_context = AUContext.hcons
@@ -993,7 +1006,22 @@ end
let hcons_cumulativity_info = CumulativityInfo.hcons
-module ACumulativityInfo = CumulativityInfo
+module ACumulativityInfo =
+struct
+ type t = AUContext.t * Variance.t array
+
+ let pr prl (univs, variance) =
+ AUContext.pr prl ~variance univs
+
+ let hcons (univs, variance) = (* should variance be hconsed? *)
+ (AUContext.hcons univs, variance)
+
+ let univ_context (univs, _subtypcst) = univs
+ let variance (_univs, variance) = variance
+
+ let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts
+ let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts
+end
let hcons_abstract_cumulativity_info = ACumulativityInfo.hcons
@@ -1145,19 +1173,20 @@ let make_inverse_instance_subst i =
LMap.empty arr
let make_abstract_instance (ctx, _) =
- Array.mapi (fun i _l -> Level.var i) ctx
+ Array.init (Array.length ctx) (fun i -> Level.var i)
-let abstract_universes ctx =
+let abstract_universes nas ctx =
let instance = UContext.instance ctx in
+ let () = assert (Int.equal (Array.length nas) (Instance.length instance)) in
let subst = make_instance_subst instance in
let cstrs = subst_univs_level_constraints subst
(UContext.constraints ctx)
in
- let ctx = UContext.make (instance, cstrs) in
+ let ctx = (nas, cstrs) in
instance, ctx
-let abstract_cumulativity_info (univs, variance) =
- let subst, univs = abstract_universes univs in
+let abstract_cumulativity_info nas (univs, variance) =
+ let subst, univs = abstract_universes nas univs in
subst, (univs, variance)
let rec compact_univ s vars i u =
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 7ac8247ca4..de7b334ae4 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -336,9 +336,6 @@ sig
val empty : t
val is_empty : t -> bool
- (** Don't use. *)
- val instance : t -> Instance.t
-
val size : t -> int
(** Keeps the order of the instances *)
@@ -347,6 +344,9 @@ sig
val instantiate : Instance.t -> t -> Constraint.t
(** Generate the set of instantiated Constraint.t **)
+ val names : t -> Names.Name.t array
+ (** Return the names of the bound universe variables *)
+
end
(** Universe info for cumulative inductive types: A context of
@@ -466,8 +466,8 @@ val make_instance_subst : Instance.t -> universe_level_subst
val make_inverse_instance_subst : Instance.t -> universe_level_subst
-val abstract_universes : UContext.t -> Instance.t * AUContext.t
-val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativityInfo.t
+val abstract_universes : Names.Name.t array -> UContext.t -> Instance.t * AUContext.t
+val abstract_cumulativity_info : Names.Name.t array -> 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/vconv.ml b/kernel/vconv.ml
index 5965853e1e..c1130e62c9 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -189,7 +189,7 @@ let warn_bytecode_compiler_failed =
strbrk "falling back to standard conversion")
let vm_conv_gen cv_pb env univs t1 t2 =
- if not Coq_config.bytecode_compiler then
+ if not (typing_flags env).Declarations.enable_VM then
Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None)
full_transparent_state env univs t1 t2
else
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 21:11:31 +0000