From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- kernel/byterun/coq_interp.c | 21 +- kernel/byterun/coq_memory.c | 6 - kernel/byterun/coq_memory.h | 1 - kernel/byterun/int64_emul.h | 2 - kernel/byterun/int64_native.h | 2 - kernel/cbytecodes.ml | 14 + kernel/cbytecodes.mli | 95 ++--- kernel/cbytegen.ml | 49 ++- kernel/cbytegen.mli | 13 +- kernel/cemitcodes.ml | 21 +- kernel/cemitcodes.mli | 7 +- kernel/closure.ml | 62 ++-- kernel/closure.mli | 72 ++-- kernel/conv_oracle.ml | 9 +- kernel/conv_oracle.mli | 16 +- kernel/cooking.ml | 36 +- kernel/cooking.mli | 13 +- kernel/csymtable.ml | 20 +- kernel/csymtable.mli | 10 + kernel/declarations.ml | 199 +++++++++-- kernel/declarations.mli | 179 +++++----- kernel/entries.ml | 22 +- kernel/entries.mli | 46 +-- kernel/environ.ml | 31 +- kernel/environ.mli | 105 +++--- kernel/esubst.ml | 10 +- kernel/esubst.mli | 61 ++-- kernel/indtypes.ml | 55 ++- kernel/indtypes.mli | 15 +- kernel/inductive.ml | 391 ++++++++++---------- kernel/inductive.mli | 51 ++- kernel/mod_subst.ml | 804 +++++++++++++++++------------------------- kernel/mod_subst.mli | 95 ++--- kernel/mod_typing.ml | 303 +++++++--------- kernel/mod_typing.mli | 46 ++- kernel/modops.ml | 404 +++++++++++---------- kernel/modops.mli | 94 +++-- kernel/names.ml | 277 +++++++++------ kernel/names.mli | 108 +++--- kernel/pre_env.ml | 9 +- kernel/pre_env.mli | 16 +- kernel/reduction.ml | 224 ++++++------ kernel/reduction.mli | 50 ++- kernel/retroknowledge.ml | 9 +- kernel/retroknowledge.mli | 32 +- kernel/safe_typing.ml | 578 ++++++++++++++++-------------- kernel/safe_typing.mli | 59 ++-- kernel/sign.ml | 12 +- kernel/sign.mli | 36 +- kernel/subtyping.ml | 168 ++++----- kernel/subtyping.mli | 6 +- kernel/term.ml | 727 +++++++++++++++++++++----------------- kernel/term.mli | 390 ++++++++++---------- kernel/term_typing.ml | 84 +++-- kernel/term_typing.mli | 14 +- kernel/type_errors.ml | 13 +- kernel/type_errors.mli | 19 +- kernel/typeops.ml | 60 ++-- kernel/typeops.mli | 42 +-- kernel/univ.ml | 570 +++++++++++++++++++++--------- kernel/univ.mli | 68 ++-- kernel/vconv.ml | 12 +- kernel/vconv.mli | 8 +- kernel/vm.ml | 64 +++- kernel/vm.mli | 43 ++- 65 files changed, 3822 insertions(+), 3256 deletions(-) (limited to 'kernel') diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a0cb4f1a..aab08d89 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -81,13 +81,6 @@ sp is a local copy of the global variable extern_sp. */ # define print_int(i) #endif -/* Wrapper pour caml_modify */ -#ifdef OCAML_307 -#define CAML_MODIFY(a,b) modify(a,b) -#else -#define CAML_MODIFY(a,b) caml_modify(a,b) -#endif - /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } @@ -158,7 +151,7 @@ sp is a local copy of the global variable extern_sp. */ #endif #endif -/* For signal handling, we highjack some code from the caml runtime */ +/* For signal handling, we hijack some code from the caml runtime */ extern intnat caml_signals_are_pending; extern intnat caml_pending_signals[]; @@ -671,7 +664,7 @@ value coq_interprete Field(accu, 0) = sp[0]; *sp = accu; /* mise a jour du block accumulate */ - CAML_MODIFY(&Field(p[i], 1),*sp); + caml_modify(&Field(p[i], 1),*sp); sp++; } pc += nfunc; @@ -842,7 +835,7 @@ value coq_interprete Instruct(SETFIELD0){ print_instr("SETFIELD0"); - CAML_MODIFY(&Field(accu, 0),*sp); + caml_modify(&Field(accu, 0),*sp); sp++; Next; } @@ -850,7 +843,7 @@ value coq_interprete Instruct(SETFIELD1){ int i, j, size, size_aux; print_instr("SETFIELD1"); - CAML_MODIFY(&Field(accu, 1),*sp); + caml_modify(&Field(accu, 1),*sp); sp++; Next; } @@ -868,9 +861,9 @@ value coq_interprete *sp = accu; Alloc_small(accu, 1, ATOM_COFIX_TAG); Field(accu, 0) = Field(Field(*sp, 1), 0); - CAML_MODIFY(&Field(*sp, 1), accu); + caml_modify(&Field(*sp, 1), accu); accu = *sp; sp++; - CAML_MODIFY(&Field(*sp, i), accu); + caml_modify(&Field(*sp, i), accu); } } sp++; @@ -879,7 +872,7 @@ value coq_interprete Instruct(SETFIELD){ print_instr("SETFIELD"); - CAML_MODIFY(&Field(accu, *pc),*sp); + caml_modify(&Field(accu, *pc),*sp); sp++; pc++; Next; } diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 91342108..00f5eb3b 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -50,12 +50,6 @@ value coq_static_alloc(value size) /* ML */ return (value) coq_stat_alloc((asize_t) Long_val(size)); } -value coq_static_free(value blk) /* ML */ -{ - coq_stat_free((void *) blk); - return Val_unit; -} - value accumulate_code(value unit) /* ML */ { return (value) accumulate; diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h index c0093a49..79e4d0fe 100644 --- a/kernel/byterun/coq_memory.h +++ b/kernel/byterun/coq_memory.h @@ -49,7 +49,6 @@ extern code_t accumulate; /* functions over global environment */ value coq_static_alloc(value size); /* ML */ -value coq_static_free(value string); /* ML */ value init_coq_vm(value unit); /* ML */ value re_init_coq_vm(value unit); /* ML */ diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h index 0a61ad79..86bee72e 100644 --- a/kernel/byterun/int64_emul.h +++ b/kernel/byterun/int64_emul.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */ - /* Software emulation of 64-bit integer arithmetic, for C compilers that do not support it. */ diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h index 4fc3c220..8a6a2664 100644 --- a/kernel/byterun/int64_native.h +++ b/kernel/byterun/int64_native.h @@ -11,8 +11,6 @@ /* */ /***********************************************************************/ -/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */ - /* Wrapper macros around native 64-bit integer arithmetic, so that it has the same interface as the software emulation provided in int64_emul.h */ diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index f4d0bb2b..8854f854 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -1,3 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* block array -> int -> bytecodes -> bytecodes) * block array - (* compilation function (see get_vm_constant_dynamic_info in + (** compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 0578c7b4..8da06f43 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -1,3 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* begin match kind_of_term f with - | Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *) + | Construct((kn,j),i) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in @@ -409,7 +421,7 @@ let rec str_const c = | _ -> Bconstr c end | Ind ind -> Bstrconst (Const_ind ind) - | Construct ((kn,j),i) -> (*arnaud: Construct ((kn,j),i as cstr) -> *) + | Construct ((kn,j),i) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -668,19 +680,6 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = -(*arnaud: let code_construct kn cont = - let f_cont = - let else_lbl = Label.create () in - Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: - Kaddint31:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) - Kgetglobal (get_allias !global_env kn):: - Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in *) fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant @@ -715,18 +714,11 @@ let compile env c = Format.print_flush(); *) init_code,!fun_code, Array.of_list fv -let compile_constant_body env body opaque boxed = - if opaque then BCconstant - else match body with - | None -> BCconstant - | Some sb -> +let compile_constant_body env = function + | Undef _ | OpaqueDef _ -> BCconstant + | Def sb -> let body = Declarations.force sb in - if boxed then - let res = compile env body in - let to_patch = to_memory res in - BCdefined(true, to_patch) - else - match kind_of_term body with + match kind_of_term body with | Const kn' -> (* we use the canonical name of the constant*) let con= constant_of_kn (canonical_con kn') in @@ -734,8 +726,11 @@ let compile_constant_body env body opaque boxed = | _ -> let res = compile env body in let to_patch = to_memory res in - BCdefined (false, to_patch) + BCdefined to_patch + +(* Shortcut of the previous function used during module strengthening *) +let compile_alias kn = BCallias (constant_of_kn (canonical_con kn)) (* spiwack: additional function which allow different part of compilation of the 31-bit integers *) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index f33fd6cb..d0bfd46c 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -7,20 +7,21 @@ open Pre_env val compile : env -> constr -> bytecodes * bytecodes * fv - (* init, fun, fv *) + (** init, fun, fv *) -val compile_constant_body : - env -> constr_substituted option -> bool -> bool -> body_code - (* opaque *) (* boxed *) +val compile_constant_body : env -> constant_def -> body_code +(** Shortcut of the previous function used during module strengthening *) -(* spiwack: this function contains the information needed to perform +val compile_alias : constant -> body_code + +(** spiwack: this function contains the information needed to perform the static compilation of int31 (trying and obtaining a 31-bit integer in processor representation at compile time) *) val compile_structured_int31 : bool -> constr array -> structured_constant -(* this function contains the information needed to perform +(** this function contains the information needed to perform the dynamic compilation of int31 (trying and obtaining a 31-bit integer in processor representation at runtime when it failed at compile time *) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 0b4df194..1f00a70e 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -1,3 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* BCdefined (b,subst_to_patch s tp) + | BCdefined tp -> BCdefined (subst_to_patch s tp) | BCallias kn -> BCallias (fst (subst_con s kn)) | BCconstant -> BCconstant @@ -338,11 +350,6 @@ let force = force subst_body_code let subst_to_patch_subst = subst_substituted -let is_boxed tps = - match force tps with - | BCdefined(b,_) -> b - | _ -> false - let repr_body_code = repr_substituted let to_memory (init_code, fun_code, fv) = diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 384146d2..287c3930 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -7,6 +7,7 @@ type reloc_info = | Reloc_getglobal of constant type patch = reloc_info * int + (* A virer *) val subst_patch : Mod_subst.substitution -> patch -> patch @@ -23,7 +24,7 @@ type to_patch = emitcodes * (patch list) * fv val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch type body_code = - | BCdefined of bool*to_patch + | BCdefined of to_patch | BCallias of constant | BCconstant @@ -34,12 +35,10 @@ val from_val : body_code -> to_patch_substituted val force : to_patch_substituted -> body_code -val is_boxed : to_patch_substituted -> bool - val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted val repr_body_code : to_patch_substituted -> Mod_subst.substitution list option * body_code val to_memory : bytecodes * bytecodes * fv -> to_patch - (* init code, fun code, fv *) + (** init code, fun code, fv *) diff --git a/kernel/closure.ml b/kernel/closure.ml index bb68835e..143d6eb4 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -1,12 +1,23 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* transparent_state -> reds val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool - val red_get_const : reds -> bool * evaluable_global_reference list end module RedFlags = (struct @@ -145,16 +158,6 @@ module RedFlags = (struct | DELTA -> (* Used for Rel/Var defined in context *) incr_cnt red.r_delta delta - let red_get_const red = - let p1,p2 = red.r_const in - let (b1,l1) = Idpred.elements p1 in - let (b2,l2) = Cpred.elements p2 in - if b1=b2 then - let l1' = List.map (fun x -> EvalVarRef x) l1 in - let l2' = List.map (fun x -> EvalConstRef x) l2 in - (b1, l1' @ l2') - else error "unrepresentable pair of predicate" - end : RedFlagsSig) open RedFlags @@ -511,7 +514,7 @@ let optimise_closure env c = let (c',(_,s)) = compact_constr (0,[]) c 1 in let env' = Array.map (fun i -> clos_rel env i) (Array.of_list s) in - (subs_cons (env', ESID 0),c') + (subs_cons (env', subs_id 0),c') let mk_lambda env t = let (env,t) = optimise_closure env t in @@ -644,7 +647,7 @@ let term_of_fconstr = | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx | _ -> to_constr term_of_fconstr_lift lfts v in - term_of_fconstr_lift ELID + term_of_fconstr_lift el_id @@ -678,16 +681,6 @@ let fapp_stack (m,stk) = zip m stk (strip_update_shift_app), a fix (get_nth_arg) or an abstraction (strip_update_shift, through get_arg). *) -(* optimised for the case where there are no shifts... *) -let strip_update_shift head stk = - assert (head.norm <> Red); - let rec strip_rec h depth = function - | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s - | Zupdate(m)::s -> - strip_rec (update m (h.norm,h.term)) depth s - | stk -> (depth,stk) in - strip_rec head 0 stk - (* optimised for the case where there are no shifts... *) let strip_update_shift_app head stk = assert (head.norm <> Red); @@ -705,15 +698,14 @@ let strip_update_shift_app head stk = let get_nth_arg head n stk = assert (head.norm <> Red); - let rec strip_rec rstk h depth n = function + let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> - strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s + strip_rec (e::rstk) (lift_fconstr k h) n s | Zapp args::s' -> let q = Array.length args in if n >= q then - strip_rec (Zapp args::rstk) - {norm=h.norm;term=FApp(h,args)} depth (n-q) s' + strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in @@ -721,9 +713,9 @@ let get_nth_arg head n stk = List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> - strip_rec rstk (update m (h.norm,h.term)) depth n s + strip_rec rstk (update m (h.norm,h.term)) n s | s -> (None, List.rev rstk @ s) in - strip_rec [] head 0 n stk + strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) @@ -746,6 +738,12 @@ let rec get_args n tys f e stk = get_args (n-na) etys f (subs_cons(l,e)) s | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) +(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) +let rec eta_expand_stack = function + | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> + e :: eta_expand_stack s + | [] -> + [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] (* Iota reduction: extract the arguments to be passed to the Case branches *) @@ -965,7 +963,7 @@ let whd_val info v = let norm_val info v = with_stats (lazy (kl info v)) -let inject = mk_clos (ESID 0) +let inject = mk_clos (subs_id 0) let whd_stack infos m stk = let k = kni infos m stk in diff --git a/kernel/closure.mli b/kernel/closure.mli index 9cfd9797..f4dc5db3 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -1,28 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -(*s Delta implies all consts (both global (= by +(** {6 ... } *) +(** Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) @@ -32,12 +29,15 @@ val with_stats: 'a Lazy.t -> 'a val all_opaque : transparent_state val all_transparent : transparent_state -(* Sets of reduction kinds. *) +val is_transparent_variable : transparent_state -> variable -> bool +val is_transparent_constant : transparent_state -> constant -> bool + +(** Sets of reduction kinds. *) module type RedFlagsSig = sig type reds type red_kind - (* The different kinds of reduction *) + (** The different kinds of reduction *) val fBETA : red_kind val fDELTA : red_kind val fIOTA : red_kind @@ -45,26 +45,24 @@ module type RedFlagsSig = sig val fCONST : constant -> red_kind val fVAR : identifier -> red_kind - (* No reduction at all *) + (** No reduction at all *) val no_red : reds - (* Adds a reduction kind to a set *) + (** Adds a reduction kind to a set *) val red_add : reds -> red_kind -> reds - (* Removes a reduction kind to a set *) + (** Removes a reduction kind to a set *) val red_sub : reds -> red_kind -> reds - (* Adds a reduction kind to a set *) + (** Adds a reduction kind to a set *) val red_add_transparent : reds -> transparent_state -> reds - (* Build a reduction set from scratch = iter [red_add] on [no_red] *) + (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds - (* Tests if a reduction kind is set *) + (** Tests if a reduction kind is set *) val red_set : reds -> red_kind -> bool - (* Gives the constant list *) - val red_get_const : reds -> bool * evaluable_global_reference list end module RedFlags : RedFlagsSig @@ -89,19 +87,19 @@ val create: ('a infos -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos val evar_value : 'a infos -> existential -> constr option -(************************************************************************) -(*s Lazy reduction. *) +(*********************************************************************** + s Lazy reduction. *) -(* [fconstr] is the type of frozen constr *) +(** [fconstr] is the type of frozen constr *) type fconstr -(* [fconstr] can be accessed by using the function [fterm_of] and by +(** [fconstr] can be accessed by using the function [fterm_of] and by matching on type [fterm] *) type fterm = | FRel of int - | FAtom of constr (* Metas and Sorts *) + | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive @@ -118,8 +116,8 @@ type fterm = | FCLOS of constr * fconstr subs | FLOCKED -(************************************************************************) -(*s A [stack] is a context of arguments, arguments are pushed by +(*********************************************************************** + s A [stack] is a context of arguments, arguments are pushed by [append_stack] one array at a time but popped with [decomp_stack] one by one *) @@ -142,13 +140,15 @@ val stack_args_size : stack -> int val stack_tail : int -> stack -> stack val stack_nth : stack -> int -> fconstr val zip_term : (fconstr -> constr) -> constr -> stack -> constr +val eta_expand_stack : stack -> stack -(* To lazy reduce a constr, create a [clos_infos] with +(** To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use a reduction function *) val inject : constr -> fconstr -(* mk_atom: prevents a term from being evaluated *) + +(** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr val fterm_of : fconstr -> fterm @@ -156,33 +156,33 @@ val term_of_fconstr : fconstr -> constr val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr -(* Global and local constant cache *) +(** Global and local constant cache *) type clos_infos val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos -(* Reduction function *) +(** Reduction function *) -(* [norm_val] is for strong normalization *) +(** [norm_val] is for strong normalization *) val norm_val : clos_infos -> fconstr -> constr -(* [whd_val] is for weak head normalization *) +(** [whd_val] is for weak head normalization *) val whd_val : clos_infos -> fconstr -> constr -(* [whd_stack] performs weak head normalization in a given stack. It +(** [whd_stack] performs weak head normalization in a given stack. It stops whenever a reduction is blocked. *) val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack -(* Conversion auxiliary functions to do step by step normalisation *) +(** Conversion auxiliary functions to do step by step normalisation *) -(* [unfold_reference] unfolds references in a [fconstr] *) +(** [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option val eq_table_key : table_key -> table_key -> bool -(************************************************************************) -(*i This is for lazy debug *) +(*********************************************************************** + i This is for lazy debug *) val lift_fconstr : int -> fconstr -> fconstr val lift_fconstr_vect : int -> fconstr array -> fconstr array @@ -200,4 +200,4 @@ val kl : clos_infos -> fconstr -> constr val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr val optimise_closure : fconstr subs -> constr -> fconstr subs * constr -(* End of cbn debug section i*) +(** End of cbn debug section i*) diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 3f6b77b0..92109258 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -1,12 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | Level n1, Opaque -> true | Level n1, Level n2 -> n1 < n2 - | _ -> false (* expand k2 *) + | _ -> l2r (* use recommended default *) (* summary operations *) let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 9272dfe5..09ca4b92 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -1,22 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a tableKey -> bool +val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool -(* Priority for the expansion of constant in the conversion test. +(** Priority for the expansion of constant in the conversion test. * Higher levels means that the expansion is less prioritary. * (And Expand stands for -oo, and Opaque +oo.) * The default value (transparent constants) is [Level 0]. @@ -26,14 +24,14 @@ val transparent : level val get_strategy : 'a tableKey -> level -(* Sets the level of a constant. +(** Sets the level of a constant. * Level of RelKey constant cannot be set. *) val set_strategy : 'a tableKey -> level -> unit val get_transp_state : unit -> transparent_state -(*****************************) -(* Summary operations *) +(**************************** + Summary operations *) type oracle val init : unit -> unit val freeze : unit -> oracle diff --git a/kernel/cooking.ml b/kernel/cooking.ml index d35c011a..02330339 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -1,12 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mkNamedProd_wo_LetIn d c) @@ -112,16 +117,24 @@ type recipe = { d_abstract : named_context; d_modlist : work_list } -let on_body f = - Option.map (fun c -> Declarations.from_val (f (Declarations.force c))) +let on_body f = function + | Undef inl -> Undef inl + | Def cs -> Def (Declarations.from_val (f (Declarations.force cs))) + | OpaqueDef lc -> + OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc))) + +let constr_of_def = function + | Undef _ -> assert false + | Def cs -> Declarations.force cs + | OpaqueDef lc -> Declarations.force_opaque lc let cook_constant env r = let cb = r.d_from in let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in - let body = - on_body (fun c -> - abstract_constant_body (expmod_constr r.d_modlist c) hyps) - cb.const_body in + let body = on_body + (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps) + cb.const_body + in let typ = match cb.const_type with | NonPolymorphicType t -> let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in @@ -129,8 +142,7 @@ let cook_constant env r = | PolymorphicArity (ctx,s) -> let t = mkArity (ctx,Type s.poly_level) in let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in - let j = make_judge (force (Option.get body)) typ in + let j = make_judge (constr_of_def body) typ in Typeops.make_polymorphic_if_constant_for_ind env j in - let boxed = Cemitcodes.is_boxed cb.const_body_code in - (body, typ, cb.const_constraints, cb.const_opaque, boxed,false) + (body, typ, cb.const_constraints) diff --git a/kernel/cooking.mli b/kernel/cooking.mli index df7e51f2..5f31ff8c 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* recipe -> - constr_substituted option * constant_type * constraints * bool * bool - * bool + env -> recipe -> constant_def * constant_type * constraints + -(*s Utility functions used in module [Discharge]. *) +(** {6 Utility functions used in module [Discharge]. } *) val expmod_constr : work_list -> constr -> constr diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 2b3d3fac..e8b66d09 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -1,3 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> tcode = "coq_tcode_of_code" -external free_tcode : tcode -> unit = "coq_static_free" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" (*******************) @@ -114,10 +127,9 @@ let rec slot_for_getglobal env kn = (* Pp.msgnl(str"not yet evaluated");*) let pos = match Cemitcodes.force cb.const_body_code with - | BCdefined(boxed,(code,pl,fv)) -> + | BCdefined(code,pl,fv) -> let v = eval_to_patch env (code,pl,fv) in - if boxed then set_global_boxed kn v - else set_global v + set_global v | BCallias kn' -> slot_for_getglobal env kn' | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index 894a33ef..8c1ad98b 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None + | Def c -> Some c + | OpaqueDef lc -> Some (force_lazy_constr lc) + +let constant_has_body cb = match cb.const_body with + | Undef _ -> false + | Def _ | OpaqueDef _ -> true + +let is_opaque cb = match cb.const_body with + | OpaqueDef _ -> true + | Undef _ | Def _ -> false + +(* Substitutions of [constant_body] *) let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in @@ -62,13 +112,78 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) +(* TODO: these substitution functions could avoid duplicating things + when the substitution have preserved all the fields *) + +let subst_const_type sub arity = + if is_empty_subst sub then arity + else match arity with + | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) + | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) + +let subst_const_def sub = function + | Undef inl -> Undef inl + | Def c -> Def (subst_constr_subst sub c) + | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc) + +let subst_const_body sub cb = { + const_hyps = (assert (cb.const_hyps=[]); []); + const_body = subst_const_def sub cb.const_body; + const_type = subst_const_type sub cb.const_type; + const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; + const_constraints = cb.const_constraints} + +(* Hash-consing of [constant_body] *) + +let hcons_rel_decl ((n,oc,t) as d) = + let n' = hcons_name n + and oc' = Option.smartmap hcons_constr oc + and t' = hcons_types t + in if n' == n && oc' == oc && t' == t then d else (n',oc',t') + +let hcons_rel_context l = list_smartmap hcons_rel_decl l + +let hcons_polyarity ar = + { poly_param_levels = + list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels; + poly_level = hcons_univ ar.poly_level } + +let hcons_const_type = function + | NonPolymorphicType t -> + NonPolymorphicType (hcons_constr t) + | PolymorphicArity (ctx,s) -> + PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s) + +let hcons_const_def = function + | Undef inl -> Undef inl + | Def l_constr -> + let constr = force l_constr in + Def (from_val (hcons_constr constr)) + | OpaqueDef lc -> + if lazy_constr_is_val lc then + let constr = force_opaque lc in + OpaqueDef (opaque_from_val (hcons_constr constr)) + else OpaqueDef lc + +let hcons_const_body cb = + { cb with + const_body = hcons_const_def cb.const_body; + const_type = hcons_const_type cb.const_type; + const_constraints = hcons_constraints cb.const_constraints } + + +(*s Inductive types (internal representation with redundant + information). *) + type recarg = | Norec - | Mrec of int + | Mrec of inductive | Imbr of inductive let subst_recarg sub r = match r with - | Norec | Mrec _ -> r + | Norec -> r + | Mrec (kn,i) -> let kn' = subst_ind sub kn in + if kn==kn' then r else Mrec (kn',i) | Imbr (kn,i) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) @@ -82,8 +197,14 @@ let mk_paths r recargs = let dest_recarg p = fst (Rtree.dest_node p) +(* dest_subterms returns the sizes of each argument of each constructor of + an inductive object of size [p]. This should never be done for Norec, + because the number of sons does not correspond to the number of + constructors. + *) let dest_subterms p = - let (_,cstrs) = Rtree.dest_node p in + let (ra,cstrs) = Rtree.dest_node p in + assert (ra<>Norec); Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs let recarg_length p j = @@ -192,24 +313,7 @@ type mutual_inductive_body = { } -let subst_arity sub arity = - if sub = empty_subst then arity - else match arity with - | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) - | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) - -(* TODO: should be changed to non-coping after Term.subst_mps *) -let subst_const_body sub cb = { - const_hyps = (assert (cb.const_hyps=[]); []); - const_body = Option.map (subst_constr_subst sub) cb.const_body; - const_type = subst_arity sub cb.const_type; - const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; - (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) - const_constraints = cb.const_constraints; - const_opaque = cb.const_opaque; - const_inline = cb.const_inline} - -let subst_arity sub = function +let subst_indarity sub = function | Monomorphic s -> Monomorphic { mind_user_arity = subst_mps sub s.mind_user_arity; @@ -223,7 +327,7 @@ let subst_mind_packet sub mbp = mind_typename = mbp.mind_typename; mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; - mind_arity = subst_arity sub mbp.mind_arity; + mind_arity = subst_indarity sub mbp.mind_arity; mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; @@ -233,7 +337,6 @@ let subst_mind_packet sub mbp = mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } - let subst_mind sub mib = { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; @@ -246,6 +349,26 @@ let subst_mind sub mib = mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints } +let hcons_indarity = function + | Monomorphic a -> + Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity; + mind_sort = hcons_sorts a.mind_sort } + | Polymorphic a -> Polymorphic (hcons_polyarity a) + +let hcons_mind_packet oib = + { oib with + mind_typename = hcons_ident oib.mind_typename; + mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; + mind_arity = hcons_indarity oib.mind_arity; + mind_consnames = array_smartmap hcons_ident oib.mind_consnames; + mind_user_lc = array_smartmap hcons_types oib.mind_user_lc; + mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc } + +let hcons_mind mib = + { mib with + mind_packets = array_smartmap hcons_mind_packet mib.mind_packets; + mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; + mind_constraints = hcons_constraints mib.mind_constraints } (*s Modules: signature component specifications, module types, and module declarations *) diff --git a/kernel/declarations.mli b/kernel/declarations.mli index db706a0c..5b800ede 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -1,30 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr_substituted val force : constr_substituted -> constr +(** Opaque proof terms are not loaded immediately, but are there + in a lazy form. Forcing this lazy may trigger some unmarshal of + the necessary structure. *) + +type lazy_constr + +val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr +val force_lazy_constr : lazy_constr -> constr_substituted +val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr +val lazy_constr_is_val : lazy_constr -> bool + +val force_opaque : lazy_constr -> constr +val opaque_from_val : constr -> lazy_constr + +(** Inlining level of parameters at functor applications. + None means no inlining *) + +type inline = int option + +(** A constant can have no body (axiom/parameter), or a + transparent body, or an opaque one *) + +type constant_def = + | Undef of inline + | Def of constr_substituted + | OpaqueDef of lazy_constr + type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constr_substituted option; + const_hyps : section_context; (** New: younger hyp at top *) + const_body : constant_def; const_type : constant_type; const_body_code : to_patch_substituted; - (*i const_type_code : to_patch;i*) - const_constraints : constraints; - const_opaque : bool; - const_inline : bool} + const_constraints : constraints } +val subst_const_def : substitution -> constant_def -> constant_def val subst_const_body : substitution -> constant_body -> constant_body -(**********************************************************************) -(*s Representation of mutual inductive types in the kernel *) +(** Is there a actual body in const_body or const_body_opaque ? *) + +val constant_has_body : constant_body -> bool + +(** Accessing const_body_opaque or const_body *) + +val body_of_constant : constant_body -> constr_substituted option + +val is_opaque : constant_body -> bool + +(** {6 Representation of mutual inductive types in the kernel } *) type recarg = | Norec - | Mrec of int + | Mrec of inductive | Imbr of inductive val subst_recarg : substitution -> recarg -> recarg @@ -72,12 +101,12 @@ val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths -(* -\begin{verbatim} +(** +{v Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 ... with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn -\end{verbatim} +v} *) type monomorphic_inductive_arity = { @@ -90,94 +119,72 @@ type inductive_arity = | Polymorphic of polymorphic_arity type one_inductive_body = { +(** {8 Primitive datas } *) -(* Primitive datas *) + mind_typename : identifier; (** Name of the type: [Ii] *) - (* Name of the type: [Ii] *) - mind_typename : identifier; + mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) - (* Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity_ctxt : rel_context; + mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) - (* Arity sort and original user arity if monomorphic *) - mind_arity : inductive_arity; + mind_consnames : identifier array; (** Names of the constructors: [cij] *) - (* Names of the constructors: [cij] *) - mind_consnames : identifier array; - - (* Types of the constructors with parameters: [forall params, Tij], - where the Ik are replaced by de Bruijn index in the context - I1:forall params, U1 .. In:forall params, Un *) mind_user_lc : types array; + (** Types of the constructors with parameters: [forall params, Tij], + where the Ik are replaced by de Bruijn index in the + context I1:forall params, U1 .. In:forall params, Un *) -(* Derived datas *) +(** {8 Derived datas } *) - (* Number of expected real arguments of the type (no let, no params) *) - mind_nrealargs : int; + mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *) - (* Length of realargs context (with let, no params) *) - mind_nrealargs_ctxt : int; + mind_nrealargs_ctxt : int; (** Length of realargs context (with let, no params) *) - (* List of allowed elimination sorts *) - mind_kelim : sorts_family list; + mind_kelim : sorts_family list; (** List of allowed elimination sorts *) - (* Head normalized constructor types so that their conclusion is atomic *) - mind_nf_lc : types array; + mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *) - (* Length of the signature of the constructors (with let, w/o params) - (not used in the kernel) *) mind_consnrealdecls : int array; + (** Length of the signature of the constructors (with let, w/o params) + (not used in the kernel) *) - (* Signature of recursive arguments in the constructors *) - mind_recargs : wf_paths; + mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *) -(* Datas for bytecode compilation *) +(** {8 Datas for bytecode compilation } *) - (* number of constant constructor *) - mind_nb_constant : int; + mind_nb_constant : int; (** number of constant constructor *) - (* number of no constant constructor *) - mind_nb_args : int; + mind_nb_args : int; (** number of no constant constructor *) mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { - (* The component of the mutual inductive block *) - mind_packets : one_inductive_body array; + mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) - (* Whether the inductive type has been declared as a record *) - mind_record : bool; + mind_record : bool; (** Whether the inductive type has been declared as a record *) - (* Whether the type is inductive or coinductive *) - mind_finite : bool; + mind_finite : bool; (** Whether the type is inductive or coinductive *) - (* Number of types in the block *) - mind_ntypes : int; + mind_ntypes : int; (** Number of types in the block *) - (* Section hypotheses on which the block depends *) - mind_hyps : section_context; + mind_hyps : section_context; (** Section hypotheses on which the block depends *) - (* Number of expected parameters *) - mind_nparams : int; + mind_nparams : int; (** Number of expected parameters *) - (* Number of recursively uniform (i.e. ordinary) parameters *) - mind_nparams_rec : int; + mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *) - (* The context of parameters (includes let-in declaration) *) - mind_params_ctxt : rel_context; + mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) - (* Universes constraints enforced by the inductive declaration *) - mind_constraints : constraints; + mind_constraints : constraints; (** Universes constraints enforced by the inductive declaration *) } val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body -(**********************************************************************) -(*s Modules: signature component specifications, module types, and - module declarations *) +(** {6 Modules: signature component specifications, module types, and + module declarations } *) type structure_field_body = | SFBconst of constant_body @@ -199,29 +206,39 @@ and with_declaration_body = | With_definition_body of identifier list * constant_body and module_body = - { (*absolute path of the module*) + { (** absolute path of the module *) mod_mp : module_path; - (* Implementation *) + (** Implementation *) mod_expr : struct_expr_body option; - (* Signature *) + (** Signature *) mod_type : struct_expr_body; - (* algebraic structure expression is kept + (** algebraic structure expression is kept if it's relevant for extraction *) mod_type_alg : struct_expr_body option; - (* set of all constraint in the module *) + (** set of all constraint in the module *) mod_constraints : constraints; - (* quotiented set of equivalent constant and inductive name *) + (** quotiented set of equivalent constant and inductive name *) mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} and module_type_body = { - (*Path of the module type*) + (** Path of the module type *) typ_mp : module_path; typ_expr : struct_expr_body; - (* algebraic structure expression is kept + (** algebraic structure expression is kept if it's relevant for extraction *) typ_expr_alg : struct_expr_body option ; typ_constraints : constraints; - (* quotiented set of equivalent constant and inductive name *) + (** quotiented set of equivalent constant and inductive name *) typ_delta :delta_resolver} + + +(** Hash-consing *) + +(** Here, strictly speaking, we don't perform true hash-consing + of the structure, but simply hash-cons all inner constr + and other known elements *) + +val hcons_const_body : constant_body -> constant_body +val hcons_mind : mutual_inductive_body -> mutual_inductive_body diff --git a/kernel/entries.ml b/kernel/entries.ml index 4ca21277..a4485fac 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Declarations.force l_body - | None -> raise (NotEvaluableConst NoBody) + | Def l_body -> Declarations.force l_body + | OpaqueDef _ -> raise (NotEvaluableConst Opaque) + | Undef _ -> raise (NotEvaluableConst NoBody) let constant_opt_value env cst = try Some (constant_value env cst) @@ -183,14 +195,9 @@ let add_mind kn mib env = { env with env_globals = new_globals } (* Universe constraints *) -let set_universes g env = - if env.env_stratification.env_universes == g then env - else - { env with env_stratification = - { env.env_stratification with env_universes = g } } let add_constraints c env = - if c == Constraint.empty then + if is_empty_constraint c then env else let s = env.env_stratification in diff --git a/kernel/environ.mli b/kernel/environ.mli index a7795136..42100e4e 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -1,26 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* named_context_val val engagement : env -> engagement option -(* is the local context empty *) +(** is the local context empty *) val empty_context : env -> bool -(************************************************************************) -(*s Context of de Bruijn variables ([rel_context]) *) +(** {5 Context of de Bruijn variables ([rel_context]) } *) + val nb_rel : env -> int val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : rec_declaration -> env -> env -(* Looks up in the context of local vars referred by indice ([rel_context]) *) -(* raises [Not_found] if the index points out of the context *) +(** Looks up in the context of local vars referred by indice ([rel_context]) + raises [Not_found] if the index points out of the context *) val lookup_rel : int -> env -> rel_declaration val evaluable_rel : int -> env -> bool -(*s Recurrence on [rel_context] *) +(** {6 Recurrence on [rel_context] } *) + val fold_rel_context : (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a -(************************************************************************) -(* Context of variables (section variables and goal assumptions) *) +(** {5 Context of variables (section variables and goal assumptions) } *) val named_context_of_val : named_context_val -> named_context val named_vals_of_val : named_context_val -> Pre_env.named_vals @@ -78,7 +74,7 @@ val val_of_named_context : named_context -> named_context_val val empty_named_context_val : named_context_val -(* [map_named_val f ctxt] apply [f] to the body and the type of +(** [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) val map_named_val : @@ -90,8 +86,8 @@ val push_named_context_val : -(* Looks up in the context of local vars referred by names ([named_context]) *) -(* raises [Not_found] if the identifier is not found *) +(** Looks up in the context of local vars referred by names ([named_context]) + raises [Not_found] if the identifier is not found *) val lookup_named : variable -> env -> named_declaration val lookup_named_val : variable -> named_context_val -> named_declaration @@ -99,34 +95,36 @@ val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option -(*s Recurrence on [named_context]: older declarations processed first *) +(** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a -(* Recurrence on [named_context] starting from younger decl *) +(** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a -(* This forgets named and rel contexts *) +(** This forgets named and rel contexts *) val reset_context : env -> env -(* This forgets rel context and sets a new named context *) + +(** This forgets rel context and sets a new named context *) val reset_with_named_context : named_context_val -> env -> env -(************************************************************************) -(*s Global constants *) -(*s Add entries to global environment *) -val add_constant : constant -> constant_body -> env -> env +(** {5 Global constants } + {6 Add entries to global environment } *) -(* Looks up in the context of global constant names *) -(* raises [Not_found] if the required path is not found *) +val add_constant : constant -> constant_body -> env -> env +(** Looks up in the context of global constant names + raises [Not_found] if the required path is not found *) val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool -(*s [constant_value env c] raises [NotEvaluableConst Opaque] if +(** {6 ... } *) +(** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no body and [Not_found] if it does not exist in [env] *) + type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result @@ -134,44 +132,44 @@ val constant_value : env -> constant -> constr val constant_type : env -> constant -> constant_type val constant_opt_value : env -> constant -> constr option -(************************************************************************) -(*s Inductive types *) +(** {5 Inductive types } *) + val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env -(* Looks up in the context of global inductive names *) -(* raises [Not_found] if the required path is not found *) +(** Looks up in the context of global inductive names + raises [Not_found] if the required path is not found *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body -(************************************************************************) -(*s Modules *) +(** {5 Modules } *) + val add_modtype : module_path -> module_type_body -> env -> env -(* [shallow_add_module] does not add module components *) +(** [shallow_add_module] does not add module components *) val shallow_add_module : module_path -> module_body -> env -> env val lookup_module : module_path -> env -> module_body val lookup_modtype : module_path -> env -> module_type_body -(************************************************************************) -(*s Universe constraints *) -val set_universes : Univ.universes -> env -> env +(** {5 Universe constraints } *) + val add_constraints : Univ.constraints -> env -> env val set_engagement : engagement -> env -> env -(************************************************************************) -(* Sets of referred section variables *) -(* [global_vars_set env c] returns the list of [id]'s occurring either +(** {6 Sets of referred section variables } + [global_vars_set env c] returns the list of [id]'s occurring either directly as [Var id] in [c] or indirectly as a section variable dependent in a global reference occurring in [c] *) + val global_vars_set : env -> constr -> Idset.t -(* the constr must be a global reference *) + +(** the constr must be a global reference *) val vars_of_global : env -> constr -> identifier list val keep_hyps : env -> Idset.t -> section_context -(************************************************************************) -(*s Unsafe judgments. We introduce here the pre-type of judgments, which is +(** {5 Unsafe judgments. } + We introduce here the pre-type of judgments, which is actually only a datatype to store a term with its type and the type of its type. *) @@ -188,23 +186,20 @@ type unsafe_type_judgment = { utj_type : sorts } -(*s Compilation of global declaration *) +(** {6 Compilation of global declaration } *) -val compile_constant_body : - env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code - (* opaque *) (* boxed *) +val compile_constant_body : env -> constant_def -> Cemitcodes.body_code exception Hyp_not_found -(* [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and +(** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) - val apply_to_hyp : named_context_val -> variable -> (named_context -> named_declaration -> named_context -> named_declaration) -> named_context_val -(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into +(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into [tail::(id,_,_)::head] and return [(g tail)::(f (id,_,_))::head]. *) val apply_to_hyp_and_dependent_on : named_context_val -> variable -> @@ -219,9 +214,10 @@ val insert_after_hyp : named_context_val -> variable -> val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val -(* spiwack: functions manipulating the retroknowledge *) -open Retroknowledge +open Retroknowledge +(** functions manipulating the retroknowledge + @author spiwack *) val retroknowledge : (retroknowledge->'a) -> env -> 'a val registered : env -> field -> bool @@ -230,3 +226,4 @@ val unregister : env -> field -> env val register : env -> field -> Retroknowledge.entry -> env + diff --git a/kernel/esubst.ml b/kernel/esubst.ml index 82d19ec4..cbce04d6 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -1,12 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* n *) (* i.e under n binders *) +let el_id = ELID + (* compose a relocation of magnitude n *) let rec el_shft_rec n = function | ELSHFT(el,k) -> el_shft_rec (k+n) el @@ -67,6 +71,8 @@ type 'a subs = * Needn't be recursive if we always use these functions *) +let subs_id i = ESID i + let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s) let subs_liftn n = function diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 76c0d481..fe978261 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -1,61 +1,66 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a subs val subs_cons: 'a array * 'a subs -> 'a subs val subs_shft: int * 'a subs -> 'a subs val subs_lift: 'a subs -> 'a subs val subs_liftn: int -> 'a subs -> 'a subs -(* [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *) + +(** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *) val subs_shift_cons: int * 'a subs * 'a array -> 'a subs -(* [expand_rel k subs] expands de Bruijn [k] in the explicit substitution - * [subs]. The result is either (Inl(lams,v)) when the variable is - * substituted by value [v] under lams binders (i.e. v *has* to be - * shifted by lams), or (Inr (k',p)) when the variable k is just relocated - * as k'; p is None if the variable points inside subs and Some(k) if the - * variable points k bindings beyond subs (cf argument of ESID). - *) +(** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution + [subs]. The result is either (Inl(lams,v)) when the variable is + substituted by value [v] under lams binders (i.e. v *has* to be + shifted by lams), or (Inr (k',p)) when the variable k is just relocated + as k'; p is None if the variable points inside subs and Some(k) if the + variable points k bindings beyond subs (cf argument of ESID). +*) val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union -(* Tests whether a substitution behaves like the identity *) +(** Tests whether a substitution behaves like the identity *) val is_subs_id: 'a subs -> bool -(* Composition of substitutions: [comp mk_clos s1 s2] computes a - * substitution equivalent to applying s2 then s1. Argument - * mk_clos is used when a closure has to be created, i.e. when - * s1 is applied on an element of s2. - *) +(** Composition of substitutions: [comp mk_clos s1 s2] computes a + substitution equivalent to applying s2 then s1. Argument + mk_clos is used when a closure has to be created, i.e. when + s1 is applied on an element of s2. +*) val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs -(*s Compact representation of explicit relocations. \\ - [ELSHFT(l,n)] == lift of [n], then apply [lift l]. - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *) -type lift = +(** {6 Compact representation } *) +(** Compact representation of explicit relocations + - [ELSHFT(l,n)] == lift of [n], then apply [lift l]. + - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *) +type lift = private | ELID | ELSHFT of lift * int | ELLFT of int * lift +val el_id : lift val el_shft : int -> lift -> lift val el_liftn : int -> lift -> lift val el_lift : lift -> lift diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 9b1ddc31..46e866a0 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* check_arity id ar) - mie.mind_entry_inds - (************************************************************************) (************************************************************************) @@ -171,7 +160,7 @@ let inductive_levels arities inds = arity or type constructor; we do not to recompute universes constraints *) let constraint_list_union = - List.fold_left Constraint.union Constraint.empty + List.fold_left union_constraints empty_constraint let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) @@ -208,7 +197,7 @@ let typecheck_inductive env mie = full_arity is used as argument or subject to cast, an upper universe will be generated *) let full_arity = it_mkProd_or_LetIn arity.utj_val params in - let cst = Constraint.union cst cst2 in + let cst = union_constraints cst cst2 in let id = ind.mind_entry_typename in let env_ar' = push_rel (Name id, None, full_arity) @@ -237,7 +226,7 @@ let typecheck_inductive env mie = infer_constructor_packet env_ar_par params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,info,lc',cstrs_univ) in - (ind'::inds, Constraint.union cst cst')) + (ind'::inds, union_constraints cst cst')) mie.mind_entry_inds arity_list ([],cst) in @@ -246,7 +235,8 @@ let typecheck_inductive env mie = let arities = Array.of_list arity_list in let param_ccls = List.fold_left (fun l (_,b,p) -> if b = None then - let _,c = dest_prod_assum env p in + (* Parameter contributes to polymorphism only if explicit Type *) + let c = strip_prod_assum p in (* Add Type levels to the ordered list of parameters contributing to *) (* polymorphism unless there is aliasing (i.e. non distinct levels) *) match kind_of_term c with @@ -373,6 +363,11 @@ if nmr = 0 then 0 else | _ -> k) in find 0 (n-1) (lpar,List.rev hyps) +let lambda_implicit_lift n a = + let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in + let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in + iterate lambda_implicit n (lift n a) + (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc env ntyps npars lc = @@ -421,7 +416,7 @@ let array_min nmr a = if nmr = 0 then 0 else (* The recursive function that checks positivity and builds the list of recursive arguments *) -let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = +let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = let lparams = rel_context_length hyps in let nmr = rel_context_nhyps hyps in (* Checking the (strict) positivity of a constructor argument type [c] *) @@ -466,8 +461,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) + if not (List.for_all (noccur_between n ntypes) auxlargs) then - failwith_non_pos_list n ntypes auxlargs; + failwith_non_pos_list n ntypes auxlargs; (* We do not deal with imbricated mutual inductive types *) let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); @@ -533,11 +529,11 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr - in (nmr', mk_paths (Mrec i) irecargs) + in (nmr', mk_paths (Mrec ind) irecargs) -let check_positivity env_ar params inds = +let check_positivity kn env_ar params inds = let ntypes = Array.length inds in - let rc = Array.mapi (fun j t -> (Mrec j,t)) (Rtree.mk_rec_calls ntypes) in + let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let lra_ind = List.rev (Array.to_list rc) in let lparams = rel_context_length params in let nmr = rel_context_nhyps params in @@ -546,7 +542,7 @@ let check_positivity env_ar params inds = list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in let nargs = rel_context_nhyps sign - nmr in - check_positivity_one ienv params i nargs lcnames lc + check_positivity_one ienv params (kn,i) nargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr @@ -558,16 +554,6 @@ let check_positivity env_ar params inds = (************************************************************************) (* Build the inductive packet *) -(* Elimination sorts *) -let is_recursive = Rtree.is_infinite -(* let rec one_is_rec rvec = - List.exists (function Mrec(i) -> List.mem i listind - | Imbr(_,lvec) -> array_exists one_is_rec lvec - | Norec -> false) rvec - in - array_exists one_is_rec -*) - (* Allowed eliminations *) let all_sorts = [InProp;InSet;InType] @@ -614,7 +600,6 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = (* Type of constructors in normal form *) let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in - let nf_lc = if nf_lc = lc then lc else nf_lc in let consnrealargs = Array.map (fun (d,_) -> rel_context_length d - rel_context_length params) splayed_lc in @@ -677,11 +662,11 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = (************************************************************************) (************************************************************************) -let check_inductive env mie = +let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar, params, inds, cst) = typecheck_inductive env mie in (* Then check positivity conditions *) - let (nmr,recargs) = check_positivity env_ar params inds in + let (nmr,recargs) = check_positivity kn env_ar params inds in (* Build the inductive packets *) build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite inds nmr recargs cst diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 71d01568..b37aefe4 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mutual_inductive_entry -> mutual_inductive_body + env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 62a48f07..21f86233 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [] then fail(); substl subs ty -let instantiate_partial_params = instantiate_params false - let full_inductive_instantiate mib params sign = let dummy = prop_sort in let t = mkArity (sign,dummy) in @@ -97,10 +93,6 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) = (* Functions to build standard types related to inductive *) - -let number_of_inductives mib = Array.length mib.mind_packets -let number_of_constructors mip = Array.length mip.mind_consnames - (* Computing the actual sort of an applied or partially applied inductive type: @@ -241,12 +233,6 @@ let type_of_constructors ind (mib,mip) = (************************************************************************) -let error_elim_expln kp ki = - match kp,ki with - | (InType | InSet), InProp -> NonInformativeToInformative - | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) - | _ -> WrongArity - (* Type of case predicates *) let local_rels ctxt = @@ -298,7 +284,7 @@ exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = if not (List.exists ((=) ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in - raise (LocalArity (Some(ksort,s,error_elim_expln ksort s))) + raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity specif params in @@ -309,7 +295,7 @@ let is_correct_arity env c pj ind specif params = let univ = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ) + srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ) | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *) let ksort = match kind_of_term (whd_betadeltaiota env a2) with | Sort s -> family_of_sort s @@ -319,13 +305,13 @@ let is_correct_arity env c pj ind specif params = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in check_allowed_sort ksort specif; - Constraint.union u univ + union_constraints u univ | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' u | _ -> raise (LocalArity None) in - try srec env pj.uj_type (List.rev arsign) Constraint.empty + try srec env pj.uj_type (List.rev arsign) empty_constraint with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds @@ -374,7 +360,7 @@ let check_case_info env indsp ci = if not (eq_ind indsp ci.ci_ind) or (mib.mind_nparams <> ci.ci_npar) or - (mip.mind_consnrealdecls <> ci.ci_cstr_nargs) + (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) @@ -431,10 +417,10 @@ let spec_of_tree t = lazy else Subterm(Strict,Lazy.force t)) let subterm_spec_glb = - let glb2 s1 s2 = - match s1,s2 with - _, Dead_code -> s1 - | Dead_code, _ -> s2 + let glb2 s1 s2 = + match s1, s2 with + s1, Dead_code -> s1 + | Dead_code, s2 -> s2 | Not_subterm, _ -> Not_subterm | _, Not_subterm -> Not_subterm | Subterm (a1,t1), Subterm (a2,t2) -> @@ -447,27 +433,20 @@ type guard_env = { env : env; (* dB of last fixpoint *) rel_min : int; - (* inductive of recarg of each fixpoint *) - inds : inductive array; - (* the recarg information of inductive family *) - recvec : wf_paths array; (* dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } -let make_renv env minds recarg (kn,tyi) = +let make_renv env recarg (kn,tyi) = let mib = Environ.lookup_mind kn env in let mind_recvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in { env = env; rel_min = recarg+2; - inds = minds; - recvec = mind_recvec; genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] } let push_var renv (x,ty,spec) = - { renv with - env = push_rel (x,None,ty) renv.env; + { env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -475,76 +454,66 @@ let assign_var_spec renv (i,spec) = { renv with genv = list_assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = - push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) + push_var renv (x,ty,lazy Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = try Lazy.force (List.nth renv.genv (p-1)) with Failure _ | Invalid_argument _ -> Not_subterm -(* Add a variable and mark it as strictly smaller with information [spec]. *) -let add_subterm renv (x,a,spec) = - push_var renv (x,a,spec_of_tree spec) - let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in - { renv with - env = push_rel_context ctxt renv.env; + { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in - { renv with - env = push_rec_types recdef renv.env; + { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } +(* Definition and manipulation of the stack *) +type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t -(******************************) -(* Computing the recursive subterms of a term (propagation of size - information through Cases). *) +let push_stack_closures renv l stack = + List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack -(* - c is a branch of an inductive definition corresponding to the spec - lrec. mind_recvec is the recursive spec of the inductive - definition of the decreasing argument n. - - case_branches_specif renv lrec lc will pass the lambdas - of c corresponding to pattern variables and collect possibly new - subterms variables and returns the bodies of the branches with the - correct envs and decreasing args. -*) +let push_stack_args l stack = + List.fold_right (fun h b -> (SArg h)::b) l stack + +(******************************) +(* {6 Computing the recursive subterms of a term (propagation of size + information through Cases).} *) let lookup_subterms env ind = let (_,mip) = lookup_mind_specif env ind in mip.mind_recargs -(*********************************) -let match_trees t1 t2 = - let v1 = dest_subterms t1 in - let v2 = dest_subterms t2 in - array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2 +let match_inductive ind ra = + match ra with + | (Mrec i | Imbr i) -> eq_ind ind i + | Norec -> false -(* In {match c as z in ind y_s return P with |C_i x_s => t end} - [branches_specif renv c_spec ind] returns an array of x_s specs given - c_spec the spec of c. *) -let branches_specif renv c_spec ind = - let (_,mip) = lookup_mind_specif renv.env ind in +(* In {match c as z in ci y_s return P with |C_i x_s => t end} + [branches_specif renv c_spec ci] returns an array of x_s specs knowing + c_spec. *) +let branches_specif renv c_spec ci = let car = (* We fetch the regular tree associated to the inductive of the match. This is just to get the number of constructors (and constructor arities) that fit the match branches without forcing c_spec. Note that c_spec might be more precise than [v] below, because of nested inductive types. *) + let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in let v = dest_subterms mip.mind_recargs in Array.map List.length v in Array.mapi (fun i nca -> (* i+1-th cstructor has arity nca *) let lvra = lazy (match Lazy.force c_spec with - Subterm (_,t) when match_trees mip.mind_recargs t -> + Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> let vra = Array.of_list (dest_subterms t).(i) in assert (nca = Array.length vra); Array.map @@ -555,106 +524,92 @@ let branches_specif renv c_spec ind = list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca) car - -(* Propagation of size information through Cases: if the matched - object is a recursive subterm then compute the information - associated to its own subterms. - Rq: if branch is not eta-long, then the recursive information - is not propagated to the missing abstractions *) -let case_branches_specif renv c_spec ind lbr = - let vlrec = branches_specif renv c_spec ind in - let rec push_branch_args renv lrec c = - match lrec with - ra::lr -> - let c' = whd_betadeltaiota renv.env c in - (match kind_of_term c' with - Lambda(x,a,b) -> - let renv' = push_var renv (x,a,ra) in - push_branch_args renv' lr b - | _ -> (* branch not in eta-long form: cannot perform rec. calls *) - (renv,c')) - | [] -> (renv, c) in - assert (Array.length vlrec = Array.length lbr); - array_map2 (push_branch_args renv) vlrec lbr - (* [subterm_specif renv t] computes the recursive structure of [t] and compare its size with the size of the initial recursive argument of the fixpoint we are checking. [renv] collects such information about variables. *) -let rec subterm_specif renv t = +let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_betadeltaiota renv.env t) in - match kind_of_term f with - | Rel k -> subterm_var k renv - - | Case (ci,_,c,lbr) -> - let lbr_spec = case_subterm_specif renv ci c lbr in - let stl = - Array.map (fun (renv',br') -> subterm_specif renv' br') - lbr_spec in - subterm_spec_glb stl - - | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> -(* when proving that the fixpoint f(x)=e is less than n, it is enough - to prove that e is less than n assuming f is less than n - furthermore when f is applied to a term which is strictly less than - n, one may assume that x itself is strictly less than n -*) - let (ctxt,clfix) = dest_prod renv.env typarray.(i) in - let oind = - let env' = push_rel_context ctxt renv.env in - try Some(fst(find_inductive env' clfix)) - with Not_found -> None in - (match oind with - None -> Not_subterm (* happens if fix is polymorphic *) - | Some ind -> - let nbfix = Array.length typarray in - let recargs = lookup_subterms renv.env ind in - (* pushing the fixpoints *) - let renv' = push_fix_renv renv recdef in - let renv' = - (* Why Strict here ? To be general, it could also be - Large... *) - assign_var_spec renv' - (nbfix-i, Lazy.lazy_from_val(Subterm(Strict,recargs))) in - let decrArg = recindxs.(i) in - let theBody = bodies.(i) in - let nbOfAbst = decrArg+1 in - let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in - (* pushing the fix parameters *) - let renv'' = push_ctxt_renv renv' sign in - let renv'' = - if List.length l < nbOfAbst then renv'' - else - let theDecrArg = List.nth l decrArg in - let arg_spec = lazy_subterm_specif renv theDecrArg in - assign_var_spec renv'' (1, arg_spec) in - subterm_specif renv'' strippedBody) - - | Lambda (x,a,b) -> - assert (l=[]); - subterm_specif (push_var_renv renv (x,a)) b - - (* Metas and evars are considered OK *) - | (Meta _|Evar _) -> Dead_code - - (* Other terms are not subterms *) - | _ -> Not_subterm - -and lazy_subterm_specif renv t = - lazy (subterm_specif renv t) - -and case_subterm_specif renv ci c lbr = - if Array.length lbr = 0 then [||] - else - let c_spec = lazy_subterm_specif renv c in - case_branches_specif renv c_spec ci.ci_ind lbr - + match kind_of_term f with + | Rel k -> subterm_var k renv + + | Case (ci,_,c,lbr) -> + let stack' = push_stack_closures renv l stack in + let cases_spec = branches_specif renv + (lazy_subterm_specif renv [] c) ci in + let stl = + Array.mapi (fun i br' -> + let stack_br = push_stack_args (cases_spec.(i)) stack' in + subterm_specif renv stack_br br') + lbr in + subterm_spec_glb stl + + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> + (* when proving that the fixpoint f(x)=e is less than n, it is enough + to prove that e is less than n assuming f is less than n + furthermore when f is applied to a term which is strictly less than + n, one may assume that x itself is strictly less than n + *) + let (ctxt,clfix) = dest_prod renv.env typarray.(i) in + let oind = + let env' = push_rel_context ctxt renv.env in + try Some(fst(find_inductive env' clfix)) + with Not_found -> None in + (match oind with + None -> Not_subterm (* happens if fix is polymorphic *) + | Some ind -> + let nbfix = Array.length typarray in + let recargs = lookup_subterms renv.env ind in + (* pushing the fixpoints *) + let renv' = push_fix_renv renv recdef in + let renv' = + (* Why Strict here ? To be general, it could also be + Large... *) + assign_var_spec renv' + (nbfix-i, lazy (Subterm(Strict,recargs))) in + let decrArg = recindxs.(i) in + let theBody = bodies.(i) in + let nbOfAbst = decrArg+1 in + let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in + (* pushing the fix parameters *) + let stack' = push_stack_closures renv l stack in + let renv'' = push_ctxt_renv renv' sign in + let renv'' = + if List.length stack' < nbOfAbst then renv'' + else + let decrArg = List.nth stack' decrArg in + let arg_spec = stack_element_specif decrArg in + assign_var_spec renv'' (1, arg_spec) in + subterm_specif renv'' [] strippedBody) + + | Lambda (x,a,b) -> + assert (l=[]); + let spec,stack' = extract_stack renv a stack in + subterm_specif (push_var renv (x,a,spec)) stack' b + + (* Metas and evars are considered OK *) + | (Meta _|Evar _) -> Dead_code + + (* Other terms are not subterms *) + | _ -> Not_subterm + +and lazy_subterm_specif renv stack t = + lazy (subterm_specif renv stack t) + +and stack_element_specif = function + |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h + |SArg x -> x + +and extract_stack renv a = function + | [] -> Lazy.lazy_from_val Not_subterm , [] + | h::t -> stack_element_specif h, t + (* Check term c can be applied to one of the mutual fixpoints. *) -let check_is_subterm renv c = - match subterm_specif renv c with +let check_is_subterm x = + match Lazy.force x with Subterm (Strict,_) | Dead_code -> true | _ -> false @@ -662,7 +617,7 @@ let check_is_subterm renv c = exception FixGuardError of env * guard_error -let error_illegal_rec_call renv fx arg = +let error_illegal_rec_call renv fx (arg_renv,arg) = let (_,le_vars,lt_vars) = List.fold_left (fun (i,le,lt) sbt -> @@ -672,7 +627,8 @@ let error_illegal_rec_call renv fx arg = | _ -> (i+1, le ,lt)) (1,[],[]) renv.genv in raise (FixGuardError (renv.env, - RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars))) + RecursionOnIllegalTerm(fx,(arg_renv.env, arg), + le_vars,lt_vars))) let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) @@ -683,8 +639,11 @@ let error_partial_apply renv fx = let check_one_fix renv recpos def = let nfi = Array.length recpos in - (* Checks if [t] only make valid recursive calls *) - let rec check_rec_call renv t = + (* Checks if [t] only make valid recursive calls + [stack] is the list of constructor's argument specification and + arguments than will be applied after reduction. + example u in t where we have (match .. with |.. => t end) u *) + let rec check_rec_call renv stack t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else @@ -694,35 +653,43 @@ let check_one_fix renv recpos def = (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p & p < renv.rel_min+nfi then begin - List.iter (check_rec_call renv) l; + List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in - if List.length l <= np then error_partial_apply renv glob + let stack' = push_stack_closures renv l stack in + if List.length stack' <= np then error_partial_apply renv glob else (* Check the decreasing arg is smaller *) - let z = List.nth l np in - if not (check_is_subterm renv z) then - error_illegal_rec_call renv glob z + let z = List.nth stack' np in + if not (check_is_subterm (stack_element_specif z)) then + begin match z with + |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') + |SArg _ -> error_partial_apply renv glob + end end else begin match pi2 (lookup_rel p renv.env) with | None -> - List.iter (check_rec_call renv) l + List.iter (check_rec_call renv []) l | Some c -> - try List.iter (check_rec_call renv) l + try List.iter (check_rec_call renv []) l with FixGuardError _ -> - check_rec_call renv (applist(lift p c,l)) + check_rec_call renv stack (applist(lift p c,l)) end - + | Case (ci,p,c_0,lrest) -> - List.iter (check_rec_call renv) (c_0::p::l); + List.iter (check_rec_call renv []) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) - let lbr = case_subterm_specif renv ci c_0 lrest in - Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr + let case_spec = branches_specif renv + (lazy_subterm_specif renv [] c_0) ci in + let stack' = push_stack_closures renv l stack in + Array.iteri (fun k br' -> + let stack_br = push_stack_args case_spec.(k) stack' in + check_rec_call renv stack_br br') lrest (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : @@ -737,79 +704,79 @@ let check_one_fix renv recpos def = then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> - List.iter (check_rec_call renv) l; - Array.iter (check_rec_call renv) typarray; + List.iter (check_rec_call renv []) l; + Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in let renv' = push_fix_renv renv recdef in - if (List.length l < (decrArg+1)) then - Array.iter (check_rec_call renv') bodies - else + let stack' = push_stack_closures renv l stack in Array.iteri (fun j body -> - if i=j then - let theDecrArg = List.nth l decrArg in - let arg_spec = lazy_subterm_specif renv theDecrArg in - check_nested_fix_body renv' (decrArg+1) arg_spec body - else check_rec_call renv' body) + if i=j && (List.length stack' > decrArg) then + let recArg = List.nth stack' decrArg in + let arg_sp = stack_element_specif recArg in + check_nested_fix_body renv' (decrArg+1) arg_sp body + else check_rec_call renv' [] body) bodies | Const kn -> if evaluable_constant kn renv.env then - try List.iter (check_rec_call renv) l + try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - check_rec_call renv(applist(constant_value renv.env kn, l)) - else List.iter (check_rec_call renv) l - - (* The cases below simply check recursively the condition on the - subterms *) - | Cast (a,_, b) -> - List.iter (check_rec_call renv) (a::b::l) + let value = (applist(constant_value renv.env kn, l)) in + check_rec_call renv stack value + else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> - List.iter (check_rec_call renv) (a::l); - check_rec_call (push_var_renv renv (x,a)) b + assert (l = []); + check_rec_call renv [] a ; + let spec, stack' = extract_stack renv a stack in + check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> - List.iter (check_rec_call renv) (a::l); - check_rec_call (push_var_renv renv (x,a)) b + assert (l = [] && stack = []); + check_rec_call renv [] a; + check_rec_call (push_var_renv renv (x,a)) [] b | CoFix (i,(_,typarray,bodies as recdef)) -> - List.iter (check_rec_call renv) l; - Array.iter (check_rec_call renv) typarray; + List.iter (check_rec_call renv []) l; + Array.iter (check_rec_call renv []) typarray; let renv' = push_fix_renv renv recdef in - Array.iter (check_rec_call renv') bodies + Array.iter (check_rec_call renv' []) bodies - | (Ind _ | Construct _ | Sort _) -> - List.iter (check_rec_call renv) l + | (Ind _ | Construct _) -> + List.iter (check_rec_call renv []) l | Var id -> begin match pi2 (lookup_named id renv.env) with | None -> - List.iter (check_rec_call renv) l + List.iter (check_rec_call renv []) l | Some c -> - try List.iter (check_rec_call renv) l - with (FixGuardError _) -> check_rec_call renv (applist(c,l)) + try List.iter (check_rec_call renv []) l + with (FixGuardError _) -> + check_rec_call renv stack (applist(c,l)) end + | Sort _ -> assert (l = []) + (* l is not checked because it is considered as the meta's context *) | (Evar _ | Meta _) -> () - | (App _ | LetIn _) -> assert false (* beta zeta reduction *) + | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) and check_nested_fix_body renv decr recArgsDecrArg body = if decr = 0 then - check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body + check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match kind_of_term body with | Lambda (x,a,b) -> - check_rec_call renv a; + check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in - check_nested_fix_body renv' (decr-1) recArgsDecrArg b + check_nested_fix_body renv' (decr-1) recArgsDecrArg b | _ -> anomaly "Not enough abstractions in fix body" - + in - check_rec_call renv def + check_rec_call renv [] def let judgment_of_fixpoint (_, types, bodies) = array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies @@ -856,7 +823,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = let (minds, rdef) = inductive_of_mutfix env fix in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in - let renv = make_renv fenv minds nvect.(i) minds.(i) in + let renv = make_renv fenv nvect.(i) minds.(i) in try check_one_fix renv nvect body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 0dac719c..a124647c 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -1,24 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* types -> inductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body -(*s Fetching information in the environment about an inductive type. +(** {6 ... } *) +(** Fetching information in the environment about an inductive type. Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif -(*s Functions to build standard types related to inductive *) +(** {6 Functions to build standard types related to inductive } *) val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list val type_of_inductive : env -> mind_specif -> types val elim_sorts : mind_specif -> sorts_family list -(* Return type as quoted by the user *) +(** Return type as quoted by the user *) val type_of_constructor : constructor -> mind_specif -> types -(* Return constructor types in normal form *) +(** Return constructor types in normal form *) val arities_of_constructors : inductive -> mind_specif -> types array -(* Return constructor types in user form *) +(** Return constructor types in user form *) val type_of_constructors : inductive -> mind_specif -> types array -(* Transforms inductive specification into types (in nf) *) +(** Transforms inductive specification into types (in nf) *) val arities_of_specif : mutual_inductive -> mind_specif -> types array val inductive_params : mind_specif -> int -(* [type_case_branches env (I,args) (p:A) c] computes useful types +(** [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression:

Cases (c :: (I args)) of b1..bn end It computes the type of every branch (pattern variables are @@ -70,20 +67,20 @@ val build_branches_type : inductive -> mutual_inductive_body * one_inductive_body -> constr list -> constr -> types array -(* Return the arity of an inductive type *) +(** Return the arity of an inductive type *) val mind_arity : one_inductive_body -> rel_context * sorts_family val inductive_sort_family : one_inductive_body -> sorts_family -(* Check a [case_info] actually correspond to a Case expression on the +(** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) val check_case_info : env -> inductive -> case_info -> unit -(*s Guard conditions for fix and cofix-points. *) +(** {6 Guard conditions for fix and cofix-points. } *) val check_fix : env -> fixpoint -> unit val check_cofix : env -> cofixpoint -> unit -(*s Support for sort-polymorphic inductive types *) +(** {6 Support for sort-polymorphic inductive types } *) (** The "polyprop" optional argument below allows to control the "Prop-polymorphism". By default, it is allowed. @@ -102,8 +99,7 @@ val max_inductive_sort : sorts array -> universe val instantiate_universes : env -> rel_context -> polymorphic_arity -> types array -> rel_context * sorts -(***************************************************************) -(* Debug *) +(** {6 Debug} *) type size = Large | Strict type subterm_spec = @@ -112,16 +108,13 @@ type subterm_spec = | Not_subterm type guard_env = { env : env; - (* dB of last fixpoint *) + (** dB of last fixpoint *) rel_min : int; - (* inductive of recarg of each fixpoint *) - inds : inductive array; - (* the recarg information of inductive family *) - recvec : wf_paths array; - (* dB of variables denoting subterms *) + (** dB of variables denoting subterms *) genv : subterm_spec Lazy.t list; } -val subterm_specif : guard_env -> constr -> subterm_spec -val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive -> - constr array -> (guard_env * constr) array +type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t + +val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec + diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index ab8b60be..314cc0ee 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -1,305 +1,249 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* debug_string_of_mbid mbid - | MPI mp -> string_of_mp mp +let is_empty_subst = Umap.is_empty -module Umap = Map.Make(struct - type t = substitution_domain - let compare = Pervasives.compare - end) +(* *) -type substitution = (module_path * delta_resolver) Umap.t - -let empty_subst = Umap.empty +let string_of_hint = function + | Inline (_,Some _) -> "inline(Some _)" + | Inline _ -> "inline()" + | Equiv kn -> string_of_kn kn + +let debug_string_of_delta resolve = + let kn_to_string kn hint s = + s^", "^(string_of_kn kn)^"=>"^(string_of_hint hint) + in + let mp_to_string mp mp' s = + s^", "^(string_of_mp mp)^"=>"^(string_of_mp mp') + in + Deltamap.fold mp_to_string kn_to_string resolve "" + +let list_contents sub = + let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in + let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in + let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in + Umap.fold mp_one_pair mbi_one_pair sub [] + +let debug_string_of_subst sub = + let l = List.map (fun (s1,(s2,s3)) -> s1^"|->"^s2^"["^s3^"]") + (list_contents sub) + in + "{" ^ String.concat "; " l ^ "}" + +let debug_pr_delta resolve = + str (debug_string_of_delta resolve) + +let debug_pr_subst sub = + let l = list_contents sub in + let f (s1,(s2,s3)) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++ + spc () ++ str "[" ++ str s3 ++ str "]") + in + str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}" +(* *) -let string_of_subst_domain = function - | MBI mbid -> debug_string_of_mbid mbid - | MPI mp -> string_of_mp mp - -let add_mbid mbid mp resolve = - Umap.add (MBI mbid) (mp,resolve) -let add_mp mp1 mp2 resolve = - Umap.add (MPI mp1) (mp2,resolve) +(** Extending a [delta_resolver] *) +let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc)) + +let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn') + +let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2 + +(** Extending a [substitution *) + +let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s +let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst -let add_inline_delta_resolver con = - Deltamap.add (KN(user_con con)) (Inline None) - -let add_inline_constr_delta_resolver con cstr = - Deltamap.add (KN(user_con con)) (Inline (Some cstr)) - -let add_constant_delta_resolver con = - Deltamap.add (KN(user_con con)) (Equiv (canonical_con con)) - -let add_mind_delta_resolver mind = - Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind)) - -let add_mp_delta_resolver mp1 mp2 = - Deltamap.add (MP mp1) (Prefix_equiv mp2) - -let mp_in_delta mp = - Deltamap.mem (MP mp) - -let con_in_delta con resolver = -try - match Deltamap.find (KN(user_con con)) resolver with - | Inline _ | Prefix_equiv _ -> false - | Equiv _ -> true -with - Not_found -> false - -let mind_in_delta mind resolver = -try - match Deltamap.find (KN(user_mind mind)) resolver with - | Inline _ | Prefix_equiv _ -> false - | Equiv _ -> true -with - Not_found -> false - -let delta_of_mp resolve mp = - try - match Deltamap.find (MP mp) resolve with - | Prefix_equiv mp1 -> mp1 - | _ -> anomaly "mod_subst: bad association in delta_resolver" - with - Not_found -> mp - -let delta_of_kn resolve kn = - try - match Deltamap.find (KN kn) resolve with - | Equiv kn1 -> kn1 - | Inline _ -> kn - | _ -> anomaly - "mod_subst: bad association in delta_resolver" - with - Not_found -> kn +let mp_in_delta mp = Deltamap.mem_mp mp -let remove_mp_delta_resolver resolver mp = - Deltamap.remove (MP mp) resolver +let kn_in_delta kn resolver = + try + match Deltamap.find_kn kn resolver with + | Equiv _ -> true + | Inline _ -> false + with Not_found -> false -exception Inline_kn +let con_in_delta con resolver = kn_in_delta (user_con con) resolver +let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver -let rec find_prefix resolve mp = +let mp_of_delta resolve mp = + try Deltamap.find_mp mp resolve with Not_found -> mp + +let rec find_prefix resolve mp = let rec sub_mp = function - | MPdot(mp,l) as mp_sup -> - (try - match Deltamap.find (MP mp_sup) resolve with - | Prefix_equiv mp1 -> mp1 - | _ -> anomaly - "mod_subst: bad association in delta_resolver" - with - Not_found -> MPdot(sub_mp mp,l)) - | p -> - match Deltamap.find (MP p) resolve with - | Prefix_equiv mp1 -> mp1 - | _ -> anomaly - "mod_subst: bad association in delta_resolver" + | MPdot(mp,l) as mp_sup -> + (try Deltamap.find_mp mp_sup resolve + with Not_found -> MPdot(sub_mp mp,l)) + | p -> Deltamap.find_mp p resolve in - try - sub_mp mp - with - Not_found -> mp + try sub_mp mp with Not_found -> mp -exception Change_equiv_to_inline of constr +exception Change_equiv_to_inline of (int * constr) let solve_delta_kn resolve kn = - try - match Deltamap.find (KN kn) resolve with - | Equiv kn1 -> kn1 - | Inline (Some c) -> - raise (Change_equiv_to_inline c) - | Inline None -> raise Inline_kn - | _ -> anomaly - "mod_subst: bad association in delta_resolver" - with - Not_found | Inline_kn -> - let mp,dir,l = repr_kn kn in - let new_mp = find_prefix resolve mp in - if mp == new_mp then - kn - else - make_kn new_mp dir l - + try + match Deltamap.find_kn kn resolve with + | Equiv kn1 -> kn1 + | Inline (lev, Some c) -> raise (Change_equiv_to_inline (lev,c)) + | Inline (_, None) -> raise Not_found + with Not_found -> + let mp,dir,l = repr_kn kn in + let new_mp = find_prefix resolve mp in + if mp == new_mp then + kn + else + make_kn new_mp dir l + +let kn_of_delta resolve kn = + try solve_delta_kn resolve kn + with _ -> kn + +let constant_of_delta_kn resolve kn = + constant_of_kn_equiv kn (kn_of_delta resolve kn) + +let gen_of_delta resolve x kn fix_can = + try + let new_kn = solve_delta_kn resolve kn in + if kn == new_kn then x else fix_can new_kn + with _ -> x let constant_of_delta resolve con = let kn = user_con con in - try - let new_kn = solve_delta_kn resolve kn in - if kn == new_kn then - con - else - constant_of_kn_equiv kn new_kn - with - _ -> con - + gen_of_delta resolve con kn (constant_of_kn_equiv kn) + let constant_of_delta2 resolve con = - let kn = canonical_con con in - let kn1 = user_con con in - try - let new_kn = solve_delta_kn resolve kn in - if kn == new_kn then - con - else - constant_of_kn_equiv kn1 new_kn - with - _ -> con + let kn, kn' = canonical_con con, user_con con in + gen_of_delta resolve con kn (constant_of_kn_equiv kn') + +let mind_of_delta_kn resolve kn = + mind_of_kn_equiv kn (kn_of_delta resolve kn) let mind_of_delta resolve mind = let kn = user_mind mind in - try - let new_kn = solve_delta_kn resolve kn in - if kn == new_kn then - mind - else - mind_of_kn_equiv kn new_kn - with - _ -> mind + gen_of_delta resolve mind kn (mind_of_kn_equiv kn) let mind_of_delta2 resolve mind = - let kn = canonical_mind mind in - let kn1 = user_mind mind in - try - let new_kn = solve_delta_kn resolve kn in - if kn == new_kn then - mind - else - mind_of_kn_equiv kn1 new_kn - with - _ -> mind - - -let inline_of_delta resolver = - let extract key hint l = - match key,hint with - |KN kn, Inline _ -> kn::l - | _,_ -> l - in - Deltamap.fold extract resolver [] + let kn, kn' = canonical_mind mind, user_mind mind in + gen_of_delta resolve mind kn (mind_of_kn_equiv kn') + +let inline_of_delta inline resolver = + match inline with + | None -> [] + | Some inl_lev -> + let extract kn hint l = + match hint with + | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l + | _ -> l + in + Deltamap.fold_kn extract resolver [] + +let find_inline_of_delta kn resolve = + match Deltamap.find_kn kn resolve with + | Inline (_,o) -> o + | _ -> raise Not_found -exception Not_inline - let constant_of_delta_with_inline resolve con = let kn1,kn2 = canonical_con con,user_con con in - try - match Deltamap.find (KN kn2) resolve with - | Inline None -> None - | Inline (Some const) -> Some const - | _ -> raise Not_inline - with - Not_found | Not_inline -> - try match Deltamap.find (KN kn1) resolve with - | Inline None -> None - | Inline (Some const) -> Some const - | _ -> raise Not_inline - with - Not_found | Not_inline -> None - -let string_of_key = function - | KN kn -> string_of_kn kn - | MP mp -> string_of_mp mp + try find_inline_of_delta kn2 resolve + with Not_found -> + try find_inline_of_delta kn1 resolve + with Not_found -> None -let string_of_hint = function - | Inline _ -> "inline" - | Equiv kn -> string_of_kn kn - | Prefix_equiv mp -> string_of_mp mp - -let debug_string_of_delta resolve = - let to_string key hint s = - s^", "^(string_of_key key)^"=>"^(string_of_hint hint) - in - Deltamap.fold to_string resolve "" - -let list_contents sub = - let one_pair uid (mp,reso) l = - (string_of_subst_domain uid, string_of_mp mp,debug_string_of_delta reso)::l - in - Umap.fold one_pair sub [] - -let debug_string_of_subst sub = - let l = List.map (fun (s1,s2,s3) -> s1^"|->"^s2^"["^s3^"]") - (list_contents sub) in - "{" ^ String.concat "; " l ^ "}" - -let debug_pr_delta resolve = - str (debug_string_of_delta resolve) - -let debug_pr_subst sub = - let l = list_contents sub in - let f (s1,s2,s3) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++ - spc () ++ str "[" ++ str s3 ++ str "]") - in - str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}" - - let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPfile sid -> - let mp',resolve = Umap.find (MPI (MPfile sid)) sub in - mp',resolve + | MPfile sid -> Umap.find_mp mp sub | MPbound bid -> begin - try - let mp',resolve = Umap.find (MBI bid) sub in - mp',resolve - with Not_found -> - let mp',resolve = Umap.find (MPI mp) sub in - mp',resolve + try Umap.find_mbi bid sub + with Not_found -> Umap.find_mp mp sub end | MPdot (mp1,l) as mp2 -> begin - try - let mp',resolve = Umap.find (MPI mp2) sub in - mp',resolve + try Umap.find_mp mp2 sub with Not_found -> let mp1',resolve = aux mp1 in - MPdot (mp1',l),resolve + MPdot (mp1',l),resolve end in - try - Some (aux mp) - with Not_found -> None + try Some (aux mp) with Not_found -> None let subst_mp sub mp = match subst_mp0 sub mp with @@ -327,107 +271,47 @@ type sideconstantsubst = | User | Canonical -let subst_ind sub mind = - let kn1,kn2 = user_mind mind,canonical_mind mind in - let mp1,dir,l = repr_kn kn1 in - let mp2,_,_ = repr_kn kn2 in - try - let side,mind',resolve = - match subst_mp0 sub mp1,subst_mp0 sub mp2 with - None,None ->raise No_subst - | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve - | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve - | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, - (make_mind_equiv mp1' mp2' dir l), resolve2 - in - match side with - |User -> - let mind = mind_of_delta resolve mind' in - mind - |Canonical -> - let mind = mind_of_delta2 resolve mind' in - mind - with - No_subst -> mind - -let subst_mind0 sub mind = - let kn1,kn2 = user_mind mind,canonical_mind mind in - let mp1,dir,l = repr_kn kn1 in - let mp2,_,_ = repr_kn kn2 in - try - let side,mind',resolve = - match subst_mp0 sub mp1,subst_mp0 sub mp2 with - None,None ->raise No_subst - | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve - | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve - | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, - (make_mind_equiv mp1' mp2' dir l), resolve2 - in - match side with - |User -> - let mind = mind_of_delta resolve mind' in - Some mind - |Canonical -> - let mind = mind_of_delta2 resolve mind' in - Some mind - with - No_subst -> Some mind +let gen_subst_mp f sub mp1 mp2 = + match subst_mp0 sub mp1, subst_mp0 sub mp2 with + | None, None -> raise No_subst + | Some (mp',resolve), None -> User, (f mp' mp2), resolve + | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve + | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 -let subst_con sub con = - let kn1,kn2 = user_con con,canonical_con con in +let subst_ind sub mind = + let kn1,kn2 = user_mind mind, canonical_mind mind in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in - try - let side,con',resolve = - match subst_mp0 sub mp1,subst_mp0 sub mp2 with - None,None ->raise No_subst - | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve - | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve - | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, - (make_con_equiv mp1' mp2' dir l), resolve2 - in - match constant_of_delta_with_inline resolve con' with - None -> begin - match side with - |User -> - let con = constant_of_delta resolve con' in - con,mkConst con - |Canonical -> - let con = constant_of_delta2 resolve con' in - con,mkConst con - end - | Some t -> - (* In case of inlining, discard the canonical part (cf #2608) *) - constant_of_kn (user_con con'), t - with No_subst -> con , mkConst con - + let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in + try + let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in + match side with + | User -> mind_of_delta resolve mind' + | Canonical -> mind_of_delta2 resolve mind' + with No_subst -> mind let subst_con0 sub con = let kn1,kn2 = user_con con,canonical_con con in let mp1,dir,l = repr_kn kn1 in let mp2,_,_ = repr_kn kn2 in - try - let side,con',resolve = - match subst_mp0 sub mp1,subst_mp0 sub mp2 with - None,None ->raise No_subst - | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve - | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve - | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical, - (make_con_equiv mp1' mp2' dir l), resolve2 + let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in + let dup con = con, mkConst con in + let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in + match constant_of_delta_with_inline resolve con' with + | Some t -> + (* In case of inlining, discard the canonical part (cf #2608) *) + constant_of_kn (user_con con'), t + | None -> + let con'' = match side with + | User -> constant_of_delta resolve con' + | Canonical -> constant_of_delta2 resolve con' in - match constant_of_delta_with_inline resolve con' with - None ->begin - match side with - |User -> - let con = constant_of_delta resolve con' in - Some (mkConst con) - |Canonical -> - let con = constant_of_delta2 resolve con' in - Some (mkConst con) - end - | t -> t - with No_subst -> Some (mkConst con) - + if con'' == con then raise No_subst else dup con'' + +let subst_con sub con = + try subst_con0 sub con + with No_subst -> con, mkConst con + (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" @@ -437,29 +321,22 @@ let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) - - let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with - | Const kn -> - (match f' kn with - None -> c - | Some const ->const) + | Const kn -> (try snd (f' kn) with No_subst -> c) | Ind (kn,i) -> - (match f kn with - None -> c - | Some kn' -> - mkInd (kn',i)) + let kn' = f kn in + if kn'==kn then c else mkInd (kn',i) | Construct ((kn,i),j) -> - (match f kn with - None -> c - | Some kn' -> - mkConstruct ((kn',i),j)) + let kn' = f kn in + if kn'==kn then c else mkConstruct ((kn',i),j) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in - (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in + let kn' = f kn in + if kn'==kn then ci.ci_ind else kn',i + in let p' = func p in let ct' = func ct in let l' = array_smartmap func l in @@ -510,8 +387,9 @@ let rec map_kn f f' c = else mkCoFix (ln,(lna,tl',bl')) | _ -> c -let subst_mps sub = - map_kn (subst_mind0 sub) (subst_con0 sub) +let subst_mps sub c = + if is_empty_subst sub then c + else map_kn (subst_ind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with @@ -533,117 +411,76 @@ let rec mp_in_mp mp mp1 = | _ when mp1 = mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false - -let mp_in_key mp key = - match key with - | MP mp1 -> - mp_in_mp mp mp1 - | KN kn -> - let mp1,dir,l = repr_kn kn in - mp_in_mp mp mp1 - + let subset_prefixed_by mp resolver = - let prefixmp key hint resolv = - match hint with - | Inline _ -> resolv - | _ -> - if mp_in_key mp key then - Deltamap.add key hint resolv - else - resolv + let mp_prefix mkey mequ rslv = + if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv + in + let kn_prefix kn hint rslv = + match hint with + | Inline _ -> rslv + | Equiv _ -> + if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv in - Deltamap.fold prefixmp resolver empty_delta_resolver + Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver let subst_dom_delta_resolver subst resolver = - let apply_subst key hint resolver = - match key with - (MP mp) -> - Deltamap.add (MP (subst_mp subst mp)) hint resolver - | (KN kn) -> - Deltamap.add (KN (subst_kn subst kn)) hint resolver + let mp_apply_subst mkey mequ rslv = + Deltamap.add_mp (subst_mp subst mkey) mequ rslv + in + let kn_apply_subst kkey hint rslv = + Deltamap.add_kn (subst_kn subst kkey) hint rslv in - Deltamap.fold apply_subst resolver empty_delta_resolver + Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver -let subst_mp_delta sub mp key= +let subst_mp_delta sub mp mkey = match subst_mp0 sub mp with None -> empty_delta_resolver,mp - | Some (mp',resolve) -> + | Some (mp',resolve) -> let mp1 = find_prefix resolve mp' in let resolve1 = subset_prefixed_by mp1 resolve in - match key with - MP mpk -> - (subst_dom_delta_resolver - (map_mp mp1 mpk empty_delta_resolver) resolve1),mp1 - | _ -> anomaly "Mod_subst: Bad association in resolver" - -let subst_codom_delta_resolver subst resolver = - let apply_subst key hint resolver = - match hint with - Prefix_equiv mp -> - let derived_resolve,mpnew = subst_mp_delta subst mp key in - Deltamap.fold Deltamap.add derived_resolve - (Deltamap.add key (Prefix_equiv mpnew) resolver) - | (Equiv kn) -> - (try - Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver - with - Change_equiv_to_inline c -> - Deltamap.add key (Inline (Some c)) resolver) - | Inline None -> - Deltamap.add key hint resolver - | Inline (Some t) -> - Deltamap.add key (Inline (Some (subst_mps subst t))) resolver + (subst_dom_delta_resolver + (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1 + +let gen_subst_delta_resolver dom subst resolver = + let mp_apply_subst mkey mequ rslv = + let mkey' = if dom then subst_mp subst mkey else mkey in + let rslv',mequ' = subst_mp_delta subst mequ mkey in + Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv) in - Deltamap.fold apply_subst resolver empty_delta_resolver - -let subst_dom_codom_delta_resolver subst resolver = - let apply_subst key hint resolver = - match key,hint with - (MP mp1),Prefix_equiv mp -> - let key = MP (subst_mp subst mp1) in - let derived_resolve,mpnew = subst_mp_delta subst mp key in - Deltamap.fold Deltamap.add derived_resolve - (Deltamap.add key (Prefix_equiv mpnew) resolver) - | (KN kn1),(Equiv kn) -> - let key = KN (subst_kn subst kn1) in - (try - Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver - with - Change_equiv_to_inline c -> - Deltamap.add key (Inline (Some c)) resolver) - | (KN kn),Inline None -> - let key = KN (subst_kn subst kn) in - Deltamap.add key hint resolver - | (KN kn),Inline (Some t) -> - let key = KN (subst_kn subst kn) in - Deltamap.add key (Inline (Some (subst_mps subst t))) resolver - | _,_ -> anomaly "Mod_subst: Bad association in resolver" + let kn_apply_subst kkey hint rslv = + let kkey' = if dom then subst_kn subst kkey else kkey in + let hint' = match hint with + | Equiv kequ -> + (try Equiv (subst_kn_delta subst kequ) + with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) + | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t)) + | Inline (_,None) -> hint + in + Deltamap.add_kn kkey' hint' rslv in - Deltamap.fold apply_subst resolver empty_delta_resolver + Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver + +let subst_codom_delta_resolver = gen_subst_delta_resolver false +let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true let update_delta_resolver resolver1 resolver2 = - let apply_res key hint res = - try - if Deltamap.mem key resolver2 then - res else - match hint with - Prefix_equiv mp -> - let new_hint = - Prefix_equiv (find_prefix resolver2 mp) - in Deltamap.add key new_hint res - | Equiv kn -> - (try - let new_hint = - Equiv (solve_delta_kn resolver2 kn) - in Deltamap.add key new_hint res - with - Change_equiv_to_inline c -> - Deltamap.add key (Inline (Some c)) res) - | _ -> Deltamap.add key hint res - with Not_found -> - Deltamap.add key hint res - in - Deltamap.fold apply_res resolver1 empty_delta_resolver + let mp_apply_rslv mkey mequ rslv = + if Deltamap.mem_mp mkey resolver2 then rslv + else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv + in + let kn_apply_rslv kkey hint rslv = + if Deltamap.mem_kn kkey resolver2 then rslv + else + let hint' = match hint with + | Equiv kequ -> + (try Equiv (solve_delta_kn resolver2 kequ) + with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c)) + | _ -> hint + in + Deltamap.add_kn kkey hint' rslv + in + Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver let add_delta_resolver resolver1 resolver2 = if resolver1 == resolver2 then @@ -651,63 +488,54 @@ let add_delta_resolver resolver1 resolver2 = else if resolver2 = empty_delta_resolver then resolver1 else - Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2) - resolver2 + Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2 let substition_prefixed_by k mp subst = - let prefixmp key (mp_to,reso) sub = - match key with - | MPI mpk -> - if mp_in_mp mp mpk && mp <> mpk then - let new_key = replace_mp_in_mp mp k mpk in - Umap.add (MPI new_key) (mp_to,reso) sub - else - sub - | _ -> sub + let mp_prefixmp kmp (mp_to,reso) sub = + if mp_in_mp mp kmp && mp <> kmp then + let new_key = replace_mp_in_mp mp k kmp in + Umap.add_mp new_key (mp_to,reso) sub + else sub + in + let mbi_prefixmp mbi _ sub = sub in - Umap.fold prefixmp subst empty_subst + Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst -let join (subst1 : substitution) (subst2 : substitution) = - let apply_subst key (mp,resolve) res = +let join subst1 subst2 = + let apply_subst mpk add (mp,resolve) res = let mp',resolve' = match subst_mp0 subst2 mp with - None -> mp, None - | Some (mp',resolve') -> mp' - ,Some resolve' in - let resolve'' : delta_resolver = + | None -> mp, None + | Some (mp',resolve') -> mp', Some resolve' in + let resolve'' = match resolve' with - Some res -> - add_delta_resolver + | Some res -> + add_delta_resolver (subst_dom_codom_delta_resolver subst2 resolve) res - | None -> + | None -> subst_codom_delta_resolver subst2 resolve in - let k = match key with MBI mp -> MPbound mp | MPI mp -> mp in - let prefixed_subst = substition_prefixed_by k mp subst2 in - Umap.fold Umap.add prefixed_subst - (Umap.add key (mp',resolve'') res) in - let subst = Umap.fold apply_subst subst1 empty_subst in - (Umap.fold Umap.add subst2 subst) - - - -let rec occur_in_path uid path = - match uid,path with - | MBI bid,MPbound bid' -> bid = bid' - | _,MPdot (mp1,_) -> occur_in_path uid mp1 + let prefixed_subst = substition_prefixed_by mpk mp' subst2 in + Umap.join prefixed_subst (add (mp',resolve'') res) + in + let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in + let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in + let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in + Umap.join subst2 subst + +let rec occur_in_path mbi = function + | MPbound bid' -> mbi = bid' + | MPdot (mp1,_) -> occur_in_path mbi mp1 | _ -> false -let occur_uid uid sub = - let check_one uid' (mp,_) = - if uid = uid' || occur_in_path uid mp then raise Exit +let occur_mbid mbi sub = + let check_one mbi' (mp,_) = + if mbi = mbi' || occur_in_path mbi mp then raise Exit in - try - Umap.iter check_one sub; - false - with Exit -> true - - -let occur_mbid uid = occur_uid (MBI uid) + try + Umap.iter_mbi check_one sub; + false + with Exit -> true type 'a lazy_subst = | LSval of 'a diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 9b48b3ea..55d2ff15 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -1,105 +1,108 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* delta_resolver -> delta_resolver +val add_mp_delta_resolver : + module_path -> module_path -> delta_resolver -> delta_resolver -val add_inline_constr_delta_resolver : constant -> constr -> delta_resolver - -> delta_resolver +val add_kn_delta_resolver : + kernel_name -> kernel_name -> delta_resolver -> delta_resolver -val add_constant_delta_resolver : constant -> delta_resolver -> delta_resolver - -val add_mind_delta_resolver : mutual_inductive -> delta_resolver -> delta_resolver - -val add_mp_delta_resolver : module_path -> module_path -> delta_resolver - -> delta_resolver +val add_inline_delta_resolver : + kernel_name -> (int * constr option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver -(* Apply the substitution on the domain of the resolver *) -val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver +(** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *) -(* Apply the substitution on the codomain of the resolver *) -val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver - -val subst_dom_codom_delta_resolver : - substitution -> delta_resolver -> delta_resolver - -(* *_of_delta return the associated name of arg2 in arg1 *) +val kn_of_delta : delta_resolver -> kernel_name -> kernel_name +val constant_of_delta_kn : delta_resolver -> kernel_name -> constant val constant_of_delta : delta_resolver -> constant -> constant +val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive -val delta_of_mp : delta_resolver -> module_path -> module_path +val mp_of_delta : delta_resolver -> module_path -> module_path -(* Extract the set of inlined constant in the resolver *) -val inline_of_delta : delta_resolver -> kernel_name list +(** Extract the set of inlined constant in the resolver *) +val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list -(* remove_mp is used for the computation of a resolver induced by Include P *) -val remove_mp_delta_resolver : delta_resolver -> module_path -> delta_resolver +(** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *) - -(* mem tests *) val mp_in_delta : module_path -> delta_resolver -> bool - val con_in_delta : constant -> delta_resolver -> bool - val mind_in_delta : mutual_inductive -> delta_resolver -> bool -(*substitution*) + +(** {6 Substitution} *) + +type substitution val empty_subst : substitution -(* add_* add [arg2/arg1]{arg3} to the substitution with no +val is_empty_subst : substitution -> bool + +(** add_* add [arg2/arg1]\{arg3\} to the substitution with no sequential composition *) val add_mbid : mod_bound_id -> module_path -> delta_resolver -> substitution -> substitution val add_mp : module_path -> module_path -> delta_resolver -> substitution -> substitution -(* map_* create a new substitution [arg2/arg1]{arg3} *) +(** map_* create a new substitution [arg2/arg1]\{arg3\} *) val map_mbid : mod_bound_id -> module_path -> delta_resolver -> substitution val map_mp : module_path -> module_path -> delta_resolver -> substitution -(* sequential composition: +(** sequential composition: [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] *) val join : substitution -> substitution -> substitution + +(** Apply the substitution on the domain of the resolver *) +val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver + +(** Apply the substitution on the codomain of the resolver *) +val subst_codom_delta_resolver : + substitution -> delta_resolver -> delta_resolver + +val subst_dom_codom_delta_resolver : + substitution -> delta_resolver -> delta_resolver + + type 'a substituted val from_val : 'a -> 'a substituted val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a val subst_substituted : substitution -> 'a substituted -> 'a substituted -(*i debugging *) +(**/**) +(* debugging *) val debug_string_of_subst : substitution -> string val debug_pr_subst : substitution -> Pp.std_ppcmds val debug_string_of_delta : delta_resolver -> string val debug_pr_delta : delta_resolver -> Pp.std_ppcmds -(*i*) +(**/**) -(* [subst_mp sub mp] guarantees that whenever the result of the +(** [subst_mp sub mp] guarantees that whenever the result of the substitution is structutally equal [mp], it is equal by pointers as well [==] *) @@ -109,13 +112,13 @@ val subst_mp : val subst_ind : substitution -> mutual_inductive -> mutual_inductive -val subst_kn : +val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : substitution -> constant -> constant * constr -(* Here the semantics is completely unclear. +(** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" where X.t is later on instantiated with y? I choose the first @@ -123,14 +126,14 @@ val subst_con : val subst_evaluable_reference : substitution -> evaluable_global_reference -> evaluable_global_reference -(* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) +(** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name -(* [subst_mps sub c] performs the substitution [sub] on all kernel +(** [subst_mps sub c] performs the substitution [sub] on all kernel names appearing in [c] *) val subst_mps : substitution -> constr -> constr -(* [occur_*id id sub] returns true iff [id] occurs in [sub] +(** [occur_*id id sub] returns true iff [id] occurs in [sub] on either side *) val occur_mbid : mod_bound_id -> substitution -> bool diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index e366bc97..a384c836 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -1,12 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* mp | _ -> raise Not_path +let rec mp_from_mexpr = function + | MSEident mp -> mp + | MSEapply (expr,_) -> mp_from_mexpr expr + | MSEfunctor (_,_,expr) -> mp_from_mexpr expr + | MSEwith (expr,_) -> mp_from_mexpr expr + let rec list_split_assoc k rev_before = function | [] -> raise Not_found | (k',b)::after when k=k' -> rev_before,b,after | h::tail -> list_split_assoc k (h::rev_before) tail -let rec list_fold_map2 f e = function - | [] -> (e,[],[]) - | h::t -> - let e',h1',h2' = f e h in - let e'',t1',t2' = list_fold_map2 f e' t in - e'',h1'::t1',h2'::t2' - let discr_resolver env mtb = match mtb.typ_expr with SEBstruct _ -> @@ -81,40 +84,41 @@ and check_with_aux_def env sign with_decl mp equiv = | With_Definition ([],_) -> assert false | With_Definition ([id],c) -> let cb = match spec with - SFBconst cb -> cb + | SFBconst cb -> cb | _ -> error_not_a_constant l in - begin - match cb.const_body with - | None -> - let (j,cst1) = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst2 = Reduction.conv_leq env' j.uj_type typ in - let cst = - Constraint.union - (Constraint.union cb.const_constraints cst1) - cst2 in - let body = Some (Declarations.from_val j.uj_val) in - let cb' = {cb with - const_body = body; - const_body_code = Cemitcodes.from_val - (compile_constant_body env' body false false); - const_constraints = cst} in - SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst - | Some b -> - let cst1 = Reduction.conv env' c (Declarations.force b) in - let cst = Constraint.union cb.const_constraints cst1 in - let body = Some (Declarations.from_val c) in - let cb' = {cb with - const_body = body; - const_body_code = Cemitcodes.from_val - (compile_constant_body env' body false false); - const_constraints = cst} in - SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst - end + (* In the spirit of subtyping.check_constant, we accept + any implementations of parameters and opaques terms, + as long as they have the right type *) + let def,cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let (j,cst1) = Typeops.infer env' c in + let typ = Typeops.type_of_constant_type env' cb.const_type in + let cst2 = Reduction.conv_leq env' j.uj_type typ in + let cst = + union_constraints + (union_constraints cb.const_constraints cst1) + cst2 + in + let def = Def (Declarations.from_val j.uj_val) in + def,cst + | Def cs -> + let cst1 = Reduction.conv env' c (Declarations.force cs) in + let cst = union_constraints cb.const_constraints cst1 in + let def = Def (Declarations.from_val c) in + def,cst + in + let cb' = + { cb with + const_body = def; + const_body_code = + Cemitcodes.from_val (compile_constant_body env' def); + const_constraints = cst } + in + SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst | With_Definition (_::_,c) -> let old = match spec with - SFBmodule msb -> msb + | SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) in begin @@ -129,12 +133,12 @@ and check_with_aux_def env sign with_decl mp equiv = mod_type_alg = None}) in SEBstruct(before@((l,new_spec)::after)),cb,cst | Some msb -> - error_a_generative_module_expected l + error_generative_module_expected l end | _ -> anomaly "Modtyping:incorrect use of with" with - Not_found -> error_no_such_label l - | Reduction.NotConvertible -> error_with_incorrect l + | Not_found -> error_no_such_label l + | Reduction.NotConvertible -> error_incorrect_with_constraint l and check_with_aux_mod env sign with_decl mp equiv = let sig_b = match sign with @@ -163,24 +167,24 @@ and check_with_aux_mod env sign with_decl mp equiv = in let mb_mp1 = (lookup_module mp1 env) in let mtb_mp1 = - module_type_of_module env' None mb_mp1 in + module_type_of_module None mb_mp1 in let cst = match old.mod_expr with None -> begin - try Constraint.union + try union_constraints (check_subtypes env' mtb_mp1 - (module_type_of_module env' None old)) + (module_type_of_module None old)) old.mod_constraints - with Failure _ -> error_with_incorrect (label_of_id id) + with Failure _ -> error_incorrect_with_constraint (label_of_id id) end | Some (SEBident(mp')) -> check_modpath_equiv env' mp1 mp'; old.mod_constraints - | _ -> error_a_generative_module_expected l + | _ -> error_generative_module_expected l + in + let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false in - let new_mb = strengthen_and_subst_mb mb_mp1 - (MPdot(mp,l)) env false in let new_spec = SFBmodule {new_mb with mod_mp = MPdot(mp,l); mod_expr = Some (SEBident mp1); @@ -215,14 +219,14 @@ and check_with_aux_mod env sign with_decl mp equiv = let mpnew = rebuild_mp mp' (List.map label_of_id idl) in check_modpath_equiv env' mpnew mp; SEBstruct(before@(l,spec)::after) - ,equiv,Constraint.empty + ,equiv,empty_constraint | _ -> - error_a_generative_module_expected l + error_generative_module_expected l end | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l - | Reduction.NotConvertible -> error_with_incorrect l + | Reduction.NotConvertible -> error_incorrect_with_constraint l and translate_module env mp inl me = match me.mod_entry_expr, me.mod_entry_type with @@ -243,14 +247,14 @@ and translate_module env mp inl me = let sign,alg1,resolver,cst2 = match me.mod_entry_type with | None -> - sign,None,resolver,Constraint.empty + sign,None,resolver,empty_constraint | Some mte -> let mtb = translate_module_type env mp inl mte in let cst = check_subtypes env {typ_mp = mp; typ_expr = sign; typ_expr_alg = None; - typ_constraints = Constraint.empty; + typ_constraints = empty_constraint; typ_delta = resolver;} mtb in @@ -258,9 +262,9 @@ and translate_module env mp inl me = in { mod_mp = mp; mod_type = sign; - mod_expr = Some alg_implem; + mod_expr = alg_implem; mod_type_alg = alg1; - mod_constraints = Univ.Constraint.union cst1 cst2; + mod_constraints = Univ.union_constraints cst1 cst2; mod_delta = resolver; mod_retroknowledge = []} (* spiwack: not so sure about that. It may @@ -268,125 +272,92 @@ and translate_module env mp inl me = If it does, I don't really know how to fix the bug.*) +and translate_apply env inl ftrans mexpr mkalg = + let sign,alg,resolver,cst1 = ftrans in + let farg_id, farg_b, fbody_b = destr_functor env sign in + let mp1 = + try path_of_mexpr mexpr + with Not_path -> error_application_to_not_path mexpr + in + let mtb = module_type_of_module None (lookup_module mp1 env) in + let cst2 = check_subtypes env mtb farg_b in + let mp_delta = discr_resolver env mtb in + let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta + in + subst_struct_expr subst fbody_b, + mkalg alg mp1 cst2, + subst_codom_delta_resolver subst resolver, + Univ.union_constraints cst1 cst2 + +and translate_functor env inl arg_id arg_e trans mkalg = + let mtb = translate_module_type env (MPbound arg_id) inl arg_e in + let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in + let sign,alg,resolver,cst = trans env' + in + SEBfunctor (arg_id, mtb, sign), + mkalg alg arg_id mtb, + resolver, + Univ.union_constraints cst mtb.typ_constraints -and translate_struct_module_entry env mp inl mse = match mse with +and translate_struct_module_entry env mp inl = function | MSEident mp1 -> - let mb = lookup_module mp1 env in - let mb' = strengthen_and_subst_mb mb mp env false in - mb'.mod_type, SEBident mp1, mb'.mod_delta,Univ.Constraint.empty + let mb = lookup_module mp1 env in + let mb' = strengthen_and_subst_mb mb mp false in + mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint | MSEfunctor (arg_id, arg_e, body_expr) -> - let mtb = translate_module_type env (MPbound arg_id) inl arg_e in - let env' = add_module (module_body_of_type (MPbound arg_id) mtb) - env in - let sign,alg,resolver,cst = - translate_struct_module_entry env' mp inl body_expr in - SEBfunctor (arg_id, mtb, sign),SEBfunctor (arg_id, mtb, alg),resolver, - Univ.Constraint.union cst mtb.typ_constraints + let trans env' = translate_struct_module_entry env' mp inl body_expr in + let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in + translate_functor env inl arg_id arg_e trans mkalg | MSEapply (fexpr,mexpr) -> - let sign,alg,resolver,cst1 = - translate_struct_module_entry env mp inl fexpr - in - let farg_id, farg_b, fbody_b = destr_functor env sign in - let mtb,mp1 = - try - let mp1 = path_of_mexpr mexpr in - let mtb = module_type_of_module env None (lookup_module mp1 env) in - mtb,mp1 - with - | Not_path -> error_application_to_not_path mexpr - (* place for nondep_supertype *) in - let cst = check_subtypes env mtb farg_b in - let mp_delta = discr_resolver env mtb in - let mp_delta = if not inl then mp_delta else - complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta - in - let subst = map_mbid farg_id mp1 mp_delta in - (subst_struct_expr subst fbody_b),SEBapply(alg,SEBident mp1,cst), - (subst_codom_delta_resolver subst resolver), - Univ.Constraint.union cst1 cst + let trans = translate_struct_module_entry env mp inl fexpr in + let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in + translate_apply env inl trans mexpr mkalg | MSEwith(mte, with_decl) -> - let sign,alg,resolve,cst1 = translate_struct_module_entry env mp inl mte in - let sign,alg,resolve,cst2 = check_with env sign with_decl (Some alg) mp resolve in - sign,Option.get alg,resolve,Univ.Constraint.union cst1 cst2 - -and translate_struct_type_entry env inl mse = match mse with + let sign,alg,resolve,cst1 = + translate_struct_module_entry env mp inl mte in + let sign,alg,resolve,cst2 = + check_with env sign with_decl alg mp resolve in + sign,alg,resolve,Univ.union_constraints cst1 cst2 + +and translate_struct_type_entry env inl = function | MSEident mp1 -> - let mtb = lookup_modtype mp1 env in - mtb.typ_expr, - Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty + let mtb = lookup_modtype mp1 env in + mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint | MSEfunctor (arg_id, arg_e, body_expr) -> - let mtb = translate_module_type env (MPbound arg_id) inl arg_e in - let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in - let sign,alg,resolve,mp_from,cst = - translate_struct_type_entry env' inl body_expr in - SEBfunctor (arg_id, mtb, sign),None,resolve,mp_from, - Univ.Constraint.union cst mtb.typ_constraints + let trans env' = translate_struct_type_entry env' inl body_expr in + translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None) | MSEapply (fexpr,mexpr) -> - let sign,alg,resolve,mp_from,cst1 = - translate_struct_type_entry env inl fexpr - in - let farg_id, farg_b, fbody_b = destr_functor env sign in - let mtb,mp1 = - try - let mp1 = path_of_mexpr mexpr in - let mtb = module_type_of_module env None (lookup_module mp1 env) in - mtb,mp1 - with - | Not_path -> error_application_to_not_path mexpr - (* place for nondep_supertype *) in - let cst2 = check_subtypes env mtb farg_b in - let mp_delta = discr_resolver env mtb in - let mp_delta = if not inl then mp_delta else - complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta - in - let subst = map_mbid farg_id mp1 mp_delta in - (subst_struct_expr subst fbody_b),None, - (subst_codom_delta_resolver subst resolve),mp_from,Univ.Constraint.union cst1 cst2 + let trans = translate_struct_type_entry env inl fexpr in + translate_apply env inl trans mexpr (fun _ _ _ -> None) | MSEwith(mte, with_decl) -> - let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in - let sign,alg,resolve,cst1 = - check_with env sign with_decl alg mp_from resolve in - sign,alg,resolve,mp_from,Univ.Constraint.union cst cst1 + let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in + let sign,alg,resolve,cst2 = + check_with env sign with_decl alg (mp_from_mexpr mte) resolve + in + sign,alg,resolve,Univ.union_constraints cst1 cst2 and translate_module_type env mp inl mte = - let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in - let mtb = subst_modtype_and_resolver - {typ_mp = mp_from; - typ_expr = sign; - typ_expr_alg = None; - typ_constraints = cst; - typ_delta = resolve} mp env - in {mtb with typ_expr_alg = alg} + let mp_from = mp_from_mexpr mte in + let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in + let mtb = subst_modtype_and_resolver + {typ_mp = mp_from; + typ_expr = sign; + typ_expr_alg = None; + typ_constraints = cst; + typ_delta = resolve} mp + in {mtb with typ_expr_alg = alg} -let rec translate_struct_include_module_entry env mp inl mse = match mse with +let rec translate_struct_include_module_entry env mp inl = function | MSEident mp1 -> - let mb = lookup_module mp1 env in - let mb' = strengthen_and_subst_mb mb mp env true in - let mb_typ = clean_bounded_mod_expr mb'.mod_type in - mb_typ, mb'.mod_delta,Univ.Constraint.empty + let mb = lookup_module mp1 env in + let mb' = strengthen_and_subst_mb mb mp true in + let mb_typ = clean_bounded_mod_expr mb'.mod_type in + mb_typ,None,mb'.mod_delta,Univ.empty_constraint | MSEapply (fexpr,mexpr) -> - let sign,resolver,cst1 = - translate_struct_include_module_entry env mp inl fexpr in - let farg_id, farg_b, fbody_b = destr_functor env sign in - let mtb,mp1 = - try - let mp1 = path_of_mexpr mexpr in - let mtb = module_type_of_module env None (lookup_module mp1 env) in - mtb,mp1 - with - | Not_path -> error_application_to_not_path mexpr - (* place for nondep_supertype *) in - let cst = check_subtypes env mtb farg_b in - let mp_delta = discr_resolver env mtb in - let mp_delta = if not inl then mp_delta else - complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta - in - let subst = map_mbid farg_id mp1 mp_delta in - (subst_struct_expr subst fbody_b), - (subst_codom_delta_resolver subst resolver), - Univ.Constraint.union cst1 cst + let ftrans = translate_struct_include_module_entry env mp inl fexpr in + translate_apply env inl ftrans mexpr (fun _ _ _ -> None) | _ -> error ("You cannot Include a high-order structure.") - let rec add_struct_expr_constraints env = function | SEBident _ -> env @@ -448,11 +419,11 @@ let rec struct_expr_constraints cst = function | SEBapply (meb1,meb2,cst1) -> struct_expr_constraints - (struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1) + (struct_expr_constraints (Univ.union_constraints cst1 cst) meb1) meb2 | SEBwith(meb,With_definition_body(_,cb))-> struct_expr_constraints - (Univ.Constraint.union cb.const_constraints cst) meb + (Univ.union_constraints cb.const_constraints cst) meb | SEBwith(meb,With_module_body(_,_))-> struct_expr_constraints cst meb @@ -468,11 +439,11 @@ and module_constraints cst mb = | Some meb -> struct_expr_constraints cst meb in let cst = struct_expr_constraints cst mb.mod_type in - Univ.Constraint.union mb.mod_constraints cst + Univ.union_constraints mb.mod_constraints cst and modtype_constraints cst mtb = - struct_expr_constraints (Univ.Constraint.union mtb.typ_constraints cst) mtb.typ_expr + struct_expr_constraints (Univ.union_constraints mtb.typ_constraints cst) mtb.typ_expr -let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty -let module_constraints = module_constraints Univ.Constraint.empty +let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint +let module_constraints = module_constraints Univ.empty_constraint diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index ec5eb332..0987ca5b 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -1,36 +1,44 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_path -> bool -> module_entry - -> module_body - -val translate_module_type : env -> module_path -> bool -> module_struct_entry -> - module_type_body - -val translate_struct_module_entry : env -> module_path -> bool -> module_struct_entry -> - struct_expr_body * struct_expr_body * delta_resolver * Univ.constraints -val translate_struct_type_entry : env -> bool -> module_struct_entry -> - struct_expr_body * struct_expr_body option * delta_resolver * module_path * Univ.constraints -val translate_struct_include_module_entry : env -> module_path - -> bool -> module_struct_entry -> struct_expr_body * delta_resolver * Univ.constraints +val translate_module : + env -> module_path -> inline -> module_entry -> module_body + +val translate_module_type : + env -> module_path -> inline -> module_struct_entry -> module_type_body + +val translate_struct_module_entry : + env -> module_path -> inline -> module_struct_entry -> + struct_expr_body (* Signature *) + * struct_expr_body option (* Algebraic expr, in fact never None *) + * delta_resolver + * Univ.constraints + +val translate_struct_type_entry : + env -> inline -> module_struct_entry -> + struct_expr_body + * struct_expr_body option + * delta_resolver + * Univ.constraints + +val translate_struct_include_module_entry : + env -> module_path -> inline -> module_struct_entry -> + struct_expr_body + * struct_expr_body option (* Algebraic expr, always None *) + * delta_resolver + * Univ.constraints val add_modtype_constraints : env -> module_type_body -> env diff --git a/kernel/modops.ml b/kernel/modops.ml index f0d579a4..0c2c6bd7 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -1,14 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "^string_of_label l'^" !") - -let error_result_must_be_signature () = - error "The result module type must be a signature." +type signature_mismatch_error = + | InductiveFieldExpected of mutual_inductive_body + | DefinitionFieldExpected + | ModuleFieldExpected + | ModuleTypeFieldExpected + | NotConvertibleInductiveField of identifier + | NotConvertibleConstructorField of identifier + | NotConvertibleBodyField + | NotConvertibleTypeField + | NotSameConstructorNamesField + | NotSameInductiveNameInBlockField + | FiniteInductiveFieldExpected of bool + | InductiveNumbersFieldExpected of int + | InductiveParamsNumberField of int + | RecordFieldExpected of bool + | RecordProjectionsExpected of name list + | NotEqualInductiveAliases + | NoTypeConstraintExpected + +type module_typing_error = + | SignatureMismatch of label * structure_field_body * signature_mismatch_error + | LabelAlreadyDeclared of label + | ApplicationToNotPath of module_struct_entry + | NotAFunctor of struct_expr_body + | IncompatibleModuleTypes of module_type_body * module_type_body + | NotEqualModulePaths of module_path * module_path + | NoSuchLabel of label + | IncompatibleLabels of label * label + | SignatureExpected of struct_expr_body + | NoModuleToEnd + | NoModuleTypeToEnd + | NotAModule of string + | NotAModuleType of string + | NotAConstant of label + | IncorrectWithConstraint of label + | GenerativeModuleExpected of label + | NonEmptyLocalContect of label option + | LabelMissing of label * string + +exception ModuleTypingError of module_typing_error + +let error_existing_label l = + raise (ModuleTypingError (LabelAlreadyDeclared l)) + +let error_application_to_not_path mexpr = + raise (ModuleTypingError (ApplicationToNotPath mexpr)) + +let error_not_a_functor mtb = + raise (ModuleTypingError (NotAFunctor mtb)) + +let error_incompatible_modtypes mexpr1 mexpr2 = + raise (ModuleTypingError (IncompatibleModuleTypes (mexpr1,mexpr2))) + +let error_not_equal_modpaths mp1 mp2 = + raise (ModuleTypingError (NotEqualModulePaths (mp1,mp2))) + +let error_signature_mismatch l spec why = + raise (ModuleTypingError (SignatureMismatch (l,spec,why))) + +let error_no_such_label l = + raise (ModuleTypingError (NoSuchLabel l)) + +let error_incompatible_labels l l' = + raise (ModuleTypingError (IncompatibleLabels (l,l'))) let error_signature_expected mtb = - error "Signature expected." + raise (ModuleTypingError (SignatureExpected mtb)) -let error_no_module_to_end _ = - error "No open module to end." +let error_no_module_to_end _ = + raise (ModuleTypingError NoModuleToEnd) let error_no_modtype_to_end _ = - error "No open module type to end." - -let error_not_a_modtype_loc loc s = - user_err_loc (loc,"",str ("\""^s^"\" is not a module type.")) - -let error_not_a_module_loc loc s = - user_err_loc (loc,"",str ("\""^s^"\" is not a module.")) + raise (ModuleTypingError NoModuleTypeToEnd) -let error_not_a_module_or_modtype_loc loc s = - user_err_loc (loc,"",str ("\""^s^"\" is not a module or module type.")) +let error_not_a_modtype s = + raise (ModuleTypingError (NotAModuleType s)) -let error_not_a_module s = error_not_a_module_loc dummy_loc s +let error_not_a_module s = + raise (ModuleTypingError (NotAModule s)) -let error_not_a_constant l = - error ("\""^(string_of_label l)^"\" is not a constant.") +let error_not_a_constant l = + raise (ModuleTypingError (NotAConstant l)) -let error_with_incorrect l = - error ("Incorrect constraint for label \""^(string_of_label l)^"\".") +let error_incorrect_with_constraint l = + raise (ModuleTypingError (IncorrectWithConstraint l)) -let error_a_generative_module_expected l = - error ("The module " ^ string_of_label l ^ " is not generative. Only " ^ - "component of generative modules can be changed using the \"with\" " ^ - "construct.") - -let error_local_context lo = - match lo with - None -> - error ("The local context is not empty.") - | (Some l) -> - error ("The local context of the component "^ - (string_of_label l)^" is not empty.") +let error_generative_module_expected l = + raise (ModuleTypingError (GenerativeModuleExpected l)) +let error_non_empty_local_context lo = + raise (ModuleTypingError (NonEmptyLocalContect lo)) let error_no_such_label_sub l l1 = - error ("The field "^(string_of_label l)^" is missing in "^l1^".") - -let error_with_in_module _ = error "The syntax \"with\" is not allowed for modules." + raise (ModuleTypingError (LabelMissing (l,l1))) -let error_application_to_module_type _ = error "Module application to a module type." +(************************) let destr_functor env mtb = match mtb with @@ -116,9 +145,9 @@ let check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else let mb1=lookup_module mp1 env in let mb2=lookup_module mp2 env in - if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2) + if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2) then () - else error_not_equal mp1 mp2 + else error_not_equal_modpaths mp1 mp2 let rec subst_with_body sub = function | With_module_body(id,mp) -> @@ -235,18 +264,13 @@ let add_retroknowledge mp = let rec add_signature mp sign resolver env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in - let con = constant_of_kn kn in - let mind = mind_of_kn kn in - match elem with - | SFBconst cb -> - let con = constant_of_delta resolver con in - Environ.add_constant con cb env - | SFBmind mib -> - let mind = mind_of_delta resolver mind in - Environ.add_mind mind mib env - | SFBmodule mb -> add_module mb env - (* adds components as well *) - | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env + match elem with + | SFBconst cb -> + Environ.add_constant (constant_of_delta_kn resolver kn) cb env + | SFBmind mib -> + Environ.add_mind (mind_of_delta_kn resolver kn) mib env + | SFBmodule mb -> add_module mb env (* adds components as well *) + | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env in List.fold_left add_one env sign @@ -260,100 +284,83 @@ and add_module mb env = | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " -let strengthen_const env mp_from l cb resolver = - match cb.const_opaque, cb.const_body with - | false, Some _ -> cb - | true, Some _ - | _, None -> - let con = make_con mp_from empty_dirpath l in - let con = constant_of_delta resolver con in - let const = mkConst con in - let const_subs = Some (Declarations.from_val const) in - {cb with - const_body = const_subs; - const_opaque = false; - const_body_code = Cemitcodes.from_val - (compile_constant_body env const_subs false false) - } - - -let rec strengthen_mod env mp_from mp_to mb = +let strengthen_const mp_from l cb resolver = + match cb.const_body with + | Def _ -> cb + | _ -> + let kn = make_kn mp_from empty_dirpath l in + let con = constant_of_delta_kn resolver kn in + { cb with + const_body = Def (Declarations.from_val (mkConst con)); + const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con) + } + +let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then - mb + mb else match mb.mod_type with - | SEBstruct (sign) -> - let resolve_out,sign_out = - strengthen_sig env mp_from sign mp_to mb.mod_delta in + | SEBstruct (sign) -> + let resolve_out,sign_out = + strengthen_sig mp_from sign mp_to mb.mod_delta in { mb with mod_expr = Some (SEBident mp_to); mod_type = SEBstruct(sign_out); mod_type_alg = mb.mod_type_alg; mod_constraints = mb.mod_constraints; - mod_delta = add_mp_delta_resolver mp_from mp_to + mod_delta = add_mp_delta_resolver mp_from mp_to (add_delta_resolver mb.mod_delta resolve_out); mod_retroknowledge = mb.mod_retroknowledge} | SEBfunctor _ -> mb | _ -> anomaly "Modops:the evaluation of the structure failed " - -and strengthen_sig env mp_from sign mp_to resolver = + +and strengthen_sig mp_from sign mp_to resolver = match sign with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) :: rest -> - let item' = - l,SFBconst (strengthen_const env mp_from l cb resolver) in - let resolve_out,rest' = - strengthen_sig env mp_from rest mp_to resolver in - resolve_out,item'::rest' + let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in + let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in + resolve_out,item'::rest' | (_,SFBmind _ as item):: rest -> - let resolve_out,rest' = - strengthen_sig env mp_from rest mp_to resolver in - resolve_out,item::rest' + let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in + resolve_out,item::rest' | (l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in - let mp_to' = MPdot(mp_to,l) in - let mb_out = - strengthen_mod env mp_from' mp_to' mb in + let mp_to' = MPdot(mp_to,l) in + let mb_out = strengthen_mod mp_from' mp_to' mb in let item' = l,SFBmodule (mb_out) in - let env' = add_module mb_out env in - let resolve_out,rest' = - strengthen_sig env' mp_from rest mp_to resolver in - add_delta_resolver resolve_out mb.mod_delta, - item':: rest' - | (l,SFBmodtype mty as item) :: rest -> - let env' = add_modtype - (MPdot(mp_from,l)) mty env - in - let resolve_out,rest' = - strengthen_sig env' mp_from rest mp_to resolver in - resolve_out,item::rest' - -let strengthen env mtb mp = + let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in + add_delta_resolver resolve_out mb.mod_delta, item':: rest' + | (l,SFBmodtype mty as item) :: rest -> + let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in + resolve_out,item::rest' + +let strengthen mtb mp = if mp_in_delta mtb.typ_mp mtb.typ_delta then (* in this case mtb has already been strengthened*) - mtb + mtb else match mtb.typ_expr with - | SEBstruct (sign) -> + | SEBstruct (sign) -> let resolve_out,sign_out = - strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in + strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in {mtb with typ_expr = SEBstruct(sign_out); typ_delta = add_delta_resolver mtb.typ_delta (add_mp_delta_resolver mtb.typ_mp mp resolve_out)} | SEBfunctor _ -> mtb | _ -> anomaly "Modops:the evaluation of the structure failed " - -let module_type_of_module env mp mb = + +let module_type_of_module mp mb = match mp with Some mp -> - strengthen env { + strengthen { typ_mp = mp; typ_expr = mb.mod_type; typ_expr_alg = None; typ_constraints = mb.mod_constraints; typ_delta = mb.mod_delta} mp - + | None -> {typ_mp = mb.mod_mp; typ_expr = mb.mod_type; @@ -361,34 +368,29 @@ let module_type_of_module env mp mb = typ_constraints = mb.mod_constraints; typ_delta = mb.mod_delta} -let complete_inline_delta_resolver env mp mbid mtb delta = - let constants = inline_of_delta mtb.typ_delta in +let inline_delta_resolver env inl mp mbid mtb delta = + let constants = inline_of_delta inl mtb.typ_delta in let rec make_inline delta = function | [] -> delta - | kn::r -> + | (lev,kn)::r -> let kn = replace_mp_in_kn (MPbound mbid) mp kn in - let con = constant_of_kn kn in - let con' = constant_of_delta delta con in - try - let constant = lookup_constant con' env in - if (not constant.Declarations.const_opaque) then - let constr = Option.map Declarations.force - constant.Declarations.const_body in - if constr = None then - (make_inline delta r) - else - add_inline_constr_delta_resolver con (Option.get constr) - (make_inline delta r) - else - (make_inline delta r) - with - Not_found -> error_no_such_label_sub (con_label con) - (string_of_mp (con_modpath con)) + let con = constant_of_delta_kn delta kn in + try + let constant = lookup_constant con env in + let l = make_inline delta r in + match constant.const_body with + | Undef _ | OpaqueDef _ -> l + | Def body -> + let constr = Declarations.force body in + add_inline_delta_resolver kn (lev, Some constr) l + with Not_found -> + error_no_such_label_sub (con_label con) + (string_of_mp (con_modpath con)) in - make_inline delta constants + make_inline delta constants let rec strengthen_and_subst_mod - mb subst env mp_from mp_to env resolver = + mb subst mp_from mp_to resolver = match mb.mod_type with SEBstruct(str) -> let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in @@ -397,7 +399,7 @@ let rec strengthen_and_subst_mod (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb else let resolver,new_sig = - strengthen_and_subst_struct str subst env + strengthen_and_subst_struct str subst mp_from mp_from mp_to false false mb.mod_delta in {mb with @@ -413,42 +415,48 @@ let rec strengthen_and_subst_mod | _ -> anomaly "Modops:the evaluation of the structure failed " and strengthen_and_subst_struct - str subst env mp_alias mp_from mp_to alias incl resolver = + str subst mp_alias mp_from mp_to alias incl resolver = match str with | [] -> empty_delta_resolver,[] | (l,SFBconst cb) :: rest -> - let item' = if alias then + let item' = if alias then + (* case alias no strengthening needed*) l,SFBconst (subst_const_body subst cb) else - l,SFBconst (strengthen_const env mp_from l + l,SFBconst (strengthen_const mp_from l (subst_const_body subst cb) resolver) in - let con = make_con mp_from empty_dirpath l in let resolve_out,rest' = - strengthen_and_subst_struct rest subst env + strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in - if incl then - let old_name = constant_of_delta resolver con in - (add_constant_delta_resolver - (constant_of_kn_equiv (make_kn mp_to empty_dirpath l) - (canonical_con old_name)) - resolve_out), - item'::rest' - else - resolve_out,item'::rest' + if incl then + (* If we are performing an inclusion we need to add + the fact that the constant mp_to.l is \Delta-equivalent + to resolver(mp_from.l) *) + let kn_from = make_kn mp_from empty_dirpath l in + let kn_to = make_kn mp_to empty_dirpath l in + let old_name = kn_of_delta resolver kn_from in + (add_kn_delta_resolver kn_to old_name resolve_out), + item'::rest' + else + (*In this case the fact that the constant mp_to.l is + \Delta-equivalent to resolver(mp_from.l) is already known + because resolve_out contains mp_to maps to resolver(mp_from)*) + resolve_out,item'::rest' | (l,SFBmind mib) :: rest -> + (*Same as constant*) let item' = l,SFBmind (subst_mind subst mib) in - let mind = make_mind mp_from empty_dirpath l in let resolve_out,rest' = - strengthen_and_subst_struct rest subst env + strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in - if incl then - let old_name = mind_of_delta resolver mind in - (add_mind_delta_resolver - (mind_of_kn_equiv (make_kn mp_to empty_dirpath l) (canonical_mind old_name)) resolve_out), - item'::rest' - else - resolve_out,item'::rest' + if incl then + let kn_from = make_kn mp_from empty_dirpath l in + let kn_to = make_kn mp_to empty_dirpath l in + let old_name = kn_of_delta resolver kn_from in + (add_kn_delta_resolver kn_to old_name resolve_out), + item'::rest' + else + resolve_out,item'::rest' | (l,SFBmodule mb) :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in @@ -457,15 +465,20 @@ and strengthen_and_subst_struct (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb else strengthen_and_subst_mod - mb subst env mp_from' mp_to' env resolver + mb subst mp_from' mp_to' resolver in let item' = l,SFBmodule (mb_out) in - let env' = add_module mb_out env in - let resolve_out,rest' = - strengthen_and_subst_struct rest subst env' + let resolve_out,rest' = + strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in - if is_functor mb_out.mod_type then (add_mp_delta_resolver - mp_to' mp_to' resolve_out),item':: rest' else + (* if mb is a functor we should not derive new equivalences + on names, hence we add the fact that the functor can only + be equivalent to itself. If we adopt an applicative + semantic for functor this should be changed.*) + if is_functor mb_out.mod_type then + (add_mp_delta_resolver + mp_to' mp_to' resolve_out),item':: rest' + else add_delta_resolver resolve_out mb_out.mod_delta, item':: rest' | (l,SFBmodtype mty) :: rest -> @@ -474,27 +487,30 @@ and strengthen_and_subst_struct let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in let mty = subst_modtype subst' (fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in - let env' = add_modtype mp_from' mty env in - let resolve_out,rest' = strengthen_and_subst_struct rest subst env' + let resolve_out,rest' = strengthen_and_subst_struct rest subst mp_alias mp_from mp_to alias incl resolver in (add_mp_delta_resolver mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest' -let strengthen_and_subst_mb mb mp env include_b = + +(* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M." + we need to perform two operations to compute the body of M. The first one is applying + the substitution {P <- M} on the type of P and the second one is strenghtening. *) +let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with SEBstruct str -> let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in - (*if mb is an alias then the strengthening is useless + (*if mb.mod_mp is an alias then the strengthening is useless (i.e. it is already done)*) - let mp_alias = delta_of_mp mb.mod_delta mb.mod_mp in + let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in let new_resolver = add_mp_delta_resolver mp mp_alias - (subst_dom_delta_resolver subst_resolver mb.mod_delta) in + (subst_dom_delta_resolver subst_resolver mb.mod_delta) in let subst = map_mp mb.mod_mp mp new_resolver in let resolver_out,new_sig = - strengthen_and_subst_struct str subst env - mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta + strengthen_and_subst_struct str subst + mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta in {mb with mod_mp = mp; @@ -509,7 +525,7 @@ let strengthen_and_subst_mb mb mp env include_b = | _ -> anomaly "Modops:the evaluation of the structure failed " -let subst_modtype_and_resolver mtb mp env = +let subst_modtype_and_resolver mtb mp = let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in let full_subst = (map_mp mtb.typ_mp mp new_delta) in diff --git a/kernel/modops.mli b/kernel/modops.mli index 37f4e8e0..b9c36d5a 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_type_body -> module_body -val module_type_of_module : env -> module_path option -> module_body -> +val module_type_of_module : module_path option -> module_body -> module_type_body val destr_functor : @@ -36,71 +32,95 @@ val subst_signature : substitution -> structure_body -> structure_body val add_signature : module_path -> structure_body -> delta_resolver -> env -> env -(* adds a module and its components, but not the constraints *) +(** adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env val check_modpath_equiv : env -> module_path -> module_path -> unit -val strengthen : env -> module_type_body -> module_path -> module_type_body +val strengthen : module_type_body -> module_path -> module_type_body -val complete_inline_delta_resolver : - env -> module_path -> mod_bound_id -> module_type_body -> +val inline_delta_resolver : + env -> inline -> module_path -> mod_bound_id -> module_type_body -> delta_resolver -> delta_resolver -val strengthen_and_subst_mb : module_body -> module_path -> env -> bool - -> module_body +val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body -val subst_modtype_and_resolver : module_type_body -> module_path -> env -> +val subst_modtype_and_resolver : module_type_body -> module_path -> module_type_body val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body -val error_existing_label : label -> 'a +(** Errors *) + +type signature_mismatch_error = + | InductiveFieldExpected of mutual_inductive_body + | DefinitionFieldExpected + | ModuleFieldExpected + | ModuleTypeFieldExpected + | NotConvertibleInductiveField of identifier + | NotConvertibleConstructorField of identifier + | NotConvertibleBodyField + | NotConvertibleTypeField + | NotSameConstructorNamesField + | NotSameInductiveNameInBlockField + | FiniteInductiveFieldExpected of bool + | InductiveNumbersFieldExpected of int + | InductiveParamsNumberField of int + | RecordFieldExpected of bool + | RecordProjectionsExpected of name list + | NotEqualInductiveAliases + | NoTypeConstraintExpected + +type module_typing_error = + | SignatureMismatch of label * structure_field_body * signature_mismatch_error + | LabelAlreadyDeclared of label + | ApplicationToNotPath of module_struct_entry + | NotAFunctor of struct_expr_body + | IncompatibleModuleTypes of module_type_body * module_type_body + | NotEqualModulePaths of module_path * module_path + | NoSuchLabel of label + | IncompatibleLabels of label * label + | SignatureExpected of struct_expr_body + | NoModuleToEnd + | NoModuleTypeToEnd + | NotAModule of string + | NotAModuleType of string + | NotAConstant of label + | IncorrectWithConstraint of label + | GenerativeModuleExpected of label + | NonEmptyLocalContect of label option + | LabelMissing of label * string + +exception ModuleTypingError of module_typing_error -val error_declaration_not_path : module_struct_entry -> 'a +val error_existing_label : label -> 'a val error_application_to_not_path : module_struct_entry -> 'a -val error_not_a_functor : module_struct_entry -> 'a - val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a -val error_not_equal : module_path -> module_path -> 'a - -val error_not_match : label -> structure_field_body -> 'a +val error_signature_mismatch : + label -> structure_field_body -> signature_mismatch_error -> 'a val error_incompatible_labels : label -> label -> 'a val error_no_such_label : label -> 'a -val error_result_must_be_signature : unit -> 'a - val error_signature_expected : struct_expr_body -> 'a val error_no_module_to_end : unit -> 'a val error_no_modtype_to_end : unit -> 'a -val error_not_a_modtype_loc : loc -> string -> 'a - -val error_not_a_module_loc : loc -> string -> 'a - -val error_not_a_module_or_modtype_loc : loc -> string -> 'a - val error_not_a_module : string -> 'a val error_not_a_constant : label -> 'a -val error_with_incorrect : label -> 'a +val error_incorrect_with_constraint : label -> 'a -val error_a_generative_module_expected : label -> 'a +val error_generative_module_expected : label -> 'a -val error_local_context : label option -> 'a +val error_non_empty_local_context : label option -> 'a val error_no_such_label_sub : label->string->'a - -val error_with_in_module : unit -> 'a - -val error_application_to_module_type : unit -> 'a - diff --git a/kernel/names.ml b/kernel/names.ml index 642f5562..ae8ad093 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1,35 +1,34 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string - let hash_sub hstr id = hstr id - let equal id1 id2 = id1 == id2 - let hash = Hashtbl.hash - end) +let id_ord = Pervasives.compare module IdOrdered = struct @@ -38,15 +37,27 @@ module IdOrdered = end module Idset = Set.Make(IdOrdered) -module Idmap = Map.Make(IdOrdered) +module Idmap = +struct + include Map.Make(IdOrdered) + exception Finded + let exists f m = + try iter (fun a b -> if f a b then raise Finded) m ; false + with |Finded -> true + let singleton k v = add k v empty +end module Idpred = Predicate.Make(IdOrdered) -(* Names *) +(** {6 Various types based on identifiers } *) type name = Name of identifier | Anonymous +type variable = identifier -(* Dirpaths are lists of module identifiers. The actual representation - is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *) +(** {6 Directory paths = section names paths } *) + +(** Dirpaths are lists of module identifiers. + The actual representation is reversed to optimise sharing: + Coq.A.B is ["B";"A";"Coq"] *) type module_ident = identifier type dir_path = module_ident list @@ -58,14 +69,17 @@ let repr_dirpath x = x let empty_dirpath = [] +(** Printing of directory paths as ["coq_root.module.submodule"] *) + let string_of_dirpath = function | [] -> "<>" | sl -> String.concat "." (List.map string_of_id (List.rev sl)) +(** {6 Unique names for bound modules } *) let u_number = ref 0 -type uniq_ident = int * string * dir_path -let make_uid dir s = incr u_number;(!u_number,String.copy s,dir) +type uniq_ident = int * identifier * dir_path +let make_uid dir s = incr u_number;(!u_number,s,dir) let debug_string_of_uid (i,s,p) = "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" let string_of_uid (i,s,p) = @@ -76,30 +90,31 @@ module Umap = Map.Make(struct let compare = Pervasives.compare end) -type label = string - type mod_bound_id = uniq_ident let make_mbid = make_uid let repr_mbid (n, id, dp) = (n, id, dp) let debug_string_of_mbid = debug_string_of_uid let string_of_mbid = string_of_uid let id_of_mbid (_,s,_) = s -let label_of_mbid (_,s,_) = s +(** {6 Names of structure elements } *) -let mk_label l = l -let string_of_label = string_of_id +type label = identifier +let mk_label = id_of_string +let string_of_label = string_of_id +let pr_label l = str (string_of_label l) let id_of_label l = l let label_of_id id = id module Labset = Idset module Labmap = Idmap +(** {6 The module part of the kernel name } *) + type module_path = | MPfile of dir_path | MPbound of mod_bound_id - (* | MPapp of module_path * module_path *) | MPdot of module_path * label let rec check_bound_mp = function @@ -110,12 +125,9 @@ let rec check_bound_mp = function let rec string_of_mp = function | MPfile sl -> string_of_dirpath sl | MPbound uid -> string_of_uid uid - (* | MPapp (mp1,mp2) -> - "("^string_of_mp mp ^ " " ^ - string_of_mp mp^")"*) | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l -(* we compare labels first if both are MPdots *) +(** we compare labels first if both are MPdots *) let rec mp_ord mp1 mp2 = match (mp1,mp2) with MPdot(mp1,l1), MPdot(mp2,l2) -> let c = Pervasives.compare l1 l2 in @@ -133,7 +145,12 @@ end module MPset = Set.Make(MPord) module MPmap = Map.Make(MPord) -(* Kernel names *) +let default_module_name = "If you see this, it's a bug" + +let initial_dir = make_dirpath [default_module_name] +let initial_path = MPfile initial_dir + +(** {6 Kernel names } *) type kernel_name = module_path * dir_path * label @@ -147,11 +164,12 @@ let label kn = let _,_,l = repr_kn kn in l let string_of_kn (mp,dir,l) = - string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l + let str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#" + in + string_of_mp mp ^ str_dir ^ string_of_label l let pr_kn kn = str (string_of_kn kn) - let kn_ord kn1 kn2 = let mp1,dir1,l1 = kn1 in let mp2,dir2,l2 = kn2 in @@ -165,87 +183,84 @@ let kn_ord kn1 kn2 = else MPord.compare mp1 mp2 -(* a constant name is a kernel name couple (kn1,kn2) +module KNord = struct + type t = kernel_name + let compare = kn_ord +end + +module KNmap = Map.Make(KNord) +module KNpred = Predicate.Make(KNord) +module KNset = Set.Make(KNord) + +(** {6 Constant names } *) + +(** a constant name is a kernel name couple (kn1,kn2) where kn1 corresponds to the name used at toplevel - (i.e. what the user see) - and kn2 corresponds to the canonical kernel name - i.e. in the environment we have + (i.e. what the user see) + and kn2 corresponds to the canonical kernel name + i.e. in the environment we have kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *) type constant = kernel_name*kernel_name -(* For the environment we distinguish constants by their - user part*) +let constant_of_kn kn = (kn,kn) +let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) +let make_con mp dir l = constant_of_kn (mp,dir,l) +let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let canonical_con con = snd con +let user_con con = fst con +let repr_con con = fst con + +let eq_constant (_,kn1) (_,kn2) = kn1=kn2 + +let con_label con = label (fst con) +let con_modpath con = modpath (fst con) + +let string_of_con con = string_of_kn (fst con) +let pr_con con = str (string_of_con con) +let debug_string_of_con con = + "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")" +let debug_pr_con con = str (debug_string_of_con con) + +let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl = + if lbl = l1 && lbl = l2 then con + else ((mp1,dp1,lbl),(mp2,dp2,lbl)) + +(** For the environment we distinguish constants by their user part*) module User_ord = struct type t = kernel_name*kernel_name let compare x y= kn_ord (fst x) (fst y) end -(* For other uses (ex: non-logical things) it is enough - to deal with the canonical part *) +(** For other uses (ex: non-logical things) it is enough + to deal with the canonical part *) module Canonical_ord = struct type t = kernel_name*kernel_name let compare x y= kn_ord (snd x) (snd y) end - -module KNord = struct - type t = kernel_name - let compare =kn_ord -end - -module KNmap = Map.Make(KNord) -module KNpred = Predicate.Make(KNord) -module KNset = Set.Make(KNord) - module Cmap = Map.Make(Canonical_ord) module Cmap_env = Map.Make(User_ord) module Cpred = Predicate.Make(Canonical_ord) module Cset = Set.Make(Canonical_ord) module Cset_env = Set.Make(User_ord) -module Mindmap = Map.Make(Canonical_ord) -module Mindset = Set.Make(Canonical_ord) -module Mindmap_env = Map.Make(User_ord) - -let default_module_name = "If you see this, it's a bug" -let initial_dir = make_dirpath [default_module_name] -let initial_path = MPfile initial_dir +(** {6 Names of mutual inductive types } *) -type variable = identifier +(** The same thing is done for mutual inductive names + it replaces also the old mind_equiv field of mutual + inductive types *) +(** Beware: first inductive has index 0 *) +(** Beware: first constructor has index 1 *) -(* The same thing is done for mutual inductive names - it replaces also the old mind_equiv field of mutual - inductive types*) type mutual_inductive = kernel_name*kernel_name type inductive = mutual_inductive * int type constructor = inductive * int -let constant_of_kn kn = (kn,kn) -let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) -let make_con mp dir l = constant_of_kn (mp,dir,l) -let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) -let canonical_con con = snd con -let user_con con = fst con -let repr_con con = fst con -let string_of_con con = string_of_kn (fst con) -let con_label con = label (fst con) -let pr_con con = pr_kn (fst con) -let debug_pr_con con = str "("++ pr_kn (fst con) ++ str ","++ pr_kn (snd con)++ str ")" -let eq_constant (_,kn1) (_,kn2) = kn1=kn2 -let debug_string_of_con con = string_of_kn (fst con)^"'"^string_of_kn (snd con) - -let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl = - if lbl = l1 && lbl = l2 then con - else ((mp1,dp1,lbl),(mp2,dp2,lbl)) - -let con_modpath con = modpath (fst con) - let mind_modpath mind = modpath (fst mind) let ind_modpath ind = mind_modpath (fst ind) let constr_modpath c = ind_modpath (fst c) - let mind_of_kn kn = (kn,kn) let mind_of_kn_equiv kn1 kn2 = (kn1,kn2) let make_mind mp dir l = ((mp,dir,l),(mp,dir,l)) @@ -253,12 +268,15 @@ let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) let canonical_mind mind = snd mind let user_mind mind = fst mind let repr_mind mind = fst mind -let string_of_mind mind = string_of_kn (fst mind) let mind_label mind= label (fst mind) -let pr_mind mind = pr_kn (fst mind) -let debug_pr_mind mind = str "("++ pr_kn (fst mind) ++ str ","++ pr_kn (snd mind)++ str ")" + let eq_mind (_,kn1) (_,kn2) = kn1=kn2 -let debug_string_of_mind mind = string_of_kn (fst mind)^"'"^string_of_kn (snd mind) + +let string_of_mind mind = string_of_kn (fst mind) +let pr_mind mind = str (string_of_mind mind) +let debug_string_of_mind mind = + "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")" +let debug_pr_mind con = str (debug_string_of_mind con) let ith_mutual_inductive (kn,_) i = (kn,i) let ith_constructor_of_inductive ind i = (ind,i) @@ -267,6 +285,10 @@ let index_of_constructor (ind,i) = i let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2 let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2 +module Mindmap = Map.Make(Canonical_ord) +module Mindset = Set.Make(Canonical_ord) +module Mindmap_env = Map.Make(User_ord) + module InductiveOrdered = struct type t = inductive let compare (spx,ix) (spy,iy) = @@ -306,7 +328,8 @@ let eq_egr e1 e2 = match e1,e2 with EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2 | _,_ -> e1 = e2 -(* Hash-consing of name objects *) +(** {6 Hash-consing of name objects } *) + module Hname = Hashcons.Make( struct type t = name @@ -326,7 +349,7 @@ module Hdir = Hashcons.Make( struct type t = dir_path type u = identifier -> identifier - let hash_sub hident d = List.map hident d + let hash_sub hident d = list_smartmap hident d let rec equal d1 d2 = match (d1,d2) with | [],[] -> true | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2 @@ -337,9 +360,9 @@ module Hdir = Hashcons.Make( module Huniqid = Hashcons.Make( struct type t = uniq_ident - type u = (string -> string) * (dir_path -> dir_path) - let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir) - let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 & s1 = s2 & dir1 == dir2 + type u = (identifier -> identifier) * (dir_path -> dir_path) + let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) + let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2 let hash = Hashtbl.hash end) @@ -355,34 +378,66 @@ module Hmod = Hashcons.Make( let rec equal d1 d2 = match (d1,d2) with | MPfile dir1, MPfile dir2 -> dir1 == dir2 | MPbound m1, MPbound m2 -> m1 == m2 - | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2 + | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2 | _ -> false let hash = Hashtbl.hash end) - -module Hcn = Hashcons.Make( - struct - type t = kernel_name*kernel_name +module Hkn = Hashcons.Make( + struct + type t = kernel_name type u = (module_path -> module_path) * (dir_path -> dir_path) * (string -> string) - let hash_sub (hmod,hdir,hstr) ((md,dir,l),(mde,dire,le)) = - ((hmod md, hdir dir, hstr l),(hmod mde, hdir dire, hstr le)) - let equal ((mod1,dir1,l1),_) ((mod2,dir2,l2),_) = + let hash_sub (hmod,hdir,hstr) (md,dir,l) = + (hmod md, hdir dir, hstr l) + let equal (mod1,dir1,l1) (mod2,dir2,l2) = mod1 == mod2 && dir1 == dir2 && l1 == l2 let hash = Hashtbl.hash end) -let hcons_names () = - let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in - let hident = Hashcons.simple_hcons Hident.f hstring in - let hname = Hashcons.simple_hcons Hname.f hident in - let hdir = Hashcons.simple_hcons Hdir.f hident in - let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in - let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in - let hmind = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in - let hcn = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in - (hcn,hmind,hdir,hname,hident,hstring) +(** For [constant] and [mutual_inductive], we discriminate only on + the user part : having the same user part implies having the + same canonical part (invariant of the system). *) + +module Hcn = Hashcons.Make( + struct + type t = kernel_name*kernel_name + type u = kernel_name -> kernel_name + let hash_sub hkn (user,can) = (hkn user, hkn can) + let equal (user1,_) (user2,_) = user1 == user2 + let hash (user,_) = Hashtbl.hash user + end) + +module Hind = Hashcons.Make( + struct + type t = inductive + type u = mutual_inductive -> mutual_inductive + let hash_sub hmind (mind, i) = (hmind mind, i) + let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2 + let hash = Hashtbl.hash + end) + +module Hconstruct = Hashcons.Make( + struct + type t = constructor + type u = inductive -> inductive + let hash_sub hind (ind, j) = (hind ind, j) + let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2 + let hash = Hashtbl.hash + end) + +let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f () +let hcons_ident = hcons_string +let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident +let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident +let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath) +let hcons_mp = + Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string) +let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string) +let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn +let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn +let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind +let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind (*******) diff --git a/kernel/names.mli b/kernel/names.mli index 612851dd..34c5e62c 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -1,62 +1,59 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string val id_of_string : string -> identifier val id_ord : identifier -> identifier -> int -(* Identifiers sets and maps *) +(** Identifiers sets and maps *) module Idset : Set.S with type elt = identifier module Idpred : Predicate.S with type elt = identifier -module Idmap : Map.S with type key = identifier +module Idmap : sig + include Map.S with type key = identifier + val exists : (identifier -> 'a -> bool) -> 'a t -> bool + val singleton : key -> 'a -> 'a t +end + +(** {6 Various types based on identifiers } *) + +type name = Name of identifier | Anonymous +type variable = identifier + +(** {6 Directory paths = section names paths } *) -(*s Directory paths = section names paths *) type module_ident = identifier module ModIdmap : Map.S with type key = module_ident type dir_path -(* Inner modules idents on top of list (to improve sharing). +(** Inner modules idents on top of list (to improve sharing). For instance: A.B.C is ["C";"B";"A"] *) val make_dirpath : module_ident list -> dir_path val repr_dirpath : dir_path -> module_ident list val empty_dirpath : dir_path -(* Printing of directory paths as ["coq_root.module.submodule"] *) +(** Printing of directory paths as ["coq_root.module.submodule"] *) val string_of_dirpath : dir_path -> string -type label - -(*s Unique names for bound modules *) -type mod_bound_id - -(* The first argument is a file name - to prevent conflict between - different files *) -val make_mbid : dir_path -> string -> mod_bound_id -val repr_mbid : mod_bound_id -> int * string * dir_path -val id_of_mbid : mod_bound_id -> identifier -val label_of_mbid : mod_bound_id -> label -val debug_string_of_mbid : mod_bound_id -> string -val string_of_mbid : mod_bound_id -> string +(** {6 Names of structure elements } *) -(*s Names of structure elements *) +type label val mk_label : string -> label val string_of_label : label -> string +val pr_label : label -> Pp.std_ppcmds val label_of_id : identifier -> label val id_of_label : label -> identifier @@ -64,14 +61,26 @@ val id_of_label : label -> identifier module Labset : Set.S with type elt = label module Labmap : Map.S with type key = label -(*s The module part of the kernel name *) +(** {6 Unique names for bound modules } *) + +type mod_bound_id + +(** The first argument is a file name - to prevent conflict between + different files *) + +val make_mbid : dir_path -> identifier -> mod_bound_id +val repr_mbid : mod_bound_id -> int * identifier * dir_path +val id_of_mbid : mod_bound_id -> identifier +val debug_string_of_mbid : mod_bound_id -> string +val string_of_mbid : mod_bound_id -> string + +(** {6 The module part of the kernel name } *) + type module_path = | MPfile of dir_path | MPbound of mod_bound_id - (* | MPapp of module_path * module_path very soon *) | MPdot of module_path * label - val check_bound_mp : module_path -> bool val string_of_mp : module_path -> string @@ -79,17 +88,17 @@ val string_of_mp : module_path -> string module MPset : Set.S with type elt = module_path module MPmap : Map.S with type key = module_path -(* Initial "seed" of the unique identifier generator *) +(** Initial "seed" of the unique identifier generator *) val initial_dir : dir_path -(* Name of the toplevel structure *) -val initial_path : module_path (* [= MPfile initial_dir] *) +(** Name of the toplevel structure *) +val initial_path : module_path (** [= MPfile initial_dir] *) -(*s The absolute names of objects seen by kernel *) +(** {6 The absolute names of objects seen by kernel } *) type kernel_name -(* Constructor and destructor *) +(** Constructor and destructor *) val make_kn : module_path -> dir_path -> label -> kernel_name val repr_kn : kernel_name -> module_path * dir_path * label @@ -99,23 +108,25 @@ val label : kernel_name -> label val string_of_kn : kernel_name -> string val pr_kn : kernel_name -> Pp.std_ppcmds +val kn_ord : kernel_name -> kernel_name -> int module KNset : Set.S with type elt = kernel_name module KNpred : Predicate.S with type elt = kernel_name module KNmap : Map.S with type key = kernel_name -(*s Specific paths for declarations *) +(** {6 Specific paths for declarations } *) -type variable = identifier type constant type mutual_inductive -(* Beware: first inductive has index 0 *) + +(** Beware: first inductive has index 0 *) type inductive = mutual_inductive * int -(* Beware: first constructor has index 1 *) + +(** Beware: first constructor has index 1 *) type constructor = inductive * int -(* *_env modules consider an order on user part of names +(** *_env modules consider an order on user part of names the others consider an order on canonical part of names*) module Cmap : Map.S with type key = constant module Cmap_env : Map.S with type key = constant @@ -169,7 +180,6 @@ val debug_string_of_mind : mutual_inductive -> string -val mind_modpath : mutual_inductive -> module_path val ind_modpath : inductive -> module_path val constr_modpath : constructor -> module_path @@ -180,7 +190,7 @@ val index_of_constructor : constructor -> int val eq_ind : inductive -> inductive -> bool val eq_constructor : constructor -> constructor -> bool -(* Better to have it here that in Closure, since required in grammar.cma *) +(** Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant @@ -188,12 +198,16 @@ type evaluable_global_reference = val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool -(* Hash-consing *) -val hcons_names : unit -> - (constant -> constant) * - (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) * - (name -> name) * (identifier -> identifier) * (string -> string) +(** {6 Hash-consing } *) +val hcons_string : string -> string +val hcons_ident : identifier -> identifier +val hcons_name : name -> name +val hcons_dirpath : dir_path -> dir_path +val hcons_con : constant -> constant +val hcons_mind : mutual_inductive -> mutual_inductive +val hcons_ind : inductive -> inductive +val hcons_construct : constructor -> constructor (******) @@ -209,8 +223,8 @@ val full_transparent_state : transparent_state val var_full_transparent_state : transparent_state val cst_full_transparent_state : transparent_state -type inv_rel_key = int (* index in the [rel_context] part of environment - starting by the end, {\em inverse} +type inv_rel_key = int (** index in the [rel_context] part of environment + starting by the end, {e inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index c852ab72..985aac95 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -1,12 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* int val push_rel : rel_declaration -> env -> env val lookup_rel_val : int -> env -> lazy_val val env_of_rel : int -> env -> env -(* Named context *) + +(** Named context *) val push_named_context_val : named_declaration -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env val lookup_named_val : identifier -> env -> lazy_val val env_of_named : identifier -> env -> env -(* Global constants *) + +(** Global constants *) val lookup_constant_key : constant -> env -> constant_key val lookup_constant : constant -> env -> constant_body -(* Mutual Inductives *) +(** Mutual Inductives *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 38d1c70b..fc5e32cf 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -1,12 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raise NotConvertible -let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty +let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint -let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty +let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint let rec no_arg_available = function | [] -> true @@ -232,14 +239,14 @@ let in_whnf (t,stk) = | FLOCKED -> assert false (* Conversion between [lft1]term1 and [lft2]term2 *) -let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = - eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv +let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = + eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) -and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = +and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = Util.check_for_interrupt (); (* First head reduce both terms *) - let rec whd_both (t1,stk1) (t2,stk2) = + let rec whd_both (t1,stk1) (t2,stk2) = let st1' = whd_stack (snd infos) t1 stk1 in let st2' = whd_stack (snd infos) t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), @@ -260,13 +267,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = sort_cmp cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if n=m - then convert_stacks infos lft1 lft2 v1 v2 cuniv + then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if ev1=ev2 then - let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in - convert_vect infos el1 el2 + let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in + convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) (Array.map (mk_clos env2) args2) u1 else raise NotConvertible @@ -274,19 +281,19 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> if reloc_rel n el1 = reloc_rel m el2 - then convert_stacks infos lft1 lft2 v1 v2 cuniv + then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) if eq_table_key fl1 fl2 - then convert_stacks infos lft1 lft2 v1 v2 cuniv + then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = - if Conv_oracle.oracle_order fl1 fl2 then + if Conv_oracle.oracle_order l2r fl1 fl2 then match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) | None -> @@ -300,79 +307,95 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (match unfold_reference infos fl1 with | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) | None -> raise NotConvertible) in - eqappr cv_pb infos app1 app2 cuniv) - - (* only one constant, defined var or defined rel *) - | (FFlex fl1, _) -> - (match unfold_reference infos fl1 with - | Some def1 -> - eqappr cv_pb infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv - | None -> raise NotConvertible) - | (_, FFlex fl2) -> - (match unfold_reference infos fl2 with - | Some def2 -> - eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv - | None -> raise NotConvertible) + eqappr cv_pb l2r infos app1 app2 cuniv) (* other constructors *) | (FLambda _, FLambda _) -> + (* Inconsistency: we tolerate that v1, v2 contain shift and update but + we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then anomaly "conversion was given ill-typed terms (FLambda)"; let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in - let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in - ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1 + let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in + ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1 | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly "conversion was given ill-typed terms (FProd)"; (* Luo's system *) - let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1 + let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in + ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1 + + (* Eta-expansion on the fly *) + | (FLambda _, _) -> + if v1 <> [] then + anomaly "conversion was given unreduced term (FLambda)"; + let (_,_ty1,bd1) = destFLambda mk_clos hd1 in + eqappr CONV l2r infos + (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv + | (_, FLambda _) -> + if v2 <> [] then + anomaly "conversion was given unreduced term (FLambda)"; + let (_,_ty2,bd2) = destFLambda mk_clos hd2 in + eqappr CONV l2r infos + (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv + + (* only one constant, defined var or defined rel *) + | (FFlex fl1, _) -> + (match unfold_reference infos fl1 with + | Some def1 -> + eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv + | None -> raise NotConvertible) + | (_, FFlex fl2) -> + (match unfold_reference infos fl2 with + | Some def2 -> + eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv + | None -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd ind1, FInd ind2) -> - if eq_ind ind1 ind2 - then - convert_stacks infos lft1 lft2 v1 v2 cuniv - else raise NotConvertible - - | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> - if j1 = j2 && eq_ind ind1 ind2 - then - convert_stacks infos lft1 lft2 v1 v2 cuniv - else raise NotConvertible - - | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> - if op1 = op2 - then - let n = Array.length cl1 in - let fty1 = Array.map (mk_clos e1) tys1 in - let fty2 = Array.map (mk_clos e2) tys2 in - let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in - let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in - let u2 = - convert_vect infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks infos lft1 lft2 v1 v2 u2 - else raise NotConvertible - - | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> - if op1 = op2 - then - let n = Array.length cl1 in - let fty1 = Array.map (mk_clos e1) tys1 in - let fty2 = Array.map (mk_clos e2) tys2 in - let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in - let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in - let u2 = - convert_vect infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks infos lft1 lft2 v1 v2 u2 - else raise NotConvertible + | (FInd ind1, FInd ind2) -> + if eq_ind ind1 ind2 + then + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> + if j1 = j2 && eq_ind ind1 ind2 + then + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> + if op1 = op2 + then + let n = Array.length cl1 in + let fty1 = Array.map (mk_clos e1) tys1 in + let fty2 = Array.map (mk_clos e2) tys2 in + let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in + let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in + let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let u2 = + convert_vect l2r infos + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in + convert_stacks l2r infos lft1 lft2 v1 v2 u2 + else raise NotConvertible + + | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> + if op1 = op2 + then + let n = Array.length cl1 in + let fty1 = Array.map (mk_clos e1) tys1 in + let fty2 = Array.map (mk_clos e2) tys2 in + let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in + let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in + let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let u2 = + convert_vect l2r infos + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in + convert_stacks l2r infos lft1 lft2 v1 v2 u2 + else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) @@ -382,13 +405,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible -and convert_stacks infos lft1 lft2 stk1 stk2 cuniv = +and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks - (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c) + (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c) (eq_ind) lft1 stk1 lft2 stk2 cuniv -and convert_vect infos lft1 lft2 v1 v2 cuniv = +and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in let lv2 = Array.length v2 in if lv1 = lv2 @@ -396,62 +419,62 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv = let rec fold n univ = if n >= lv1 then univ else - let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in + let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in fold (n+1) u1 in fold 0 cuniv else raise NotConvertible -let clos_fconv trans cv_pb evars env t1 t2 = +let clos_fconv trans cv_pb l2r evars env t1 t2 = let infos = trans, create_clos_infos ~evars betaiotazeta env in - ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty + ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint -let trans_fconv reds cv_pb evars env t1 t2 = - if eq_constr t1 t2 then Constraint.empty - else clos_fconv reds cv_pb evars env t1 t2 +let trans_fconv reds cv_pb l2r evars env t1 t2 = + if eq_constr t1 t2 then empty_constraint + else clos_fconv reds cv_pb l2r evars env t1 t2 -let trans_conv_cmp conv reds = trans_fconv reds conv (fun _->None) -let trans_conv ?(evars=fun _->None) reds = trans_fconv reds CONV evars -let trans_conv_leq ?(evars=fun _->None) reds = trans_fconv reds CUMUL evars +let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) +let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars +let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars let fconv = trans_fconv (Idpred.full, Cpred.full) -let conv_cmp cv_pb = fconv cv_pb (fun _->None) -let conv ?(evars=fun _->None) = fconv CONV evars -let conv_leq ?(evars=fun _->None) = fconv CUMUL evars +let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) +let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars +let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars -let conv_leq_vecti ?(evars=fun _->None) env v1 v2 = +let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = array_fold_left2_i (fun i c t1 t2 -> let c' = - try conv_leq ~evars env t1 t2 + try conv_leq ~l2r ~evars env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in - Constraint.union c c') - Constraint.empty + union_constraints c c') + empty_constraint v1 v2 (* option for conversion *) -let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None)) +let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None)) let set_vm_conv f = vm_conv := f let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb (fun _->None) env t1 t2 + fconv cv_pb false (fun _->None) env t1 t2 -let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None)) +let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None)) let set_default_conv f = default_conv := f -let default_conv cv_pb env t1 t2 = +let default_conv cv_pb ?(l2r=false) env t1 t2 = try - !default_conv cv_pb env t1 t2 + !default_conv ~l2r cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb (fun _->None) env t1 t2 + fconv cv_pb false (fun _->None) env t1 t2 let default_conv_leq = default_conv CUMUL (* @@ -511,15 +534,16 @@ let dest_prod_assum env = in prodec_rec env empty_rel_context +exception NotArity + let dest_arity env c = let l, c = dest_prod_assum env c in match kind_of_term c with | Sort s -> l,s - | _ -> error "not an arity" + | _ -> raise NotArity let is_arity env c = try let _ = dest_arity env c in true - with UserError _ -> false - + with NotArity -> false diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 4a3e4cd5..aa78fbda 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -1,21 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr val whd_betadeltaiota : env -> constr -> constr @@ -24,8 +20,8 @@ val whd_betadeltaiota_nolet : env -> constr -> constr val whd_betaiota : constr -> constr val nf_betaiota : constr -> constr -(************************************************************************) -(*s conversion functions *) +(*********************************************************************** + s conversion functions *) exception NotConvertible exception NotConvertibleVect of int @@ -40,45 +36,47 @@ val sort_cmp : val conv_sort : sorts conversion_function val conv_sort_leq : sorts conversion_function -val trans_conv_cmp : conv_pb -> constr trans_conversion_function +val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : - ?evars:(existential->constr option) -> constr trans_conversion_function + ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function val trans_conv_leq : - ?evars:(existential->constr option) -> types trans_conversion_function + ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function -val conv_cmp : conv_pb -> constr conversion_function +val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function val conv : - ?evars:(existential->constr option) -> constr conversion_function + ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function val conv_leq : - ?evars:(existential->constr option) -> types conversion_function + ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function val conv_leq_vecti : - ?evars:(existential->constr option) -> types array conversion_function + ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function -(* option for conversion *) +(** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function -val set_default_conv : (conv_pb -> types conversion_function) -> unit -val default_conv : conv_pb -> types conversion_function -val default_conv_leq : types conversion_function +val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit +val default_conv : conv_pb -> ?l2r:bool -> types conversion_function +val default_conv_leq : ?l2r:bool -> types conversion_function (************************************************************************) -(* Builds an application node, reducing beta redexes it may produce. *) +(** Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr -(* Builds an application node, reducing the [n] first beta-zeta redexes. *) +(** Builds an application node, reducing the [n] first beta-zeta redexes. *) val betazeta_appvect : int -> constr -> constr array -> constr -(* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) +(** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types -(************************************************************************) -(*s Recognizing products and arities modulo reduction *) +(*********************************************************************** + s Recognizing products and arities modulo reduction *) val dest_prod : env -> types -> rel_context * types val dest_prod_assum : env -> types -> rel_context * types -val dest_arity : env -> types -> arity +exception NotArity + +val dest_arity : env -> types -> arity (* raises NotArity if not an arity *) val is_arity : env -> types -> bool diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 5e8dd9f8..10d0bae7 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -1,12 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* entry -> Cbytecodes.comp_env -> Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes -(* Given a type identifier, this function is used before compiling a match + +(** Given a type identifier, this function is used before compiling a match over this type. In the case of 31-bit integers for instance, it is used to add the instruction sequence which would perform a dynamic decompilation in case the argument of the match is not in coq representation *) val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes -(* Given a type identifier, this function is used by pretyping/vnorm.ml to +(** Given a type identifier, this function is used by pretyping/vnorm.ml to recover the elements of that type from their compiled form if it's non standard (it is used (and can be used) only when the compiled form is not a block *) val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr -(* the following functions are solely used in Pre_env and Environ to implement +(** the following functions are solely used in Pre_env and Environ to implement the functions register and unregister (and mem) of Environ *) val add_field : retroknowledge -> field -> entry -> retroknowledge val mem : retroknowledge -> field -> bool val remove : retroknowledge -> field -> retroknowledge val find : retroknowledge -> field -> entry -(* the following function manipulate the reactive information of values +(** the following function manipulate the reactive information of values they are only used by the functions of Pre_env, and Environ to implement the functions register and unregister of Environ *) val add_vm_compiling_info : retroknowledge-> entry -> diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 4575d5bc..c2d71ebb 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1,12 +1,61 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* check_label l senv) ls - -let labels_of_mib mib = - let add,get = - let labels = ref Labset.empty in - (fun id -> labels := Labset.add (label_of_id id) !labels), - (fun () -> !labels) - in - let visit_mip mip = - add mip.mind_typename; - Array.iter add mip.mind_consnames - in - Array.iter visit_mip mib.mind_packets; - get () - let set_engagement_opt oeng env = match oeng with Some eng -> set_engagement eng env @@ -79,16 +109,26 @@ type safe_environment = loads : (module_path * module_body) list; local_retroknowledge : Retroknowledge.action list} -(* - { old = senv.old; - env = ; - modinfo = senv.modinfo; - labset = ; - revsign = ; - imports = senv.imports ; - loads = senv.loads } -*) +let exists_label l senv = Labset.mem l senv.labset + +let check_label l senv = + if exists_label l senv then error_existing_label l +let check_labels ls senv = + Labset.iter (fun l -> check_label l senv) ls + +let labels_of_mib mib = + let add,get = + let labels = ref Labset.empty in + (fun id -> labels := Labset.add (label_of_id id) !labels), + (fun () -> !labels) + in + let visit_mip mip = + add mip.mind_typename; + Array.iter add mip.mind_consnames + in + Array.iter visit_mip mib.mind_packets; + get () (* a small hack to avoid variants and an unused case in all functions *) let rec empty_environment = @@ -102,7 +142,7 @@ let rec empty_environment = resolver_of_param = empty_delta_resolver}; labset = Labset.empty; revstruct = []; - univ = Univ.Constraint.empty; + univ = Univ.empty_constraint; engagement = None; imports = []; loads = []; @@ -111,16 +151,50 @@ let rec empty_environment = let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env - - - - - - let add_constraints cst senv = - {senv with + { senv with env = Environ.add_constraints cst senv.env; - univ = Univ.Constraint.union cst senv.univ } + univ = Univ.union_constraints cst senv.univ } + +let constraints_of_sfb = function + | SFBconst cb -> cb.const_constraints + | SFBmind mib -> mib.mind_constraints + | SFBmodtype mtb -> mtb.typ_constraints + | SFBmodule mb -> mb.mod_constraints + +(* A generic function for adding a new field in a same environment. + It also performs the corresponding [add_constraints]. *) + +type generic_name = + | C of constant + | I of mutual_inductive + | MT of module_path + | M + +let add_field ((l,sfb) as field) gn senv = + let labels = match sfb with + | SFBmind mib -> labels_of_mib mib + | _ -> Labset.singleton l + in + check_labels labels senv; + let senv = add_constraints (constraints_of_sfb sfb) senv in + let env' = match sfb, gn with + | SFBconst cb, C con -> Environ.add_constant con cb senv.env + | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env + | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env + | SFBmodule mb, M -> Modops.add_module mb senv.env + | _ -> assert false + in + { senv with + env = env'; + labset = Labset.union labels senv.labset; + revstruct = field :: senv.revstruct } + +(* Applying a certain function to the resolver of a safe environment *) + +let update_resolver f senv = + let mi = senv.modinfo in + { senv with modinfo = { mi with resolver = f mi.resolver }} (* universal lifting, used for the "get" operations mostly *) @@ -131,8 +205,9 @@ let register senv field value by_clause = (* todo : value closed, by_clause safe, by_clause of the proper type*) (* spiwack : updates the safe_env with the information that the register action has to be performed (again) when the environement is imported *) - {senv with env = Environ.register senv.env field value; - local_retroknowledge = + {senv with + env = Environ.register senv.env field value; + local_retroknowledge = Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge } @@ -185,52 +260,21 @@ type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe -let hcons_constant_type = function - | NonPolymorphicType t -> - NonPolymorphicType (hcons1_constr t) - | PolymorphicArity (ctx,s) -> - PolymorphicArity (map_rel_context hcons1_constr ctx,s) - -let hcons_constant_body cb = - let body = match cb.const_body with - None -> None - | Some l_constr -> let constr = Declarations.force l_constr in - Some (Declarations.from_val (hcons1_constr constr)) - in - { cb with - const_body = body; - const_type = hcons_constant_type cb.const_type } - let add_constant dir l decl senv = - check_label l senv.labset; let kn = make_con senv.modinfo.modpath dir l in - let cb = - match decl with - | ConstantEntry ce -> translate_constant senv.env kn ce - | GlobalRecipe r -> - let cb = translate_recipe senv.env kn r in - if dir = empty_dirpath then hcons_constant_body cb else cb + let cb = match decl with + | ConstantEntry ce -> translate_constant senv.env kn ce + | GlobalRecipe r -> + let cb = translate_recipe senv.env kn r in + if dir = empty_dirpath then hcons_const_body cb else cb in - let senv' = add_constraints cb.const_constraints senv in - let env'' = Environ.add_constant kn cb senv'.env in - let resolver = - if cb.const_inline then - add_inline_delta_resolver kn senv'.modinfo.resolver - else - senv'.modinfo.resolver + let senv' = add_field (l,SFBconst cb) (C kn) senv in + let senv'' = match cb.const_body with + | Undef (Some lev) -> + update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv' + | _ -> senv' in - kn, { old = senv'.old; - env = env''; - modinfo = {senv'.modinfo with - resolver = resolver}; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBconst cb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads ; - local_retroknowledge = senv'.local_retroknowledge } - + kn, senv'' (* Insertion of inductive types. *) @@ -242,79 +286,41 @@ let add_mind dir l mie senv = if l <> label_of_id id then anomaly ("the label of inductive packet and its first inductive"^ " type do not match"); - let mib = translate_mind senv.env mie in - let labels = labels_of_mib mib in - check_labels labels senv.labset; - let senv' = add_constraints mib.mind_constraints senv in let kn = make_mind senv.modinfo.modpath dir l in - let env'' = Environ.add_mind kn mib senv'.env in - kn, { old = senv'.old; - env = env''; - modinfo = senv'.modinfo; - labset = Labset.union labels senv'.labset; - revstruct = (l,SFBmind mib)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } + let mib = translate_mind senv.env kn mie in + let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in + let senv' = add_field (l,SFBmind mib) (I kn) senv in + kn, senv' (* Insertion of module types *) let add_modtype l mte inl senv = - check_label l senv.labset; let mp = MPdot(senv.modinfo.modpath, l) in let mtb = translate_module_type senv.env mp inl mte in - let senv' = add_constraints mtb.typ_constraints senv in - let env'' = Environ.add_modtype mp mtb senv'.env in - mp, { old = senv'.old; - env = env''; - modinfo = senv'.modinfo; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBmodtype mtb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } - + let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in + mp, senv' (* full_add_module adds module with universes and constraints *) let full_add_module mb senv = let senv = add_constraints mb.mod_constraints senv in - let env = Modops.add_module mb senv.env in - {senv with env = env} + { senv with env = Modops.add_module mb senv.env } (* Insertion of modules *) let add_module l me inl senv = - check_label l senv.labset; let mp = MPdot(senv.modinfo.modpath, l) in let mb = translate_module senv.env mp inl me in - let senv' = full_add_module mb senv in - let modinfo = match mb.mod_type with - SEBstruct _ -> - { senv'.modinfo with - resolver = - add_delta_resolver mb.mod_delta senv'.modinfo.resolver} - | _ -> senv'.modinfo + let senv' = add_field (l,SFBmodule mb) M senv in + let senv'' = match mb.mod_type with + | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv' + | _ -> senv' in - mp,mb.mod_delta, - { old = senv'.old; - env = senv'.env; - modinfo = modinfo; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBmodule mb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } - + mp,mb.mod_delta,senv'' + (* Interactive modules *) let start_module l senv = - check_label l senv.labset; + check_label l senv; let mp = MPdot(senv.modinfo.modpath, l) in let modinfo = { modpath = mp; label = l; @@ -327,7 +333,7 @@ let start_module l senv = modinfo = modinfo; labset = Labset.empty; revstruct = []; - univ = Univ.Constraint.empty; + univ = Univ.empty_constraint; engagement = None; imports = senv.imports; loads = []; @@ -347,7 +353,7 @@ let end_module l restype senv = | STRUCT params -> params, (List.length params > 0) in if l <> modinfo.label then error_incompatible_labels l modinfo.label; - if not (empty_context senv.env) then error_local_context None; + if not (empty_context senv.env) then error_non_empty_local_context None; let functorize_struct tb = List.fold_left (fun mtb (arg_id,arg_b) -> @@ -361,13 +367,13 @@ let end_module l restype senv = let mexpr,mod_typ,mod_typ_alg,resolver,cst = match restype with | None -> let mexpr = functorize_struct auto_tb in - mexpr,mexpr,None,modinfo.resolver,Constraint.empty + mexpr,mexpr,None,modinfo.resolver,empty_constraint | Some mtb -> let auto_mtb = { typ_mp = senv.modinfo.modpath; typ_expr = auto_tb; typ_expr_alg = None; - typ_constraints = Constraint.empty; + typ_constraints = empty_constraint; typ_delta = empty_delta_resolver} in let cst = check_subtypes senv.env auto_mtb mtb in @@ -377,7 +383,7 @@ let end_module l restype senv = Option.map functorize_struct mtb.typ_expr_alg in mexpr,mod_typ,typ_alg,mtb.typ_delta,cst in - let cst = Constraint.union cst senv.univ in + let cst = union_constraints cst senv.univ in let mb = { mod_mp = mp; mod_expr = Some mexpr; @@ -411,12 +417,12 @@ let end_module l restype senv = modinfo = modinfo; labset = Labset.add l oldsenv.labset; revstruct = (l,SFBmodule mb)::oldsenv.revstruct; - univ = Univ.Constraint.union senv'.univ oldsenv.univ; + univ = Univ.union_constraints senv'.univ oldsenv.univ; (* engagement is propagated to the upper level *) engagement = senv'.engagement; imports = senv'.imports; loads = senv'.loads@oldsenv.loads; - local_retroknowledge = + local_retroknowledge = senv'.local_retroknowledge@oldsenv.local_retroknowledge } @@ -424,8 +430,8 @@ let end_module l restype senv = let add_include me is_module inl senv = let sign,cst,resolver = if is_module then - let sign,resolver,cst = - translate_struct_include_module_entry senv.env + let sign,_,resolver,cst = + translate_struct_include_module_entry senv.env senv.modinfo.modpath inl me in sign,cst,resolver else @@ -437,106 +443,46 @@ let end_module l restype senv = let senv = add_constraints cst senv in let mp_sup = senv.modinfo.modpath in (* Include Self support *) - let rec compute_sign sign mb resolver senv = + let rec compute_sign sign mb resolver senv = match sign with | SEBfunctor(mbid,mtb,str) -> let cst_sub = check_subtypes senv.env mb mtb in let senv = add_constraints cst_sub senv in - let mpsup_delta = if not inl then mb.typ_delta else - complete_inline_delta_resolver senv.env mp_sup mbid mtb mb.typ_delta + let mpsup_delta = + inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta in let subst = map_mbid mbid mp_sup mpsup_delta in let resolver = subst_codom_delta_resolver subst resolver in (compute_sign - (subst_struct_expr subst str) mb resolver senv) + (subst_struct_expr subst str) mb resolver senv) | str -> resolver,str,senv - in + in let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup; typ_expr = SEBstruct (List.rev senv.revstruct); typ_expr_alg = None; - typ_constraints = Constraint.empty; - typ_delta = senv.modinfo.resolver} resolver senv in + typ_constraints = empty_constraint; + typ_delta = senv.modinfo.resolver} resolver senv + in let str = match sign with | SEBstruct(str_l) -> str_l | _ -> error ("You cannot Include a high-order structure.") in - let senv = - {senv - with modinfo = - {senv.modinfo - with resolver = - add_delta_resolver resolver senv.modinfo.resolver}} + let senv = update_resolver (add_delta_resolver resolver) senv in - let add senv (l,elem) = - check_label l senv.labset; - match elem with - | SFBconst cb -> + let add senv ((l,elem) as field) = + let new_name = match elem with + | SFBconst _ -> let kn = make_kn mp_sup empty_dirpath l in - let con = constant_of_kn_equiv kn - (canonical_con - (constant_of_delta resolver (constant_of_kn kn))) - in - let senv' = add_constraints cb.const_constraints senv in - let env'' = Environ.add_constant con cb senv'.env in - { old = senv'.old; - env = env''; - modinfo = senv'.modinfo; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBconst cb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads ; - local_retroknowledge = senv'.local_retroknowledge } - | SFBmind mib -> + C (constant_of_delta_kn resolver kn) + | SFBmind _ -> let kn = make_kn mp_sup empty_dirpath l in - let mind = mind_of_kn_equiv kn - (canonical_mind - (mind_of_delta resolver (mind_of_kn kn))) - in - let labels = labels_of_mib mib in - check_labels labels senv.labset; - let senv' = add_constraints mib.mind_constraints senv in - let env'' = Environ.add_mind mind mib senv'.env in - { old = senv'.old; - env = env''; - modinfo = senv'.modinfo; - labset = Labset.union labels senv'.labset; - revstruct = (l,SFBmind mib)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } - - | SFBmodule mb -> - let senv' = full_add_module mb senv in - { old = senv'.old; - env = senv'.env; - modinfo = senv'.modinfo; - labset = Labset.add l senv'.labset; - revstruct = (l,SFBmodule mb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } - | SFBmodtype mtb -> - let senv' = add_constraints mtb.typ_constraints senv in - let mp = MPdot(senv.modinfo.modpath, l) in - let env' = Environ.add_modtype mp mtb senv'.env in - { old = senv.old; - env = env'; - modinfo = senv'.modinfo; - labset = Labset.add l senv.labset; - revstruct = (l,SFBmodtype mtb)::senv'.revstruct; - univ = senv'.univ; - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads; - local_retroknowledge = senv'.local_retroknowledge } + I (mind_of_delta_kn resolver kn) + | SFBmodule _ -> M + | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l)) + in + add_field field new_name senv in - resolver,(List.fold_left add senv str) + resolver,(List.fold_left add senv str) (* Adding parameters to modules or module types *) @@ -576,7 +522,7 @@ let add_module_parameter mbid mte inl senv = (* Interactive module types *) let start_modtype l senv = - check_label l senv.labset; + check_label l senv; let mp = MPdot(senv.modinfo.modpath, l) in let modinfo = { modpath = mp; label = l; @@ -589,7 +535,7 @@ let start_modtype l senv = modinfo = modinfo; labset = Labset.empty; revstruct = []; - univ = Univ.Constraint.empty; + univ = Univ.empty_constraint; engagement = None; imports = senv.imports; loads = [] ; @@ -605,7 +551,7 @@ let end_modtype l senv = | SIG params -> params in if l <> modinfo.label then error_incompatible_labels l modinfo.label; - if not (empty_context senv.env) then error_local_context None; + if not (empty_context senv.env) then error_non_empty_local_context None; let auto_tb = SEBstruct (List.rev senv.revstruct) in @@ -640,7 +586,7 @@ let end_modtype l senv = modinfo = oldsenv.modinfo; labset = Labset.add l oldsenv.labset; revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; - univ = Univ.Constraint.union senv.univ oldsenv.univ; + univ = Univ.union_constraints senv.univ oldsenv.univ; engagement = senv.engagement; imports = senv.imports; loads = senv.loads@oldsenv.loads; @@ -699,7 +645,7 @@ let start_library dir senv = modinfo = modinfo; labset = Labset.empty; revstruct = []; - univ = Univ.Constraint.empty; + univ = Univ.empty_constraint; engagement = None; imports = senv.imports; loads = []; @@ -710,7 +656,7 @@ let pack_module senv = mod_expr=None; mod_type= SEBstruct (List.rev senv.revstruct); mod_type_alg=None; - mod_constraints=Constraint.empty; + mod_constraints=empty_constraint; mod_delta=senv.modinfo.resolver; mod_retroknowledge=[]; } @@ -786,40 +732,146 @@ let import (dp,mb,depends,engmt) digest senv = loads = (mp,mb)::senv.loads } -(* Remove the body of opaque constants in modules *) - let rec lighten_module mb = - { mb with - mod_expr = None; - mod_type = lighten_modexpr mb.mod_type; - } - -and lighten_struct struc = - let lighten_body (l,body) = (l,match body with - | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None} - | (SFBconst _ | SFBmind _ ) as x -> x - | SFBmodule m -> SFBmodule (lighten_module m) - | SFBmodtype m -> SFBmodtype - ({m with - typ_expr = lighten_modexpr m.typ_expr})) - in - List.map lighten_body struc - -and lighten_modexpr = function - | SEBfunctor (mbid,mty,mexpr) -> - SEBfunctor (mbid, + (* Store the body of modules' opaque constants inside a table. + + This module is used during the serialization and deserialization + of vo files. + + By adding an indirection to the opaque constant definitions, we + gain the ability not to load them. As these constant definitions + are usually big terms, we save a deserialization time as well as + some memory space. *) +module LightenLibrary : sig + type table + type lightened_compiled_library + val save : compiled_library -> lightened_compiled_library * table + val load : load_proof:Flags.load_proofs -> table Lazy.t + -> lightened_compiled_library -> compiled_library +end = struct + + (* The table is implemented as an array of [constr_substituted]. + Keys are hence integers. To avoid changing the [compiled_library] + type, we brutally encode integers into [lazy_constr]. This isn't + pretty, but shouldn't be dangerous since the produced structure + [lightened_compiled_library] is abstract and only meant for writing + to .vo via Marshal (which doesn't care about types). + *) + type table = constr_substituted array + let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr) + let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int) + + (* To avoid any future misuse of the lightened library that could + interpret encoded keys as real [constr_substituted], we hide + these kind of values behind an abstract datatype. *) + type lightened_compiled_library = compiled_library + + (* Map a [compiled_library] to another one by just updating + the opaque term [t] to [on_opaque_const_body t]. *) + let traverse_library on_opaque_const_body = + let rec traverse_module mb = + match mb.mod_expr with + None -> + { mb with + mod_expr = None; + mod_type = traverse_modexpr mb.mod_type; + } + | Some impl when impl == mb.mod_type-> + let mtb = traverse_modexpr mb.mod_type in + { mb with + mod_expr = Some mtb; + mod_type = mtb; + } + | Some impl -> + { mb with + mod_expr = Option.map traverse_modexpr mb.mod_expr; + mod_type = traverse_modexpr mb.mod_type; + } + and traverse_struct struc = + let traverse_body (l,body) = (l,match body with + | SFBconst cb when is_opaque cb -> + SFBconst {cb with const_body = on_opaque_const_body cb.const_body} + | (SFBconst _ | SFBmind _ ) as x -> + x + | SFBmodule m -> + SFBmodule (traverse_module m) + | SFBmodtype m -> + SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr})) + in + List.map traverse_body struc + + and traverse_modexpr = function + | SEBfunctor (mbid,mty,mexpr) -> + SEBfunctor (mbid, ({mty with - typ_expr = lighten_modexpr mty.typ_expr}), - lighten_modexpr mexpr) - | SEBident mp as x -> x - | SEBstruct (struc) -> - SEBstruct (lighten_struct struc) - | SEBapply (mexpr,marg,u) -> - SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u) - | SEBwith (seb,wdcl) -> - SEBwith (lighten_modexpr seb,wdcl) - -let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s) - + typ_expr = traverse_modexpr mty.typ_expr}), + traverse_modexpr mexpr) + | SEBident mp as x -> x + | SEBstruct (struc) -> + SEBstruct (traverse_struct struc) + | SEBapply (mexpr,marg,u) -> + SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u) + | SEBwith (seb,wdcl) -> + SEBwith (traverse_modexpr seb,wdcl) + in + fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) + + (* To disburden a library from opaque definitions, we simply + traverse it and add an indirection between the module body + and its reference to a [const_body]. *) + let save library = + let ((insert : constant_def -> constant_def), + (get_table : unit -> table)) = + (* We use an integer as a key inside the table. *) + let counter = ref (-1) in + + (* During the traversal, the table is implemented by a list + to get constant time insertion. *) + let opaque_definitions = ref [] in + + ((* Insert inside the table. *) + (fun def -> + let opaque_definition = match def with + | OpaqueDef lc -> force_lazy_constr lc + | _ -> assert false + in + incr counter; + opaque_definitions := opaque_definition :: !opaque_definitions; + OpaqueDef (key_as_lazy_constr !counter)), + + (* Get the final table representation. *) + (fun () -> Array.of_list (List.rev !opaque_definitions))) + in + let lightened_library = traverse_library insert library in + (lightened_library, get_table ()) + + (* Loading is also a traversing that decodes the embedded keys that + are inside the [lightened_library]. If the [load_proof] flag is + set, we lookup inside the table to graft the + [constr_substituted]. Otherwise, we set the [const_body] field + to [None]. + *) + let load ~load_proof (table : table Lazy.t) lightened_library = + let decode_key = function + | Undef _ | Def _ -> assert false + | OpaqueDef k -> + let k = key_of_lazy_constr k in + let access key = + try (Lazy.force table).(key) + with _ -> error "Error while retrieving an opaque body" + in + match load_proof with + | Flags.Force -> + let lc = Lazy.lazy_from_val (access k) in + OpaqueDef (make_lazy_constr lc) + | Flags.Lazy -> + let lc = lazy (access k) in + OpaqueDef (make_lazy_constr lc) + | Flags.Dont -> + Undef None + in + traverse_library decode_key lightened_library + +end type judgment = unsafe_judgment diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 33a6a775..6f46a45b 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -1,22 +1,20 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Environ.env val empty_environment : safe_environment val is_empty : safe_environment -> bool -(* Adding and removing local declarations (Local or Variables) *) +(** Adding and removing local declarations (Local or Variables) *) val push_named_assum : identifier * types -> safe_environment -> Univ.constraints * safe_environment @@ -39,7 +37,7 @@ val push_named_def : identifier * constr * types option -> safe_environment -> Univ.constraints * safe_environment -(* Adding global axioms or definitions *) +(** Adding global axioms or definitions *) type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe @@ -48,39 +46,40 @@ val add_constant : dir_path -> label -> global_declaration -> safe_environment -> constant * safe_environment -(* Adding an inductive type *) +(** Adding an inductive type *) val add_mind : dir_path -> label -> mutual_inductive_entry -> safe_environment -> mutual_inductive * safe_environment -(* Adding a module *) +(** Adding a module *) val add_module : - label -> module_entry -> bool -> safe_environment + label -> module_entry -> inline -> safe_environment -> module_path * delta_resolver * safe_environment -(* Adding a module type *) +(** Adding a module type *) val add_modtype : - label -> module_struct_entry -> bool -> safe_environment + label -> module_struct_entry -> inline -> safe_environment -> module_path * safe_environment -(* Adding universe constraints *) +(** Adding universe constraints *) val add_constraints : Univ.constraints -> safe_environment -> safe_environment -(* Settin the strongly constructive or classical logical engagement *) +(** Settin the strongly constructive or classical logical engagement *) val set_engagement : engagement -> safe_environment -> safe_environment -(*s Interactive module functions *) +(** {6 Interactive module functions } *) + val start_module : label -> safe_environment -> module_path * safe_environment val end_module : - label -> (module_struct_entry * bool) option + label -> (module_struct_entry * inline) option -> safe_environment -> module_path * delta_resolver * safe_environment val add_module_parameter : - mod_bound_id -> module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment + mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment val start_modtype : label -> safe_environment -> module_path * safe_environment @@ -89,16 +88,17 @@ val end_modtype : label -> safe_environment -> module_path * safe_environment val add_include : - module_struct_entry -> bool -> bool -> safe_environment -> + module_struct_entry -> bool -> inline -> safe_environment -> delta_resolver * safe_environment val pack_module : safe_environment -> module_body val current_modpath : safe_environment -> module_path val delta_of_senv : safe_environment -> delta_resolver*delta_resolver -(* Loading and saving compilation units *) -(* exporting and importing modules *) +(** Loading and saving compilation units *) + +(** exporting and importing modules *) type compiled_library val start_library : dir_path -> safe_environment @@ -110,18 +110,25 @@ val export : safe_environment -> dir_path val import : compiled_library -> Digest.t -> safe_environment -> module_path * safe_environment -(* Remove the body of opaque constants *) +(** Remove the body of opaque constants *) -val lighten_library : compiled_library -> compiled_library +module LightenLibrary : +sig + type table + type lightened_compiled_library + val save : compiled_library -> lightened_compiled_library * table + val load : load_proof:Flags.load_proofs -> table Lazy.t -> + lightened_compiled_library -> compiled_library +end -(*s Typing judgments *) +(** {6 Typing judgments } *) type judgment val j_val : judgment -> constr val j_type : judgment -> constr -(* Safe typing of a term returning a typing judgment and universe +(** Safe typing of a term returning a typing judgment and universe constraints to be added to the environment for the judgment to hold. It is guaranteed that the constraints are satisfiable *) @@ -129,7 +136,9 @@ val safe_infer : safe_environment -> constr -> judgment * Univ.constraints val typing : safe_environment -> constr -> judgment +(** {7 Query } *) +val exists_label : label -> safe_environment -> bool (*spiwack: safe retroknowledge functionalities *) diff --git a/kernel/sign.ml b/kernel/sign.ml index d241f677..71169563 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -1,12 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raise Not_found let named_context_length = List.length +let named_context_equal = list_equal eq_named_declaration let vars_of_named_context = List.map (fun (id,_,_) -> id) diff --git a/kernel/sign.mli b/kernel/sign.mli index 35e49003..074139c9 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -1,19 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* identifier list val lookup_named : identifier -> named_context -> named_declaration -(* number of declarations *) +(** number of declarations *) val named_context_length : named_context -> int -(*s Recurrence on [named_context]: older declarations processed first *) +(** named context equality *) +val named_context_equal : named_context -> named_context -> bool + +(** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a -(* newer declarations first *) + +(** newer declarations first *) val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a -(*s Section-related auxiliary functions *) +(** {6 Section-related auxiliary functions } *) val instance_from_named_context : named_context -> constr array -(*s Signatures of ordered optionally named variables, intended to be +(** {6 ... } *) +(** Signatures of ordered optionally named variables, intended to be accessed by de Bruijn indices *) val push_named_to_rel_context : named_context -> rel_context -> rel_context -(*s Recurrence on [rel_context]: older declarations processed first *) +(** {6 Recurrence on [rel_context]: older declarations processed first } *) val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a -(* newer declarations first *) + +(** newer declarations first *) val fold_rel_context_reverse : ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a -(*s Map function of [rel_context] *) +(** {6 Map function of [rel_context] } *) val map_rel_context : (constr -> constr) -> rel_context -> rel_context -(*s Map function of [named_context] *) +(** {6 Map function of [named_context] } *) val map_named_context : (constr -> constr) -> named_context -> named_context -(*s Map function of [rel_context] *) +(** {6 Map function of [rel_context] } *) val iter_rel_context : (constr -> unit) -> rel_context -> unit -(*s Map function of [named_context] *) +(** {6 Map function of [named_context] } *) val iter_named_context : (constr -> unit) -> named_context -> unit diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 447e062a..c141a02a 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -1,12 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* error () + NotConvertible -> error why (* for now we do not allow reorderings *) let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= let kn1 = make_mind mp1 empty_dirpath l in let kn2 = make_mind mp2 empty_dirpath l in - let error () = error_not_match l spec2 in - let check_conv cst f = check_conv_error error cst f in + let error why = error_signature_mismatch l spec2 why in + let check_conv why cst f = check_conv_error error why cst f in let mib1 = match info1 with | IndType ((_,0), mib) -> subst_mind subst1 mib - | _ -> error () + | _ -> error (InductiveFieldExpected mib2) in let mib2 = subst_mind subst2 mib2 in - let check_inductive_type cst env t1 t2 = + let check_inductive_type cst name env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds @@ -114,40 +115,43 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let s1,s2 = match s1, s2 with | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort - | (Prop _, Type _) | (Type _,Prop _) -> error () + | (Prop _, Type _) | (Type _,Prop _) -> + error (NotConvertibleInductiveField name) | _ -> (s1, s2) in - check_conv cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + check_conv (NotConvertibleInductiveField name) + cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = - let check f = if f p1 <> f p2 then error () in - check (fun p -> p.mind_consnames); - check (fun p -> p.mind_typename); + let check f why = if f p1 <> f p2 then error why in + check (fun p -> p.mind_consnames) NotSameConstructorNamesField; + check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField; (* nf_lc later *) (* nf_arity later *) (* user_lc ignored *) (* user_arity ignored *) - check (fun p -> p.mind_nrealargs); + check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *) (* kelim ignored *) (* listrec ignored *) (* finite done *) (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) - let cst = check_inductive_type cst env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) + let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) in cst in let check_cons_types i cst p1 p2 = - array_fold_left2 - (fun cst t1 t2 -> check_conv cst conv env t1 t2) + array_fold_left3 + (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2) cst + p2.mind_consnames (arities_of_specif kn1 (mib1,p1)) (arities_of_specif kn1 (mib2,p2)) in - let check f = if f mib1 <> f mib2 then error () in - check (fun mib -> mib.mind_finite); - check (fun mib -> mib.mind_ntypes); + let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in + check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x); + check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x); assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); @@ -157,17 +161,17 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 (* at the time of checking the inductive arities in check_packet. *) (* Notice that we don't expect the local definitions to match: only *) (* the inductive types and constructors types have to be convertible *) - check (fun mib -> mib.mind_nparams); + check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x); - begin + begin match mind_of_delta reso2 kn2 with | kn2' when kn2=kn2' -> () | kn2' -> if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then - error () + error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) - check (fun mib -> mib.mind_record); + check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x); if mib1.mind_record then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) @@ -179,7 +183,11 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); - check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); + check (fun mib -> + let nparamdecls = List.length mib.mind_params_ctxt in + let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in + snd (list_chop nparamdecls names)) + (fun x -> RecordProjectionsExpected x); end; (* we first check simple things *) let cst = @@ -193,7 +201,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = - let error () = error_not_match l spec2 in + let error why = error_signature_mismatch l spec2 why in let check_conv cst f = check_conv_error error cst f in let check_type cst env t1 t2 = @@ -233,66 +241,42 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = constraints of the form "univ <= max(...)" are not expressible in the system of algebraic universes: we fail (the user has to use an explicit type in the interface *) - error () - with UserError _ (* "not an arity" *) -> - error () end - | _ -> t1,t2 + error NoTypeConstraintExpected + with NotArity -> + error NotConvertibleTypeField end + | _ -> + t1,t2 else (t1,t2) in - check_conv cst conv_leq env t1 t2 + check_conv NotConvertibleTypeField cst conv_leq env t1 t2 in match info1 with | Constant cb1 -> - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; - (*Start by checking types*) - let cb1 = subst_const_body subst1 cb1 in - let cb2 = subst_const_body subst2 cb2 in + assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; + let cb1 = subst_const_body subst1 cb1 in + let cb2 = subst_const_body subst2 cb2 in + (* Start by checking types*) let typ1 = Typeops.type_of_constant_type env cb1.const_type in let typ2 = Typeops.type_of_constant_type env cb2.const_type in let cst = check_type cst env typ1 typ2 in - let con = make_con mp1 empty_dirpath l in - let cst = - if cb2.const_opaque then - (* In this case we compare opaque definitions, we need to bypass - the opacity and do a delta step*) - match cb2.const_body with - | None -> cst - | Some lc2 -> - let c2 = Declarations.force lc2 in - let c1 = match cb1.const_body with - | Some lc1 -> - let c = Declarations.force lc1 in - begin - match (kind_of_term c),(kind_of_term c2) with - Const n1,Const n2 when (eq_constant n1 n2) -> c - (* c1 may have been strenghtened - we need to unfold it*) - | Const n,_ -> - let cb = subst_const_body subst1 - (lookup_constant n env) in - (match cb.const_opaque, - cb.const_body with - | true, Some lc1 -> - Declarations.force lc1 - | _,_ -> c) - | _ ,_-> c - end - | None -> mkConst con - in - check_conv cst conv env c1 c2 - else - match cb2.const_body with - | None -> cst - | Some lc2 -> - let c2 = Declarations.force lc2 in - let c1 = match cb1.const_body with - | Some lc1 -> Declarations.force lc1 - | None -> mkConst con - in - check_conv cst conv env c1 c2 - in - cst + (* Now we check the bodies: + - A transparent constant can only be implemented by a compatible + transparent constant. + - In the signature, an opaque is handled just as a parameter: + anything of the right type can implement it, even if bodies differ. + *) + (match cb2.const_body with + | Undef _ | OpaqueDef _ -> cst + | Def lc2 -> + (match cb1.const_body with + | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField + | Def lc1 -> + (* NB: cb1 might have been strengthened and appear as transparent. + Anyway [check_conv] will handle that afterwards. *) + let c1 = Declarations.force lc1 in + let c2 = Declarations.force lc2 in + check_conv NotConvertibleBodyField cst conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -300,10 +284,10 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "inductive type and give a definition to map the old name to the new " ^ "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; - if cb2.const_body <> None then error () ; + if constant_has_body cb2 then error DefinitionFieldExpected; let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv cst conv_leq env arity1 typ2 + check_conv NotConvertibleTypeField cst conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -311,15 +295,15 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "constructor and give a definition to map the old name to the new " ^ "name.")); assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; - if cb2.const_body <> None then error () ; + if constant_has_body cb2 then error DefinitionFieldExpected; let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv cst conv env ty1 ty2 - | _ -> error () + check_conv NotConvertibleTypeField cst conv env ty1 ty2 + | _ -> error DefinitionFieldExpected let rec check_modules cst env msb1 msb2 subst1 subst2 = - let mty1 = module_type_of_module env None msb1 in - let mty2 = module_type_of_module env None msb2 in + let mty1 = module_type_of_module None msb1 in + let mty2 = module_type_of_module None msb2 in let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in cst @@ -344,13 +328,13 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= match info1 with | Module msb -> check_modules cst env msb msb2 subst1 subst2 - | _ -> error_not_match l spec2 + | _ -> error_signature_mismatch l spec2 ModuleFieldExpected end | SFBmodtype mtb2 -> let mtb1 = match info1 with | Modtype mtb -> mtb - | _ -> error_not_match l spec2 + | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected in let env = add_module (module_body_of_type mtb2.typ_mp mtb2) (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in @@ -368,7 +352,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = if equiv then let subst2 = add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in - Univ.Constraint.union + Univ.union_constraints (check_signatures cst env mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 mtb1.typ_delta mtb2.typ_delta) @@ -412,7 +396,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module (module_body_of_type sup.typ_mp sup) env in - check_modtypes Constraint.empty env - (strengthen env sup sup.typ_mp) super empty_subst + check_modtypes empty_constraint env + (strengthen sup sup.typ_mp) super empty_subst (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index a32804b9..cf9cb540 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -1,18 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* module_type_body -> module_type_body -> constraints diff --git a/kernel/term.ml b/kernel/term.ml index 1894417c..dcb63cf7 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -1,14 +1,27 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* SortType s - | Cast (c,_,t) -> CastType (c, t) - | Prod (na,t,c) -> ProdType (na, t, c) - | LetIn (na,b,t,c) -> LetInType (na, b, t, c) - | App (c,l) -> AtomicType (c, l) - | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c) - -> AtomicType (c,[||]) - | (Lambda _ | Construct _) -> failwith "Not a type" - (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type constr = (constr,constr) kind_of_term @@ -117,82 +112,10 @@ type rec_declaration = name array * constr array * constr array type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration -(***************************) -(* hash-consing functions *) -(***************************) -let comp_term t1 t2 = - match t1, t2 with - | Rel n1, Rel n2 -> n1 = n2 - | Meta m1, Meta m2 -> m1 == m2 - | Var id1, Var id2 -> id1 == id2 - | Sort s1, Sort s2 -> s1 == s2 - | Cast (c1,_,t1), Cast (c2,_,t2) -> c1 == c2 & t1 == t2 - | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 - | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 - | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> - n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2 - | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2 - | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2 - | Const c1, Const c2 -> c1 == c2 - | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2 - | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> - sp1 == sp2 & i1 = i2 & j1 = j2 - | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> - ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2 - | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) -> - ln1 = ln2 - & array_for_all2 (==) lna1 lna2 - & array_for_all2 (==) tl1 tl2 - & array_for_all2 (==) bl1 bl2 - | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) -> - ln1 = ln2 - & array_for_all2 (==) lna1 lna2 - & array_for_all2 (==) tl1 tl2 - & array_for_all2 (==) bl1 bl2 - | _ -> false - -let hash_term (sh_rec,(sh_sort,sh_con,sh_kn,sh_na,sh_id)) t = - match t with - | Rel _ -> t - | Meta x -> Meta x - | Var x -> Var (sh_id x) - | Sort s -> Sort (sh_sort s) - | Cast (c, k, t) -> Cast (sh_rec c, k, (sh_rec t)) - | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c) - | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c) - | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c) - | App (c,l) -> App (sh_rec c, Array.map sh_rec l) - | Evar (e,l) -> Evar (e, Array.map sh_rec l) - | Const c -> Const (sh_con c) - | Ind (kn,i) -> Ind (sh_kn kn,i) - | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j) - | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *) - Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl) - | Fix (ln,(lna,tl,bl)) -> - Fix (ln,(Array.map sh_na lna, - Array.map sh_rec tl, - Array.map sh_rec bl)) - | CoFix(ln,(lna,tl,bl)) -> - CoFix (ln,(Array.map sh_na lna, - Array.map sh_rec tl, - Array.map sh_rec bl)) - -module Hconstr = - Hashcons.Make( - struct - type t = constr - type u = (constr -> constr) * - ((sorts -> sorts) * (constant -> constant) * - (mutual_inductive -> mutual_inductive) * (name -> name) * - (identifier -> identifier)) - let hash_sub = hash_term - let equal = comp_term - let hash = Hashtbl.hash - end) - -let hcons_term (hsorts,hcon,hkn,hname,hident) = - Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident) +(*********************) +(* Term constructors *) +(*********************) (* Constructs a DeBrujin index with number n *) let rels = @@ -201,21 +124,20 @@ let rels = let mkRel n = if 0 mkProp (* Easy sharing *) + | Prop Pos -> mkSet + | s -> Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) -(* (that means t2 is declared as the type of t1) - [s] is the strategy to use when *) +(* (that means t2 is declared as the type of t1) *) let mkCast (t1,k2,t2) = match t1 with - | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2) + | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2) | _ -> Cast (t1,k2,t2) (* Constructs the product (x:t1)t2 *) @@ -236,16 +158,13 @@ let mkApp (f, a) = | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) - (* Constructs a constant *) -(* The array of terms correspond to the variables introduced in the section *) let mkConst c = Const c (* Constructs an existential variable *) let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named kn *) -(* The array of terms correspond to the variables introduced in the section *) let mkInd m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the @@ -256,12 +175,48 @@ let mkConstruct c = Construct c (* Constructs the term

Case c of c1 | c2 .. | cn end *) let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) +(* If recindxs = [|i1,...in|] + funnames = [|f1,...fn|] + typarray = [|t1,...tn|] + bodies = [|b1,...bn|] + then + + mkFix ((recindxs,i),(funnames,typarray,bodies)) + + constructs the ith function of the block + + Fixpoint f1 [ctx1] : t1 := b1 + with f2 [ctx2] : t2 := b2 + ... + with fn [ctxn] : tn := bn. + + where the lenght of the jth context is ij. +*) + let mkFix fix = Fix fix -let mkCoFix cofix = CoFix cofix +(* If funnames = [|f1,...fn|] + typarray = [|t1,...tn|] + bodies = [|b1,...bn|] + then + + mkCoFix (i,(funnames,typsarray,bodies)) + + constructs the ith function of the block + + CoFixpoint f1 : t1 := b1 + with f2 : t2 := b2 + ... + with fn : tn := bn. +*) +let mkCoFix cofix= CoFix cofix + +(* Constructs an existential variable named "?n" *) +let mkMeta n = Meta n + +(* Constructs a Variable named id *) +let mkVar id = Var id -let kind_of_term c = c -let kind_of_term2 c = c (************************************************************************) (* kind_of_term = constructions as seen by the user *) @@ -271,15 +226,25 @@ let kind_of_term2 c = c least one argument and the function is not itself an applicative term *) -let kind_of_term = kind_of_term +let kind_of_term c = c +(* Experimental, used in Presburger contrib *) +type ('constr, 'types) kind_of_type = + | SortType of sorts + | CastType of 'types * 'types + | ProdType of name * 'types * 'types + | LetInType of name * 'constr * 'types * 'types + | AtomicType of 'constr * 'constr array -(* En vue d'un kind_of_type : constr -> hnftype ??? *) -type hnftype = - | HnfSort of sorts - | HnfProd of name * constr * constr - | HnfAtom of constr - | HnfInd of inductive * constr array +let kind_of_type = function + | Sort s -> SortType s + | Cast (c,_,t) -> CastType (c, t) + | Prod (na,t,c) -> ProdType (na, t, c) + | LetIn (na,b,t,c) -> LetInType (na, b, t, c) + | App (c,l) -> AtomicType (c, l) + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c) + -> AtomicType (c,[||]) + | (Lambda _ | Construct _) -> failwith "Not a type" (**********************************************************************) (* Non primitive term destructors *) @@ -334,18 +299,12 @@ let rec is_Type c = match kind_of_term c with | Cast (c,_,_) -> is_Type c | _ -> false -let isType = function - | Type _ -> true - | _ -> false - let is_small = function | Prop _ -> true | _ -> false let iskind c = isprop c or is_Type c -let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2) - (* Tests if an evar *) let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false @@ -366,6 +325,7 @@ let isRel c = match kind_of_term c with Rel _ -> true | _ -> false (* Tests if a variable *) let isVar c = match kind_of_term c with Var _ -> true | _ -> false +let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false (* Tests if an inductive *) let isInd c = match kind_of_term c with Ind _ -> true | _ -> false @@ -387,7 +347,7 @@ let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false (* Destructs the let [x:=b:t1]t2 *) let destLetIn c = match kind_of_term c with | LetIn (x,b,t1,t2) -> (x,b,t1,t2) - | _ -> invalid_arg "destProd" + | _ -> invalid_arg "destLetIn" let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false @@ -412,10 +372,6 @@ let destEvar c = match kind_of_term c with | Evar (kn, a as r) -> r | _ -> invalid_arg "destEvar" -let num_of_evar c = match kind_of_term c with - | Evar (n, _) -> n - | _ -> anomaly "num_of_evar called with bad args" - (* Destructs a (co)inductive type named kn *) let destInd c = match kind_of_term c with | Ind (kn, a as r) -> r @@ -485,18 +441,6 @@ let decompose_app c = | App (f,cl) -> (f, Array.to_list cl) | _ -> (c,[]) -(* strips head casts and flattens head applications *) -let rec strip_head_cast c = match kind_of_term c with - | App (f,cl) -> - let rec collapse_rec f cl2 = match kind_of_term f with - | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | Cast (c,_,_) -> collapse_rec c cl2 - | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2) - in - collapse_rec f cl - | Cast (c,_,_) -> strip_head_cast c - | _ -> c - (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) @@ -621,15 +565,11 @@ let compare_constr f t1 t2 = | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 + | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2 + | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2)) | App (c1,l1), App (c2,l2) -> - if Array.length l1 = Array.length l2 then - f c1 c2 & array_for_all2 f l1 l2 - else - let (h1,l1) = decompose_app t1 in - let (h2,l2) = decompose_app t2 in - if List.length l1 = List.length l2 then - f h1 h2 & List.for_all2 f l1 l2 - else false + Array.length l1 = Array.length l2 && + f c1 c2 && array_for_all2 f l1 l2 | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 | Const c1, Const c2 -> eq_constant c1 c2 | Ind c1, Ind c2 -> eq_ind c1 c2 @@ -642,6 +582,62 @@ let compare_constr f t1 t2 = ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | _ -> false +(*******************************) +(* alpha conversion functions *) +(*******************************) + +(* alpha conversion : ignore print names and casts *) + +let rec eq_constr m n = + (m==n) or + compare_constr eq_constr m n + +let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) + +let constr_ord_int f t1 t2 = + let (=?) f g i1 i2 j1 j2= + let c=f i1 i2 in + if c=0 then g j1 j2 else c in + let (==?) fg h i1 i2 j1 j2 k1 k2= + let c=fg i1 i2 j1 j2 in + if c=0 then h k1 k2 else c in + match kind_of_term t1, kind_of_term t2 with + | Rel n1, Rel n2 -> n1 - n2 + | Meta m1, Meta m2 -> m1 - m2 + | Var id1, Var id2 -> id_ord id1 id2 + | Sort s1, Sort s2 -> Pervasives.compare s1 s2 + | Cast (c1,_,_), _ -> f c1 t2 + | _, Cast (c2,_,_) -> f t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> + (f =? f) t1 t2 c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 + | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2 + | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2)) + | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> + ((-) =? (array_compare f)) e1 e2 l1 l2 + | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2) + | Ind (spx, ix), Ind (spy, iy) -> + let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c + | Construct ((spx, ix), jx), Construct ((spy, iy), jy) -> + let c = jx - jy in if c = 0 then + (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c) + else c + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + ((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2 + | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> + ((Pervasives.compare =? (array_compare f)) ==? (array_compare f)) + ln1 ln2 tl1 tl2 bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + ((Pervasives.compare =? (array_compare f)) ==? (array_compare f)) + ln1 ln2 tl1 tl2 bl1 bl2 + | t1, t2 -> Pervasives.compare t1 t2 + +let rec constr_ord m n= + constr_ord_int constr_ord m n + (***************************************************************************) (* Type of assumptions *) (***************************************************************************) @@ -659,6 +655,18 @@ let map_rel_declaration = map_named_declaration let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a) let fold_rel_declaration = fold_named_declaration +let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty +let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty + +let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty +let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty + +let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = + id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2 + +let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) = + n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2 + (***************************************************************************) (* Type of local contexts (telescopes) *) (***************************************************************************) @@ -762,12 +770,12 @@ let rec exliftn el c = match kind_of_term c with (* Lifting the binding depth across k bindings *) -let liftn k n = - match el_liftn (pred n) (el_shft k ELID) with +let liftn n k = + match el_liftn (pred k) (el_shft n el_id) with | ELID -> (fun c -> c) | el -> exliftn el -let lift k = liftn k 1 +let lift n = liftn n 1 (*********************) (* Substituting *) @@ -814,12 +822,12 @@ let substnl laml n = let substl laml = substnl laml 0 let subst1 lam = substl [lam] -let substnl_decl laml k (id,bodyopt,typ) = - (id,Option.map (substnl laml k) bodyopt,substnl laml k typ) +let substnl_decl laml k = map_rel_declaration (substnl laml k) let substl_decl laml = substnl_decl laml 0 let subst1_decl lam = substl_decl [lam] -let subst1_named_decl = subst1_decl +let substnl_named laml k = map_named_declaration (substnl laml k) let substl_named_decl = substl_decl +let subst1_named_decl = subst1_decl (* (thin_val sigma) removes identity substitutions from sigma *) @@ -858,44 +866,12 @@ let substn_vars p vars = let subst_vars = substn_vars 1 -(*********************) -(* Term constructors *) -(*********************) - -(* Constructs a DeBrujin index with number n *) -let mkRel = mkRel - -(* Constructs an existential variable named "?n" *) -let mkMeta = mkMeta - -(* Constructs a Variable named id *) -let mkVar = mkVar - -(* Construct a type *) -let mkProp = mkSort prop_sort -let mkSet = mkSort set_sort -let mkType u = mkSort (Type u) -let mkSort = function - | Prop Null -> mkProp (* Easy sharing *) - | Prop Pos -> mkSet - | s -> mkSort s - -(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) -(* (that means t2 is declared as the type of t1) *) -let mkCast = mkCast +(***************************) +(* Other term constructors *) +(***************************) -(* Constructs the product (x:t1)t2 *) -let mkProd = mkProd let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) -let mkProd_string s t c = mkProd (Name (id_of_string s), t, c) - -(* Constructs the abstraction [x:t1]t2 *) -let mkLambda = mkLambda let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) -let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c) - -(* Constructs [x=c_1:t]c_2 *) -let mkLetIn = mkLetIn let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) @@ -909,17 +885,6 @@ let mkNamedProd_or_LetIn (id,body,t) c = | None -> mkNamedProd id t c | Some b -> mkNamedLetIn id b t c -(* Constructs either [[x:t]c] or [[x=b:t]c] *) -let mkLambda_or_LetIn (na,body,t) c = - match body with - | None -> mkLambda (na, t, c) - | Some b -> mkLetIn (na, b, t, c) - -let mkNamedLambda_or_LetIn (id,body,t) c = - match body with - | None -> mkNamedLambda id t c - | Some b -> mkNamedLetIn id b t c - (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) let mkProd_wo_LetIn (na,body,t) c = match body with @@ -934,83 +899,16 @@ let mkNamedProd_wo_LetIn (id,body,t) c = (* non-dependent product t1 -> t2 *) let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) -(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) -(* We ensure applicative terms have at most one arguments and the - function is not itself an applicative term *) -let mkApp = mkApp - -let mkAppA v = - let l = Array.length v in - if l=0 then anomaly "mkAppA received an empty array" - else mkApp (v.(0), Array.sub v 1 (Array.length v -1)) - -(* Constructs a constant *) -(* The array of terms correspond to the variables introduced in the section *) -let mkConst = mkConst - -(* Constructs an existential variable *) -let mkEvar = mkEvar - -(* Constructs the ith (co)inductive type of the block named kn *) -(* The array of terms correspond to the variables introduced in the section *) -let mkInd = mkInd - -(* Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) -let mkConstruct = mkConstruct - -(* Constructs the term

Case c of c1 | c2 .. | cn end *) -let mkCase = mkCase -let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac) - -(* If recindxs = [|i1,...in|] - funnames = [|f1,...fn|] - typarray = [|t1,...tn|] - bodies = [|b1,...bn|] - then - - mkFix ((recindxs,i),(funnames,typarray,bodies)) - - constructs the ith function of the block - - Fixpoint f1 [ctx1] : t1 := b1 - with f2 [ctx2] : t2 := b2 - ... - with fn [ctxn] : tn := bn. - - where the lenght of the jth context is ij. -*) - -let mkFix = mkFix - -(* If funnames = [|f1,...fn|] - typarray = [|t1,...tn|] - bodies = [|b1,...bn|] - then - - mkCoFix (i,(funnames,typsarray,bodies)) - - constructs the ith function of the block - - CoFixpoint f1 : t1 := b1 - with f2 : t2 := b2 - ... - with fn : tn := bn. -*) -let mkCoFix = mkCoFix - -(* Construct an implicit *) -let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0)) -let mkImplicit = mkSort implicit_sort - -(***************************) -(* Other term constructors *) -(***************************) +(* Constructs either [[x:t]c] or [[x=b:t]c] *) +let mkLambda_or_LetIn (na,body,t) c = + match body with + | None -> mkLambda (na, t, c) + | Some b -> mkLetIn (na, b, t, c) -let abs_implicit c = mkLambda (Anonymous, mkImplicit, c) -let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a) -let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a) +let mkNamedLambda_or_LetIn (id,body,t) c = + match body with + | None -> mkNamedLambda id t c + | Some b -> mkNamedLetIn id b t c (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = @@ -1252,37 +1150,216 @@ let rec isArity c = | Sort _ -> true | _ -> false -(*******************************) -(* alpha conversion functions *) -(*******************************) - -(* alpha conversion : ignore print names and casts *) - -let rec eq_constr m n = - (m==n) or - compare_constr eq_constr m n - -let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) - (*******************) (* hash-consing *) (*******************) -module Htype = - Hashcons.Make( - struct - type t = types - type u = (constr -> constr) * (sorts -> sorts) -(* - let hash_sub (hc,hs) j = {body=hc j.body; typ=hs j.typ} - let equal j1 j2 = j1.body==j2.body & j1.typ==j2.typ +(* Hash-consing of [constr] does not use the module [Hashcons] because + [Hashcons] is not efficient on deep tree-like data + structures. Indeed, [Hashcons] is based the (very efficient) + generic hash function [Hashtbl.hash], which computes the hash key + through a depth bounded traversal of the data structure to be + hashed. As a consequence, for a deep [constr] like the natural + number 1000 (S (S (... (S O)))), the same hash is assigned to all + the sub [constr]s greater than the maximal depth handled by + [Hashtbl.hash]. This entails a huge number of collisions in the + hash table and leads to cubic hash-consing in this worst-case. + + In order to compute a hash key that is independent of the data + structure depth while being constant-time, an incremental hashing + function must be devised. A standard implementation creates a cache + of the hashing function by decorating each node of the hash-consed + data structure with its hash key. In that case, the hash function + can deduce the hash key of a toplevel data structure by a local + computation based on the cache held on its substructures. + Unfortunately, this simple implementation introduces a space + overhead that is damageable for the hash-consing of small [constr]s + (the most common case). One can think of an heterogeneous + distribution of caches on smartly chosen nodes, but this is forbidden + by the use of generic equality in Coq source code. (Indeed, this forces + each [constr] to have a unique canonical representation.) + + Given that hash-consing proceeds inductively, we can nonetheless + computes the hash key incrementally during hash-consing by changing + a little the signature of the hash-consing function: it now returns + both the hash-consed term and its hash key. This simple solution is + implemented in the following code: it does not introduce a space + overhead in [constr], that's why the efficiency is unchanged for + small [constr]s. Besides, it does handle deep [constr]s without + introducing an unreasonable number of collisions in the hash table. + Some benchmarks make us think that this implementation of + hash-consing is linear in the size of the hash-consed data + structure for our daily use of Coq. *) -(**) - let hash_sub (hc,hs) j = hc j - let equal j1 j2 = j1==j2 -(**) - let hash = Hashtbl.hash - end) + +let array_eqeq t1 t2 = + t1 == t2 || + (Array.length t1 = Array.length t2 && + let rec aux i = + (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + +let equals_constr t1 t2 = + match t1, t2 with + | Rel n1, Rel n2 -> n1 == n2 + | Meta m1, Meta m2 -> m1 == m2 + | Var id1, Var id2 -> id1 == id2 + | Sort s1, Sort s2 -> s1 == s2 + | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & t1 == t2 + | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 + | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 + | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> + n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2 + | App (c1,l1), App (c2,l2) -> c1 == c2 & array_eqeq l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq l1 l2 + | Const c1, Const c2 -> c1 == c2 + | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2 + | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> + sp1 == sp2 & i1 = i2 & j1 = j2 + | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> + ci1 == ci2 & p1 == p2 & c1 == c2 & array_eqeq bl1 bl2 + | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) -> + ln1 = ln2 + & array_eqeq lna1 lna2 + & array_eqeq tl1 tl2 + & array_eqeq bl1 bl2 + | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) -> + ln1 = ln2 + & array_eqeq lna1 lna2 + & array_eqeq tl1 tl2 + & array_eqeq bl1 bl2 + | _ -> false + +(** Note that the following Make has the side effect of creating + once and for all the table we'll use for hash-consing all constr *) + +module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end) + +open Hashtbl_alt.Combine + +(* [hcons_term hash_consing_functions constr] computes an hash-consed + representation for [constr] using [hash_consing_functions] on + leaves. *) +let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = + + (* Note : we hash-cons constr arrays *in place* *) + + let rec hash_term_array t = + let accu = ref 0 in + for i = 0 to Array.length t - 1 do + let x, h = sh_rec t.(i) in + accu := combine !accu h; + t.(i) <- x + done; + !accu + + and hash_term t = + match t with + | Var i -> + (Var (sh_id i), combinesmall 1 (Hashtbl.hash i)) + | Sort s -> + (Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s)) + | Cast (c, k, t) -> + let c, hc = sh_rec c in + let t, ht = sh_rec t in + (Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht)) + | Prod (na,t,c) -> + let t, ht = sh_rec t + and c, hc = sh_rec c in + (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc)) + | Lambda (na,t,c) -> + let t, ht = sh_rec t + and c, hc = sh_rec c in + (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc)) + | LetIn (na,b,t,c) -> + let b, hb = sh_rec b in + let t, ht = sh_rec t in + let c, hc = sh_rec c in + (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc)) + | App (c,l) -> + let c, hc = sh_rec c in + let hl = hash_term_array l in + (App (c, l), combinesmall 7 (combine hl hc)) + | Evar (e,l) -> + let hl = hash_term_array l in + (* since the array have been hashed in place : *) + (t, combinesmall 8 (combine (Hashtbl.hash e) hl)) + | Const c -> + (Const (sh_con c), combinesmall 9 (Hashtbl.hash c)) + | Ind ((kn,i) as ind) -> + (Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i)) + | Construct (((kn,i),j) as c)-> + (Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j)) + | Case (ci,p,c,bl) -> + let p, hp = sh_rec p + and c, hc = sh_rec c in + let hbl = hash_term_array bl in + let hbl = combine (combine hc hp) hbl in + (Case (sh_ci ci, p, c, bl), combinesmall 11 hbl) + | Fix (ln,(lna,tl,bl)) -> + let hbl = hash_term_array bl in + let htl = hash_term_array tl in + Array.iteri (fun i x -> lna.(i) <- sh_na x) lna; + (* since the three arrays have been hashed in place : *) + (t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl))) + | CoFix(ln,(lna,tl,bl)) -> + let hbl = hash_term_array bl in + let htl = hash_term_array tl in + Array.iteri (fun i x -> lna.(i) <- sh_na x) lna; + (* since the three arrays have been hashed in place : *) + (t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl))) + | Meta n -> + (t, combinesmall 15 n) + | Rel n -> + (t, combinesmall 16 n) + + and sh_rec t = + let (y, h) = hash_term t in + (* [h] must be positive. *) + let h = h land 0x3FFFFFFF in + (H.may_add_and_get h y, h) + + in + (* Make sure our statically allocated Rels (1 to 16) are considered + as canonical, and hence hash-consed to themselves *) + ignore (hash_term_array rels); + + fun t -> fst (sh_rec t) + +(* Exported hashing fonction on constr, used mainly in plugins. + Appears to have slight differences from [snd (hash_term t)] above ? *) + +let rec hash_constr t = + match kind_of_term t with + | Var i -> combinesmall 1 (Hashtbl.hash i) + | Sort s -> combinesmall 2 (Hashtbl.hash s) + | Cast (c, _, _) -> hash_constr c + | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c)) + | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c)) + | LetIn (_, b, t, c) -> + combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c)) + | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l)) + | App (c,l) -> + combinesmall 7 (combine (hash_term_array l) (hash_constr c)) + | Evar (e,l) -> + combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l)) + | Const c -> + combinesmall 9 (Hashtbl.hash c) (* TODO: proper hash function for constants *) + | Ind (kn,i) -> + combinesmall 9 (combine (Hashtbl.hash kn) i) + | Construct ((kn,i),j) -> + combinesmall 10 (combine3 (Hashtbl.hash kn) i j) + | Case (_ , p, c, bl) -> + combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl)) + | Fix (ln ,(_, tl, bl)) -> + combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl)) + | CoFix(ln, (_, tl, bl)) -> + combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl)) + | Meta n -> combinesmall 15 n + | Rel n -> combinesmall 16 n + +and hash_term_array t = + Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t module Hsorts = Hashcons.Make( @@ -1300,16 +1377,34 @@ module Hsorts = let hash = Hashtbl.hash end) -let hsort = Hsorts.f +module Hcaseinfo = + Hashcons.Make( + struct + type t = case_info + type u = inductive -> inductive + let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind } + let equal ci ci' = + ci.ci_ind == ci'.ci_ind && + ci.ci_npar = ci'.ci_npar && + ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *) + ci.ci_pp_info = ci'.ci_pp_info (* we use (=) on purpose *) + let hash = Hashtbl.hash + end) -let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) = - let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in - let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in - let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in - (hcci,htcci) +let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ +let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind -let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names()) +let hcons_constr = + hcons_term + (hcons_sorts, + hcons_caseinfo, + hcons_construct, + hcons_ind, + hcons_con, + hcons_name, + hcons_ident) +let hcons_types = hcons_constr (*******) (* Type of abstract machine values *) diff --git a/kernel/term.mli b/kernel/term.mli index c9a97bbe..d5899f18 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -1,169 +1,176 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* sorts_family -(*s Useful types *) +(** {6 Useful types } *) -(*s Existential variables *) +(** {6 Existential variables } *) type existential_key = int -(*s Existential variables *) +(** {6 Existential variables } *) type metavariable = int -(*s Case annotation *) -type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle +(** {6 Case annotation } *) +type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle + | RegularStyle (** infer printing form from number of constructor *) type case_printing = - { ind_nargs : int; (* length of the arity of the inductive type *) + { ind_nargs : int; (** length of the arity of the inductive type *) style : case_style } -(* the integer is the number of real args, needed for reduction *) + +(** the integer is the number of real args, needed for reduction *) type case_info = { ci_ind : inductive; ci_npar : int; - ci_cstr_nargs : int array; (* number of real args of each constructor *) - ci_pp_info : case_printing (* not interpreted by the kernel *) + ci_cstr_ndecls : int array; (** number of real args of each constructor *) + ci_pp_info : case_printing (** not interpreted by the kernel *) } -(*s*******************************************************************) -(* The type of constructions *) +(** {6 The type of constructions } *) type constr -(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts, +(** [eq_constr a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val eq_constr : constr -> constr -> bool -(* [types] is the same as [constr] but is intended to be used for +(** [types] is the same as [constr] but is intended to be used for documentation to indicate that such or such function specifically works - with {\em types} (i.e. terms of type a sort). + with {e types} (i.e. terms of type a sort). (Rem:plurial form since [type] is a reserved ML keyword) *) type types = constr -(*s Functions for dealing with constr terms. +(** {5 Functions for dealing with constr terms. } The following functions are intended to simplify and to uniform the manipulation of terms. Some of these functions may be overlapped with previous ones. *) -(*s Term constructors. *) +(** {6 Term constructors. } *) -(* Constructs a DeBrujin index (DB indices begin at 1) *) +(** Constructs a DeBrujin index (DB indices begin at 1) *) val mkRel : int -> constr -(* Constructs a Variable *) +(** Constructs a Variable *) val mkVar : identifier -> constr -(* Constructs an patvar named "?n" *) +(** Constructs an patvar named "?n" *) val mkMeta : metavariable -> constr -(* Constructs an existential variable *) +(** Constructs an existential variable *) type existential = existential_key * constr array val mkEvar : existential -> constr -(* Construct a sort *) +(** Construct a sort *) val mkSort : sorts -> types val mkProp : types val mkSet : types val mkType : Univ.universe -> types -(* This defines the strategy to use for verifiying a Cast *) -type cast_kind = VMcast | DEFAULTcast +(** This defines the strategy to use for verifiying a Cast *) +type cast_kind = VMcast | DEFAULTcast | REVERTcast -(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the - type $t_2$ (that means t2 is declared as the type of t1). *) +(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the + type t{_ 2} (that means t2 is declared as the type of t1). *) val mkCast : constr * cast_kind * constr -> constr -(* Constructs the product [(x:t1)t2] *) +(** Constructs the product [(x:t1)t2] *) val mkProd : name * types * types -> types val mkNamedProd : identifier -> types -> types -> types -(* non-dependant product $t_1 \rightarrow t_2$, an alias for - [(_:t1)t2]. Beware $t_2$ is NOT lifted. - Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *) + +(** non-dependent product [t1 -> t2], an alias for + [forall (_:t1), t2]. Beware [t_2] is NOT lifted. + Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))] +*) val mkArrow : types -> types -> constr -(* Constructs the abstraction $[x:t_1]t_2$ *) +(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *) val mkLambda : name * types * constr -> constr val mkNamedLambda : identifier -> types -> constr -> constr -(* Constructs the product [let x = t1 : t2 in t3] *) +(** Constructs the product [let x = t1 : t2 in t3] *) val mkLetIn : name * constr * types * constr -> constr val mkNamedLetIn : identifier -> constr -> types -> constr -> constr -(* [mkApp (f,[| t_1; ...; t_n |]] constructs the application - $(f~t_1~\dots~t_n)$. *) +(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application + {% $(f~t_1~\dots~t_n)$ %}. *) val mkApp : constr * constr array -> constr -(* Constructs a constant *) -(* The array of terms correspond to the variables introduced in the section *) +(** Constructs a constant + The array of terms correspond to the variables introduced in the section *) val mkConst : constant -> constr -(* Inductive types *) +(** Inductive types *) -(* Constructs the ith (co)inductive type of the block named kn *) -(* The array of terms correspond to the variables introduced in the section *) +(** Constructs the ith (co)inductive type of the block named kn + The array of terms correspond to the variables introduced in the section *) val mkInd : inductive -> constr -(* Constructs the jth constructor of the ith (co)inductive type of the +(** Constructs the jth constructor of the ith (co)inductive type of the block named kn. The array of terms correspond to the variables introduced in the section *) val mkConstruct : constructor -> constr -(* Constructs the term

Case c of c1 | c2 .. | cn end *) +(** Constructs a destructor of inductive type. + + [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] + presented as describe in [ci]. + + [p] stucture is [fun args x -> "return clause"] + + [ac]{^ ith} element is ith constructor case presented as + {e lambda construct_args (without params). case_term } *) val mkCase : case_info * constr * constr * constr array -> constr -(* If [recindxs = [|i1,...in|]] +(** If [recindxs = [|i1,...in|]] [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] [bodies = [|b1,.....bn|]] - then [ mkFix ((recindxs,i), funnames, typarray, bodies) ] - constructs the $i$th function of the block (counting from 0) + then [mkFix ((recindxs,i), funnames, typarray, bodies) ] + constructs the {% $ %}i{% $ %}th function of the block (counting from 0) [Fixpoint f1 [ctx1] = b1 with f2 [ctx2] = b2 ... with fn [ctxn] = bn.] - \noindent where the length of the $j$th context is $ij$. + where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) type rec_declaration = name array * types array * constr array type fixpoint = (int array * int) * rec_declaration val mkFix : fixpoint -> constr -(* If [funnames = [|f1,.....fn|]] +(** If [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] - [bodies = [b1,.....bn]] \par\noindent - then [mkCoFix (i, (typsarray, funnames, bodies))] + [bodies = [b1,.....bn]] + then [mkCoFix (i, (funnames, typarray, bodies))] constructs the ith function of the block - + [CoFixpoint f1 = b1 with f2 = b2 ... @@ -173,9 +180,9 @@ type cofixpoint = int * rec_declaration val mkCoFix : cofixpoint -> constr -(*s Concrete type for making pattern-matching. *) +(** {6 Concrete type for making pattern-matching. } *) -(* [constr array] is an instance matching definitional [named_context] in +(** [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = @@ -203,14 +210,13 @@ type ('constr, 'types) kind_of_term = | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint -(* User view of [constr]. For [App], it is ensured there is at +(** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative term *) val kind_of_term : constr -> (constr, types) kind_of_term -val kind_of_term2 : constr -> ((constr,types) kind_of_term,constr) kind_of_term -(* Experimental *) +(** Experimental, used in Presburger contrib *) type ('constr, 'types) kind_of_type = | SortType of sorts | CastType of 'types * 'types @@ -220,10 +226,11 @@ type ('constr, 'types) kind_of_type = val kind_of_type : types -> (constr, types) kind_of_type -(*s Simple term case analysis. *) +(** {6 Simple term case analysis. } *) val isRel : constr -> bool val isVar : constr -> bool +val isVarId : identifier -> constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool @@ -247,77 +254,83 @@ val is_Type : constr -> bool val iskind : constr -> bool val is_small : sorts -> bool -(*s Term destructors. - Destructor operations are partial functions and - raise [invalid_arg "dest*"] if the term has not the expected form. *) -(* Destructs a DeBrujin index *) +(** {6 Term destructors } *) +(** Destructor operations are partial functions and + @raise Invalid_argument "dest*" if the term has not the expected form. *) + +(** Destructs a DeBrujin index *) val destRel : constr -> int -(* Destructs an existential variable *) +(** Destructs an existential variable *) val destMeta : constr -> metavariable -(* Destructs a variable *) +(** Destructs a variable *) val destVar : constr -> identifier -(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether - [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *) +(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether + [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) val destSort : constr -> sorts -(* Destructs a casted term *) +(** Destructs a casted term *) val destCast : constr -> constr * cast_kind * constr -(* Destructs the product $(x:t_1)t_2$ *) +(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) val destProd : types -> name * types * types -(* Destructs the abstraction $[x:t_1]t_2$ *) +(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) val destLambda : constr -> name * types * constr -(* Destructs the let $[x:=b:t_1]t_2$ *) +(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) val destLetIn : constr -> name * constr * types * constr -(* Destructs an application *) +(** Destructs an application *) val destApp : constr -> constr * constr array -(* Obsolete synonym of destApp *) +(** Obsolete synonym of destApp *) val destApplication : constr -> constr * constr array -(* Decompose any term as an applicative term; the list of args can be empty *) +(** Decompose any term as an applicative term; the list of args can be empty *) val decompose_app : constr -> constr * constr list -(* Destructs a constant *) +(** Destructs a constant *) val destConst : constr -> constant -(* Destructs an existential variable *) +(** Destructs an existential variable *) val destEvar : constr -> existential -(* Destructs a (co)inductive type *) +(** Destructs a (co)inductive type *) val destInd : constr -> inductive -(* Destructs a constructor *) +(** Destructs a constructor *) val destConstruct : constr -> constructor -(* Destructs a term

Case c of lc1 | lc2 .. | lcn end *) +(** Destructs a [match c as x in I args return P with ... | +Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args +return P in t1], or [if c then t1 else t2]) +@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] +where [info] is pretty-printing information *) val destCase : constr -> case_info * constr * constr * constr array -(* Destructs the $i$th function of the block - $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1 - \mathit{with} ~ f_2 ~ [ctx_2] = b_2 - \dots - \mathit{with} ~ f_n ~ [ctx_n] = b_n$, - where the lenght of the $j$th context is $ij$. +(** Destructs the {% $ %}i{% $ %}th function of the block + [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} + with f{_ 2} ctx{_ 2} = b{_ 2} + ... + with f{_ n} ctx{_ n} = b{_ n}], + where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) val destFix : constr -> fixpoint val destCoFix : constr -> cofixpoint -(*s A {\em declaration} has the form (name,body,type). It is either an - {\em assumption} if [body=None] or a {\em definition} if - [body=Some actualbody]. It is referred by {\em name} if [na] is an - identifier or by {\em relative index} if [na] is not an identifier +(** {6 Local } *) +(** A {e declaration} has the form [(name,body,type)]. It is either an + {e assumption} if [body=None] or a {e definition} if + [body=Some actualbody]. It is referred by {e name} if [na] is an + identifier or by {e relative index} if [na] is not an identifier (in the latter case, [na] is of type [name] but just for printing - purpose *) + purpose) *) type named_declaration = identifier * constr option * types type rel_declaration = name * constr option * types @@ -332,9 +345,25 @@ val fold_named_declaration : val fold_rel_declaration : (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a -(*s Contexts of declarations referred to by de Bruijn indices *) +val exists_named_declaration : + (constr -> bool) -> named_declaration -> bool +val exists_rel_declaration : + (constr -> bool) -> rel_declaration -> bool -(* In [rel_context], more recent declaration is on top *) +val for_all_named_declaration : + (constr -> bool) -> named_declaration -> bool +val for_all_rel_declaration : + (constr -> bool) -> rel_declaration -> bool + +val eq_named_declaration : + named_declaration -> named_declaration -> bool + +val eq_rel_declaration : + rel_declaration -> rel_declaration -> bool + +(** {6 Contexts of declarations referred to by de Bruijn indices } *) + +(** In [rel_context], more recent declaration is on top *) type rel_context = rel_declaration list val empty_rel_context : rel_context @@ -344,185 +373,186 @@ val lookup_rel : int -> rel_context -> rel_declaration val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int -(* Constructs either [(x:t)c] or [[x=b:t]c] *) +(** Constructs either [(x:t)c] or [[x=b:t]c] *) val mkProd_or_LetIn : rel_declaration -> types -> types +val mkProd_wo_LetIn : rel_declaration -> types -> types val mkNamedProd_or_LetIn : named_declaration -> types -> types val mkNamedProd_wo_LetIn : named_declaration -> types -> types -(* Constructs either [[x:t]c] or [[x=b:t]c] *) +(** Constructs either [[x:t]c] or [[x=b:t]c] *) val mkLambda_or_LetIn : rel_declaration -> constr -> constr val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr -(*s Other term constructors. *) +(** {6 Other term constructors. } *) -val abs_implicit : constr -> constr -val lambda_implicit : constr -> constr -val lambda_implicit_lift : int -> constr -> constr - -(* [applist (f,args)] and co work as [mkApp] *) +(** [applist (f,args)] and its variants work as [mkApp] *) val applist : constr * constr list -> constr val applistc : constr -> constr list -> constr val appvect : constr * constr array -> constr val appvectc : constr -> constr array -> constr -(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ - where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *) +(** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b] + where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) val prodn : int -> (name * constr) list -> constr -> constr -(* [compose_prod l b] = $(x_1:T_1)..(x_n:T_n)b$ - where $l = [(x_n,T_n);\dots;(x_1,T_1)]$. +(** [compose_prod l b] + @return [forall (x_1:T_1)...(x_n:T_n), b] + where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [decompose_prod]. *) val compose_prod : (name * constr) list -> constr -> constr -(* [lamn n l b] = $[x_1:T_1]..[x_n:T_n]b$ - where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *) +(** [lamn n l b] + @return [fun (x_1:T_1)...(x_n:T_n) => b] + where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) val lamn : int -> (name * constr) list -> constr -> constr -(* [compose_lam l b] = $[x_1:T_1]..[x_n:T_n]b$ - where $l = [(x_n,T_n);\dots;(x_1,T_1)]$. +(** [compose_lam l b] + @return [fun (x_1:T_1)...(x_n:T_n) => b] + where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [it_destLam] *) val compose_lam : (name * constr) list -> constr -> constr -(* [to_lambda n l] - = $[x_1:T_1]...[x_n:T_n]T$ - where $l = (x_1:T_1)...(x_n:T_n)T$ *) +(** [to_lambda n l] + @return [fun (x_1:T_1)...(x_n:T_n) => T] + where [l] is [forall (x_1:T_1)...(x_n:T_n), T] *) val to_lambda : int -> constr -> constr -(* [to_prod n l] - = $(x_1:T_1)...(x_n:T_n)T$ - where $l = [x_1:T_1]...[x_n:T_n]T$ *) +(** [to_prod n l] + @return [forall (x_1:T_1)...(x_n:T_n), T] + where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr -(* pseudo-reduction rule *) +(** pseudo-reduction rule *) -(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *) +(** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) val prod_appvect : constr -> constr array -> constr val prod_applist : constr -> constr list -> constr val it_mkLambda_or_LetIn : constr -> rel_context -> constr val it_mkProd_or_LetIn : types -> rel_context -> types -(*s Other term destructors. *) +(** {6 Other term destructors. } *) -(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair - $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product. +(** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair + {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. It includes also local definitions *) val decompose_prod : constr -> (name*constr) list * constr -(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair - $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *) +(** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair + {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) val decompose_lam : constr -> (name*constr) list * constr -(* Given a positive integer n, transforms a product term - $(x_1:T_1)..(x_n:T_n)T$ - into the pair $([(xn,Tn);...;(x1,T1)],T)$. *) +(** Given a positive integer n, transforms a product term + {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} + into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *) val decompose_prod_n : int -> constr -> (name * constr) list * constr -(* Given a positive integer $n$, transforms a lambda term - $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *) +(** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term + {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *) val decompose_lam_n : int -> constr -> (name * constr) list * constr -(* Extract the premisses and the conclusion of a term of the form +(** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) val decompose_prod_assum : types -> rel_context * types -(* Idem with lambda's *) +(** Idem with lambda's *) val decompose_lam_assum : constr -> rel_context * constr -(* Idem but extract the first [n] premisses *) +(** Idem but extract the first [n] premisses *) val decompose_prod_n_assum : int -> types -> rel_context * types val decompose_lam_n_assum : int -> constr -> rel_context * constr -(* [nb_lam] $[x_1:T_1]...[x_n:T_n]c$ where $c$ is not an abstraction - gives $n$ (casts are ignored) *) +(** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction + gives {% $ %}n{% $ %} (casts are ignored) *) val nb_lam : constr -> int -(* Similar to [nb_lam], but gives the number of products instead *) +(** Similar to [nb_lam], but gives the number of products instead *) val nb_prod : constr -> int -(* Returns the premisses/parameters of a type/term (let-in included) *) +(** Returns the premisses/parameters of a type/term (let-in included) *) val prod_assum : types -> rel_context val lam_assum : constr -> rel_context -(* Returns the first n-th premisses/parameters of a type/term (let included)*) +(** Returns the first n-th premisses/parameters of a type/term (let included)*) val prod_n_assum : int -> types -> rel_context val lam_n_assum : int -> constr -> rel_context -(* Remove the premisses/parameters of a type/term *) +(** Remove the premisses/parameters of a type/term *) val strip_prod : types -> types val strip_lam : constr -> constr -(* Remove the first n-th premisses/parameters of a type/term *) +(** Remove the first n-th premisses/parameters of a type/term *) val strip_prod_n : int -> types -> types val strip_lam_n : int -> constr -> constr -(* Remove the premisses/parameters of a type/term (including let-in) *) +(** Remove the premisses/parameters of a type/term (including let-in) *) val strip_prod_assum : types -> types val strip_lam_assum : constr -> constr -(* flattens application lists *) +(** flattens application lists *) val collapse_appl : constr -> constr -(* Removes recursively the casts around a term i.e. - [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) +(** Removes recursively the casts around a term i.e. + [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) val strip_outer_cast : constr -> constr -(* Apply a function letting Casted types in place *) +(** Apply a function letting Casted types in place *) val under_casts : (constr -> constr) -> constr -> constr -(* Apply a function under components of Cast if any *) +(** Apply a function under components of Cast if any *) val under_outer_cast : (constr -> constr) -> constr -> constr -(*s An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. +(** {6 ... } *) +(** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort. Such a term can canonically be seen as the pair of a context of types and of a sort *) type arity = rel_context * sorts -(* Build an "arity" from its canonical form *) +(** Build an "arity" from its canonical form *) val mkArity : arity -> types -(* Destructs an "arity" into its canonical form *) +(** Destructs an "arity" into its canonical form *) val destArity : types -> arity -(* Tells if a term has the form of an arity *) +(** Tells if a term has the form of an arity *) val isArity : types -> bool -(*s Occur checks *) +(** {6 Occur checks } *) -(* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *) +(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *) val closedn : int -> constr -> bool -(* [closed0 M] is true iff [M] is a (deBruijn) closed term *) +(** [closed0 M] is true iff [M] is a (deBruijn) closed term *) val closed0 : constr -> bool -(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *) +(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *) val noccurn : int -> constr -> bool -(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M] +(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M] for n <= p < n+m *) val noccur_between : int -> int -> constr -> bool -(* Checking function for terms containing existential- or +(** Checking function for terms containing existential- or meta-variables. The function [noccur_with_meta] does not consider meta-variables applied to some terms (intended to be its local context) (for existential variables, it is necessarily the case) *) val noccur_with_meta : int -> int -> constr -> bool -(*s Relocation and substitution *) +(** {6 Relocation and substitution } *) -(* [exliftn el c] lifts [c] with lifting [el] *) +(** [exliftn el c] lifts [c] with lifting [el] *) val exliftn : Esubst.lift -> constr -> constr -(* [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) +(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) val liftn : int -> int -> constr -> constr -(* [lift n c] lifts by [n] the positive indexes in [c] *) +(** [lift n c] lifts by [n] the positive indexes in [c] *) val lift : int -> constr -> constr -(* [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an] +(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates accordingly indexes in [a1],...,[an] *) val substnl : constr list -> int -> constr -> constr @@ -539,29 +569,30 @@ val substl_named_decl : constr list -> named_declaration -> named_declaration val replace_vars : (identifier * constr) list -> constr -> constr val subst_var : identifier -> constr -> constr -(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] +(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] if two names are identical, the one of least indice is kept *) val subst_vars : identifier list -> constr -> constr -(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] + +(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> identifier list -> constr -> constr -(*s Functionals working on the immediate subterm of a construction *) +(** {6 Functionals working on the immediate subterm of a construction } *) -(* [fold_constr f acc c] folds [f] on the immediate subterms of [c] +(** [fold_constr f acc c] folds [f] on the immediate subterms of [c] starting from [acc] and proceeding from left to right according to the usual representation of the constructions; it is not recursive *) val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a -(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is +(** [map_constr f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val map_constr : (constr -> constr) -> constr -> constr -(* [map_constr_with_binders g f n c] maps [f n] on the immediate +(** [map_constr_with_binders g f n c] maps [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which @@ -570,13 +601,13 @@ val map_constr : (constr -> constr) -> constr -> constr val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr -(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is +(** [iter_constr f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) val iter_constr : (constr -> unit) -> constr -> unit -(* [iter_constr_with_binders g f n c] iters [f n] on the immediate +(** [iter_constr_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive and the order with which @@ -585,27 +616,20 @@ val iter_constr : (constr -> unit) -> constr -> unit val iter_constr_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit -(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare +(** [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed; Cast's, binders name and Cases annotations are not taken into account *) val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool +val constr_ord : constr -> constr -> int +val hash_constr : constr -> int + (*********************************************************************) -val hcons_constr: - (constant -> constant) * - (mutual_inductive -> mutual_inductive) * - (dir_path -> dir_path) * - (name -> name) * - (identifier -> identifier) * - (string -> string) - -> - (constr -> constr) * - (types -> types) - -val hcons1_constr : constr -> constr -val hcons1_types : types -> types +val hcons_sorts : sorts -> sorts +val hcons_constr : constr -> constr +val hcons_types : types -> types (**************************************) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index c1eb97a6..478b9c6f 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -1,12 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let (tj,cst2) = infer_type env t in let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (t = tj.utj_val); - NonPolymorphicType t, Constraint.union (Constraint.union cst1 cst2) cst3 + assert (eq_constr t tj.utj_val); + let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in + NonPolymorphicType t, cstrs let local_constrain_type env j cst1 = function | None -> @@ -37,8 +42,8 @@ let local_constrain_type env j cst1 = function | Some t -> let (tj,cst2) = infer_type env t in let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (t = tj.utj_val); - t, Constraint.union (Constraint.union cst1 cst2) cst3 + assert (eq_constr t tj.utj_val); + t, union_constraints (union_constraints cst1 cst2) cst3 let translate_local_def env (b,topt) = let (j,cst) = infer env b in @@ -88,13 +93,20 @@ let infer_declaration env dcl = match dcl with | DefinitionEntry c -> let (j,cst) = infer env c.const_entry_body in + let j = + {uj_val = hcons_constr j.uj_val; + uj_type = hcons_constr j.uj_type} in let (typ,cst) = constrain_type env j cst c.const_entry_type in - Some (Declarations.from_val j.uj_val), typ, cst, - c.const_entry_opaque, c.const_entry_boxed, false - | ParameterEntry (t,nl) -> + let def = + if c.const_entry_opaque + then OpaqueDef (Declarations.opaque_from_val j.uj_val) + else Def (Declarations.from_val j.uj_val) + in + def, typ, cst, c.const_entry_secctx + | ParameterEntry (ctx,t,nl) -> let (j,cst) = infer env t in - None, NonPolymorphicType (Typeops.assumption_of_judgment env j), cst, - false, false, nl + let t = hcons_constr (Typeops.assumption_of_judgment env j) in + Undef nl, NonPolymorphicType t, cst, ctx let global_vars_set_constant_type env = function | NonPolymorphicType t -> global_vars_set env t @@ -104,25 +116,32 @@ let global_vars_set_constant_type env = function (fun t c -> Idset.union (global_vars_set env t) c)) ctx ~init:Idset.empty -let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) = - let ids = - match body with - | None -> global_vars_set_constant_type env typ - | Some b -> - Idset.union - (global_vars_set env (Declarations.force b)) - (global_vars_set_constant_type env typ) - in - let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in - let hyps = keep_hyps env ids in - { const_hyps = hyps; - const_body = body; - const_type = typ; - const_body_code = tps; - (* const_type_code = to_patch env typ;*) - const_constraints = cst; - const_opaque = op; - const_inline = inline} +let build_constant_declaration env kn (def,typ,cst,ctx) = + let hyps = + let inferred = + let ids_typ = global_vars_set_constant_type env typ in + let ids_def = match def with + | Undef _ -> Idset.empty + | Def cs -> global_vars_set env (Declarations.force cs) + | OpaqueDef lc -> + global_vars_set env (Declarations.force_opaque lc) in + keep_hyps env (Idset.union ids_typ ids_def) in + let declared = match ctx with + | None -> inferred + | Some declared -> declared in + let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in + let inferred_set, declared_set = mk_set inferred, mk_set declared in + if not (Idset.subset inferred_set declared_set) then + error ("The following section variable are used but not declared:\n"^ + (String.concat ", " (List.map string_of_id + (Idset.elements (Idset.diff inferred_set declared_set))))); + declared in + let tps = Cemitcodes.from_val (compile_constant_body env def) in + { const_hyps = hyps; + const_body = def; + const_type = typ; + const_body_code = tps; + const_constraints = cst } (*s Global and local constant declaration. *) @@ -130,8 +149,9 @@ let translate_constant env kn ce = build_constant_declaration env kn (infer_declaration env ce) let translate_recipe env kn r = - build_constant_declaration env kn (Cooking.cook_constant env r) + build_constant_declaration env kn + (let def,typ,cst = Cooking.cook_constant env r in def,typ,cst,None) (* Insertion of inductive types. *) -let translate_mind env mie = check_inductive env mie +let translate_mind env kn mie = check_inductive env kn mie diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 217c9f91..3bbf5667 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr * types option -> constr * types * Univ.constraints @@ -26,16 +22,16 @@ val translate_local_assum : env -> types -> types * Univ.constraints val infer_declaration : env -> constant_entry -> - constr_substituted option * constant_type * constraints * bool * bool * bool + constant_def * constant_type * constraints * Sign.section_context option val build_constant_declaration : env -> 'a -> - constr_substituted option * constant_type * constraints * bool * bool * bool -> - constant_body + constant_def * constant_type * constraints * Sign.section_context option -> + constant_body val translate_constant : env -> constant -> constant_entry -> constant_body val translate_mind : - env -> mutual_inductive_entry -> mutual_inductive_body + env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body val translate_recipe : env -> constant -> Cooking.recipe -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 2e6b8d50..8f129999 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* NonInformativeToInformative + | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) + | _ -> WrongArity diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 989b8fbb..7c61e105 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -1,30 +1,26 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a -val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a +val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a val error_generalization : env -> name * types -> unsafe_judgment -> 'a @@ -101,3 +97,4 @@ val error_ill_formed_rec_body : val error_ill_typed_rec_body : env -> int -> name array -> unsafe_judgment array -> types array -> 'a +val error_elim_explain : sorts_family -> sorts_family -> arity_error diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 2fd02063..49106c91 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* raise (NotConvertibleVect i) in - Constraint.union c c') - Constraint.empty + union_constraints c c') + empty_constraint v1 v2 @@ -47,8 +44,6 @@ let assumption_of_judgment env j = with TypeError _ -> error_assumption env j -let sort_judgment env j = (type_judgment env j).utj_type - (************************************************) (* Incremental typing rules: builds a typing judgement given the *) (* judgements for the subterms. *) @@ -206,8 +201,8 @@ let judge_of_apply env funj argjv = (match kind_of_term (whd_betadeltaiota env typ) with | Prod (_,c1,c2) -> (try - let c = conv_leq env hj.uj_type c1 in - let cst' = Constraint.union cst c in + let c = conv_leq false env hj.uj_type c1 in + let cst' = union_constraints cst c in apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl with NotConvertible -> error_cant_apply_bad_type env @@ -219,7 +214,7 @@ let judge_of_apply env funj argjv = in apply_rec 1 funj.uj_type - Constraint.empty + empty_constraint (Array.to_list argjv) (* Type of product *) @@ -270,11 +265,18 @@ let judge_of_product env name t1 t2 = let judge_of_cast env cj k tj = let expected_type = tj.utj_val in try - let cst = + let c, cst = match k with - | VMcast -> vm_conv CUMUL env cj.uj_type expected_type - | DEFAULTcast -> conv_leq env cj.uj_type expected_type in - { uj_val = mkCast (cj.uj_val, k, expected_type); + | VMcast -> + mkCast (cj.uj_val, k, expected_type), + vm_conv CUMUL env cj.uj_type expected_type + | DEFAULTcast -> + mkCast (cj.uj_val, k, expected_type), + conv_leq false env cj.uj_type expected_type + | REVERTcast -> + cj.uj_val, + conv_leq true env cj.uj_type expected_type in + { uj_val = c; uj_type = expected_type }, cst with NotConvertible -> @@ -318,11 +320,11 @@ let judge_of_constructor env c = (* Case. *) -let check_branch_types env cj (lfj,explft) = +let check_branch_types env ind cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> - error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) @@ -333,11 +335,11 @@ let judge_of_case env ci pj cj lfj = let _ = check_case_info env (fst indspec) ci in let (bty,rslty,univ) = type_case_branches env indspec pj cj.uj_val in - let univ' = check_branch_types env cj (lfj,bty) in + let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty }, - Constraint.union univ univ') + union_constraints univ univ') (* Fixpoints. *) @@ -359,7 +361,7 @@ let type_fixpoint env lna lar vdefj = graph and in the universes of the environment. This is to ensure that the infered local graph is satisfiable. *) let univ_combinator (cst,univ) (j,c') = - (j,(Constraint.union cst c', merge_constraints c' univ)) + (j,(union_constraints cst c', merge_constraints c' univ)) (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, @@ -476,23 +478,21 @@ and execute_recdef env (names,lar,vdef) i cu = and execute_array env = array_fold_map' (execute env) -and execute_list env = list_fold_map' (execute env) - (* Derived functions *) let infer env constr = let (j,(cst,_)) = - execute env constr (Constraint.empty, universes env) in - assert (j.uj_val = constr); - ({ j with uj_val = constr }, cst) + execute env constr (empty_constraint, universes env) in + assert (eq_constr j.uj_val constr); + (j, cst) let infer_type env constr = let (j,(cst,_)) = - execute_type env constr (Constraint.empty, universes env) in + execute_type env constr (empty_constraint, universes env) in (j, cst) let infer_v env cv = let (jv,(cst,_)) = - execute_array env cv (Constraint.empty, universes env) in + execute_array env cv (empty_constraint, universes env) in (jv, cst) (* Typing of several terms. *) @@ -510,8 +510,8 @@ let infer_local_decls env decls = | (id, d) :: l -> let env, l, cst1 = inferec env l in let d, cst2 = infer_local_decl env id d in - push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2 - | [] -> env, empty_rel_context, Constraint.empty in + push_rel d env, add_rel_decl d l, union_constraints cst1 cst2 + | [] -> env, empty_rel_context, empty_constraint in inferec env decls (* Exported typing functions *) diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 6e922041..c1c805f3 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -1,23 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr -> unsafe_judgment * constraints val infer_v : env -> constr array -> unsafe_judgment array * constraints @@ -27,56 +23,56 @@ val infer_local_decls : env -> (identifier * local_entry) list -> env * rel_context * constraints -(*s Basic operations of the typing machine. *) +(** {6 Basic operations of the typing machine. } *) -(* If [j] is the judgement $c:t$, then [assumption_of_judgement env j] - returns the type $c$, checking that $t$ is a sort. *) +(** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j] + returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *) val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment -(*s Type of sorts. *) +(** {6 Type of sorts. } *) val judge_of_prop_contents : contents -> unsafe_judgment val judge_of_type : universe -> unsafe_judgment -(*s Type of a bound variable. *) +(** {6 Type of a bound variable. } *) val judge_of_relative : env -> int -> unsafe_judgment -(*s Type of variables *) +(** {6 Type of variables } *) val judge_of_variable : env -> variable -> unsafe_judgment -(*s type of a constant *) +(** {6 type of a constant } *) val judge_of_constant : env -> constant -> unsafe_judgment val judge_of_constant_knowing_parameters : env -> constant -> unsafe_judgment array -> unsafe_judgment -(*s Type of application. *) +(** {6 Type of application. } *) val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints -(*s Type of an abstraction. *) +(** {6 Type of an abstraction. } *) val judge_of_abstraction : env -> name -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment -(*s Type of a product. *) +(** {6 Type of a product. } *) val judge_of_product : env -> name -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment -(* s Type of a let in. *) +(** s Type of a let in. *) val judge_of_letin : env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment -(*s Type of a cast. *) +(** {6 Type of a cast. } *) val judge_of_cast : env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> unsafe_judgment * constraints -(*s Inductive types. *) +(** {6 Inductive types. } *) val judge_of_inductive : env -> inductive -> unsafe_judgment @@ -85,16 +81,16 @@ val judge_of_inductive_knowing_parameters : val judge_of_constructor : env -> constructor -> unsafe_judgment -(*s Type of Cases. *) +(** {6 Type of Cases. } *) val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints -(* Typecheck general fixpoint (not checking guard conditions) *) +(** Typecheck general fixpoint (not checking guard conditions) *) val type_fixpoint : env -> name array -> types array -> unsafe_judgment array -> constraints -(* Kernel safe typing but applicable to partial proofs *) +(** Kernel safe typing but applicable to partial proofs *) val typing : env -> constr -> unsafe_judgment val type_of_constant : env -> constant -> types @@ -104,7 +100,7 @@ val type_of_constant_type : env -> constant_type -> types val type_of_constant_knowing_parameters : env -> constant_type -> constr array -> types -(* Make a type polymorphic if an arity *) +(** Make a type polymorphic if an arity *) val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type diff --git a/kernel/univ.ml b/kernel/univ.ml index 0646a501..a8934544 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1,17 +1,21 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 + | Set, _ -> -1 + | _, Set -> 1 + | Level (dp1, i1), Level (dp2, i2) -> + if i1 < i2 then -1 + else if i1 > i2 then 1 + else compare dp1 dp2 + + let to_string = function + | Set -> "Set" + | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n +end + +module UniverseLMap = Map.Make (UniverseLevel) +module UniverseLSet = Set.Make (UniverseLevel) + +type universe_level = UniverseLevel.t + +let compare_levels = UniverseLevel.compare (* An algebraic universe [universe] is either a universe variable - [universe_level] or a formal universe known to be greater than some + [UniverseLevel.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables @@ -37,38 +70,21 @@ open Util universes inferred while type-checking: it is either the successor of a universe present in the initial term to type-check or the maximum of two algebraic universes - *) - -type universe_level = - | Set - | Level of Names.dir_path * int - -(* A specialized comparison function: we compare the [int] part first. - This way, most of the time, the [dir_path] part is not considered. *) - -let cmp_univ_level u v = match u,v with - | Set, Set -> 0 - | Set, _ -> -1 - | _, Set -> 1 - | Level (dp1,i1), Level (dp2,i2) -> - if i1 < i2 then -1 - else if i1 > i2 then 1 - else compare dp1 dp2 - -let string_of_univ_level = function - | Set -> "Set" - | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n - -module UniverseLMap = - Map.Make (struct type t = universe_level let compare = cmp_univ_level end) +*) type universe = - | Atom of universe_level - | Max of universe_level list * universe_level list + | Atom of UniverseLevel.t + | Max of UniverseLevel.t list * UniverseLevel.t list + +let make_universe_level (m,n) = UniverseLevel.Level (m,n) +let make_universe l = Atom l +let make_univ c = Atom (make_universe_level c) -let make_univ (m,n) = Atom (Level (m,n)) +let universe_level = function + | Atom l -> Some l + | Max _ -> None -let pr_uni_level u = str (string_of_univ_level u) +let pr_uni_level u = str (UniverseLevel.to_string u) let pr_uni = function | Atom u -> @@ -97,7 +113,7 @@ let super = function let sup u v = match u,v with | Atom u, Atom v -> - if cmp_univ_level u v = 0 then Atom u else Max ([u;v],[]) + if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[]) | u, Max ([],[]) -> u | Max ([],[]), v -> v | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl) @@ -109,16 +125,16 @@ let sup u v = (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: universe_level; lt: universe_level list; le: universe_level list } + { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list } let terminal u = {univ=u; lt=[]; le=[]} -(* A universe_level is either an alias for another one, or a canonical one, +(* A UniverseLevel.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc - | Equiv of universe_level + | Equiv of UniverseLevel.t type universes = univ_entry UniverseLMap.t @@ -129,12 +145,6 @@ let enter_equiv_arc u v g = let enter_arc ca g = UniverseLMap.add ca.univ (Canonical ca) g -let declare_univ u g = - if not (UniverseLMap.mem u g) then - enter_arc (terminal u) g - else - g - (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m_univ = Max ([],[]) @@ -144,28 +154,30 @@ let is_type0m_univ = function | _ -> false (* The level of predicative Set *) -let type0_univ = Atom Set +let type0_univ = Atom UniverseLevel.Set let is_type0_univ = function - | Atom Set -> true - | Max ([Set],[]) -> warning "Non canonical Set"; true + | Atom UniverseLevel.Set -> true + | Max ([UniverseLevel.Set], []) -> warning "Non canonical Set"; true | u -> false let is_univ_variable = function - | Atom a when a<>Set -> true + | Atom a when a<>UniverseLevel.Set -> true | _ -> false (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) -let type1_univ = Max ([],[Set]) +let type1_univ = Max ([], [UniverseLevel.Set]) let initial_universes = UniverseLMap.empty +let is_initial_universes = UniverseLMap.is_empty -(* Every universe_level has a unique canonical arc representative *) +(* Every UniverseLevel.t has a unique canonical arc representative *) -(* repr : universes -> universe_level -> canonical_arc *) +(* repr : universes -> UniverseLevel.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) + let repr g u = let rec repr_rec u = let a = @@ -181,6 +193,20 @@ let repr g u = let can g = List.map (repr g) +(* [safe_repr] also search for the canonical representative, but + if the graph doesn't contain the searched universe, we add it. *) + +let safe_repr g u = + let rec safe_repr_rec u = + match UniverseLMap.find u g with + | Equiv v -> safe_repr_rec v + | Canonical arc -> arc + in + try g, safe_repr_rec u + with Not_found -> + let can = terminal u in + enter_arc can g, can + (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) let reprleq g arcu = @@ -196,11 +222,11 @@ let reprleq g arcu = searchrec [] arcu.le -(* between : universe_level -> canonical_arc -> canonical_arc list *) +(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) (* between u v = {w|u<=w<=v, w canonical} *) (* between is the most costly operation *) -let between g u arcv = +let between g arcu arcv = (* good are all w | u <= w <= v *) (* bad are all w | u <= w ~<= v *) (* find good and bad nodes in {w | u <= w} *) @@ -221,7 +247,7 @@ let between g u arcv = else good, arcu::bad, b (* b or false *) in - let good,_,_ = explore ([arcv],[],false) (repr g u) in + let good,_,_ = explore ([arcv],[],false) arcu in good (* We assume compare(u,v) = LE with v canonical (see compare below). @@ -272,9 +298,7 @@ let compare_neq g arcu arcv = in cmp [] [] ([],[arcu]) -let compare g u v = - let arcu = repr g u - and arcv = repr g v in +let compare g arcu arcv = if arcu == arcv then EQ else compare_neq g arcu arcv (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ @@ -286,11 +310,12 @@ let compare g u v = Adding u>v is consistent iff compare(v,u) = NLE and then it is redundant iff compare(u,v) = LT *) -let compare_eq g u v = - let g = declare_univ u g in - let g = declare_univ v g in - repr g u == repr g v +(** * Universe checks [check_eq] and [check_geq], used in coqchk *) +let compare_eq g u v = + let g, arcu = safe_repr g u in + let _, arcv = safe_repr g v in + arcu == arcv type check_function = universes -> universe -> universe -> bool @@ -310,10 +335,10 @@ let rec check_eq g u v = | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *) let compare_greater g strict u v = - let g = declare_univ u g in - let g = declare_univ v g in - if not strict && compare_eq g v Set then true else - match compare g v u with + let g, arcu = safe_repr g u in + let g, arcv = safe_repr g v in + if not strict && arcv == snd (safe_repr g UniverseLevel.Set) then true else + match compare g arcv arcu with | (EQ|LE) -> not strict | LT -> true | NLE -> false @@ -323,44 +348,50 @@ let compare_greater g strict u v = ppnl(str (if b then if strict then ">" else ">=" else "NOT >=")); b *) -let rec check_greater g strict u v = +let check_geq g u v = match u, v with - | Atom ul, Atom vl -> compare_greater g strict ul vl + | Atom ul, Atom vl -> compare_greater g false ul vl | Atom ul, Max(le,lt) -> - List.for_all (fun vl -> compare_greater g strict ul vl) le && + List.for_all (fun vl -> compare_greater g false ul vl) le && List.for_all (fun vl -> compare_greater g true ul vl) lt | _ -> anomaly "check_greater" -let check_geq g = check_greater g false +(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) -(* setlt : universe_level -> universe_level -> unit *) +(* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *) (* forces u > v *) -let setlt g u v = - let arcu = repr g u in - enter_arc {arcu with lt=v::arcu.lt} g +(* this is normally an update of u in g rather than a creation. *) +let setlt g arcu arcv = + let arcu' = {arcu with lt=arcv.univ::arcu.lt} in + enter_arc arcu' g, arcu' (* checks that non-redundant *) -let setlt_if g u v = match compare g u v with - | LT -> g - | _ -> setlt g u v +let setlt_if (g,arcu) v = + let arcv = repr g v in + match compare g arcu arcv with + | LT -> g, arcu + | _ -> setlt g arcu arcv -(* setleq : universe_level -> universe_level -> unit *) +(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* forces u >= v *) -let setleq g u v = - let arcu = repr g u in - enter_arc {arcu with le=v::arcu.le} g +(* this is normally an update of u in g rather than a creation. *) +let setleq g arcu arcv = + let arcu' = {arcu with le=arcv.univ::arcu.le} in + enter_arc arcu' g, arcu' (* checks that non-redundant *) -let setleq_if g u v = match compare g u v with - | NLE -> setleq g u v - | _ -> g +let setleq_if (g,arcu) v = + let arcv = repr g v in + match compare g arcu arcv with + | NLE -> setleq g arcu arcv + | _ -> g, arcu -(* merge : universe_level -> universe_level -> unit *) +(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) -let merge g u v = - match between g u (repr g v) with +let merge g arcu arcv = + match between g arcu arcv with | arcu::v -> (* arcu is chosen as canonical and all others (v) are *) (* redirected to it *) let redirect (g,w,w') arcv = @@ -368,87 +399,84 @@ let merge g u v = (g',list_unionq arcv.lt w,arcv.le@w') in let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in - let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in - g''' + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu w in + let g_arcu = List.fold_left setleq_if g_arcu w' in + fst g_arcu | [] -> anomaly "Univ.between" -(* merge_disc : universe_level -> universe_level -> unit *) +(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) -let merge_disc g u v = - let arcu = repr g u in - let arcv = repr g v in +let merge_disc g arcu arcv = let g' = enter_equiv_arc arcv.univ arcu.univ g in - let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in - let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in - g''' + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in + let g_arcu = List.fold_left setleq_if g_arcu arcv.le in + fst g_arcu (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) -type order_request = Lt | Le | Eq +type constraint_type = Lt | Le | Eq -exception UniverseInconsistency of order_request * universe * universe +exception UniverseInconsistency of constraint_type * universe * universe let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v)) -(* enforce_univ_leq : universe_level -> universe_level -> unit *) +(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - let g = declare_univ u g in - let g = declare_univ v g in - match compare g u v with + let g,arcu = safe_repr g u in + let g,arcv = safe_repr g v in + match compare g arcu arcv with | NLE -> - (match compare g v u with + (match compare g arcv arcu with | LT -> error_inconsistency Le u v - | LE -> merge g v u - | NLE -> setleq g u v + | LE -> merge g arcv arcu + | NLE -> fst (setleq g arcu arcv) | EQ -> anomaly "Univ.compare") | _ -> g -(* enforc_univ_eq : universe_level -> universe_level -> unit *) +(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = - let g = declare_univ u g in - let g = declare_univ v g in - match compare g u v with + let g,arcu = safe_repr g u in + let g,arcv = safe_repr g v in + match compare g arcu arcv with | EQ -> g | LT -> error_inconsistency Eq u v - | LE -> merge g u v + | LE -> merge g arcu arcv | NLE -> - (match compare g v u with + (match compare g arcv arcu with | LT -> error_inconsistency Eq u v - | LE -> merge g v u - | NLE -> merge_disc g u v + | LE -> merge g arcv arcu + | NLE -> merge_disc g arcu arcv | EQ -> anomaly "Univ.compare") (* enforce_univ_lt u v will force u g - | LE -> setlt g u v + | LE -> fst (setlt g arcu arcv) | EQ -> error_inconsistency Lt u v | NLE -> - (match compare g v u with - | NLE -> setlt g u v + (match compare g arcv arcu with + | NLE -> fst (setlt g arcu arcv) | _ -> error_inconsistency Lt u v) (* Constraints and sets of consrtaints. *) -type constraint_type = Lt | Leq | Eq - -type univ_constraint = universe_level * constraint_type * universe_level +type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t let enforce_constraint cst g = match cst with | (u,Lt,v) -> enforce_univ_lt u v g - | (u,Leq,v) -> enforce_univ_leq u v g + | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g - module Constraint = Set.Make( struct type t = univ_constraint @@ -457,11 +485,16 @@ module Constraint = Set.Make( type constraints = Constraint.t +let empty_constraint = Constraint.empty +let is_empty_constraint = Constraint.is_empty + +let union_constraints = Constraint.union + type constraint_function = universe -> universe -> constraints -> constraints let constraint_add_leq v u c = - if v = Set then c else Constraint.add (v,Leq,u) c + if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c let enforce_geq u v c = match u, v with @@ -479,13 +512,207 @@ let enforce_eq u v c = let merge_constraints c g = Constraint.fold enforce_constraint c g +(* Normalization *) + +let lookup_level u g = + try Some (UniverseLMap.find u g) with Not_found -> None + +(** [normalize_universes g] returns a graph where all edges point + directly to the canonical representent of their target. The output + graph should be equivalent to the input graph from a logical point + of view, but optimized. We maintain the invariant that the key of + a [Canonical] element is its own name, by keeping [Equiv] edges + (see the assertion)... I (Stéphane Glondu) am not sure if this + plays a role in the rest of the module. *) +let normalize_universes g = + let rec visit u arc cache = match lookup_level u cache with + | Some x -> x, cache + | None -> match Lazy.force arc with + | None -> + u, UniverseLMap.add u u cache + | Some (Canonical {univ=v; lt=_; le=_}) -> + v, UniverseLMap.add u v cache + | Some (Equiv v) -> + let v, cache = visit v (lazy (lookup_level v g)) cache in + v, UniverseLMap.add u v cache + in + let cache = UniverseLMap.fold + (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) + g UniverseLMap.empty + in + let repr x = UniverseLMap.find x cache in + let lrepr us = List.fold_left + (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us + in + let canonicalize u = function + | Equiv _ -> Equiv (repr u) + | Canonical {univ=v; lt=lt; le=le} -> + assert (u == v); + (* avoid duplicates and self-loops *) + let lt = lrepr lt and le = lrepr le in + let le = UniverseLSet.filter + (fun x -> x != u && not (UniverseLSet.mem x lt)) le + in + UniverseLSet.iter (fun x -> assert (x != u)) lt; + Canonical { + univ = v; + lt = UniverseLSet.elements lt; + le = UniverseLSet.elements le; + } + in + UniverseLMap.mapi canonicalize g + +(** [check_sorted g sorted]: [g] being a universe graph, [sorted] + being a map to levels, checks that all constraints in [g] are + satisfied in [sorted]. *) +let check_sorted g sorted = + let get u = try UniverseLMap.find u sorted with + | Not_found -> assert false + in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with + | Equiv v -> assert (lu = get v) + | Canonical {univ=u'; lt=lt; le=le} -> + assert (u == u'); + List.iter (fun v -> assert (lu <= get v)) le; + List.iter (fun v -> assert (lu < get v)) lt) g + +(** + Bellman-Ford algorithm with a few customizations: + - [weight(eq|le) = 0], [weight(lt) = -1] + - a [le] edge is initially added from [bottom] to all other + vertices, and [bottom] is used as the source vertex +*) +let bellman_ford bottom g = + assert (lookup_level bottom g = None); + let ( << ) a b = match a, b with + | _, None -> true + | None, _ -> false + | Some x, Some y -> x < y + and ( ++ ) a y = match a with + | None -> None + | Some x -> Some (x-y) + and push u x m = match x with + | None -> m + | Some y -> UniverseLMap.add u y m + in + let relax u v uv distances = + let x = lookup_level u distances ++ uv in + if x << lookup_level v distances then push v x distances + else distances + in + let init = UniverseLMap.add bottom 0 UniverseLMap.empty in + let vertices = UniverseLMap.fold (fun u arc res -> + let res = UniverseLSet.add u res in + match arc with + | Equiv e -> UniverseLSet.add e res + | Canonical {univ=univ; lt=lt; le=le} -> + assert (u == univ); + let add res v = UniverseLSet.add v res in + let res = List.fold_left add res le in + let res = List.fold_left add res lt in + res) g UniverseLSet.empty + in + let g = + let node = Canonical { + univ = bottom; + lt = []; + le = UniverseLSet.elements vertices + } in UniverseLMap.add bottom node g + in + let rec iter count accu = + if count <= 0 then + accu + else + let accu = UniverseLMap.fold (fun u arc res -> match arc with + | Equiv e -> relax e u 0 (relax u e 0 res) + | Canonical {univ=univ; lt=lt; le=le} -> + assert (u == univ); + let res = List.fold_left (fun res v -> relax u v 0 res) res le in + let res = List.fold_left (fun res v -> relax u v 1 res) res lt in + res) g accu + in iter (count-1) accu + in + let distances = iter (UniverseLSet.cardinal vertices) init in + let () = UniverseLMap.iter (fun u arc -> + let lu = lookup_level u distances in match arc with + | Equiv v -> + let lv = lookup_level v distances in + assert (not (lu << lv) && not (lv << lu)) + | Canonical {univ=univ; lt=lt; le=le} -> + assert (u == univ); + List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le; + List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g + in distances + +(** [sort_universes g] builds a map from universes in [g] to natural + numbers. It outputs a graph containing equivalence edges from each + level appearing in [g] to [Type.n], and [lt] edges between the + [Type.n]s. The output graph should imply the input graph (and the + implication will be strict most of the time), but is not + necessarily minimal. Note: the result is unspecified if the input + graph already contains [Type.n] nodes (calling a module Type is + probably a bad idea anyway). *) +let sort_universes orig = + let mp = Names.make_dirpath [Names.id_of_string "Type"] in + let rec make_level accu g i = + let type0 = UniverseLevel.Level (mp, i) in + let distances = bellman_ford type0 g in + let accu, continue = UniverseLMap.fold (fun u x (accu, continue) -> + let continue = continue || x < 0 in + let accu = + if x = 0 && u != type0 then UniverseLMap.add u i accu + else accu + in accu, continue) distances (accu, false) + in + let filter x = not (UniverseLMap.mem x accu) in + let push g u = + if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g + in + let g = UniverseLMap.fold (fun u arc res -> match arc with + | Equiv v as x -> + begin match filter u, filter v with + | true, true -> UniverseLMap.add u x res + | true, false -> push res u + | false, true -> push res v + | false, false -> res + end + | Canonical {univ=v; lt=lt; le=le} -> + assert (u == v); + if filter u then + let lt = List.filter filter lt in + let le = List.filter filter le in + UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le}) res + else + let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in + let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in + res) g UniverseLMap.empty + in + if continue then make_level accu g (i+1) else i, accu + in + let max, levels = make_level UniverseLMap.empty orig 0 in + (* defensively check that the result makes sense *) + check_sorted orig levels; + let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in + let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in + let g = + let rec aux i g = + if i < max then + let u = types.(i) in + let g = UniverseLMap.add u (Canonical { + univ = u; + le = []; + lt = [types.(i+1)] + }) g in aux (i+1) g + else g + in aux 0 g + in g + (**********************************************************************) (* Tools for sort-polymorphic inductive types *) (* Temporary inductive type levels *) let fresh_level = - let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n) + let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n) let fresh_local_univ () = Atom (fresh_level ()) @@ -559,16 +786,6 @@ let no_upper_constraints u cst = (* Pretty-printing *) -let num_universes g = - UniverseLMap.fold (fun _ _ -> succ) g 0 - -let num_edges g = - let reln_len = function - | Equiv _ -> 1 - | Canonical {lt=lt;le=le} -> List.length lt + List.length le - in - UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0 - let pr_arc = function | _, Canonical {univ=u; lt=[]; le=[]} -> mt () @@ -590,7 +807,7 @@ let pr_constraints c = Constraint.fold (fun (u1,op,u2) pp_std -> let op_str = match op with | Lt -> " < " - | Leq -> " <= " + | Le -> " <= " | Eq -> " = " in pp_std ++ pr_uni_level u1 ++ str op_str ++ pr_uni_level u2 ++ fnl () ) c (str "") @@ -600,37 +817,40 @@ let pr_constraints c = let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> - let u_str = string_of_univ_level u in - List.iter - (fun v -> - Printf.fprintf output "%s < %s ;\n" u_str - (string_of_univ_level v)) - lt; - List.iter - (fun v -> - Printf.fprintf output "%s <= %s ;\n" u_str - (string_of_univ_level v)) - le + let u_str = UniverseLevel.to_string u in + List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt; + List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le | Equiv v -> - Printf.fprintf output "%s = %s ;\n" - (string_of_univ_level u) (string_of_univ_level v) + output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v) in UniverseLMap.iter dump_arc g (* Hash-consing *) +module Hunivlevel = + Hashcons.Make( + struct + type t = universe_level + type u = Names.dir_path -> Names.dir_path + let hash_sub hdir = function + | UniverseLevel.Set -> UniverseLevel.Set + | UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n) + let equal l1 l2 = match l1,l2 with + | UniverseLevel.Set, UniverseLevel.Set -> true + | UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') -> + n == n' && d == d' + | _ -> false + let hash = Hashtbl.hash + end) + module Huniv = Hashcons.Make( struct type t = universe - type u = Names.dir_path -> Names.dir_path - let hash_aux hdir = function - | Set -> Set - | Level (d,n) -> Level (hdir d,n) + type u = universe_level -> universe_level let hash_sub hdir = function - | Atom u -> Atom (hash_aux hdir u) - | Max (gel,gtl) -> - Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl) + | Atom u -> Atom (hdir u) + | Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl) let equal u v = match u, v with | Atom u, Atom v -> u == v @@ -641,7 +861,33 @@ module Huniv = let hash = Hashtbl.hash end) -let hcons1_univ u = - let _,_,hdir,_,_,_ = Names.hcons_names() in - Hashcons.simple_hcons Huniv.f hdir u +let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath +let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel + +module Hconstraint = + Hashcons.Make( + struct + type t = univ_constraint + type u = universe_level -> universe_level + let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2) + let equal (l1,k,l2) (l1',k',l2') = + l1 == l1' && k = k' && l2 == l2' + let hash = Hashtbl.hash + end) + +module Hconstraints = + Hashcons.Make( + struct + type t = constraints + type u = univ_constraint -> univ_constraint + let hash_sub huc s = + Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty + let equal s s' = + list_for_all2eq (==) + (Constraint.elements s) + (Constraint.elements s') + let hash = Hashtbl.hash + end) +let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel +let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint diff --git a/kernel/univ.mli b/kernel/univ.mli index 4cb6dec1..8b3f6291 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -1,37 +1,43 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 0 *) +module UniverseLSet : Set.S with type elt = universe_level + +(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... + Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) -val type0m_univ : universe (* image of Prop in the universes hierarchy *) -val type0_univ : universe (* image of Set in the universes hierarchy *) -val type1_univ : universe (* the universe of the type of Prop/Set *) +val type0m_univ : universe (** image of Prop in the universes hierarchy *) +val type0_univ : universe (** image of Set in the universes hierarchy *) +val type1_univ : universe (** the universe of the type of Prop/Set *) +val make_universe_level : Names.dir_path * int -> universe_level +val make_universe : universe_level -> universe val make_univ : Names.dir_path * int -> universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool -(* The type of a universe *) +val universe_level : universe -> universe_level option +val compare_levels : universe_level -> universe_level -> int + +(** The type of a universe *) val super : universe -> universe -(* The max of 2 universes *) +(** The max of 2 universes *) val sup : universe -> universe -> universe -(*s Graphs of universes. *) +(** {6 Graphs of universes. } *) type universes @@ -39,32 +45,39 @@ type check_function = universes -> universe -> universe -> bool val check_geq : check_function val check_eq : check_function -(* The empty graph of universes *) +(** The empty graph of universes *) val initial_universes : universes +val is_initial_universes : universes -> bool -(*s Constraints. *) +(** {6 Constraints. } *) -module Constraint : Set.S +type constraints -type constraints = Constraint.t +val empty_constraint : constraints +val union_constraints : constraints -> constraints -> constraints + +val is_empty_constraint : constraints -> bool type constraint_function = universe -> universe -> constraints -> constraints val enforce_geq : constraint_function val enforce_eq : constraint_function -(*s Merge of constraints in a universes graph. +(** {6 ... } *) +(** Merge of constraints in a universes graph. The function [merge_constraints] merges a set of constraints in a given universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) -type order_request = Lt | Le | Eq +type constraint_type = Lt | Le | Eq -exception UniverseInconsistency of order_request * universe * universe +exception UniverseInconsistency of constraint_type * universe * universe val merge_constraints : constraints -> universes -> universes +val normalize_universes : universes -> universes +val sort_universes : universes -> universes -(*s Support for sort-polymorphic inductive types *) +(** {6 Support for sort-polymorphic inductive types } *) val fresh_local_univ : unit -> universe @@ -78,14 +91,21 @@ val subst_large_constraints : val no_upper_constraints : universe -> constraints -> bool -(*s Pretty-printing of universes. *) +(** {6 Pretty-printing of universes. } *) +val pr_uni_level : universe_level -> Pp.std_ppcmds val pr_uni : universe -> Pp.std_ppcmds val pr_universes : universes -> Pp.std_ppcmds val pr_constraints : constraints -> Pp.std_ppcmds -(*s Dumping to a file *) +(** {6 Dumping to a file } *) + +val dump_universes : + (constraint_type -> string -> string -> unit) -> + universes -> unit -val dump_universes : out_channel -> universes -> unit +(** {6 Hash-consing } *) -val hcons1_univ : universe -> universe +val hcons_univlevel : universe_level -> universe_level +val hcons_univ : universe -> universe +val hcons_constraints : constraints -> constraints diff --git a/kernel/vconv.ml b/kernel/vconv.ml index a35d1d88..4d0edc68 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -74,6 +74,8 @@ and conv_whd pb k whd1 whd2 cu = else raise NotConvertible | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom pb k a1 stk1 a2 stk2 cu + | Vfun _, _ | _, Vfun _ -> + conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu | _, Vatom_stk(Aiddef(_,v),stk) -> conv_whd pb k whd1 (force_whd v stk) cu | Vatom_stk(Aiddef(_,v),stk), _ -> @@ -98,7 +100,7 @@ and conv_atom pb k a1 stk1 a2 stk2 cu = conv_stack k stk1 stk2 cu else raise NotConvertible with NotConvertible -> - if oracle_order ik1 ik2 then + if oracle_order false ik1 ik2 then conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu end @@ -219,12 +221,12 @@ and conv_eq_vect vt1 vt2 cu = let vconv pb env t1 t2 = let cu = - try conv_eq pb t1 t2 Constraint.empty + try conv_eq pb t1 t2 empty_constraint with NotConvertible -> infos := create_clos_infos betaiotazeta env; let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in - let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in + let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in cu in cu @@ -234,8 +236,8 @@ let use_vm = ref false let set_use_vm b = use_vm := b; - if b then Reduction.set_default_conv vconv - else Reduction.set_default_conv Reduction.conv_cmp + if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb) + else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb) let use_vm _ = !use_vm diff --git a/kernel/vconv.mli b/kernel/vconv.mli index e23aaf79..2d65170c 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool val set_use_vm : bool -> unit val vconv : conv_pb -> types conversion_function diff --git a/kernel/vm.ml b/kernel/vm.ml index c24de162..86aed5d9 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* assert false + with Not_found -> assert false let check_cofix vcf1 vcf2 = (current_cofix vcf1 = current_cofix vcf2) && @@ -538,13 +536,8 @@ let branch_of_switch k sw = Array.map eval_branch sw.sw_annot.rtbl -(* Evaluation *) - -let is_accu v = - let o = Obj.repr v in - Obj.is_block o && Obj.tag o = accu_tag && - fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag +(* Evaluation *) let rec whd_stack v stk = match stk with @@ -594,6 +587,55 @@ let rec force_whd v stk = | res -> res +let rec eta_stack a stk v = + match stk with + | [] -> apply_vstack a [|v|] + | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v + | Zfix(f,args) :: stk -> + let a,stk = + match stk with + | Zapp args' :: stk -> + push_ra stop; + push_arguments args'; + push_val a; + push_arguments args; + let a = + interprete (fun_code f) (Obj.magic f) (Obj.magic f) + (nargs args+ nargs args') in + a, stk + | _ -> + push_ra stop; + push_val a; + push_arguments args; + let a = + interprete (fun_code f) (Obj.magic f) (Obj.magic f) + (nargs args) in + a, stk in + eta_stack a stk v + | Zswitch sw :: stk -> + eta_stack (apply_switch sw a) stk v + +let eta_whd k whd = + let v = val_of_rel k in + match whd with + | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false + | Vfun f -> body_of_vfun k f + | Vfix(f, None) -> + push_ra stop; + push_val v; + interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0 + | Vfix(f, Some args) -> + push_ra stop; + push_val v; + push_arguments args; + interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) + | Vcofix(_,to_up,_) -> + push_ra stop; + push_val v; + interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 + | Vatom_stk(a,stk) -> + eta_stack (val_of_atom a) stk v - + + diff --git a/kernel/vm.mli b/kernel/vm.mli index 5ecc8d99..58228eb8 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -3,15 +3,18 @@ open Term open Cbytecodes open Cemitcodes +(** Efficient Virtual Machine *) val set_drawinstr : unit -> unit val transp_values : unit -> bool val set_transp_values : bool -> unit -(* le code machine *) + +(** Machine code *) + type tcode -(* Les valeurs ***********) +(** Values *) type vprod type vfun @@ -26,11 +29,11 @@ type atom = | Aiddef of id_key * values | Aind of inductive -(* Les zippers *) +(** Zippers *) type zipper = | Zapp of arguments - | Zfix of vfix*arguments (* Peut-etre vide *) + | Zfix of vfix * arguments (** might be empty *) | Zswitch of vswitch type stack = zipper list @@ -48,6 +51,7 @@ type whd = | Vatom_stk of atom * stack (** Constructors *) + val val_of_str_const : structured_constant -> values val val_of_rel : int -> values @@ -62,45 +66,56 @@ val val_of_constant_def : int -> constant -> values -> values external val_of_annot_switch : annot_switch -> values = "%identity" (** Destructors *) + val whd_val : values -> whd -(* Arguments *) +(** Arguments *) + val nargs : arguments -> int val arg : arguments -> int -> values -(* Product *) +(** Product *) + val dom : vprod -> values val codom : vprod -> vfun -(* Function *) +(** Function *) + val body_of_vfun : int -> vfun -> values val decompose_vfun2 : int -> vfun -> vfun -> int * values * values -(* Fix *) +(** Fix *) + val current_fix : vfix -> int val check_fix : vfix -> vfix -> bool val rec_args : vfix -> int array val reduce_fix : int -> vfix -> vfun array * values array - (* bodies , types *) + (** bodies , types *) + +(** CoFix *) -(* CoFix *) val current_cofix : vcofix -> int val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array - (* bodies , types *) -(* Block *) + (** bodies , types *) + +(** Block *) + val btag : vblock -> int val bsize : vblock -> int val bfield : vblock -> int -> values -(* Switch *) +(** Switch *) + val check_switch : vswitch -> vswitch -> bool val case_info : vswitch -> case_info val type_of_switch : vswitch -> values val branch_of_switch : int -> vswitch -> (int * values) array -(* Evaluation *) +(** Evaluation *) + val whd_stack : values -> stack -> whd val force_whd : values -> stack -> whd +val eta_whd : int -> whd -> values -- cgit v1.2.3