diff options
Diffstat (limited to 'kernel')
100 files changed, 7274 insertions, 7070 deletions
diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index d5feafbf91..be2b05da8d 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -18,6 +18,7 @@ #include <caml/misc.h> #include <caml/mlvalues.h> #include <caml/fail.h> +#include <caml/alloc.h> #include <caml/memory.h> #include "coq_instruct.h" #include "coq_fix_code.h" @@ -78,38 +79,41 @@ void * coq_stat_alloc (asize_t sz) } value coq_makeaccu (value i) { - code_t q; - code_t res = coq_stat_alloc(2 * sizeof(opcode_t)); - q = res; + CAMLparam1(i); + CAMLlocal1(res); + code_t q = coq_stat_alloc(2 * sizeof(opcode_t)); + res = caml_alloc_small(1, Abstract_tag); + Code_val(res) = q; *q++ = VALINSTR(MAKEACCU); *q = (opcode_t)Int_val(i); - return (value)res; + CAMLreturn(res); } value coq_pushpop (value i) { - code_t res; - int n; - n = Int_val(i); + CAMLparam1(i); + CAMLlocal1(res); + code_t q; + res = caml_alloc_small(1, Abstract_tag); + int n = Int_val(i); if (n == 0) { - res = coq_stat_alloc(sizeof(opcode_t)); - *res = VALINSTR(STOP); - return (value)res; + q = coq_stat_alloc(sizeof(opcode_t)); + Code_val(res) = q; + *q = VALINSTR(STOP); + CAMLreturn(res); } else { - code_t q; - res = coq_stat_alloc(3 * sizeof(opcode_t)); - q = res; + q = coq_stat_alloc(3 * sizeof(opcode_t)); + Code_val(res) = q; *q++ = VALINSTR(POP); *q++ = (opcode_t)n; *q = VALINSTR(STOP); - return (value)res; + CAMLreturn(res); } } value coq_is_accumulate_code(value code){ - code_t q; + code_t q = Code_val(code); int res; - q = (code_t)code; res = Is_instruction(q,ACCUMULATE); return Val_bool(res); } @@ -132,11 +136,14 @@ value coq_is_accumulate_code(value code){ #define COPY32(dst,src) (*dst=*src) #endif /* ARCH_BIG_ENDIAN */ -value coq_tcode_of_code (value code, value size) { - code_t p, q, res; - asize_t len = (asize_t) Long_val(size); - res = coq_stat_alloc(len); - q = res; +value coq_tcode_of_code (value code) { + CAMLparam1 (code); + CAMLlocal1 (res); + code_t p, q; + asize_t len = (asize_t) caml_string_length(code); + res = caml_alloc_small(1, Abstract_tag); + q = coq_stat_alloc(len); + Code_val(res) = q; len /= sizeof(opcode_t); for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { opcode_t instr; @@ -166,5 +173,5 @@ value coq_tcode_of_code (value code, value size) { for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } } - return (value)res; + CAMLreturn(res); } diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 5c85389dd5..638d6b5ab5 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -26,7 +26,7 @@ void init_arity(); #define Is_instruction(pc,instr) (*pc == VALINSTR(instr)) -value coq_tcode_of_code(value code, value len); +value coq_tcode_of_code(value code); value coq_makeaccu (value i); value coq_pushpop (value i); value coq_is_accumulate_code(value code); diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index af89712d5e..a944dbb06c 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -16,6 +16,7 @@ #include <stdio.h> #include <signal.h> #include <stdint.h> +#include <caml/memory.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" @@ -163,8 +164,11 @@ extern void caml_process_pending_signals(void); /* The interpreter itself */ value coq_interprete -(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args) +(code_t coq_pc, value coq_accu, value coq_atom_tbl, value coq_global_data, value coq_env, long coq_extra_args) { + /* coq_accu is not allocated on the OCaml heap */ + CAMLparam2(coq_atom_tbl, coq_global_data); + /*Declaration des variables */ #ifdef PC_REG register code_t pc PC_REG; @@ -196,7 +200,7 @@ value coq_interprete coq_instr_table = (char **) coq_jumptable; coq_instr_base = coq_Jumptbl_base; #endif - return Val_unit; + CAMLreturn(Val_unit); } #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) coq_jumptbl_base = coq_Jumptbl_base; @@ -626,7 +630,7 @@ value coq_interprete print_instr("CLOSUREREC"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ - Alloc_small(accu, nfuncs, 0); + Alloc_small(accu, nfuncs, Abstract_tag); for(i = 0; i < nfuncs; i++) { Field(accu,i) = (value)(pc+pc[i]); } @@ -662,7 +666,7 @@ value coq_interprete print_instr("CLOSURECOFIX"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ - Alloc_small(accu, nfunc, 0); + Alloc_small(accu, nfunc, Abstract_tag); for(i = 0; i < nfunc; i++) { Field(accu,i) = (value)(pc+pc[i]); } @@ -1028,7 +1032,7 @@ value coq_interprete CHECK_STACK(nargs+1); sp -= nargs; for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); - *--sp = accu; // Last argument is the pointer to the suspension + *--sp = accu; // Leftmost argument is the pointer to the suspension print_lint(nargs); coq_extra_args = nargs; pc = Code_val(coq_env); // Trigger evaluation @@ -1068,12 +1072,22 @@ value coq_interprete } } *--sp = accu; - /* We create the switch zipper */ - Alloc_small(accu, 5, Default_tag); - Field(accu, 0) = (value)typlbl; Field(accu, 1) = (value)swlbl; - Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; - Field(accu, 4) = coq_env; - sp++;sp[0] = accu; + /* Create bytecode wrappers */ + Alloc_small(accu, 1, Abstract_tag); + Code_val(accu) = typlbl; + *--sp = accu; + Alloc_small(accu, 1, Abstract_tag); + Code_val(accu) = swlbl; + *--sp = accu; + /* We create the switch zipper */ + Alloc_small(accu, 5, Default_tag); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; + Field(accu, 2) = sp[3]; + Field(accu, 3) = sp[2]; + Field(accu, 4) = coq_env; + sp += 3; + sp[0] = accu; /* We create the atom */ Alloc_small(accu, 2, ATOM_SWITCH_TAG); Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; @@ -1460,7 +1474,7 @@ value coq_interprete Instruct(STOP){ print_instr("STOP"); coq_sp = sp; - return accu; + CAMLreturn(accu); } @@ -1473,7 +1487,8 @@ value coq_interprete #endif } -value coq_push_ra(value tcode) { +value coq_push_ra(value code) { + code_t tcode = Code_val(code); print_instr("push_ra"); coq_sp -= 3; coq_sp[0] = (value) tcode; @@ -1512,12 +1527,18 @@ value coq_push_vstack(value stk, value max_stack_size) { return Val_unit; } -value coq_interprete_ml(value tcode, value a, value e, value ea) { +value coq_interprete_ml(value tcode, value a, value t, value g, value e, value ea) { + // Registering the other arguments w.r.t. the OCaml GC is done by coq_interprete + CAMLparam1(tcode); print_instr("coq_interprete"); - return coq_interprete((code_t)tcode, a, e, Long_val(ea)); + CAMLreturn (coq_interprete(Code_val(tcode), a, t, g, e, Long_val(ea))); print_instr("end coq_interprete"); } -value coq_eval_tcode (value tcode, value e) { - return coq_interprete_ml(tcode, Val_unit, e, 0); +value coq_interprete_byte(value* argv, int argn){ + return coq_interprete_ml(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value coq_eval_tcode (value tcode, value t, value g, value e) { + return coq_interprete_ml(tcode, Val_unit, t, g, e, 0); } diff --git a/kernel/byterun/coq_interp.h b/kernel/byterun/coq_interp.h index 60865c32ec..c04e9e00b2 100644 --- a/kernel/byterun/coq_interp.h +++ b/kernel/byterun/coq_interp.h @@ -17,11 +17,10 @@ value coq_push_arguments(value args); value coq_push_vstack(value stk); -value coq_interprete_ml(value tcode, value a, value e, value ea); +value coq_interprete_ml(value tcode, value a, value t, value g, value e, value ea); +value coq_interprete_byte(value* argv, int argn); value coq_interprete - (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args); - -value coq_eval_tcode (value tcode, value e); - + (code_t coq_pc, value coq_accu, value coq_atom_tbl, value coq_global_data, value coq_env, long coq_extra_args); +value coq_eval_tcode (value tcode, value t, value g, value e); diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 45cfae509d..542a05fd25 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -10,6 +10,8 @@ #include <stdio.h> #include <string.h> +#include <caml/alloc.h> +#include <caml/address_class.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" @@ -24,10 +26,6 @@ value * coq_stack_threshold; asize_t coq_max_stack_size = Coq_max_stack_size; /* global_data */ - -value coq_global_data; -value coq_atom_tbl; - int drawinstr; /* interp state */ @@ -50,7 +48,11 @@ value coq_static_alloc(value size) /* ML */ value accumulate_code(value unit) /* ML */ { - return (value) accumulate; + CAMLparam1(unit); + CAMLlocal1(res); + res = caml_alloc_small(1, Abstract_tag); + Code_val(res) = accumulate; + CAMLreturn(res); } static void (*coq_prev_scan_roots_hook) (scanning_action); @@ -58,11 +60,12 @@ static void (*coq_prev_scan_roots_hook) (scanning_action); static void coq_scan_roots(scanning_action action) { register value * i; - /* Scan the global variables */ - (*action)(coq_global_data, &coq_global_data); - (*action)(coq_atom_tbl, &coq_atom_tbl); /* Scan the stack */ for (i = coq_sp; i < coq_stack_high; i++) { +#ifdef NO_NAKED_POINTERS + /* The VM stack may contain C-allocated bytecode */ + if (Is_block(*i) && !Is_in_heap_or_young(*i)) continue; +#endif (*action) (*i, i); }; /* Hook */ @@ -79,24 +82,10 @@ void init_coq_stack() coq_max_stack_size = Coq_max_stack_size; } -void init_coq_global_data(long requested_size) -{ - int i; - coq_global_data = alloc_shr(requested_size, 0); - for (i = 0; i < requested_size; i++) - Field (coq_global_data, i) = Val_unit; -} - -void init_coq_atom_tbl(long requested_size){ - int i; - coq_atom_tbl = alloc_shr(requested_size, 0); - for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit; -} - void init_coq_interpreter() { coq_sp = coq_stack_high; - coq_interprete(NULL, Val_unit, Val_unit, 0); + coq_interprete(NULL, Val_unit, Atom(0), Atom(0), Val_unit, 0); } static int coq_vm_initialized = 0; @@ -112,13 +101,15 @@ value init_coq_vm(value unit) /* ML */ #endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); - init_coq_global_data(Coq_global_data_Size); - init_coq_atom_tbl(40); /* Initialing the interpreter */ init_coq_interpreter(); - /* Some predefined pointer code */ - accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t)); + /* Some predefined pointer code. + * It is typically contained in accumlator blocks whose tag is 0 and thus + * scanned by the GC, so make it look like an OCaml block. */ + value accu_block = (value) coq_stat_alloc(2 * sizeof(value)); + Hd_hp (accu_block) = Make_header (1, Abstract_tag, Caml_black); \ + accumulate = (code_t) Val_hp(accu_block); *accumulate = VALINSTR(ACCUMULATE); /* Initialize GC */ @@ -157,53 +148,6 @@ void realloc_coq_stack(asize_t required_space) #undef shift } -value get_coq_global_data(value unit) /* ML */ -{ - return coq_global_data; -} - -value get_coq_atom_tbl(value unit) /* ML */ -{ - return coq_atom_tbl; -} - -value realloc_coq_global_data(value size) /* ML */ -{ - mlsize_t requested_size, actual_size, i; - value new_global_data; - requested_size = Long_val(size); - actual_size = Wosize_val(coq_global_data); - if (requested_size >= actual_size) { - requested_size = (requested_size + 0x100) & 0xFFFFFF00; - new_global_data = alloc_shr(requested_size, 0); - for (i = 0; i < actual_size; i++) - initialize(&Field(new_global_data, i), Field(coq_global_data, i)); - for (i = actual_size; i < requested_size; i++){ - Field (new_global_data, i) = Val_long (0); - } - coq_global_data = new_global_data; - } - return Val_unit; -} - -value realloc_coq_atom_tbl(value size) /* ML */ -{ - mlsize_t requested_size, actual_size, i; - value new_atom_tbl; - requested_size = Long_val(size); - actual_size = Wosize_val(coq_atom_tbl); - if (requested_size >= actual_size) { - requested_size = (requested_size + 0x100) & 0xFFFFFF00; - new_atom_tbl = alloc_shr(requested_size, 0); - for (i = 0; i < actual_size; i++) - initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i)); - for (i = actual_size; i < requested_size; i++) - Field (new_atom_tbl, i) = Val_long (0); - coq_atom_tbl = new_atom_tbl; - } - return Val_unit; -} - value coq_set_drawinstr(value unit) { drawinstr = 1; diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h index cec34f566c..9375b15de2 100644 --- a/kernel/byterun/coq_memory.h +++ b/kernel/byterun/coq_memory.h @@ -20,7 +20,6 @@ #define Coq_stack_size (4096 * sizeof(value)) #define Coq_stack_threshold (256 * sizeof(value)) -#define Coq_global_data_Size (4096 * sizeof(value)) #define Coq_max_stack_size (256 * 1024) #define TRANSP 0 @@ -34,9 +33,7 @@ extern value * coq_stack_threshold; /* global_data */ -extern value coq_global_data; extern int coq_all_transp; -extern value coq_atom_tbl; extern int drawinstr; /* interp state */ @@ -53,10 +50,6 @@ value init_coq_vm(value unit); /* ML */ value re_init_coq_vm(value unit); /* ML */ void realloc_coq_stack(asize_t required_space); -value get_coq_global_data(value unit); /* ML */ -value realloc_coq_global_data(value size); /* ML */ -value get_coq_atom_tbl(value unit); /* ML */ -value realloc_coq_atom_tbl(value size); /* ML */ value coq_set_transp_value(value transp); /* ML */ value get_coq_transp_value(value unit); /* ML */ #endif /* _COQ_MEMORY_ */ diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c index 528babebfc..e05f3fb82e 100644 --- a/kernel/byterun/coq_values.c +++ b/kernel/byterun/coq_values.c @@ -9,6 +9,7 @@ /***********************************************************************/ #include <stdio.h> +#include <caml/memory.h> #include "coq_fix_code.h" #include "coq_instruct.h" #include "coq_memory.h" @@ -58,10 +59,36 @@ value coq_offset_closure(value v, value offset){ return (value)&Field(v, Int_val(offset)); } +value coq_set_bytecode_field(value v, value i, value code) { + // No write barrier because the bytecode does not live on the OCaml heap + Field(v, Long_val(i)) = (value) Code_val(code); + return Val_unit; +} + value coq_offset_tcode(value code,value offset){ - return((value)((code_t)code + Int_val(offset))); + CAMLparam1(code); + CAMLlocal1(res); + res = caml_alloc_small(1, Abstract_tag); + Code_val(res) = Code_val(code) + Int_val(offset); + CAMLreturn(res); } -value coq_int_tcode(value code, value offset) { +value coq_int_tcode(value pc, value offset) { + code_t code = Code_val(pc); return Val_int(*((code_t) code + Int_val(offset))); } + +value coq_tcode_array(value tcodes) { + CAMLparam1(tcodes); + CAMLlocal2(res, tmp); + int i; + /* Assumes that the vector of types is small. This was implicit in the + previous code which was building the type array using Alloc_small. */ + res = caml_alloc_small(Wosize_val(tcodes), Default_tag); + for (i = 0; i < Wosize_val(tcodes); i++) { + tmp = caml_alloc_small(1, Abstract_tag); + Code_val(tmp) = (code_t) Field(tcodes, i); + Store_field(res, i, tmp); + } + CAMLreturn(res); +} diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 7e193ef829..ac4c6c52c6 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Bruno Barras with Benjamin Werner's account to implement @@ -23,7 +25,7 @@ open CErrors open Util open Pp open Names -open Term +open Constr open Vars open Environ open Esubst @@ -85,15 +87,16 @@ module type RedFlagsSig = sig val fFIX : red_kind val fCOFIX : red_kind val fZETA : red_kind - val fCONST : constant -> red_kind + val fCONST : Constant.t -> red_kind val fVAR : Id.t -> red_kind val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds val red_add_transparent : reds -> transparent_state -> reds + val red_transparent : reds -> transparent_state val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool - val red_projection : reds -> projection -> bool + val red_projection : reds -> Projection.t -> bool end module RedFlags = (struct @@ -114,7 +117,7 @@ module RedFlags = (struct type red_kind = BETA | DELTA | ETA | MATCH | FIX | COFIX | ZETA - | CONST of constant | VAR of Id.t + | CONST of Constant.t | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fETA = ETA @@ -164,6 +167,8 @@ module RedFlags = (struct let (l1,l2) = red.r_const in { red with r_const = Id.Pred.remove id l1, l2 } + let red_transparent red = red.r_const + let red_add_transparent red tr = { red with r_const = tr } @@ -234,7 +239,7 @@ let unfold_red kn = * instantiations (cbv or lazy) are. *) -type table_key = constant puniverses tableKey +type table_key = Constant.t Univ.puniverses tableKey let eq_pconstant_key (c,u) (c',u') = eq_constant_key c c' && Univ.Instance.equal u u' @@ -254,12 +259,14 @@ module KeyTable = Hashtbl.Make(IdKeyHash) let eq_table_key = IdKeyHash.equal +type 'a infos_tab = 'a KeyTable.t + type 'a infos_cache = { - i_repr : 'a infos -> constr -> 'a; + i_repr : 'a infos -> 'a infos_tab -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; - i_rels : constr option array; - i_tab : 'a KeyTable.t } + i_rels : (Constr.rel_declaration * lazy_val) Range.t; +} and 'a infos = { i_flags : reds; @@ -274,26 +281,29 @@ let assoc_defined id env = match Environ.lookup_named id env with | LocalDef (_, c, _) -> c | _ -> raise Not_found -let ref_value_cache ({i_cache = cache} as infos) ref = +let ref_value_cache ({i_cache = cache} as infos) tab ref = try - Some (KeyTable.find cache.i_tab ref) + Some (KeyTable.find tab ref) with Not_found -> try let body = match ref with | RelKey n -> - let len = Array.length cache.i_rels in - let i = n - 1 in - let () = if i < 0 || len <= i then raise Not_found in - begin match Array.unsafe_get cache.i_rels i with - | None -> raise Not_found - | Some t -> lift n t - end + let open Context.Rel.Declaration in + let i = n - 1 in + let (d, _) = + try Range.get cache.i_rels i + with Invalid_argument _ -> raise Not_found + in + begin match d with + | LocalAssum _ -> raise Not_found + | LocalDef (_, t, _) -> lift n t + end | VarKey id -> assoc_defined id cache.i_env | ConstKey cst -> constant_value_in cache.i_env cst in - let v = cache.i_repr infos body in - KeyTable.add cache.i_tab ref v; + let v = cache.i_repr infos tab body in + KeyTable.add tab ref v; Some v with | Not_found (* List.assoc *) @@ -303,27 +313,13 @@ let ref_value_cache ({i_cache = cache} as infos) ref = let evar_value cache ev = cache.i_sigma ev -let defined_rels flags env = -(* if red_local_const (snd flags) then*) - let ctx = rel_context env in - let len = List.length ctx in - let ans = Array.make len None in - let open Context.Rel.Declaration in - let iter i = function - | LocalAssum _ -> () - | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) - in - let () = List.iteri iter ctx in - ans -(* else (0,[])*) - let create mk_cl flgs env evars = let cache = { i_repr = mk_cl; i_env = env; i_sigma = evars; - i_rels = defined_rels flgs env; - i_tab = KeyTable.create 17 } + i_rels = env.env_rel_context.env_rel_map; + } in { i_flags = flgs; i_cache = cache } @@ -367,7 +363,7 @@ and fterm = | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array - | FProj of projection * fconstr + | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) @@ -401,7 +397,7 @@ let update v1 no t = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * constant + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -480,11 +476,12 @@ let rec lft_fconstr n ft = | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false - | _ -> {norm=ft.norm; term=FLIFT(n,ft)} + | FFlex _ | FAtom _ | FCast _ | FApp _ | FProj _ | FCaseT _ | FProd _ + | FLetIn _ | FEvar _ | FCLOS _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = - if Int.equal k 0 then v else CArray.Fun1.map lft_fconstr k v + if Int.equal k 0 then v else Array.Fun1.map lft_fconstr k v let clos_rel e i = match expand_rel i e with @@ -516,7 +513,7 @@ let zupdate m s = else s let mk_lambda env t = - let (rvars,t') = decompose_lam t in + let (rvars,t') = Term.decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = @@ -530,7 +527,7 @@ let destFLambda clos_fun t = (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = - match kind_of_term t with + match kind t with | Rel i -> clos_rel e i | Var x -> { norm = Red; term = FFlex (VarKey x) } | Const c -> { norm = Red; term = FFlex (ConstKey c) } @@ -549,14 +546,14 @@ let mk_clos_vect env v = match v with | [|v0; v1; v2|] -> [|mk_clos env v0; mk_clos env v1; mk_clos env v2|] | [|v0; v1; v2; v3|] -> [|mk_clos env v0; mk_clos env v1; mk_clos env v2; mk_clos env v3|] -| v -> CArray.Fun1.map mk_clos env v +| v -> Array.Fun1.map mk_clos env v (* Translate the head constructor of t from constr to fconstr. This function is parameterized by the function to apply on the direct subterms. Could be used insted of mk_clos. *) let mk_clos_deep clos_fun env t = - match kind_of_term t with + match kind t with | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> mk_clos env t | Cast (a,k,b) -> @@ -564,7 +561,7 @@ let mk_clos_deep clos_fun env t = term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; - term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) } + term = FApp (clos_fun env f, Array.Fun1.map clos_fun env v) } | Proj (p,c) -> { norm = Red; term = FProj (p, clos_fun env c) } @@ -590,78 +587,95 @@ let mk_clos_deep clos_fun env t = let mk_clos2 = mk_clos_deep mk_clos (* The inverse of mk_clos_deep: move back to constr *) -let rec to_constr constr_fun lfts v = +let rec to_constr lfts v = match v.term with | FRel i -> mkRel (reloc_rel i lfts) | FFlex (RelKey p) -> mkRel (reloc_rel p lfts) | FFlex (VarKey x) -> mkVar x | FAtom c -> exliftn lfts c | FCast (a,k,b) -> - mkCast (constr_fun lfts a, k, constr_fun lfts b) + mkCast (to_constr lfts a, k, to_constr lfts b) | FFlex (ConstKey op) -> mkConstU op | FInd op -> mkIndU op | FConstruct op -> mkConstructU op | FCaseT (ci,p,c,ve,env) -> - mkCase (ci, constr_fun lfts (mk_clos env p), - constr_fun lfts c, - Array.map (fun b -> constr_fun lfts (mk_clos env b)) ve) - | FFix ((op,(lna,tys,bds)),e) -> + if is_subs_id env && is_lift_id lfts then + mkCase (ci, p, to_constr lfts c, ve) + else + let subs = comp_subs lfts env in + mkCase (ci, subst_constr subs p, + to_constr lfts c, + Array.map (fun b -> subst_constr subs b) ve) + | FFix ((op,(lna,tys,bds)) as fx, e) -> + if is_subs_id e && is_lift_id lfts then + mkFix fx + else let n = Array.length bds in - let ftys = CArray.Fun1.map mk_clos e tys in - let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in - let lfts' = el_liftn n lfts in - mkFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys, - CArray.Fun1.map constr_fun lfts' fbds)) - | FCoFix ((op,(lna,tys,bds)),e) -> + let subs_ty = comp_subs lfts e in + let subs_bd = comp_subs (el_liftn n lfts) (subs_liftn n e) in + let tys = Array.Fun1.map subst_constr subs_ty tys in + let bds = Array.Fun1.map subst_constr subs_bd bds in + mkFix (op, (lna, tys, bds)) + | FCoFix ((op,(lna,tys,bds)) as cfx, e) -> + if is_subs_id e && is_lift_id lfts then + mkCoFix cfx + else let n = Array.length bds in - let ftys = CArray.Fun1.map mk_clos e tys in - let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in - let lfts' = el_liftn (Array.length bds) lfts in - mkCoFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys, - CArray.Fun1.map constr_fun lfts' fbds)) + let subs_ty = comp_subs lfts e in + let subs_bd = comp_subs (el_liftn n lfts) (subs_liftn n e) in + let tys = Array.Fun1.map subst_constr subs_ty tys in + let bds = Array.Fun1.map subst_constr subs_bd bds in + mkCoFix (op, (lna, tys, bds)) | FApp (f,ve) -> - mkApp (constr_fun lfts f, - CArray.Fun1.map constr_fun lfts ve) + mkApp (to_constr lfts f, + Array.Fun1.map to_constr lfts ve) | FProj (p,c) -> - mkProj (p,constr_fun lfts c) + mkProj (p,to_constr lfts c) - | FLambda _ -> - let (na,ty,bd) = destFLambda mk_clos2 v in - mkLambda (na, constr_fun lfts ty, - constr_fun (el_lift lfts) bd) + | FLambda (len, tys, f, e) -> + if is_subs_id e && is_lift_id lfts then + Term.compose_lam (List.rev tys) f + else + let subs = comp_subs lfts e in + let tys = List.mapi (fun i (na, c) -> na, subst_constr (subs_liftn i subs) c) tys in + let f = subst_constr (subs_liftn len subs) f in + Term.compose_lam (List.rev tys) f | FProd (n,t,c) -> - mkProd (n, constr_fun lfts t, - constr_fun (el_lift lfts) c) + mkProd (n, to_constr lfts t, + to_constr (el_lift lfts) c) | FLetIn (n,b,t,f,e) -> - let fc = mk_clos2 (subs_lift e) f in - mkLetIn (n, constr_fun lfts b, - constr_fun lfts t, - constr_fun (el_lift lfts) fc) + let subs = comp_subs (el_lift lfts) (subs_lift e) in + mkLetIn (n, to_constr lfts b, + to_constr lfts t, + subst_constr subs f) | FEvar ((ev,args),env) -> - mkEvar(ev,Array.map (fun a -> constr_fun lfts (mk_clos2 env a)) args) - | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a + let subs = comp_subs lfts env in + mkEvar(ev,Array.map (fun a -> subst_constr subs a) args) + | FLIFT (k,a) -> to_constr (el_shft k lfts) a | FCLOS (t,env) -> - let fr = mk_clos2 env t in - let unfv = update v fr.norm fr.term in - to_constr constr_fun lfts unfv + if is_subs_id env && is_lift_id lfts then t + else + let subs = comp_subs lfts env in + subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) +and subst_constr subst c = match Constr.kind c with +| Rel i -> + begin match expand_rel i subst with + | Inl (k, lazy v) -> Vars.lift k v + | Inr (m, _) -> mkRel m + end +| _ -> + Constr.map_with_binders Esubst.subs_lift subst_constr subst c + +and comp_subs el s = + Esubst.lift_subst (fun el c -> lazy (to_constr el c)) el s + (* This function defines the correspondance between constr and fconstr. When we find a closure whose substitution is the identity, then we directly return the constr to avoid possibly huge reallocation. *) -let term_of_fconstr = - let rec term_of_fconstr_lift lfts v = - match v.term with - | FCLOS(t,env) when is_subs_id env && is_lift_id lfts -> t - | FLambda(_,tys,f,e) when is_subs_id e && is_lift_id lfts -> - compose_lam (List.rev tys) f - | 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 el_id - - +let term_of_fconstr c = to_constr el_id c (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a @@ -677,8 +691,8 @@ let rec zip m stk = | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s - | Zproj (i,j,cst) :: s -> - zip {norm=neutr m.norm; term=FProj(Projection.make cst true,m)} s + | Zproj p :: s -> + zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> @@ -802,25 +816,30 @@ let drop_parameters depth n argstk = s. @assumes [t] is an irreducible term, and not a constructor. [ind] is the inductive of the constructor term [c] - @raises Not_found if the inductive is not a primitive record, or if the + @raise Not_found if the inductive is not a primitive record, or if the constructor is partially applied. *) let eta_expand_ind_stack env ind m s (f, s') = + let open Declarations in let mib = lookup_mind (fst ind) env in - match mib.Declarations.mind_record with - | Some (Some (_,projs,pbs)) when - mib.Declarations.mind_finite == Decl_kinds.BiFinite -> - (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> + (* disallow eta-exp for non-primitive records *) + if not (mib.mind_finite == BiFinite) then raise Not_found; + match Declareops.inductive_make_projections ind mib with + | Some projs -> + (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) - let pars = mib.Declarations.mind_nparams in - let right = fapp_stack (f, s') in - let (depth, args, s) = strip_update_shift_app m s in - (** Try to drop the params, might fail on partially applied constructors. *) - let argss = try_drop_parameters depth pars args in - let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) - term = FProj (Projection.make p true, right) }) projs in - argss, [Zapp hstack] - | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) + let pars = mib.Declarations.mind_nparams in + let right = fapp_stack (f, s') in + let (depth, args, s) = strip_update_shift_app m s in + (** Try to drop the params, might fail on partially applied constructors. *) + let argss = try_drop_parameters depth pars args in + let hstack = Array.map (fun p -> + { norm = Red; (* right can't be a constructor though *) + term = FProj (Projection.make p true, right) }) + projs + in + argss, [Zapp hstack] + | None -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with @@ -856,6 +875,12 @@ let contract_fix_vect fix = in (subs_cons(Array.init nfix make_body, env), thisbody) +let unfold_projection info p = + if red_projection info.i_flags p + then + Some (Zproj (Projection.repr p)) + else None + (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, @@ -874,15 +899,9 @@ let rec knh info m stk = | (None, stk') -> (m,stk')) | FCast(t,_,_) -> knh info t stk | FProj (p,c) -> - let unf = Projection.unfolded p in - if unf || red_set info.i_flags (fCONST (Projection.constant p)) then - (match try Some (lookup_projection p (info_env info)) with Not_found -> None with - | None -> (m, stk) - | Some pb -> - knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - Projection.constant p) - :: zupdate m stk)) - else (m,stk) + (match unfold_projection info p with + | None -> (m, stk) + | Some s -> knh info c (s :: zupdate m stk)) (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| @@ -891,7 +910,7 @@ let rec knh info m stk = (* The same for pure terms *) and knht info e t stk = - match kind_of_term t with + match kind t with | App(a,b) -> knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> @@ -908,23 +927,23 @@ and knht info e t stk = (************************************************************************) (* Computes a weak head normal form from the result of knh. *) -let rec knr info m stk = +let rec knr info tab m stk = match m.term with | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with - Inl e', s -> knit info e' f s + Inl e', s -> knit info tab e' f s | Inr lam, s -> (lam,s)) | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> - (match ref_value_cache info (ConstKey c) with - Some v -> kni info v stk + (match ref_value_cache info tab (ConstKey c) with + Some v -> kni info tab v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> - (match ref_value_cache info (VarKey id) with - Some v -> kni info v stk + (match ref_value_cache info tab (VarKey id) with + Some v -> kni info tab v stk | None -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> - (match ref_value_cache info (RelKey k) with - Some v -> kni info v stk + (match ref_value_cache info tab (RelKey k) with + Some v -> kni info tab v stk | None -> (set_norm m; (m,stk))) | FConstruct((ind,c),u) -> let use_match = red_set info.i_flags fMATCH in @@ -934,41 +953,44 @@ let rec knr info m stk = | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in - knit info e br.(c-1) (rargs@s) + knit info tab e br.(c-1) (rargs@s) | (_, cargs, Zfix(fx,par)::s) when use_fix -> let rarg = fapp_stack(m,cargs) in let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in - knit info fxe fxbd stk' - | (depth, args, Zproj (n, m, cst)::s) when use_match -> - let rargs = drop_parameters depth n args in - let rarg = project_nth_arg m rargs in - kni info rarg s + knit info tab fxe fxbd stk' + | (depth, args, Zproj p::s) when use_match -> + let rargs = drop_parameters depth (Projection.Repr.npars p) args in + let rarg = project_nth_arg (Projection.Repr.arg p) rargs in + kni info tab rarg s | (_,args,s) -> (m,args@s)) else (m,stk) | FCoFix _ when red_set info.i_flags fCOFIX -> (match strip_update_shift_app m stk with (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in - knit info fxe fxbd (args@stk') + knit info tab fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> - knit info (subs_cons([|v|],e)) bd stk + knit info tab (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> (match evar_value info.i_cache ev with - Some c -> knit info env c stk + Some c -> knit info tab env c stk | None -> (m,stk)) - | _ -> (m,stk) + | FLOCKED | FRel _ | FAtom _ | FCast _ | FFlex _ | FInd _ | FApp _ | FProj _ + | FFix _ | FCoFix _ | FCaseT _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ + | FCLOS _ -> (m, stk) + (* Computes the weak head normal form of a term *) -and kni info m stk = +and kni info tab m stk = let (hm,s) = knh info m stk in - knr info hm s -and knit info e t stk = + knr info tab hm s +and knit info tab e t stk = let (ht,s) = knht info e t stk in - knr info ht s + knr info tab ht s -let kh info v stk = fapp_stack(kni info v stk) +let kh info tab v stk = fapp_stack(kni info tab v stk) (************************************************************************) @@ -981,7 +1003,7 @@ let rec zip_term zfun m stk = let t = mkCase(ci, zfun (mk_clos e p), m, Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s - | Zproj(_,_,p)::s -> + | Zproj p::s -> let t = mkProj (Projection.make p true, m) in zip_term zfun t s | Zfix(fx,par)::s -> @@ -996,60 +1018,66 @@ let rec zip_term zfun m stk = 1- Calls kni 2- tries to rebuild the term. If a closure still has to be computed, calls itself recursively. *) -let rec kl info m = +let rec kl info tab m = if is_val m then (incr prune; term_of_fconstr m) else - let (nm,s) = kni info m [] in + let (nm,s) = kni info tab m [] in let () = if !share then ignore (fapp_stack (nm, s)) in (* to unlock Zupdates! *) - zip_term (kl info) (norm_head info nm) s + zip_term (kl info tab) (norm_head info tab nm) s (* no redex: go up for atoms and already normalized terms, go down otherwise. *) -and norm_head info m = +and norm_head info tab m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with | FLambda(n,tys,f,e) -> let (e',rvtys) = List.fold_left (fun (e,ctxt) (na,ty) -> - (subs_lift e, (na,kl info (mk_clos e ty))::ctxt)) + (subs_lift e, (na,kl info tab (mk_clos e ty))::ctxt)) (e,[]) tys in - let bd = kl info (mk_clos e' f) in + let bd = kl info tab (mk_clos e' f) in List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in - mkLetIn(na, kl info a, kl info b, kl info c) + mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) | FProd(na,dom,rng) -> - mkProd(na, kl info dom, kl info rng) + mkProd(na, kl info tab dom, kl info tab rng) | FCoFix((n,(na,tys,bds)),e) -> - let ftys = CArray.Fun1.map mk_clos e tys in + let ftys = Array.Fun1.map mk_clos e tys in let fbds = - CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in - mkCoFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) + Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in + mkCoFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FFix((n,(na,tys,bds)),e) -> - let ftys = CArray.Fun1.map mk_clos e tys in + let ftys = Array.Fun1.map mk_clos e tys in let fbds = - CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in - mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) + Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in + mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FEvar((i,args),env) -> - mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) + mkEvar(i, Array.map (fun a -> kl info tab (mk_clos env a)) args) | FProj (p,c) -> - mkProj (p, kl info c) - | t -> term_of_fconstr m + mkProj (p, kl info tab c) + | FLOCKED | FRel _ | FAtom _ | FCast _ | FFlex _ | FInd _ | FConstruct _ + | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ -> term_of_fconstr m (* Initialization and then normalization *) (* weak reduction *) -let whd_val info v = - with_stats (lazy (term_of_fconstr (kh info v []))) +let whd_val info tab v = + with_stats (lazy (term_of_fconstr (kh info tab v []))) (* strong reduction *) -let norm_val info v = - with_stats (lazy (kl info v)) +let norm_val info tab v = + with_stats (lazy (kl info tab v)) let inject c = mk_clos (subs_id 0) c -let whd_stack infos m stk = - let k = kni infos m stk in +let whd_stack infos tab m stk = match m.norm with +| Whnf | Norm -> + (** No need to perform [kni] nor to unlock updates because + every head subterm of [m] is [Whnf] or [Norm] *) + knh infos m stk +| Red | Cstr -> + let k = kni infos tab m stk in let () = if !share then ignore (fapp_stack k) in (* to unlock Zupdates! *) k @@ -1057,7 +1085,10 @@ let whd_stack infos m stk = type clos_infos = fconstr infos let create_clos_infos ?(evars=fun _ -> None) flgs env = - create (fun _ -> inject) flgs env evars + create (fun _ _ c -> inject c) flgs env evars + +let create_tab () = KeyTable.create 17 + let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env let env_of_infos infos = infos.i_cache.i_env @@ -1065,14 +1096,14 @@ let env_of_infos infos = infos.i_cache.i_env let infos_with_reds infos reds = { infos with i_flags = reds } -let unfold_reference info key = +let unfold_reference info tab key = match key with | ConstKey (kn,_) -> if red_set info.i_flags (fCONST kn) then - ref_value_cache info key + ref_value_cache info tab key else None | VarKey i -> if red_set info.i_flags (fVAR i) then - ref_value_cache info key + ref_value_cache info tab key else None - | _ -> ref_value_cache info key + | _ -> ref_value_cache info tab key diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 9e5cb48a49..1e3e7b48ac 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Environ open Esubst @@ -29,7 +31,7 @@ val all_opaque : transparent_state val all_transparent : transparent_state val is_transparent_variable : transparent_state -> variable -> bool -val is_transparent_constant : transparent_state -> constant -> bool +val is_transparent_constant : transparent_state -> Constant.t -> bool (** Sets of reduction kinds. *) module type RedFlagsSig = sig @@ -46,7 +48,7 @@ module type RedFlagsSig = sig val fFIX : red_kind val fCOFIX : red_kind val fZETA : red_kind - val fCONST : constant -> red_kind + val fCONST : Constant.t -> red_kind val fVAR : Id.t -> red_kind (** No reduction at all *) @@ -61,6 +63,9 @@ module type RedFlagsSig = sig (** Adds a reduction kind to a set *) val red_add_transparent : reds -> transparent_state -> reds + (** Retrieve the transparent state of the reduction flags *) + val red_transparent : reds -> transparent_state + (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds @@ -69,7 +74,7 @@ module type RedFlagsSig = sig (** This tests if the projection is in unfolded state already or is unfodable due to delta. *) - val red_projection : reds -> projection -> bool + val red_projection : reds -> Projection.t -> bool end module RedFlags : RedFlagsSig @@ -92,16 +97,18 @@ val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) -type table_key = constant puniverses tableKey +type table_key = Constant.t Univ.puniverses tableKey type 'a infos_cache +type 'a infos_tab type 'a infos = { i_flags : reds; i_cache : 'a infos_cache } -val ref_value_cache: 'a infos -> table_key -> 'a option -val create: ('a infos -> constr -> 'a) -> reds -> env -> +val ref_value_cache: 'a infos -> 'a infos_tab -> table_key -> 'a option +val create: ('a infos -> 'a infos_tab -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos +val create_tab : unit -> 'a infos_tab val evar_value : 'a infos_cache -> existential -> constr option val info_env : 'a infos -> env @@ -122,10 +129,10 @@ type fterm = | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive puniverses - | FConstruct of constructor puniverses + | FInd of inductive Univ.puniverses + | FConstruct of constructor Univ.puniverses | FApp of fconstr * fconstr array - | FProj of projection * fconstr + | FProj of Projection.t * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) @@ -145,7 +152,7 @@ type fterm = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * constant + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -163,6 +170,7 @@ 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 +val unfold_projection : 'a infos -> Projection.t -> stack_member option (** To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use @@ -194,15 +202,15 @@ val infos_with_reds : clos_infos -> reds -> clos_infos (** Reduction function *) (** [norm_val] is for strong normalization *) -val norm_val : clos_infos -> fconstr -> constr +val norm_val : clos_infos -> fconstr infos_tab -> fconstr -> constr (** [whd_val] is for weak head normalization *) -val whd_val : clos_infos -> fconstr -> constr +val whd_val : clos_infos -> fconstr infos_tab -> fconstr -> constr (** [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 + clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack (** [eta_expand_ind_stack env ind c s t] computes stacks correspoding to the conversion of the eta expansion of t, considered as an inhabitant @@ -210,7 +218,7 @@ val whd_stack : s. @assumes [t] is a rigid term, and not a constructor. [ind] is the inductive of the constructor term [c] - @raises Not_found if the inductive is not a primitive record, or if the + @raise Not_found if the inductive is not a primitive record, or if the constructor is partially applied. *) val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> @@ -219,7 +227,7 @@ val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) -val unfold_reference : clos_infos -> table_key -> fconstr option +val unfold_reference : clos_infos -> fconstr infos_tab -> table_key -> fconstr option val eq_table_key : table_key -> table_key -> bool @@ -231,14 +239,11 @@ val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array -val mk_clos_deep : - (fconstr subs -> constr -> fconstr) -> - fconstr subs -> constr -> fconstr -val kni: clos_infos -> fconstr -> stack -> fconstr * stack -val knr: clos_infos -> fconstr -> stack -> fconstr * stack -val kl : clos_infos -> fconstr -> constr +val kni: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack +val knr: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack +val kl : clos_infos -> fconstr infos_tab -> fconstr -> constr -val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr +val to_constr : lift -> fconstr -> constr (** End of cbn debug section i*) diff --git a/kernel/primitives.ml b/kernel/cPrimitives.ml index 14c11bf107..5b91a9b572 100644 --- a/kernel/primitives.ml +++ b/kernel/cPrimitives.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) type t = diff --git a/kernel/primitives.mli b/kernel/cPrimitives.mli index 8cdffb6702..1e99a69d2f 100644 --- a/kernel/primitives.mli +++ b/kernel/cPrimitives.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) type t = diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 25f61c7aa9..9a1224aab2 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Bruno Barras for Benjamin Grégoire as part of the @@ -13,7 +15,7 @@ (* This file defines the type of bytecode instructions *) open Names -open Term +open Constr type tag = int @@ -32,19 +34,60 @@ let cofix_evaluated_tag = 7 let last_variant_tag = 245 type structured_constant = - | Const_sorts of sorts + | Const_sort of Sorts.t | Const_ind of inductive - | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array - | Const_univ_level of Univ.universe_level - | Const_type of Univ.universe + | Const_univ_level of Univ.Level.t type reloc_table = (tag * int) array type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} +let rec eq_structured_constant c1 c2 = match c1, c2 with +| Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2 +| Const_sort _, _ -> false +| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 +| Const_ind _, _ -> false +| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 +| Const_b0 _, _ -> false +| Const_bn (t1, a1), Const_bn (t2, a2) -> + Int.equal t1 t2 && CArray.equal eq_structured_constant a1 a2 +| Const_bn _, _ -> false +| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 +| Const_univ_level _ , _ -> false + +let rec hash_structured_constant c = + let open Hashset.Combine in + match c with + | Const_sort s -> combinesmall 1 (Sorts.hash s) + | Const_ind i -> combinesmall 2 (ind_hash i) + | Const_b0 t -> combinesmall 3 (Int.hash t) + | Const_bn (t, a) -> + let fold h c = combine h (hash_structured_constant c) in + let h = Array.fold_left fold 0 a in + combinesmall 4 (combine (Int.hash t) h) + | Const_univ_level l -> combinesmall 5 (Univ.Level.hash l) + +let eq_annot_switch asw1 asw2 = + let eq_ci ci1 ci2 = + eq_ind ci1.ci_ind ci2.ci_ind && + Int.equal ci1.ci_npar ci2.ci_npar && + CArray.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls + in + let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in + eq_ci asw1.ci asw2.ci && + CArray.equal eq_rlc asw1.rtbl asw2.rtbl && + (asw1.tailcall : bool) == asw2.tailcall + +let hash_annot_switch asw = + let open Hashset.Combine in + let h1 = Constr.case_info_hash asw.ci in + let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in + let h3 = if asw.tailcall then 1 else 0 in + combine3 h1 h2 h3 + module Label = struct type t = int @@ -74,7 +117,7 @@ type instruction = | Kclosurerec of int * int * Label.t array * Label.t array | Kclosurecofix of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) - | Kgetglobal of constant + | Kgetglobal of Constant.t | Kconst of structured_constant | Kmakeblock of int * tag | Kmakeprod @@ -85,8 +128,7 @@ type instruction = | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes - | Kproj of int * Constant.t (* index of the projected argument, - name of projection *) + | Kproj of Projection.Repr.t | Kensurestackcapacity of int (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) @@ -135,6 +177,7 @@ type fv_elem = | FVnamed of Id.t | FVrel of int | FVuniv_var of int + | FVevar of Evar.t type fv = fv_elem array @@ -149,12 +192,15 @@ type t = fv_elem let compare e1 e2 = match e1, e2 with | FVnamed id1, FVnamed id2 -> Id.compare id1 id2 -| FVnamed _, _ -> -1 +| FVnamed _, (FVrel _ | FVuniv_var _ | FVevar _) -> -1 | FVrel _, FVnamed _ -> 1 | FVrel r1, FVrel r2 -> Int.compare r1 r2 -| FVrel _, FVuniv_var _ -> -1 +| FVrel _, (FVuniv_var _ | FVevar _) -> -1 | FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 -| FVuniv_var i1, _ -> 1 +| FVuniv_var i1, (FVnamed _ | FVrel _) -> 1 +| FVuniv_var i1, FVevar _ -> -1 +| FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1 +| FVevar e1, FVevar e2 -> Evar.compare e1 e2 end @@ -170,6 +216,7 @@ type vm_env = { type comp_env = { + arity : int; (* arity of the current function, 0 if none *) nb_uni_stack : int ; (* number of universes on the stack, *) (* universes are always at the bottom. *) nb_stack : int; (* number of variables on the stack *) @@ -186,20 +233,19 @@ open Pp open Util let pp_sort s = - match family_of_sort s with - | InSet -> str "Set" - | InProp -> str "Prop" - | InType -> str "Type" + let open Sorts in + match s with + | Prop -> str "Prop" + | Set -> str "Set" + | Type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}" let rec pp_struct_const = function - | Const_sorts s -> pp_sort s - | Const_ind (mind, i) -> pr_mind mind ++ str"#" ++ int i - | Const_proj p -> Constant.print p + | Const_sort s -> pp_sort s + | Const_ind (mind, i) -> MutInd.print mind ++ str"#" ++ int i | Const_b0 i -> int i | Const_bn (i,t) -> int i ++ surround (prvect_with_sep pr_comma pp_struct_const t) | Const_univ_level l -> Univ.Level.pr l - | Const_type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}" let pp_lbl lbl = str "L" ++ int lbl @@ -207,6 +253,7 @@ let pp_fv_elem = function | FVnamed id -> str "FVnamed(" ++ Id.print id ++ str ")" | FVrel i -> str "Rel(" ++ int i ++ str ")" | FVuniv_var v -> str "FVuniv(" ++ int v ++ str ")" + | FVevar e -> str "FVevar(" ++ int (Evar.repr e) ++ str ")" let rec pp_instr i = match i with @@ -241,7 +288,7 @@ let rec pp_instr i = prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ str " bodies = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) - | Kgetglobal idu -> str "getglobal " ++ pr_con idu + | Kgetglobal idu -> str "getglobal " ++ Constant.print idu | Kconst sc -> str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> @@ -257,13 +304,13 @@ let rec pp_instr i = prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kpushfields n -> str "pushfields " ++ int n | Kfield n -> str "field " ++ int n - | Ksetfield n -> str "set field" ++ int n + | Ksetfield n -> str "setfield " ++ int n | Kstop -> str "stop" | Kbranch lbl -> str "branch " ++ pp_lbl lbl - | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p + | Kproj p -> str "proj " ++ Projection.Repr.print p | Kensurestackcapacity size -> str "growstack " ++ int size @@ -300,16 +347,3 @@ and pp_bytecodes c = pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c | i :: c -> pp_instr i ++ fnl () ++ pp_bytecodes c - -(*spiwack: moved this type in this file because I needed it for - retroknowledge which can't depend from cbytegen *) -type block = - | Bconstr of constr - | Bstrconst of structured_constant - | Bmakeblock of int * block array - | Bconstruct_app of int * int * int * block array - (* tag , nparams, arity *) - | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array - (* spiwack: compilation given by a function *) - (* compilation function (see get_vm_constant_dynamic_info in - retroknowledge.mli for more info) , argument array *) diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 8f38e9d34e..f17a1e657e 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -1,15 +1,17 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* $Id$ *) open Names -open Term +open Constr type tag = int @@ -26,21 +28,25 @@ val cofix_evaluated_tag : tag val last_variant_tag : tag type structured_constant = - | Const_sorts of sorts + | Const_sort of Sorts.t | Const_ind of inductive - | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array - | Const_univ_level of Univ.universe_level - | Const_type of Univ.universe + | Const_univ_level of Univ.Level.t -val pp_struct_const : structured_constant -> Pp.std_ppcmds +val pp_struct_const : structured_constant -> Pp.t type reloc_table = (tag * int) array type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} +val eq_structured_constant : structured_constant -> structured_constant -> bool +val hash_structured_constant : structured_constant -> int + +val eq_annot_switch : annot_switch -> annot_switch -> bool +val hash_annot_switch : annot_switch -> int + module Label : sig type t = int @@ -69,7 +75,7 @@ type instruction = (** nb fv, init, lbl types, lbl bodies *) | Kclosurecofix of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) - | Kgetglobal of constant + | Kgetglobal of Constant.t | Kconst of structured_constant | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from @@ -82,8 +88,7 @@ type instruction = | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop | Ksequence of bytecodes * bytecodes - | Kproj of int * Constant.t (** index of the projected argument, - name of projection *) + | Kproj of Projection.Repr.t | Kensurestackcapacity of int (** spiwack: instructions concerning integers *) @@ -132,6 +137,7 @@ type fv_elem = FVnamed of Id.t | FVrel of int | FVuniv_var of int +| FVevar of Evar.t type fv = fv_elem array @@ -152,6 +158,7 @@ type vm_env = { type comp_env = { + arity : int; (* arity of the current function, 0 if none *) nb_uni_stack : int ; (** number of universes on the stack *) nb_stack : int; (** number of variables on the stack *) in_stack : int list; (** position in the stack *) @@ -163,16 +170,5 @@ type comp_env = { in_env : vm_env ref (** the variables that are accessed *) } -val pp_bytecodes : bytecodes -> Pp.std_ppcmds -val pp_fv_elem : fv_elem -> Pp.std_ppcmds - -(*spiwack: moved this here because I needed it for retroknowledge *) -type block = - | Bconstr of constr - | Bstrconst of structured_constant - | Bmakeblock of int * block array - | Bconstruct_app of int * int * int * block array - (** tag , nparams, arity *) - | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array - (** compilation function (see get_vm_constant_dynamic_info in - retroknowledge.mli for more info) , argument array *) +val pp_bytecodes : bytecodes -> Pp.t +val pp_fv_elem : fv_elem -> Pp.t diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index d63fcffa2c..e336ea922d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction @@ -14,9 +16,11 @@ open Util open Names open Cbytecodes open Cemitcodes -open Term +open Cinstr +open Clambda +open Constr open Declarations -open Pre_env +open Environ (* Compilation of variables + computing free variables *) @@ -73,6 +77,7 @@ open Pre_env (* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) (* If such a block is matched against, we have to force evaluation, *) (* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *) +(* (note that [ai'] is a pointer to the closure, passed as argument) *) (* Once evaluation is completed [ai'] is updated with the result: *) (* ai' <-- *) (* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) @@ -96,7 +101,7 @@ module Config = struct let stack_safety_margin = 15 end -type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t +type argument = ArgLambda of lambda | ArgUniv of Univ.Level.t let empty_fv = { size= 0; fv_rev = []; fv_fwd = FvMap.empty } let push_fv d e = { @@ -107,8 +112,9 @@ let push_fv d e = { let fv r = !(r.in_env) -let empty_comp_env ?(univs=0) ()= - { nb_uni_stack = univs; +let empty_comp_env ()= + { arity = 0; + nb_uni_stack = 0; nb_stack = 0; in_stack = []; nb_rec = 0; @@ -143,7 +149,8 @@ let rec add_param n sz l = if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l) let comp_env_fun ?(univs=0) arity = - { nb_uni_stack = univs ; + { arity; + nb_uni_stack = univs ; nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; @@ -154,7 +161,8 @@ let comp_env_fun ?(univs=0) arity = let comp_env_fix_type rfv = - { nb_uni_stack = 0; + { arity = 0; + nb_uni_stack = 0; nb_stack = 0; in_stack = []; nb_rec = 0; @@ -168,7 +176,8 @@ let comp_env_fix ndef curr_pos arity rfv = for i = ndef downto 1 do prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; - { nb_uni_stack = 0; + { arity; + nb_uni_stack = 0; nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; @@ -178,7 +187,8 @@ let comp_env_fix ndef curr_pos arity rfv = } let comp_env_cofix_type ndef rfv = - { nb_uni_stack = 0; + { arity = 0; + nb_uni_stack = 0; nb_stack = 0; in_stack = []; nb_rec = 0; @@ -192,7 +202,8 @@ let comp_env_cofix ndef arity rfv = for i = 1 to ndef do prec := Kenvacc i :: !prec done; - { nb_uni_stack = 0; + { arity; + nb_uni_stack = 0; nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; @@ -244,8 +255,15 @@ let pos_rel i r sz = Kenvacc(r.offset + pos) let pos_universe_var i r sz = - if i < r.nb_uni_stack then - Kacc (sz - r.nb_stack - (r.nb_uni_stack - i)) + (* Compilation of a universe variable can happen either at toplevel (the + current closure correspond to a constant and has local universes) or in a + local closure (which has no local universes). *) + if r.nb_uni_stack != 0 then + (* Universe variables are represented by De Bruijn levels (not indices), + starting at 0. The shape of the stack will be [v1|..|vn|u1..up|arg1..argq] + with size = n + p + q, and q = r.arity. So Kacc (sz - r.arity - 1) will access + the last universe. *) + Kacc (sz - r.arity - (r.nb_uni_stack - i)) else let env = !(r.in_env) in let db = FVuniv_var i in @@ -255,6 +273,15 @@ let pos_universe_var i r sz = r.in_env := push_fv db env; Kenvacc(r.offset + pos) +let pos_evar evk r = + let env = !(r.in_env) in + let cid = FVevar evk in + try Kenvacc(r.offset + find_at cid env) + with Not_found -> + let pos = env.size in + r.in_env := push_fv cid env; + Kenvacc (r.offset + pos) + (*i Examination of the continuation *) (* Discard all instructions up to the next label. *) @@ -356,13 +383,6 @@ let cont_cofix arity = Kreturn (arity+2) ] -(*i Global environment *) - -let global_env = ref empty_env - -let set_global_env env = global_env := env - - (* Code of closures *) let fun_code = ref [] @@ -370,31 +390,8 @@ let init_fun_code () = fun_code := [] (* Compilation of constructors and inductive types *) - -(* Limitation due to OCaml's representation of non-constant - constructors: limited to 245 + 1 (0 tag) cases. *) - -exception TooLargeInductive of Id.t - -let max_nb_const = 0x1000000 -let max_nb_block = 0x1000000 + last_variant_tag - 1 - -let str_max_constructors = - Format.sprintf - " which has more than %i constant constructors or more than %i non-constant constructors" max_nb_const max_nb_block - -let check_compilable ib = - - if not (ib.mind_nb_args <= max_nb_block && ib.mind_nb_constant <= max_nb_const) then - raise (TooLargeInductive ib.mind_typename) - (* Inv: arity > 0 *) -let const_bn tag args = - if tag < last_variant_tag then Const_bn(tag, args) - else - Const_bn(last_variant_tag, Array.append [|Const_b0 (tag - last_variant_tag) |] args) - (* If [tag] hits the OCaml limitation for non constant constructors, we switch to another representation for the remaining constructors: @@ -415,170 +412,55 @@ let code_makeblock ~stack_size ~arity ~tag cont = Kpush :: nest_block tag arity cont end -(* [code_construct] compiles an abstracted constructor dropping parameters and - updates [fun_code] *) -(* Inv : nparam + arity > 0 *) -let code_construct tag nparams arity cont = - let f_cont = - add_pop nparams - (if Int.equal arity 0 then - [Kconst (Const_b0 tag); Kreturn 0] - else if tag < last_variant_tag then - [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0] - else - nest_block tag arity [Kreturn 0]) - in - let lbl = Label.create() in - (* No need to grow the stack here, as the function does not push stuff. *) - fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; - Kclosure(lbl,0) :: cont - -let get_strcst = function - | Bstrconst sc -> sc - | _ -> raise Not_found - -let rec str_const c = - match kind_of_term c with - | Sort s -> Bstrconst (Const_sorts s) - | Cast(c,_,_) -> str_const c - | App(f,args) -> - begin - match kind_of_term f with - | Construct(((kn,j),i),u) -> - begin - let oib = lookup_mind kn !global_env in - let oip = oib.mind_packets.(j) in - let () = check_compilable oip in - let tag,arity = oip.mind_reloc_tbl.(i-1) in - let nparams = oib.mind_nparams in - if Int.equal (nparams + arity) (Array.length args) then - (* spiwack: *) - (* 1/ tries to compile the constructor in an optimal way, - it is supposed to work only if the arguments are - all fully constructed, fails with Cbytecodes.NotClosed. - it can also raise Not_found when there is no special - treatment for this constructor - for instance: tries to to compile an integer of the - form I31 D1 D2 ... D31 to [D1D2...D31] as - a processor number (a caml number actually) *) - try - try - Bstrconst (Retroknowledge.get_vm_constant_static_info - (!global_env).retroknowledge - f args) - with NotClosed -> - (* 2/ if the arguments are not all closed (this is - expectingly (and it is currently the case) the only - reason why this exception is raised) tries to - give a clever, run-time behavior to the constructor. - Raises Not_found if there is no special treatment - for this integer. - this is done in a lazy fashion, using the constructor - Bspecial because it needs to know the continuation - and such, which can't be done at this time. - for instance, for int31: if one of the digit is - not closed, it's not impossible that the number - gets fully instanciated at run-time, thus to ensure - uniqueness of the representation in the vm - it is necessary to try and build a caml integer - during the execution *) - let rargs = Array.sub args nparams arity in - let b_args = Array.map str_const rargs in - Bspecial ((Retroknowledge.get_vm_constant_dynamic_info - (!global_env).retroknowledge - f), - b_args) - with Not_found -> - (* 3/ if no special behavior is available, then the compiler - falls back to the normal behavior *) - if Int.equal arity 0 then Bstrconst(Const_b0 tag) - else - let rargs = Array.sub args nparams arity in - let b_args = Array.map str_const rargs in - try - let sc_args = Array.map get_strcst b_args in - Bstrconst(const_bn tag sc_args) - with Not_found -> - Bmakeblock(tag,b_args) - else - let b_args = Array.map str_const args in - (* spiwack: tries first to apply the run-time compilation - behavior of the constructor, as in 2/ above *) - try - Bspecial ((Retroknowledge.get_vm_constant_dynamic_info - (!global_env).retroknowledge - f), - b_args) - with Not_found -> - Bconstruct_app(tag, nparams, arity, b_args) - end - | _ -> Bconstr c - end - | Ind (ind,u) when Univ.Instance.is_empty u -> - Bstrconst (Const_ind ind) - | Construct (((kn,j),i),_) -> - begin - (* spiwack: tries first to apply the run-time compilation - behavior of the constructor, as in 2/ above *) - try - Bspecial ((Retroknowledge.get_vm_constant_dynamic_info - (!global_env).retroknowledge - c), - [| |]) - with Not_found -> - let oib = lookup_mind kn !global_env in - let oip = oib.mind_packets.(j) in - let () = check_compilable oip in - let num,arity = oip.mind_reloc_tbl.(i-1) in - let nparams = oib.mind_nparams in - if Int.equal (nparams + arity) 0 then Bstrconst(Const_b0 num) - else Bconstruct_app(num,nparams,arity,[||]) - end - | _ -> Bconstr c +let compile_structured_constant cenv sc sz cont = + set_max_stack_size sz; + Kconst sc :: cont (* compiling application *) -let comp_args comp_expr reloc args sz cont = +let comp_args comp_expr cenv args sz cont = let nargs_m_1 = Array.length args - 1 in - let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in + let c = ref (comp_expr cenv args.(0) (sz + nargs_m_1) cont) in for i = 1 to nargs_m_1 do - c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) + c := comp_expr cenv args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) done; !c -(* Precondition: args not empty *) -let comp_app comp_fun comp_arg reloc f args sz cont = +let comp_app comp_fun comp_arg cenv f args sz cont = let nargs = Array.length args in + if Int.equal nargs 0 then comp_fun cenv f sz cont + else match is_tailcall cont with | Some k -> - comp_args comp_arg reloc args sz + comp_args comp_arg cenv args sz (Kpush :: - comp_fun reloc f (sz + nargs) + comp_fun cenv f (sz + nargs) (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> if nargs < 4 then - comp_args comp_arg reloc args sz - (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) + comp_args comp_arg cenv args sz + (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: - (comp_args comp_arg reloc args (sz + 3) - (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) + (comp_args comp_arg cenv args (sz + 3) + (Kpush :: (comp_fun cenv f (sz+3+nargs) (Kapply nargs :: cont1)))) (* Compiling free variables *) -let compile_fv_elem reloc fv sz cont = +let compile_fv_elem cenv fv sz cont = match fv with - | FVrel i -> pos_rel i reloc sz :: cont - | FVnamed id -> pos_named id reloc :: cont - | FVuniv_var i -> pos_universe_var i reloc sz :: cont + | FVrel i -> pos_rel i cenv sz :: cont + | FVnamed id -> pos_named id cenv :: cont + | FVuniv_var i -> pos_universe_var i cenv sz :: cont + | FVevar evk -> pos_evar evk cenv :: cont -let rec compile_fv reloc l sz cont = +let rec compile_fv cenv l sz cont = match l with | [] -> cont - | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont + | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem cenv fvn sz cont | fvn :: tl -> - compile_fv_elem reloc fvn sz - (Kpush :: compile_fv reloc tl (sz + 1) cont) + compile_fv_elem cenv fvn sz + (Kpush :: compile_fv cenv tl (sz + 1) cont) (* Compiling constants *) @@ -593,112 +475,111 @@ let rec get_alias env kn = | BCalias kn' -> get_alias env kn' | _ -> kn) +(* spiwack: additional function which allow different part of compilation of the + 31-bit integers *) + +let make_areconst n else_lbl cont = + if n <= 0 then + cont + else + Kareconst (n, else_lbl)::cont + (* sz is the size of the local stack *) -let rec compile_constr reloc c sz cont = +let rec compile_lam env cenv lam sz cont = set_max_stack_size sz; - match kind_of_term c with - | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" - | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" - | Proj (p,c) -> - let kn = Projection.constant p in - let cb = lookup_constant kn !global_env in - let pb = Option.get cb.const_proj in - let n = pb.proj_arg in - compile_constr reloc c sz (Kproj (n,kn) :: cont) - - | Cast(c,_,_) -> compile_constr reloc c sz cont - - | Rel i -> pos_rel i reloc sz :: cont - | Var id -> pos_named id reloc :: cont - | Const (kn,u) -> compile_const reloc kn u [||] sz cont - | Ind (ind,u) -> - let bcst = Bstrconst (Const_ind ind) in + match lam with + | Lrel(_, i) -> pos_rel i cenv sz :: cont + + | Lval v -> compile_structured_constant cenv v sz cont + + | Lproj (p,arg) -> + compile_lam env cenv arg sz (Kproj p :: cont) + + | Lvar id -> pos_named id cenv :: cont + + | Levar (evk, args) -> + if Array.is_empty args then + compile_fv_elem cenv (FVevar evk) sz cont + else + (** Arguments are reversed in evar instances *) + let args = Array.copy args in + let () = Array.rev args in + comp_app compile_fv_elem (compile_lam env) cenv (FVevar evk) args sz cont + + | Lconst (kn,u) -> compile_constant env cenv kn u [||] sz cont + + | Lind (ind,u) -> if Univ.Instance.is_empty u then - compile_str_cst reloc bcst sz cont + compile_structured_constant cenv (Const_ind ind) sz cont + else comp_app compile_structured_constant compile_universe cenv + (Const_ind ind) (Univ.Instance.to_array u) sz cont + + | Lsort (Sorts.Prop | Sorts.Set as s) -> + compile_structured_constant cenv (Const_sort s) sz cont + | Lsort (Sorts.Type u) -> + (* We represent universes as a global constant with local universes + "compacted", i.e. as [u arg0 ... argn] where we will substitute (after + evaluation) [Var 0,...,Var n] with values of [arg0,...,argn] *) + let u,s = Univ.compact_univ u in + let compile_get_univ cenv idx sz cont = + set_max_stack_size sz; + compile_fv_elem cenv (FVuniv_var idx) sz cont + in + if List.is_empty s then + compile_structured_constant cenv (Const_sort (Sorts.Type u)) sz cont else - comp_app compile_str_cst compile_universe reloc - bcst - (Univ.Instance.to_array u) - sz - cont - | Sort (Prop _) | Construct _ -> - compile_str_cst reloc (str_const c) sz cont - | Sort (Type u) -> - (* We separate global and local universes in [u]. The former will be part - of the structured constant, while the later (if any) will be applied as - arguments. *) - let open Univ in begin - let levels = Universe.levels u in - let global_levels = - LSet.filter (fun x -> Level.var_index x = None) levels - in - let local_levels = - List.map_filter (fun x -> Level.var_index x) - (LSet.elements levels) - in - (* We assume that [Universe.type0m] is a neutral element for [Universe.sup] *) - let uglob = - LSet.fold (fun lvl u -> Universe.sup u (Universe.make lvl)) global_levels Universe.type0m - in - if local_levels = [] then - compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont - else - let compile_get_univ reloc idx sz cont = - set_max_stack_size sz; - compile_fv_elem reloc (FVuniv_var idx) sz cont - in - comp_app compile_str_cst compile_get_univ reloc - (Bstrconst (Const_type u)) (Array.of_list local_levels) sz cont + comp_app compile_structured_constant compile_get_univ cenv + (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont + + | Llet (id,def,body) -> + compile_lam env cenv def sz + (Kpush :: + compile_lam env (push_local sz cenv) body (sz+1) (add_pop 1 cont)) + + | Lprod (dom,codom) -> + let cont1 = + Kpush :: compile_lam env cenv dom (sz+1) (Kmakeprod :: cont) in + compile_lam env cenv codom sz cont1 + + | Llam (ids,body) -> + let arity = Array.length ids in + let r_fun = comp_env_fun arity in + let lbl_fun = Label.create() in + let cont_fun = + ensure_stack_capacity (compile_lam env r_fun body arity) [Kreturn arity] + in + fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; + let fv = fv r_fun in + compile_fv cenv fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) + + | Lapp (f, args) -> + begin match f with + | Lconst (kn,u) -> compile_constant env cenv kn u args sz cont + | _ -> comp_app (compile_lam env) (compile_lam env) cenv f args sz cont end - | LetIn(_,xb,_,body) -> - compile_constr reloc xb sz - (Kpush :: - (compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont))) - | Prod(id,dom,codom) -> - let cont1 = - Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in - compile_constr reloc (mkLambda(id,dom,codom)) sz cont1 - | Lambda _ -> - let params, body = decompose_lam c in - let arity = List.length params in - let r_fun = comp_env_fun arity in - let lbl_fun = Label.create() in - let cont_fun = - ensure_stack_capacity (compile_constr r_fun body arity) [Kreturn arity] - in - fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; - let fv = fv r_fun in - compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) - - | App(f,args) -> - begin - match kind_of_term f with - | Construct _ -> compile_str_cst reloc (str_const c) sz cont - | Const (kn,u) -> compile_const reloc kn u args sz cont - | _ -> comp_app compile_constr compile_constr reloc f args sz cont - end - | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> - let ndef = Array.length type_bodies in + + | Lfix ((rec_args, init), (decl, types, bodies)) -> + let ndef = Array.length types in let rfv = ref empty_fv in let lbl_types = Array.make ndef Label.no in let lbl_bodies = Array.make ndef Label.no in - (* Compilation des types *) + (* Compiling types *) let env_type = comp_env_fix_type rfv in for i = 0 to ndef - 1 do let fcode = - ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] + ensure_stack_capacity (compile_lam env env_type types.(i) 0) [Kstop] in - let lbl,fcode = label_code fcode in - lbl_types.(i) <- lbl; + let lbl,fcode = label_code fcode in + lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do - let params,body = decompose_lam rec_bodies.(i) in - let arity = List.length params in + let params,body = decompose_Llam bodies.(i) in + let arity = Array.length params in let env_body = comp_env_fix ndef i arity rfv in - let cont1 = - ensure_stack_capacity (compile_constr env_body body arity) [Kreturn arity] + let cont1 = + ensure_stack_capacity (compile_lam env env_body body arity) [Kreturn arity] in let lbl = Label.create () in lbl_bodies.(i) <- lbl; @@ -706,11 +587,12 @@ let rec compile_constr reloc c sz cont = fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in - compile_fv reloc fv.fv_rev sz + compile_fv cenv fv.fv_rev sz (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) - | CoFix(init,(_,type_bodies,rec_bodies)) -> - let ndef = Array.length type_bodies in + + | Lcofix(init, (decl,types,bodies)) -> + let ndef = Array.length types in let lbl_types = Array.make ndef Label.no in let lbl_bodies = Array.make ndef Label.no in (* Compiling types *) @@ -718,22 +600,22 @@ let rec compile_constr reloc c sz cont = let env_type = comp_env_cofix_type ndef rfv in for i = 0 to ndef - 1 do let fcode = - ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] + ensure_stack_capacity (compile_lam env env_type types.(i) 0) [Kstop] in - let lbl,fcode = label_code fcode in - lbl_types.(i) <- lbl; + let lbl,fcode = label_code fcode in + lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do - let params,body = decompose_lam rec_bodies.(i) in - let arity = List.length params in + let params,body = decompose_Llam bodies.(i) in + let arity = Array.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in let comp arity = (* 4 stack slots are needed to update the cofix when forced *) set_max_stack_size (arity + 4); - compile_constr env_body body (arity+1) (cont_cofix arity) + compile_lam env env_body body (arity+1) (cont_cofix arity) in let cont = ensure_stack_capacity comp arity in lbl_bodies.(i) <- lbl; @@ -741,36 +623,37 @@ let rec compile_constr reloc c sz cont = done; let fv = !rfv in set_max_stack_size (sz + fv.size + ndef + 2); - compile_fv reloc fv.fv_rev sz + compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) - | Case(ci,t,a,branchs) -> + + | Lcase(ci,rtbl,t,a,branches) -> let ind = ci.ci_ind in - let mib = lookup_mind (fst ind) !global_env in + let mib = lookup_mind (fst ind) env in let oib = mib.mind_packets.(snd ind) in - let () = check_compilable oib in - let tbl = oib.mind_reloc_tbl in let lbl_consts = Array.make oib.mind_nb_constant Label.no in let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *) + let nconst = Array.length branches.constant_branches in let nblock = min nallblock (last_variant_tag + 1) in let lbl_blocks = Array.make nblock Label.no in let neblock = max 0 (nallblock - last_variant_tag) in let lbl_eblocks = Array.make neblock Label.no in - let branch1,cont = make_branch cont in - (* Compiling return type *) + let branch1, cont = make_branch cont in + (* Compilation of the return type *) let fcode = - ensure_stack_capacity (compile_constr reloc t sz) [Kpop sz; Kstop] + ensure_stack_capacity (compile_lam env cenv t sz) [Kpop sz; Kstop] in let lbl_typ,fcode = label_code fcode in fun_code := [Ksequence(fcode,!fun_code)]; - (* Compiling branches *) + (* Compilation of the branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = - match branch1 with - | Kreturn k -> - assert (Int.equal k sz) ; - sz, branch1, true - | _ -> sz+3, Kjump, false + match branch1 with + | Kreturn k -> + assert (Int.equal k sz) ; + sz, branch1, true + | Kbranch _ -> sz+3, Kjump, false + | _ -> assert false in let c = ref cont in @@ -781,29 +664,26 @@ let rec compile_constr reloc c sz cont = Kpush :: Kfield 0 :: Kswitch(lbl_eblocks, [||]) :: !c) in lbl_blocks.(last_variant_tag) <- lbl_b; c := code_b - end; - - (* Compiling regular constructor branches *) - for i = 0 to Array.length tbl - 1 do - let tag, arity = tbl.(i) in - if Int.equal arity 0 then - let lbl_b,code_b = - label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in - lbl_consts.(tag) <- lbl_b; - c := code_b - else - let args, body = decompose_lam branchs.(i) in - let nargs = List.length args in - - let code_b = - if Int.equal nargs arity then - compile_constr (push_param arity sz_b reloc) - body (sz_b+arity) (add_pop arity (branch :: !c)) - else - let sz_appterm = if is_tailcall then sz_b + arity else arity in - compile_constr reloc branchs.(i) (sz_b+arity) - (Kappterm(arity,sz_appterm) :: !c) in - let code_b = + end; + + (* Compilation of constant branches *) + for i = nconst - 1 downto 0 do + let aux = + compile_lam env cenv branches.constant_branches.(i) sz_b (branch::!c) + in + let lbl_b,code_b = label_code aux in + lbl_consts.(i) <- lbl_b; + c := code_b + done; + (* -1 for accu branch *) + for i = nallblock - 2 downto 0 do + let tag = i + 1 in + let (ids, body) = branches.nonconstant_branches.(i) in + let arity = Array.length ids in + let code_b = + compile_lam env (push_param arity sz_b cenv) + body (sz_b+arity) (add_pop arity (branch::!c)) in + let code_b = if tag < last_variant_tag then begin set_max_stack_size (sz_b + arity); Kpushfields arity :: code_b @@ -812,15 +692,15 @@ let rec compile_constr reloc c sz cont = set_max_stack_size (sz_b + arity + 1); Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b end - in - let lbl_b,code_b = label_code code_b in - if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b + in + let lbl_b, code_b = label_code code_b in + if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b else lbl_eblocks.(tag - last_variant_tag) <- lbl_b; - c := code_b + c := code_b done; let annot = - {ci = ci; rtbl = tbl; tailcall = is_tailcall; + {ci = ci; rtbl = rtbl; tailcall = is_tailcall; max_stack_size = !max_stack_size - sz} in @@ -839,82 +719,120 @@ let rec compile_constr reloc c sz cont = | Kbranch lbl -> Kpush_retaddr lbl :: !c | _ -> !c in - compile_constr reloc a sz - (try - let entry = mkInd ind in - Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge - entry code_sw - with Not_found -> - code_sw) - -and compile_str_cst reloc sc sz cont = - set_max_stack_size sz; - match sc with - | Bconstr c -> compile_constr reloc c sz cont - | Bstrconst sc -> Kconst sc :: cont - | Bmakeblock(tag,args) -> - let arity = Array.length args in - let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in - comp_args compile_str_cst reloc args sz cont - | Bconstruct_app(tag,nparams,arity,args) -> - if Int.equal (Array.length args) 0 then - code_construct tag nparams arity cont - else - comp_app - (fun _ _ _ cont -> code_construct tag nparams arity cont) - compile_str_cst reloc () args sz cont - | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont + compile_lam env cenv a sz code_sw + + | Lmakeblock (tag,args) -> + let arity = Array.length args in + let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in + comp_args (compile_lam env) cenv args sz cont + + | Lprim (kn, ar, op, args) -> + op_compilation env ar op kn cenv args sz cont + + | Luint v -> + (match v with + | UintVal i -> compile_structured_constant cenv (Const_b0 (Uint31.to_int i)) sz cont + | UintDigits ds -> + let nargs = Array.length ds in + if Int.equal nargs 31 then + let (escape,labeled_cont) = make_branch cont in + let else_lbl = Label.create() in + comp_args (compile_lam env) cenv ds sz + ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) + else + let code_construct cont = (* spiwack: variant of the global code_construct + which handles dynamic compilation of + integers *) + let f_cont = + let else_lbl = Label.create () in + [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); + Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] + in + let lbl = Label.create() in + fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; + Kclosure(lbl,0) :: cont + in + comp_app (fun _ _ _ cont -> code_construct cont) + (compile_lam env) cenv () ds sz cont + | UintDecomp t -> + let escape_lbl, labeled_cont = label_code cont in + compile_lam env cenv t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont)) (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) -and compile_get_global reloc (kn,u) sz cont = +and compile_get_global cenv (kn,u) sz cont = set_max_stack_size sz; - let kn = get_alias !global_env kn in if Univ.Instance.is_empty u then Kgetglobal kn :: cont else comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) - compile_universe reloc () (Univ.Instance.to_array u) sz cont + compile_universe cenv () (Univ.Instance.to_array u) sz cont -and compile_universe reloc uni sz cont = +and compile_universe cenv uni sz cont = set_max_stack_size sz; match Univ.Level.var_index uni with - | None -> Kconst (Const_univ_level uni) :: cont - | Some idx -> pos_universe_var idx reloc sz :: cont + | None -> compile_structured_constant cenv (Const_univ_level uni) sz cont + | Some idx -> pos_universe_var idx cenv sz :: cont -and compile_const reloc kn u args sz cont = +and compile_constant env cenv kn u args sz cont = set_max_stack_size sz; + if Univ.Instance.is_empty u then + (* normal compilation *) + comp_app (fun _ _ sz cont -> + compile_get_global cenv (kn,u) sz cont) + (compile_lam env) cenv () args sz cont + else + let compile_arg cenv constr_or_uni sz cont = + match constr_or_uni with + | ArgLambda t -> compile_lam env cenv t sz cont + | ArgUniv uni -> compile_universe cenv uni sz cont + in + let u = Univ.Instance.to_array u in + let lu = Array.length u in + let all = + Array.init (lu + Array.length args) + (fun i -> if i < lu then ArgUniv u.(i) else ArgLambda args.(i-lu)) + in + comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) + compile_arg cenv () all sz cont + +(*template for n-ary operation, invariant: n>=1, + the operations does the following : + 1/ checks if all the arguments are constants (i.e. non-block values) + 2/ if they are, uses the "op" instruction to execute + 3/ if at least one is not, branches to the normal behavior: + Kgetglobal (get_alias !global_env kn) *) +and op_compilation env n op = + let code_construct cenv kn sz cont = + let f_cont = + let else_lbl = Label.create () in + Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: + op:: Kreturn 0:: Klabel else_lbl:: + (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) + compile_get_global cenv kn sz ( + Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) + in + let lbl = Label.create () in + fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; + Kclosure(lbl, 0)::cont + in + fun kn cenv args sz cont -> let nargs = Array.length args in - (* spiwack: checks if there is a specific way to compile the constant - if there is not, Not_found is raised, and the function - falls back on its normal behavior *) - try - Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge - (mkConstU (kn,u)) reloc args sz cont - with Not_found -> - if Int.equal nargs 0 then - compile_get_global reloc (kn,u) sz cont - else - if Univ.Instance.is_empty u then - (* normal compilation *) - comp_app (fun _ _ sz cont -> - compile_get_global reloc (kn,u) sz cont) - compile_constr reloc () args sz cont - else - let compile_arg reloc constr_or_uni sz cont = - match constr_or_uni with - | ArgConstr cst -> compile_constr reloc cst sz cont - | ArgUniv uni -> compile_universe reloc uni sz cont - in - let u = Univ.Instance.to_array u in - let lu = Array.length u in - let all = - Array.init (lu + Array.length args) - (fun i -> if i < lu then ArgUniv u.(i) else ArgConstr args.(i-lu)) - in - comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) - compile_arg reloc () all sz cont + if Int.equal nargs n then (*if it is a fully applied addition*) + let (escape, labeled_cont) = make_branch cont in + let else_lbl = Label.create () in + assert (n < 4); + comp_args (compile_lam env) cenv args sz + (Kisconst else_lbl::(make_areconst (n-1) else_lbl + (*Kaddint31::escape::Klabel else_lbl::Kpush::*) + (op::escape::Klabel else_lbl::Kpush:: + (* works as comp_app with nargs < 4 and non-tailcall cont*) + compile_get_global cenv kn (sz+n) (Kapply n::labeled_cont)))) + else + comp_app (fun cenv _ sz cont -> code_construct cenv kn sz cont) + (compile_lam env) cenv () args sz cont + let is_univ_copy max u = let u = Univ.Instance.to_array u in @@ -928,6 +846,8 @@ let is_univ_copy max u = else false +let dump_bytecode = ref false + let dump_bytecodes init code fvs = let open Pp in (str "code =" ++ fnl () ++ @@ -937,56 +857,49 @@ let dump_bytecodes init code fvs = prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ fnl ()) -let compile fail_on_error ?universes:(universes=0) env c = - set_global_env env; +let compile ~fail_on_error ?universes:(universes=0) env c = init_fun_code (); Label.reset_label_counter (); let cont = [Kstop] in try - let reloc, init_code = + let cenv, init_code = if Int.equal universes 0 then - let reloc = empty_comp_env () in - reloc, ensure_stack_capacity (compile_constr reloc c 0) cont + let lam = lambda_of_constr ~optimize:true env c in + let cenv = empty_comp_env () in + cenv, ensure_stack_capacity (compile_lam env cenv lam 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. *) - let reloc = empty_comp_env () in - let arity , body = - match kind_of_term c with - | Lambda _ -> - let params, body = decompose_lam c in - List.length params , body - | _ -> 0 , c - in + let lam = lambda_of_constr ~optimize:true env c in + let params, body = decompose_Llam lam in + let arity = Array.length params in + let cenv = empty_comp_env () in let full_arity = arity + universes in let r_fun = comp_env_fun ~univs:universes arity in let lbl_fun = Label.create () in let cont_fun = - ensure_stack_capacity (compile_constr r_fun body full_arity) + ensure_stack_capacity (compile_lam env r_fun body full_arity) [Kreturn full_arity] in fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in let init_code = - ensure_stack_capacity (compile_fv reloc fv.fv_rev 0) + ensure_stack_capacity (compile_fv cenv fv.fv_rev 0) (Kclosure(lbl_fun,fv.size) :: cont) in - reloc, init_code + cenv, init_code in - let fv = List.rev (!(reloc.in_env).fv_rev) in - (if !Flags.dump_bytecode then + let fv = List.rev (!(cenv.in_env).fv_rev) in + (if !dump_bytecode then Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) - with TooLargeInductive tname -> + with TooLargeInductive msg -> let fn = if fail_on_error then CErrors.user_err ?loc:None ~hdr:"compile" else - (fun x -> Feedback.msg_warning x) in - (Pp.(fn - (str "Cannot compile code for virtual machine as it uses inductive " ++ - Id.print tname ++ str str_max_constructors)); - None) + (fun x -> Feedback.msg_warning x) in + fn msg; None -let compile_constant_body fail_on_error env univs = function +let compile_constant_body ~fail_on_error env univs = function | Undef _ | OpaqueDef _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in @@ -995,70 +908,18 @@ let compile_constant_body fail_on_error env univs = function | Monomorphic_const _ -> 0 | Polymorphic_const univ -> Univ.AUContext.size univ in - match kind_of_term body with + match kind body with | Const (kn',u) when is_univ_copy instance_size u -> (* we use the canonical name of the constant*) - let con= constant_of_kn (canonical_con kn') in + let con= Constant.make1 (Constant.canonical kn') in Some (BCalias (get_alias env con)) | _ -> - let res = compile fail_on_error ~universes:instance_size env body in + let res = compile ~fail_on_error ~universes:instance_size env body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) -let compile_alias kn = BCalias (constant_of_kn (canonical_con kn)) - -(* spiwack: additional function which allow different part of compilation of the - 31-bit integers *) - -let make_areconst n else_lbl cont = - if n <= 0 then - cont - else - Kareconst (n, else_lbl)::cont - - -(* try to compile int31 as a const_b0. Succeed if all the arguments are closed - fails otherwise by raising NotClosed*) -let compile_structured_int31 fc args = - if not fc then raise Not_found else - Const_b0 - (Array.fold_left - (fun temp_i -> fun t -> match kind_of_term t with - | Construct ((_,d),_) -> 2*temp_i+d-1 - | _ -> raise NotClosed) - 0 args - ) - -(* this function is used for the compilation of the constructor of - the int31, it is used when it appears not fully applied, or - applied to at least one non-closed digit *) -let dynamic_int31_compilation fc reloc args sz cont = - if not fc then raise Not_found else - let nargs = Array.length args in - if Int.equal nargs 31 then - let (escape,labeled_cont) = make_branch cont in - let else_lbl = Label.create() in - comp_args compile_str_cst reloc args sz - ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) - else - let code_construct cont = (* spiwack: variant of the global code_construct - which handles dynamic compilation of - integers *) - let f_cont = - let else_lbl = Label.create () in - [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); - Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] - in - let lbl = Label.create() in - fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; - Kclosure(lbl,0) :: cont - in - if Int.equal nargs 0 then - code_construct cont - else - comp_app (fun _ _ _ cont -> code_construct cont) - compile_str_cst reloc () args sz cont +let compile_alias kn = BCalias (Constant.make1 (Constant.canonical kn)) (*(* template compilation for 2ary operation, it probably possible to make a generic such function with arity abstracted *) @@ -1077,13 +938,13 @@ let op2_compilation op = fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in - fun normal fc _ reloc args sz cont -> + fun normal fc _ cenv args sz cont -> if not fc then raise Not_found else let nargs = Array.length args in if nargs=2 then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in - comp_args compile_constr reloc args sz + comp_args compile_constr cenv args sz (Kisconst else_lbl::(make_areconst 1 else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: @@ -1095,49 +956,5 @@ let op2_compilation op = code_construct normal cont else comp_app (fun _ _ _ cont -> code_construct normal cont) - compile_constr reloc () args sz cont *) + compile_constr cenv () args sz cont *) -(*template for n-ary operation, invariant: n>=1, - the operations does the following : - 1/ checks if all the arguments are constants (i.e. non-block values) - 2/ if they are, uses the "op" instruction to execute - 3/ if at least one is not, branches to the normal behavior: - Kgetglobal (get_alias !global_env kn) *) -let op_compilation n op = - let code_construct reloc kn sz cont = - let f_cont = - let else_lbl = Label.create () in - Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: - op:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) - compile_get_global reloc kn sz ( - Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in - fun kn fc reloc args sz cont -> - if not fc then raise Not_found else - let nargs = Array.length args in - if Int.equal nargs n then (*if it is a fully applied addition*) - let (escape, labeled_cont) = make_branch cont in - let else_lbl = Label.create () in - comp_args compile_constr reloc args sz - (Kisconst else_lbl::(make_areconst (n-1) else_lbl - (*Kaddint31::escape::Klabel else_lbl::Kpush::*) - (op::escape::Klabel else_lbl::Kpush:: - (* works as comp_app with nargs = n and non-tailcall cont*) - compile_get_global reloc kn sz (Kapply n::labeled_cont)))) - else if Int.equal nargs 0 then - code_construct reloc kn sz cont - else - comp_app (fun reloc _ sz cont -> code_construct reloc kn sz cont) - compile_constr reloc () args sz cont - -let int31_escape_before_match fc cont = - if not fc then - raise Not_found - else - let escape_lbl, labeled_cont = label_code cont in - (Kisconst escape_lbl)::Kdecompint31::labeled_cont diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 48c2e45332..57d3e6fc27 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -1,42 +1,30 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Cbytecodes open Cemitcodes -open Term +open Constr open Declarations -open Pre_env +open Environ (** Should only be used for monomorphic terms *) -val compile : bool -> (* Fail on error with a nice user message, otherwise simply a warning *) +val compile : fail_on_error:bool -> ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option (** init, fun, fv *) -val compile_constant_body : bool -> +val compile_constant_body : fail_on_error:bool -> env -> constant_universes -> constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) -val compile_alias : Names.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 - the dynamic compilation of int31 (trying and obtaining a - 31-bit integer in processor representation at runtime when - it failed at compile time *) -val dynamic_int31_compilation : bool -> comp_env -> - block array -> - int -> bytecodes -> bytecodes - -(*spiwack: template for the compilation n-ary operation, invariant: n>=1. - works as follow: checks if all the arguments are non-pointers - if they are applies the operation (second argument) if not - all of them are, returns to a coq definition (third argument) *) -val op_compilation : int -> instruction -> pconstant -> bool -> comp_env -> - constr array -> int -> bytecodes-> bytecodes +val compile_alias : Names.Constant.t -> body_code -(*spiwack: compiling function to insert dynamic decompilation before - matching integers (in case they are in processor representation) *) -val int31_escape_before_match : bool -> bytecodes -> bytecodes +(** Dump the bytecode after compilation (for debugging purposes) *) +val dump_bytecode : bool ref diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 092bcecc38..ca24f9b689 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -1,27 +1,66 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction machine, Oct 2004 *) (* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *) -open Term +open Names +open Constr open Cbytecodes open Copcodes open Mod_subst +type emitcodes = String.t + +external tcode_of_code : Bytes.t -> Vmvalues.tcode = "coq_tcode_of_code" + (* Relocation information *) type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant - | Reloc_getglobal of Names.constant - -type patch = reloc_info * int + | Reloc_getglobal of Names.Constant.t + | Reloc_proj_name of Projection.Repr.t + +let eq_reloc_info r1 r2 = match r1, r2 with +| Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2 +| Reloc_annot _, _ -> false +| Reloc_const c1, Reloc_const c2 -> eq_structured_constant c1 c2 +| Reloc_const _, _ -> false +| Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 +| Reloc_getglobal _, _ -> false +| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2 +| Reloc_proj_name _, _ -> false + +let hash_reloc_info r = + let open Hashset.Combine in + match r with + | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) + | Reloc_const c -> combinesmall 2 (hash_structured_constant c) + | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) + | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p) + +module RelocTable = Hashtbl.Make(struct + type t = reloc_info + let equal = eq_reloc_info + let hash = hash_reloc_info +end) + +(** We use arrays for on-disk representation. On 32-bit machines, this means we + can only have a maximum amount of about 4.10^6 relocations, which seems + quite a lot, but potentially reachable if e.g. compiling big proofs. This + would prevent VM computing with these terms on 32-bit architectures. Maybe + we should use a more robust data structure? *) +type patches = { + reloc_infos : (reloc_info * int array) array; +} let patch_char4 buff pos c1 c2 c3 c4 = Bytes.unsafe_set buff pos c1; @@ -29,40 +68,48 @@ let patch_char4 buff pos c1 c2 c3 c4 = Bytes.unsafe_set buff (pos + 2) c3; Bytes.unsafe_set buff (pos + 3) c4 -let patch buff (pos, n) = +let patch1 buff pos n = patch_char4 buff pos (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16)) (Char.unsafe_chr (n asr 24)) -(* val patch_int : emitcodes -> ((\*pos*\)int * int) list -> emitcodes *) -let patch_int buff patches = +let patch_int buff reloc = (* copy code *before* patching because of nested evaluations: the code we are patching might be called (and thus "concurrently" patched) and results in wrong results. Side-effects... *) let buff = Bytes.of_string buff in - let () = List.iter (fun p -> patch buff p) patches in - (* Note: we follow the apporach suggested by Gabriel Scherer in - PR#136 here, and use unsafe as we own buff. - - The crux of the question that avoids defining emitcodes just as a - Byte.t is the call to hcons in to_memory below. Even if disabling - this optimization has no visible time impact, test data shows - that the optimization is indeed triggered quite often so we - choose ugliness over altering the semantics. + let iter (reloc, npos) = Array.iter (fun pos -> patch1 buff pos reloc) npos in + let () = CArray.iter iter reloc in + buff - Handle with care. - *) - Bytes.unsafe_to_string buff +let patch buff pl f = + (** Order seems important here? *) + let reloc = CArray.map (fun (r, pos) -> (f r, pos)) pl.reloc_infos in + let buff = patch_int buff reloc in + tcode_of_code buff (* Buffering of bytecode *) -let out_buffer = ref(Bytes.create 1024) -and out_position = ref 0 +type label_definition = + Label_defined of int + | Label_undefined of (int * int) list -let out_word b1 b2 b3 b4 = - let p = !out_position in - if p >= Bytes.length !out_buffer then begin - let len = Bytes.length !out_buffer in +type env = { + mutable out_buffer : Bytes.t; + mutable out_position : int; + mutable label_table : label_definition array; + (* le ieme element de la table = Label_defined n signifie que l'on a + deja rencontrer le label i et qu'il est a l'offset n. + = Label_undefined l signifie que l'on a + pas encore rencontrer ce label, le premier entier indique ou est l'entier + a patcher dans la string, le deuxieme son origine *) + reloc_info : int list RelocTable.t; +} + +let out_word env b1 b2 b3 b4 = + let p = env.out_position in + if p >= Bytes.length env.out_buffer then begin + let len = Bytes.length env.out_buffer in let new_len = if len <= Sys.max_string_length / 2 then 2 * len @@ -71,289 +118,276 @@ let out_word b1 b2 b3 b4 = then invalid_arg "String.create" (* Pas la bonne exception .... *) else Sys.max_string_length in let new_buffer = Bytes.create new_len in - Bytes.blit !out_buffer 0 new_buffer 0 len; - out_buffer := new_buffer + Bytes.blit env.out_buffer 0 new_buffer 0 len; + env.out_buffer <- new_buffer end; - patch_char4 !out_buffer p (Char.unsafe_chr b1) + patch_char4 env.out_buffer p (Char.unsafe_chr b1) (Char.unsafe_chr b2) (Char.unsafe_chr b3) (Char.unsafe_chr b4); - out_position := p + 4 + env.out_position <- p + 4 -let out opcode = - out_word opcode 0 0 0 +let out env opcode = + out_word env opcode 0 0 0 -let out_int n = - out_word n (n asr 8) (n asr 16) (n asr 24) +let out_int env n = + out_word env n (n asr 8) (n asr 16) (n asr 24) (* Handling of local labels and backpatching *) -type label_definition = - Label_defined of int - | Label_undefined of (int * int) list - -let label_table = ref ([| |] : label_definition array) -(* le ieme element de la table = Label_defined n signifie que l'on a - deja rencontrer le label i et qu'il est a l'offset n. - = Label_undefined l signifie que l'on a - pas encore rencontrer ce label, le premier entier indique ou est l'entier - a patcher dans la string, le deuxieme son origine *) - -let extend_label_table needed = - let new_size = ref(Array.length !label_table) in +let extend_label_table env needed = + let new_size = ref(Array.length env.label_table) in while needed >= !new_size do new_size := 2 * !new_size done; let new_table = Array.make !new_size (Label_undefined []) in - Array.blit !label_table 0 new_table 0 (Array.length !label_table); - label_table := new_table - -let backpatch (pos, orig) = - let displ = (!out_position - orig) asr 2 in - Bytes.set !out_buffer pos @@ Char.unsafe_chr displ; - Bytes.set !out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8); - Bytes.set !out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16); - Bytes.set !out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24) - -let define_label lbl = - if lbl >= Array.length !label_table then extend_label_table lbl; - match (!label_table).(lbl) with + Array.blit env.label_table 0 new_table 0 (Array.length env.label_table); + env.label_table <- new_table + +let backpatch env (pos, orig) = + let displ = (env.out_position - orig) asr 2 in + Bytes.set env.out_buffer pos @@ Char.unsafe_chr displ; + Bytes.set env.out_buffer (pos+1) @@ Char.unsafe_chr (displ asr 8); + Bytes.set env.out_buffer (pos+2) @@ Char.unsafe_chr (displ asr 16); + Bytes.set env.out_buffer (pos+3) @@ Char.unsafe_chr (displ asr 24) + +let define_label env lbl = + if lbl >= Array.length env.label_table then extend_label_table env lbl; + match (env.label_table).(lbl) with Label_defined _ -> raise(Failure "CEmitcode.define_label") | Label_undefined patchlist -> - List.iter backpatch patchlist; - (!label_table).(lbl) <- Label_defined !out_position + List.iter (fun p -> backpatch env p) patchlist; + (env.label_table).(lbl) <- Label_defined env.out_position -let out_label_with_orig orig lbl = - if lbl >= Array.length !label_table then extend_label_table lbl; - match (!label_table).(lbl) with +let out_label_with_orig env orig lbl = + if lbl >= Array.length env.label_table then extend_label_table env lbl; + match (env.label_table).(lbl) with Label_defined def -> - out_int((def - orig) asr 2) + out_int env ((def - orig) asr 2) | Label_undefined patchlist -> (* spiwack: patchlist is supposed to be non-empty all the time thus I commented that out. If there is no problem I suggest removing it for next release (cur: 8.1) *) (*if patchlist = [] then *) - (!label_table).(lbl) <- - Label_undefined((!out_position, orig) :: patchlist); - out_int 0 + (env.label_table).(lbl) <- + Label_undefined((env.out_position, orig) :: patchlist); + out_int env 0 -let out_label l = out_label_with_orig !out_position l +let out_label env l = out_label_with_orig env env.out_position l (* Relocation information *) -let reloc_info = ref ([] : (reloc_info * int) list) +let enter env info = + let pos = env.out_position in + let old = try RelocTable.find env.reloc_info info with Not_found -> [] in + RelocTable.replace env.reloc_info info (pos :: old) -let enter info = - reloc_info := (info, !out_position) :: !reloc_info +let slot_for_const env c = + enter env (Reloc_const c); + out_int env 0 -let slot_for_const c = - enter (Reloc_const c); - out_int 0 +let slot_for_annot env a = + enter env (Reloc_annot a); + out_int env 0 -let slot_for_annot a = - enter (Reloc_annot a); - out_int 0 - -let slot_for_getglobal p = - enter (Reloc_getglobal p); - out_int 0 +let slot_for_getglobal env p = + enter env (Reloc_getglobal p); + out_int env 0 +let slot_for_proj_name env p = + enter env (Reloc_proj_name p); + out_int env 0 (* Emission of one instruction *) -let emit_instr = function - | Klabel lbl -> define_label lbl +let emit_instr env = function + | Klabel lbl -> define_label env lbl | Kacc n -> - if n < 8 then out(opACC0 + n) else (out opACC; out_int n) + if n < 8 then out env(opACC0 + n) else (out env opACC; out_int env n) | Kenvacc n -> if n >= 1 && n <= 4 - then out(opENVACC1 + n - 1) - else (out opENVACC; out_int n) + then out env(opENVACC1 + n - 1) + else (out env opENVACC; out_int env n) | Koffsetclosure ofs -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 - then out (opOFFSETCLOSURE0 + ofs / 2) - else (out opOFFSETCLOSURE; out_int ofs) + then out env (opOFFSETCLOSURE0 + ofs / 2) + else (out env opOFFSETCLOSURE; out_int env ofs) | Kpush -> - out opPUSH + out env opPUSH | Kpop n -> - out opPOP; out_int n + out env opPOP; out_int env n | Kpush_retaddr lbl -> - out opPUSH_RETADDR; out_label lbl + out env opPUSH_RETADDR; out_label env lbl | Kapply n -> - if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) + if n < 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) | Kappterm(n, sz) -> - if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) - else (out opAPPTERM; out_int n; out_int sz) + if n < 4 then (out env(opAPPTERM1 + n - 1); out_int env sz) + else (out env opAPPTERM; out_int env n; out_int env sz) | Kreturn n -> - out opRETURN; out_int n + out env opRETURN; out_int env n | Kjump -> - out opRETURN; out_int 0 + out env opRETURN; out_int env 0 | Krestart -> - out opRESTART + out env opRESTART | Kgrab n -> - out opGRAB; out_int n + out env opGRAB; out_int env n | Kgrabrec(rec_arg) -> - out opGRABREC; out_int rec_arg + out env opGRABREC; out_int env rec_arg | Kclosure(lbl, n) -> - out opCLOSURE; out_int n; out_label lbl + out env opCLOSURE; out_int env n; out_label env lbl | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> - out opCLOSUREREC;out_int (Array.length lbl_bodies); - out_int nfv; out_int init; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_types; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_bodies + out env opCLOSUREREC;out_int env (Array.length lbl_bodies); + out_int env nfv; out_int env init; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_types; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_bodies | Kclosurecofix(nfv,init,lbl_types,lbl_bodies) -> - out opCLOSURECOFIX;out_int (Array.length lbl_bodies); - out_int nfv; out_int init; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_types; - let org = !out_position in - Array.iter (out_label_with_orig org) lbl_bodies + out env opCLOSURECOFIX;out_int env (Array.length lbl_bodies); + out_int env nfv; out_int env init; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_types; + let org = env.out_position in + Array.iter (out_label_with_orig env org) lbl_bodies | Kgetglobal q -> - out opGETGLOBAL; slot_for_getglobal q + out env opGETGLOBAL; slot_for_getglobal env q | Kconst (Const_b0 i) -> if i >= 0 && i <= 3 - then out (opCONST0 + i) - else (out opCONSTINT; out_int i) + then out env (opCONST0 + i) + else (out env opCONSTINT; out_int env i) | Kconst c -> - out opGETGLOBAL; slot_for_const c + out env opGETGLOBAL; slot_for_const env c | Kmakeblock(n, t) -> if Int.equal n 0 then invalid_arg "emit_instr : block size = 0" - else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t) - else (out opMAKEBLOCK; out_int n; out_int t) + else if n < 4 then (out env(opMAKEBLOCK1 + n - 1); out_int env t) + else (out env opMAKEBLOCK; out_int env n; out_int env t) | Kmakeprod -> - out opMAKEPROD + out env opMAKEPROD | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> - out opMAKESWITCHBLOCK; - out_label typlbl; out_label swlbl; - slot_for_annot annot;out_int sz + out env opMAKESWITCHBLOCK; + out_label env typlbl; out_label env swlbl; + slot_for_annot env annot;out_int env sz | Kswitch (tbl_const, tbl_block) -> let lenb = Array.length tbl_block in let lenc = Array.length tbl_const in assert (lenb < 0x100 && lenc < 0x1000000); - out opSWITCH; - out_word lenc (lenc asr 8) (lenc asr 16) (lenb); -(* out_int (Array.length tbl_const + (Array.length tbl_block lsl 23)); *) - let org = !out_position in - Array.iter (out_label_with_orig org) tbl_const; - Array.iter (out_label_with_orig org) tbl_block + out env opSWITCH; + out_word env lenc (lenc asr 8) (lenc asr 16) (lenb); +(* out_int env (Array.length tbl_const + (Array.length tbl_block lsl 23)); *) + let org = env.out_position in + Array.iter (out_label_with_orig env org) tbl_const; + Array.iter (out_label_with_orig env org) tbl_block | Kpushfields n -> - out opPUSHFIELDS;out_int n + out env opPUSHFIELDS;out_int env n | Kfield n -> - if n <= 1 then out (opGETFIELD0+n) - else (out opGETFIELD;out_int n) + if n <= 1 then out env (opGETFIELD0+n) + else (out env opGETFIELD;out_int env n) | Ksetfield n -> - if n <= 1 then out (opSETFIELD0+n) - else (out opSETFIELD;out_int n) + if n <= 1 then out env (opSETFIELD0+n) + else (out env opSETFIELD;out_int env n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" - | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p) - | Kensurestackcapacity size -> out opENSURESTACKCAPACITY; out_int size + | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p + | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size (* spiwack *) - | Kbranch lbl -> out opBRANCH; out_label lbl - | Kaddint31 -> out opADDINT31 - | Kaddcint31 -> out opADDCINT31 - | Kaddcarrycint31 -> out opADDCARRYCINT31 - | Ksubint31 -> out opSUBINT31 - | Ksubcint31 -> out opSUBCINT31 - | Ksubcarrycint31 -> out opSUBCARRYCINT31 - | Kmulint31 -> out opMULINT31 - | Kmulcint31 -> out opMULCINT31 - | Kdiv21int31 -> out opDIV21INT31 - | Kdivint31 -> out opDIVINT31 - | Kaddmuldivint31 -> out opADDMULDIVINT31 - | Kcompareint31 -> out opCOMPAREINT31 - | Khead0int31 -> out opHEAD0INT31 - | Ktail0int31 -> out opTAIL0INT31 - | Kisconst lbl -> out opISCONST; out_label lbl - | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl - | Kcompint31 -> out opCOMPINT31 - | Kdecompint31 -> out opDECOMPINT31 - | Klorint31 -> out opORINT31 - | Klandint31 -> out opANDINT31 - | Klxorint31 -> out opXORINT31 + | Kbranch lbl -> out env opBRANCH; out_label env lbl + | Kaddint31 -> out env opADDINT31 + | Kaddcint31 -> out env opADDCINT31 + | Kaddcarrycint31 -> out env opADDCARRYCINT31 + | Ksubint31 -> out env opSUBINT31 + | Ksubcint31 -> out env opSUBCINT31 + | Ksubcarrycint31 -> out env opSUBCARRYCINT31 + | Kmulint31 -> out env opMULINT31 + | Kmulcint31 -> out env opMULCINT31 + | Kdiv21int31 -> out env opDIV21INT31 + | Kdivint31 -> out env opDIVINT31 + | Kaddmuldivint31 -> out env opADDMULDIVINT31 + | Kcompareint31 -> out env opCOMPAREINT31 + | Khead0int31 -> out env opHEAD0INT31 + | Ktail0int31 -> out env opTAIL0INT31 + | Kisconst lbl -> out env opISCONST; out_label env lbl + | Kareconst(n,lbl) -> out env opARECONST; out_int env n; out_label env lbl + | Kcompint31 -> out env opCOMPINT31 + | Kdecompint31 -> out env opDECOMPINT31 + | Klorint31 -> out env opORINT31 + | Klandint31 -> out env opANDINT31 + | Klxorint31 -> out env opXORINT31 (*/spiwack *) | Kstop -> - out opSTOP + out env opSTOP (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) -let rec emit insns remaining = match insns with +let rec emit env insns remaining = match insns with | [] -> (match remaining with [] -> () - | (first::rest) -> emit first rest) + | (first::rest) -> emit env first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> - if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); - emit c remaining + if n < 8 then out env(opPUSHACC0 + n) else (out env opPUSHACC; out_int env n); + emit env c remaining | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 - then out(opPUSHENVACC1 + n - 1) - else (out opPUSHENVACC; out_int n); - emit c remaining + then out env(opPUSHENVACC1 + n - 1) + else (out env opPUSHENVACC; out_int env n); + emit env c remaining | Kpush :: Koffsetclosure ofs :: c -> if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 - then out(opPUSHOFFSETCLOSURE0 + ofs / 2) - else (out opPUSHOFFSETCLOSURE; out_int ofs); - emit c remaining + then out env(opPUSHOFFSETCLOSURE0 + ofs / 2) + else (out env opPUSHOFFSETCLOSURE; out_int env ofs); + emit env c remaining | Kpush :: Kgetglobal id :: c -> - out opPUSHGETGLOBAL; slot_for_getglobal id; emit c remaining + out env opPUSHGETGLOBAL; slot_for_getglobal env id; emit env c remaining | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 - then out (opPUSHCONST0 + i) - else (out opPUSHCONSTINT; out_int i); - emit c remaining + then out env (opPUSHCONST0 + i) + else (out env opPUSHCONSTINT; out_int env i); + emit env c remaining | Kpush :: Kconst const :: c -> - out opPUSHGETGLOBAL; slot_for_const const; - emit c remaining + out env opPUSHGETGLOBAL; slot_for_const env const; + emit env c remaining | Kpop n :: Kjump :: c -> - out opRETURN; out_int n; emit c remaining + out env opRETURN; out_int env n; emit env c remaining | Ksequence(c1,c2)::c -> - emit c1 (c2::c::remaining) + emit env c1 (c2::c::remaining) (* Default case *) | instr :: c -> - emit_instr instr; emit c remaining + emit_instr env instr; emit env c remaining (* Initialization *) -let init () = - out_position := 0; - label_table := Array.make 16 (Label_undefined []); - reloc_info := [] - -type emitcodes = String.t - -let length = String.length - -type to_patch = emitcodes * (patch list) * fv +type to_patch = emitcodes * patches * fv (* Substitution *) let rec subst_strcst s sc = match sc with - | Const_sorts _ | Const_b0 _ | Const_univ_level _ | Const_type _ -> sc - | Const_proj p -> Const_proj (subst_constant s p) + | Const_sort _ | Const_b0 _ | Const_univ_level _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) -let subst_patch s (ri,pos) = +let subst_reloc s ri = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in - (Reloc_annot {a with ci = ci},pos) - | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (subst_constant s kn), pos) + Reloc_annot {a with ci = ci} + | Reloc_const sc -> Reloc_const (subst_strcst s sc) + | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn) + | Reloc_proj_name p -> Reloc_proj_name (subst_proj_repr s p) + +let subst_patches subst p = + let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in + { reloc_infos = infos; } let subst_to_patch s (code,pl,fv) = - code,List.rev_map (subst_patch s) pl,fv + code, subst_patches s pl, fv type body_code = | BCdefined of to_patch - | BCalias of Names.constant + | BCalias of Names.Constant.t | BCconstant type to_patch_substituted = | PBCdefined of to_patch substituted -| PBCalias of Names.constant substituted +| PBCalias of Names.Constant.t substituted | PBCconstant let from_val = function @@ -381,16 +415,23 @@ let repr_body_code = function | PBCconstant -> (None, BCconstant) let to_memory (init_code, fun_code, fv) = - init(); - emit init_code []; - emit fun_code []; + let env = { + out_buffer = Bytes.create 1024; + out_position = 0; + label_table = Array.make 16 (Label_undefined []); + reloc_info = RelocTable.create 91; + } in + emit env init_code []; + emit env fun_code []; (** Later uses of this string are all purely functional *) - let code = Bytes.sub_string !out_buffer 0 !out_position in + let code = Bytes.sub_string env.out_buffer 0 env.out_position in let code = CString.hcons code in - let reloc = List.rev !reloc_info in + let fold reloc npos accu = (reloc, Array.of_list npos) :: accu in + let reloc = RelocTable.fold fold env.reloc_info [] in + let reloc = { reloc_infos = CArray.of_list reloc } in Array.iter (fun lbl -> (match lbl with Label_defined _ -> assert true | Label_undefined patchlist -> - assert (patchlist = []))) !label_table; + assert (patchlist = []))) env.label_table; (code, reloc, fv) diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index c80edd5965..9009926bdb 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -4,26 +4,19 @@ open Cbytecodes type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant - | Reloc_getglobal of constant - -type patch = reloc_info * int - -(* A virer *) -val subst_patch : Mod_subst.substitution -> patch -> patch + | Reloc_getglobal of Constant.t + | Reloc_proj_name of Projection.Repr.t +type patches type emitcodes -val length : emitcodes -> int - -val patch_int : emitcodes -> ((*pos*)int * int) list -> emitcodes - -type to_patch = emitcodes * (patch list) * fv +val patch : emitcodes -> patches -> (reloc_info -> int) -> Vmvalues.tcode -val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch +type to_patch = emitcodes * patches * fv type body_code = | BCdefined of to_patch - | BCalias of constant + | BCalias of Constant.t | BCconstant diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli new file mode 100644 index 0000000000..171ca38830 --- /dev/null +++ b/kernel/cinstr.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Names +open Constr +open Cbytecodes + +(** This file defines the lambda code for the bytecode compiler. It has been +extracted from Clambda.ml because of the retroknowledge architecture. *) + +type uint = + | UintVal of Uint31.t + | UintDigits of lambda array + | UintDecomp of lambda + +and lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Levar of Evar.t * lambda array + | Lprod of lambda * lambda + | Llam of Name.t array * lambda + | Llet of Name.t * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of pconstant + | Lprim of pconstant * int (* arity *) * instruction * lambda array + | Lcase of case_info * reloc_table * lambda * lambda * lam_branches + | Lfix of (int array * int) * fix_decl + | Lcofix of int * fix_decl (* must be in eta-expanded form *) + | Lmakeblock of int * lambda array + | Lval of structured_constant + | Lsort of Sorts.t + | Lind of pinductive + | Lproj of Projection.Repr.t * lambda + | Luint of uint + +(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation +to be correct. Otherwise, memoization of previous evaluations will be applied +again to extra arguments (see #7333). *) + +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t array * lambda) array } + +and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/clambda.ml b/kernel/clambda.ml new file mode 100644 index 0000000000..7c00e40fb0 --- /dev/null +++ b/kernel/clambda.ml @@ -0,0 +1,860 @@ +open Util +open Names +open Esubst +open Term +open Constr +open Declarations +open Cbytecodes +open Cinstr +open Environ +open Pp + +let pr_con sp = str(Names.Label.to_string (Constant.label sp)) + +(** Printing **) + +let pp_names ids = + prlist_with_sep (fun _ -> brk(1,1)) Name.print (Array.to_list ids) + +let pp_rel name n = + Name.print name ++ str "##" ++ int n + +let pp_sort s = + match Sorts.family s with + | InSet -> str "Set" + | InProp -> str "Prop" + | InType -> str "Type" + +let rec pp_lam lam = + match lam with + | Lrel (id,n) -> pp_rel id n + | Lvar id -> Id.print id + | Levar (evk, args) -> + hov 1 (str "evar(" ++ Evar.print evk ++ str "," ++ spc () ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ str ")") + | Lprod(dom,codom) -> hov 1 + (str "forall(" ++ + pp_lam dom ++ + str "," ++ spc() ++ + pp_lam codom ++ + str ")") + | Llam(ids,body) -> hov 1 + (str "(fun " ++ + pp_names ids ++ + str " =>" ++ + spc() ++ + pp_lam body ++ + str ")") + | Llet(id,def,body) -> hov 0 + (str "let " ++ + Name.print id ++ + str ":=" ++ + pp_lam def ++ + str " in" ++ + spc() ++ + pp_lam body) + | Lapp(f, args) -> hov 1 + (str "(" ++ pp_lam f ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") + | Lconst (kn,_) -> pr_con kn + | Lcase(_ci, _rtbl, t, a, branches) -> + let ic = ref (-1) in + let ib = ref 0 in + v 0 (str"<" ++ pp_lam t ++ str">" ++ cut() ++ + str "Case" ++ spc () ++ pp_lam a ++ spc() ++ str "of" ++ cut() ++ + v 0 + ((prlist_with_sep (fun _ -> str "") + (fun c -> + cut () ++ str "| " ++ + int (incr ic; !ic) ++ str " => " ++ pp_lam c) + (Array.to_list branches.constant_branches)) ++ + (prlist_with_sep (fun _ -> str "") + (fun (ids,c) -> + cut () ++ str "| " ++ + int (incr ib; !ib) ++ str " " ++ + pp_names ids ++ str " => " ++ pp_lam c) + (Array.to_list branches.nonconstant_branches))) + ++ cut() ++ str "end") + | Lfix((t,i),(lna,tl,bl)) -> + let fixl = Array.mapi (fun i id -> (id,t.(i),tl.(i),bl.(i))) lna in + hov 1 + (str"fix " ++ int i ++ spc() ++ str"{" ++ + v 0 + (prlist_with_sep spc + (fun (na,i,ty,bd) -> + Name.print na ++ str"/" ++ int i ++ str":" ++ + pp_lam ty ++ cut() ++ str":=" ++ + pp_lam bd) (Array.to_list fixl)) ++ + str"}") + + | Lcofix (i,(lna,tl,bl)) -> + let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in + hov 1 + (str"cofix " ++ int i ++ spc() ++ str"{" ++ + v 0 + (prlist_with_sep spc + (fun (na,ty,bd) -> + Name.print na ++ str":" ++ pp_lam ty ++ + cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ + str"}") + | Lmakeblock(tag, args) -> + hov 1 + (str "(makeblock " ++ int tag ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") + | Lval _ -> str "values" + | Lsort s -> pp_sort s + | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i + | Lprim((kn,_u),ar,op,args) -> + hov 1 + (str "(PRIM " ++ pr_con kn ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") + | Lproj(p,arg) -> + hov 1 + (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg + ++ str ")") + | Luint _ -> + str "(uint)" + +(*s Constructors *) + +let mkLapp f args = + if Array.length args = 0 then f + else + match f with + | Lapp(f', args') -> Lapp (f', Array.append args' args) + | _ -> Lapp(f, args) + +let mkLlam ids body = + if Array.length ids = 0 then body + else + match body with + | Llam(ids', body) -> Llam(Array.append ids ids', body) + | _ -> Llam(ids, body) + +let decompose_Llam lam = + match lam with + | Llam(ids,body) -> ids, body + | _ -> [||], lam + +(*s Operators on substitution *) +let subst_id = subs_id 0 +let lift = subs_lift +let liftn = subs_liftn +let cons v subst = subs_cons([|v|], subst) +let shift subst = subs_shft (1, subst) + +(* A generic map function *) + +let rec map_lam_with_binders g f n lam = + match lam with + | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ -> lam + | Levar (evk, args) -> + let args' = Array.Smart.map (f n) args in + if args == args' then lam else Levar (evk, args') + | Lprod(dom,codom) -> + let dom' = f n dom in + let codom' = f n codom in + if dom == dom' && codom == codom' then lam else Lprod(dom',codom') + | Llam(ids,body) -> + let body' = f (g (Array.length ids) n) body in + if body == body' then lam else mkLlam ids body' + | Llet(id,def,body) -> + let def' = f n def in + let body' = f (g 1 n) body in + if body == body' && def == def' then lam else Llet(id,def',body') + | Lapp(fct,args) -> + let fct' = f n fct in + let args' = Array.Smart.map (f n) args in + if fct == fct' && args == args' then lam else mkLapp fct' args' + | Lcase(ci,rtbl,t,a,branches) -> + let const = branches.constant_branches in + let nonconst = branches.nonconstant_branches in + let t' = f n t in + let a' = f n a in + let const' = Array.Smart.map (f n) const in + let on_b b = + let (ids,body) = b in + let body' = f (g (Array.length ids) n) body in + if body == body' then b else (ids,body') in + let nonconst' = Array.Smart.map on_b nonconst in + let branches' = + if const == const' && nonconst == nonconst' then + branches + else + { constant_branches = const'; + nonconstant_branches = nonconst' } + in + if t == t' && a == a' && branches == branches' then lam else + Lcase(ci,rtbl,t',a',branches') + | Lfix(init,(ids,ltypes,lbodies)) -> + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in + if ltypes == ltypes' && lbodies == lbodies' then lam + else Lfix(init,(ids,ltypes',lbodies')) + | Lcofix(init,(ids,ltypes,lbodies)) -> + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in + if ltypes == ltypes' && lbodies == lbodies' then lam + else Lcofix(init,(ids,ltypes',lbodies')) + | Lmakeblock(tag,args) -> + let args' = Array.Smart.map (f n) args in + if args == args' then lam else Lmakeblock(tag,args') + | Lprim(kn,ar,op,args) -> + let args' = Array.Smart.map (f n) args in + if args == args' then lam else Lprim(kn,ar,op,args') + | Lproj(p,arg) -> + let arg' = f n arg in + if arg == arg' then lam else Lproj(p,arg') + | Luint u -> + let u' = map_uint g f n u in + if u == u' then lam else Luint u' + +and map_uint g f n u = + match u with + | UintVal _ -> u + | UintDigits(args) -> + let args' = Array.Smart.map (f n) args in + if args == args' then u else UintDigits(args') + | UintDecomp(a) -> + let a' = f n a in + if a == a' then u else UintDecomp(a') + +(*s Lift and substitution *) + + +let rec lam_exlift el lam = + match lam with + | Lrel(id,i) -> + let i' = reloc_rel i el in + if i == i' then lam else Lrel(id,i') + | _ -> map_lam_with_binders el_liftn lam_exlift el lam + +let lam_lift k lam = + if k = 0 then lam + else lam_exlift (el_shft k el_id) lam + +let lam_subst_rel lam id n subst = + match expand_rel n subst with + | Inl(k,v) -> lam_lift k v + | Inr(n',_) -> + if n == n' then lam + else Lrel(id, n') + +let rec lam_exsubst subst lam = + match lam with + | Lrel(id,i) -> lam_subst_rel lam id i subst + | _ -> map_lam_with_binders liftn lam_exsubst subst lam + +let lam_subst_args subst args = + if is_subs_id subst then args + else Array.Smart.map (lam_exsubst subst) args + +(** Simplification of lambda expression *) + +(* [simplify subst lam] simplify the expression [lam_subst subst lam] *) +(* that is : *) +(* - Reduce [let] is the definition can be substituted i.e: *) +(* - a variable (rel or identifier) *) +(* - a constant *) +(* - a structured constant *) +(* - a function *) +(* - Transform beta redex into [let] expression *) +(* - Move arguments under [let] *) +(* Invariant : Terms in [subst] are already simplified and can be *) +(* substituted *) + +let can_subst lam = + match lam with + | Lrel _ | Lvar _ | Lconst _ + | Lval _ | Lsort _ | Lind _ | Llam _ -> true + | _ -> false + +let rec simplify subst lam = + match lam with + | Lrel(id,i) -> lam_subst_rel lam id i subst + + | Llet(id,def,body) -> + let def' = simplify subst def in + if can_subst def' then simplify (cons def' subst) body + else + let body' = simplify (lift subst) body in + if def == def' && body == body' then lam + else Llet(id,def',body') + + | Lapp(f,args) -> + begin match simplify_app subst f subst args with + | Lapp(f',args') when f == f' && args == args' -> lam + | lam' -> lam' + end + + | _ -> map_lam_with_binders liftn simplify subst lam + +and simplify_app substf f substa args = + match f with + | Lrel(id, i) -> + begin match lam_subst_rel f id i substf with + | Llam(ids, body) -> + reduce_lapp + subst_id (Array.to_list ids) body + substa (Array.to_list args) + | f' -> mkLapp f' (simplify_args substa args) + end + | Llam(ids, body) -> + reduce_lapp substf (Array.to_list ids) body substa (Array.to_list args) + | Llet(id, def, body) -> + let def' = simplify substf def in + if can_subst def' then + simplify_app (cons def' substf) body substa args + else + Llet(id, def', simplify_app (lift substf) body (shift substa) args) + | Lapp(f, args') -> + let args = Array.append + (lam_subst_args substf args') (lam_subst_args substa args) in + simplify_app substf f subst_id args + | _ -> mkLapp (simplify substf f) (simplify_args substa args) + +and simplify_args subst args = Array.Smart.map (simplify subst) args + +and reduce_lapp substf lids body substa largs = + match lids, largs with + | id::lids, a::largs -> + let a = simplify substa a in + if can_subst a then + reduce_lapp (cons a substf) lids body substa largs + else + let body = reduce_lapp (lift substf) lids body (shift substa) largs in + Llet(id, a, body) + | [], [] -> simplify substf body + | _::_, _ -> + Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) + | [], _::_ -> simplify_app substf body substa (Array.of_list largs) + + + + +(* [occurrence kind k lam]: + If [kind] is [true] return [true] if the variable [k] does not appear in + [lam], return [false] if the variable appear one time and not + under a lambda, a fixpoint, a cofixpoint; else raise Not_found. + If [kind] is [false] return [false] if the variable does not appear in [lam] + else raise [Not_found] +*) + +let rec occurrence k kind lam = + match lam with + | Lrel (_,n) -> + if n = k then + if kind then false else raise Not_found + else kind + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ -> kind + | Levar (_, args) -> + occurrence_args k kind args + | Lprod(dom, codom) -> + occurrence k (occurrence k kind dom) codom + | Llam(ids,body) -> + let _ = occurrence (k+Array.length ids) false body in kind + | Llet(_,def,body) -> + occurrence (k+1) (occurrence k kind def) body + | Lapp(f, args) -> + occurrence_args k (occurrence k kind f) args + | Lprim(_,_,_,args) | Lmakeblock(_,args) -> + occurrence_args k kind args + | Lcase(_ci,_rtbl,t,a,branches) -> + let kind = occurrence k (occurrence k kind t) a in + let r = ref kind in + Array.iter (fun c -> r := occurrence k kind c && !r) branches.constant_branches; + let on_b (ids,c) = + r := occurrence (k+Array.length ids) kind c && !r + in + Array.iter on_b branches.nonconstant_branches; + !r + | Lfix(_,(ids,ltypes,lbodies)) + | Lcofix(_,(ids,ltypes,lbodies)) -> + let kind = occurrence_args k kind ltypes in + let _ = occurrence_args (k+Array.length ids) false lbodies in + kind + | Lproj(_,arg) -> + occurrence k kind arg + | Luint u -> occurrence_uint k kind u + +and occurrence_args k kind args = + Array.fold_left (occurrence k) kind args + +and occurrence_uint k kind u = + match u with + | UintVal _ -> kind + | UintDigits args -> occurrence_args k kind args + | UintDecomp t -> occurrence k kind t + +let occur_once lam = + try let _ = occurrence 1 true lam in true + with Not_found -> false + +(* [remove_let lam] remove let expression in [lam] if the variable is *) +(* used at most once time in the body, and does not appear under *) +(* a lambda or a fix or a cofix *) + +let rec remove_let subst lam = + match lam with + | Lrel(id,i) -> lam_subst_rel lam id i subst + | Llet(id,def,body) -> + let def' = remove_let subst def in + if occur_once body then remove_let (cons def' subst) body + else + let body' = remove_let (lift subst) body in + if def == def' && body == body' then lam else Llet(id,def',body') + | _ -> map_lam_with_binders liftn remove_let subst lam + + +(*s Translation from [constr] to [lambda] *) + +(* Translation of constructor *) + +(* Limitation due to OCaml's representation of non-constant + constructors: limited to 245 + 1 (0 tag) cases. *) + +exception TooLargeInductive of Pp.t + +let max_nb_const = 0x1000000 +let max_nb_block = 0x1000000 + last_variant_tag - 1 + +let str_max_constructors = + Format.sprintf + " which has more than %i constant constructors or more than %i non-constant constructors" max_nb_const max_nb_block + +let check_compilable ib = + + if not (ib.mind_nb_args <= max_nb_block && ib.mind_nb_constant <= max_nb_const) then + let msg = + Pp.(str "Cannot compile code for virtual machine as it uses inductive " + ++ Id.print ib.mind_typename ++ str str_max_constructors) + in + raise (TooLargeInductive msg) + +let is_value lc = + match lc with + | Lval _ -> true + | _ -> false + +let get_value lc = + match lc with + | Lval v -> v + | _ -> raise Not_found + +let mkConst_b0 n = Lval (Cbytecodes.Const_b0 n) + +let make_args start _end = + Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) + +(* Translation of constructors *) +let expand_constructor tag nparams arity = + let ids = Array.make (nparams + arity) Anonymous in + if arity = 0 then mkLlam ids (mkConst_b0 tag) + else + let args = make_args arity 1 in + Llam(ids, Lmakeblock (tag, args)) + +let makeblock tag nparams arity args = + let nargs = Array.length args in + if nparams > 0 || nargs < arity then + mkLapp (expand_constructor tag nparams arity) args + else + (* The constructor is fully applied *) + if arity = 0 then mkConst_b0 tag + else + if Array.for_all is_value args then + if tag < last_variant_tag then + Lval(Cbytecodes.Const_bn(tag, Array.map get_value args)) + else + let args = Array.map get_value args in + let args = Array.append [|Cbytecodes.Const_b0 (tag - last_variant_tag) |] args in + Lval(Cbytecodes.Const_bn(last_variant_tag, args)) + else Lmakeblock(tag, args) + + +(* Compiling constants *) + +let rec get_alias env kn = + let cb = lookup_constant kn env in + let tps = cb.const_body_code in + match tps with + | None -> kn + | Some tps -> + (match Cemitcodes.force tps with + | Cemitcodes.BCalias kn' -> get_alias env kn' + | _ -> kn) + +(* Compilation of primitive *) + +let _h = Name(Id.of_string "f") + +(* +let expand_prim kn op arity = + let ids = Array.make arity Anonymous in + let args = make_args arity 1 in + Llam(ids, prim kn op args) +*) + +let compile_prim n op kn fc args = + if not fc then raise Not_found + else + Lprim(kn, n, op, args) + + (* + let (nparams, arity) = CPrimitives.arity op in + let expected = nparams + arity in + if Array.length args >= expected then prim kn op args + else mkLapp (expand_prim kn op expected) args +*) + +(*i Global environment *) + +let get_names decl = + let decl = Array.of_list decl in + Array.map fst decl + + +(* Rel Environment *) +module Vect = +struct + type 'a t = { + mutable elems : 'a array; + mutable size : int; + } + + let make n a = { + elems = Array.make n a; + size = 0; + } + + let extend v = + if v.size = Array.length v.elems then + let new_size = min (2*v.size) Sys.max_array_length in + if new_size <= v.size then raise (Invalid_argument "Vect.extend"); + let new_elems = Array.make new_size v.elems.(0) in + Array.blit v.elems 0 new_elems 0 (v.size); + v.elems <- new_elems + + let push v a = + extend v; + v.elems.(v.size) <- a; + v.size <- v.size + 1 + + let popn v n = + v.size <- max 0 (v.size - n) + + let pop v = popn v 1 + + let get_last v n = + if v.size <= n then raise + (Invalid_argument "Vect.get:index out of bounds"); + v.elems.(v.size - n - 1) + +end + +let dummy_lambda = Lrel(Anonymous, 0) + +let empty_args = [||] + +module Renv = +struct + + type constructor_info = tag * int * int (* nparam nrealargs *) + + type t = { + global_env : env; + name_rel : Name.t Vect.t; + construct_tbl : (constructor, constructor_info) Hashtbl.t; + } + + let make env = { + global_env = env; + name_rel = Vect.make 16 Anonymous; + construct_tbl = Hashtbl.create 111 + } + + let push_rel env id = Vect.push env.name_rel id + + let push_rels env ids = + Array.iter (push_rel env) ids + + let pop env = Vect.pop env.name_rel + + let popn env n = + for _i = 1 to n do pop env done + + let get env n = + Lrel (Vect.get_last env.name_rel (n-1), n) + + let get_construct_info env c = + try Hashtbl.find env.construct_tbl c + with Not_found -> + let ((mind,j), i) = c in + let oib = lookup_mind mind env.global_env in + let oip = oib.mind_packets.(j) in + check_compilable oip; + let tag,arity = oip.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + let r = (tag, nparams, arity) in + Hashtbl.add env.construct_tbl c r; + r +end + +open Renv + +let rec lambda_of_constr env c = + match Constr.kind c with + | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta") + | Evar (evk, args) -> + let args = lambda_of_args env 0 args in + Levar (evk, args) + + | Cast (c, _, _) -> lambda_of_constr env c + + | Rel i -> Renv.get env i + + | Var id -> Lvar id + + | Sort s -> Lsort s + | Ind ind -> Lind ind + + | Prod(id, dom, codom) -> + let ld = lambda_of_constr env dom in + Renv.push_rel env id; + let lc = lambda_of_constr env codom in + Renv.pop env; + Lprod(ld, Llam([|id|], lc)) + + | Lambda _ -> + let params, body = decompose_lam c in + let ids = get_names (List.rev params) in + Renv.push_rels env ids; + let lb = lambda_of_constr env body in + Renv.popn env (Array.length ids); + mkLlam ids lb + + | LetIn(id, def, _, body) -> + let ld = lambda_of_constr env def in + Renv.push_rel env id; + let lb = lambda_of_constr env body in + Renv.pop env; + Llet(id, ld, lb) + + | App(f, args) -> lambda_of_app env f args + + | Const _ -> lambda_of_app env c empty_args + + | Construct _ -> lambda_of_app env c empty_args + + | Case(ci,t,a,branches) -> + let ind = ci.ci_ind in + let mib = lookup_mind (fst ind) env.global_env in + let oib = mib.mind_packets.(snd ind) in + let () = check_compilable oib in + let rtbl = oib.mind_reloc_tbl in + + + (* translation of the argument *) + let la = lambda_of_constr env a in + let entry = mkInd ind in + let la = + try + Retroknowledge.get_vm_before_match_info env.global_env.retroknowledge + entry la + with Not_found -> la + in + (* translation of the type *) + let lt = lambda_of_constr env t in + (* translation of branches *) + let consts = Array.make oib.mind_nb_constant dummy_lambda in + let blocks = Array.make oib.mind_nb_args ([||],dummy_lambda) in + for i = 0 to Array.length rtbl - 1 do + let tag, arity = rtbl.(i) in + let b = lambda_of_constr env branches.(i) in + if arity = 0 then consts.(tag) <- b + else + let b = + match b with + | Llam(ids, body) when Array.length ids = arity -> (ids, body) + | _ -> + let ids = Array.make arity Anonymous in + let args = make_args arity 1 in + let ll = lam_lift arity b in + (ids, mkLapp ll args) + in blocks.(tag-1) <- b + done; + let branches = + { constant_branches = consts; + nonconstant_branches = blocks } + in + Lcase(ci, rtbl, lt, la, branches) + + | Fix(rec_init,(names,type_bodies,rec_bodies)) -> + let ltypes = lambda_of_args env 0 type_bodies in + Renv.push_rels env names; + let lbodies = lambda_of_args env 0 rec_bodies in + Renv.popn env (Array.length names); + Lfix(rec_init, (names, ltypes, lbodies)) + + | CoFix(init,(names,type_bodies,rec_bodies)) -> + let rec_bodies = Array.map2 (Reduction.eta_expand env.global_env) rec_bodies type_bodies in + let ltypes = lambda_of_args env 0 type_bodies in + Renv.push_rels env names; + let lbodies = lambda_of_args env 0 rec_bodies in + Renv.popn env (Array.length names); + Lcofix(init, (names, ltypes, lbodies)) + + | Proj (p,c) -> + let lc = lambda_of_constr env c in + Lproj (Projection.repr p,lc) + +and lambda_of_app env f args = + match Constr.kind f with + | Const (kn,u as c) -> + let kn = get_alias env.global_env kn in + (* spiwack: checks if there is a specific way to compile the constant + if there is not, Not_found is raised, and the function + falls back on its normal behavior *) + (try + (* We delay the compilation of arguments to avoid an exponential behavior *) + let f = Retroknowledge.get_vm_compiling_info env.global_env.retroknowledge + (mkConstU (kn,u)) in + let args = lambda_of_args env 0 args in + f args + with Not_found -> + let cb = lookup_constant kn env.global_env in + begin match cb.const_body with + | Def csubst when cb.const_inline_code -> + lambda_of_app env (Mod_subst.force_constr csubst) args + | Def _ | OpaqueDef _ | Undef _ -> mkLapp (Lconst c) (lambda_of_args env 0 args) + end) + | Construct (c,_) -> + let tag, nparams, arity = Renv.get_construct_info env c in + let nargs = Array.length args in + if Int.equal (nparams + arity) nargs then (* fully applied *) + (* spiwack: *) + (* 1/ tries to compile the constructor in an optimal way, + it is supposed to work only if the arguments are + all fully constructed, fails with Cbytecodes.NotClosed. + it can also raise Not_found when there is no special + treatment for this constructor + for instance: tries to to compile an integer of the + form I31 D1 D2 ... D31 to [D1D2...D31] as + a processor number (a caml number actually) *) + try + try + Retroknowledge.get_vm_constant_static_info + env.global_env.retroknowledge + f args + with NotClosed -> + (* 2/ if the arguments are not all closed (this is + expectingly (and it is currently the case) the only + reason why this exception is raised) tries to + give a clever, run-time behavior to the constructor. + Raises Not_found if there is no special treatment + for this integer. + this is done in a lazy fashion, using the constructor + Bspecial because it needs to know the continuation + and such, which can't be done at this time. + for instance, for int31: if one of the digit is + not closed, it's not impossible that the number + gets fully instanciated at run-time, thus to ensure + uniqueness of the representation in the vm + it is necessary to try and build a caml integer + during the execution *) + let rargs = Array.sub args nparams arity in + let args = lambda_of_args env nparams rargs in + Retroknowledge.get_vm_constant_dynamic_info + env.global_env.retroknowledge + f args + with Not_found -> + (* 3/ if no special behavior is available, then the compiler + falls back to the normal behavior *) + let args = lambda_of_args env nparams args in + makeblock tag 0 arity args + else + let args = lambda_of_args env nparams args in + (* spiwack: tries first to apply the run-time compilation + behavior of the constructor, as in 2/ above *) + (try + (Retroknowledge.get_vm_constant_dynamic_info + env.global_env.retroknowledge + f) args + with Not_found -> + if nparams <= nargs then (* got all parameters *) + makeblock tag 0 arity args + else (* still expecting some parameters *) + makeblock tag (nparams - nargs) arity empty_args) + | _ -> + let f = lambda_of_constr env f in + let args = lambda_of_args env 0 args in + mkLapp f args + +and lambda_of_args env start args = + let nargs = Array.length args in + if start < nargs then + Array.init (nargs - start) + (fun i -> lambda_of_constr env args.(start + i)) + else empty_args + + + + +(*********************************) +let dump_lambda = ref false + +let optimize_lambda lam = + let lam = simplify subst_id lam in + remove_let subst_id lam + +let lambda_of_constr ~optimize genv c = + let env = Renv.make genv in + let ids = List.rev_map Context.Rel.Declaration.get_name (rel_context genv) in + Renv.push_rels env (Array.of_list ids); + let lam = lambda_of_constr env c in + let lam = if optimize then optimize_lambda lam else lam in + if !dump_lambda then + Feedback.msg_debug (pp_lam lam); + lam + +(** Retroknowledge, to be removed once we move to primitive machine integers *) +let compile_structured_int31 fc args = + if not fc then raise Not_found else + Luint (UintVal + (Uint31.of_int (Array.fold_left + (fun temp_i -> fun t -> match kind t with + | Construct ((_,d),_) -> 2*temp_i+d-1 + | _ -> raise NotClosed) + 0 args))) + +let dynamic_int31_compilation fc args = + if not fc then raise Not_found else + Luint (UintDigits args) + +(* We are relying here on the tags of digits constructors *) +let digits_from_uint i = + let d0 = mkConst_b0 0 in + let d1 = mkConst_b0 1 in + let digits = Array.make 31 d0 in + for k = 0 to 30 do + if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then + digits.(30-k) <- d1 + done; + digits + +let int31_escape_before_match fc t = + if not fc then + raise Not_found + else + match t with + | Luint (UintVal i) -> + let digits = digits_from_uint i in + Lmakeblock (1, digits) + | Luint (UintDigits args) -> + Lmakeblock (1,args) + | Luint (UintDecomp _) -> + assert false + | _ -> Luint (UintDecomp t) diff --git a/kernel/clambda.mli b/kernel/clambda.mli new file mode 100644 index 0000000000..8ff10b4549 --- /dev/null +++ b/kernel/clambda.mli @@ -0,0 +1,31 @@ +open Names +open Cinstr +open Environ + +exception TooLargeInductive of Pp.t + +val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda + +val decompose_Llam : lambda -> Name.t array * lambda + +val get_alias : env -> Constant.t -> Constant.t + +val compile_prim : int -> Cbytecodes.instruction -> Constr.pconstant -> bool -> lambda array -> lambda + +(** 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.t array -> lambda + +(** 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 *) +val dynamic_int31_compilation : bool -> lambda array -> lambda + +(*spiwack: compiling function to insert dynamic decompilation before + matching integers (in case they are in processor representation) *) +val int31_escape_before_match : bool -> lambda -> lambda + +(** Dump the VM lambda code after compilation (for debugging purposes) *) +val dump_lambda : bool ref diff --git a/kernel/constr.ml b/kernel/constr.ml index c3e6095363..9bf743152f 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* File initially created by Gérard Huet and Thierry Coquand in 1984 *) @@ -75,7 +77,7 @@ type ('constr, 'types) pfixpoint = type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration type 'a puniverses = 'a Univ.puniverses -type pconstant = constant puniverses +type pconstant = Constant.t puniverses type pinductive = inductive puniverses type pconstructor = constructor puniverses @@ -92,34 +94,26 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of (constant * 'univs) + | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) | Construct of (constructor * 'univs) | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr + | Proj of Projection.t * 'constr (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t, t, Sorts.t, Instance.t) kind_of_term type constr = t type existential = existential_key * constr array -type rec_declaration = Name.t array * constr array * constr array -type fixpoint = (int array * int) * rec_declaration - (* The array of [int]'s tells for each component of the array of - mutual fixpoints the number of lambdas to skip before finding the - recursive argument (e.g., value is 2 in "fix f (x:A) (y:=t) (z:B) - (v:=u) (w:I) {struct w}"), telling to skip x and z and that w is - the recursive argument); - The second component [int] tells which component of the block is - returned *) -type cofixpoint = int * rec_declaration - (* The component [int] tells which component of the block of - cofixpoint is returned *) type types = constr +type rec_declaration = (constr, types) prec_declaration +type fixpoint = (constr, types) pfixpoint +type cofixpoint = (constr, types) pcofixpoint + (*********************) (* Term constructors *) (*********************) @@ -136,8 +130,8 @@ let mkProp = Sort Sorts.prop let mkSet = Sort Sorts.set let mkType u = Sort (Sorts.Type u) let mkSort = function - | Sorts.Prop Sorts.Null -> mkProp (* Easy sharing *) - | Sorts.Prop Sorts.Pos -> mkSet + | Sorts.Prop -> mkProp (* Easy sharing *) + | Sorts.Set -> mkSet | s -> Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) @@ -233,7 +227,6 @@ let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id - (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -250,6 +243,168 @@ let of_kind = function | Cast (c, knd, t) -> mkCast (c, knd, t) | k -> k +(**********************************************************************) +(* Non primitive term destructors *) +(**********************************************************************) + +(* Destructor operations : partial functions + Raise [DestKO] if the const has not the expected form *) + +exception DestKO + +let isMeta c = match kind c with Meta _ -> true | _ -> false + +(* Destructs a type *) +let isSort c = match kind c with + | Sort _ -> true + | _ -> false + +let rec isprop c = match kind c with + | Sort (Sorts.Prop | Sorts.Set) -> true + | Cast (c,_,_) -> isprop c + | _ -> false + +let rec is_Prop c = match kind c with + | Sort Sorts.Prop -> true + | Cast (c,_,_) -> is_Prop c + | _ -> false + +let rec is_Set c = match kind c with + | Sort Sorts.Set -> true + | Cast (c,_,_) -> is_Set c + | _ -> false + +let rec is_Type c = match kind c with + | Sort (Sorts.Type _) -> true + | Cast (c,_,_) -> is_Type c + | _ -> false + +let is_small = Sorts.is_small +let iskind c = isprop c || is_Type c + +(* Tests if an evar *) +let isEvar c = match kind c with Evar _ -> true | _ -> false +let isEvar_or_Meta c = match kind c with + | Evar _ | Meta _ -> true + | _ -> false + +let isCast c = match kind c with Cast _ -> true | _ -> false +(* Tests if a de Bruijn index *) +let isRel c = match kind c with Rel _ -> true | _ -> false +let isRelN n c = + match kind c with Rel n' -> Int.equal n n' | _ -> false +(* Tests if a variable *) +let isVar c = match kind c with Var _ -> true | _ -> false +let isVarId id c = match kind c with Var id' -> Id.equal id id' | _ -> false +(* Tests if an inductive *) +let isInd c = match kind c with Ind _ -> true | _ -> false +let isProd c = match kind c with | Prod _ -> true | _ -> false +let isLambda c = match kind c with | Lambda _ -> true | _ -> false +let isLetIn c = match kind c with LetIn _ -> true | _ -> false +let isApp c = match kind c with App _ -> true | _ -> false +let isConst c = match kind c with Const _ -> true | _ -> false +let isConstruct c = match kind c with Construct _ -> true | _ -> false +let isCase c = match kind c with Case _ -> true | _ -> false +let isProj c = match kind c with Proj _ -> true | _ -> false +let isFix c = match kind c with Fix _ -> true | _ -> false +let isCoFix c = match kind c with CoFix _ -> true | _ -> false + +(* Destructs a de Bruijn index *) +let destRel c = match kind c with + | Rel n -> n + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destMeta c = match kind c with + | Meta n -> n + | _ -> raise DestKO + +(* Destructs a variable *) +let destVar c = match kind c with + | Var id -> id + | _ -> raise DestKO + +let destSort c = match kind c with + | Sort s -> s + | _ -> raise DestKO + +(* Destructs a casted term *) +let destCast c = match kind c with + | Cast (t1,k,t2) -> (t1,k,t2) + | _ -> raise DestKO + +(* Destructs the product (x:t1)t2 *) +let destProd c = match kind c with + | Prod (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the abstraction [x:t1]t2 *) +let destLambda c = match kind c with + | Lambda (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the let [x:=b:t1]t2 *) +let destLetIn c = match kind c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) + | _ -> raise DestKO + +(* Destructs an application *) +let destApp c = match kind c with + | App (f,a) -> (f, a) + | _ -> raise DestKO + +(* Destructs a constant *) +let destConst c = match kind c with + | Const kn -> kn + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destEvar c = match kind c with + | Evar (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a (co)inductive type named kn *) +let destInd c = match kind c with + | Ind (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a constructor *) +let destConstruct c = match kind c with + | Construct (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) +let destCase c = match kind c with + | Case (ci,p,c,v) -> (ci,p,c,v) + | _ -> raise DestKO + +let destProj c = match kind c with + | Proj (p, c) -> (p, c) + | _ -> raise DestKO + +let destFix c = match kind c with + | Fix fix -> fix + | _ -> raise DestKO + +let destCoFix c = match kind c with + | CoFix cofix -> cofix + | _ -> raise DestKO + + +(******************************************************************) +(* Flattening and unflattening of embedded applications and casts *) +(******************************************************************) + +let decompose_app c = + match kind c with + | App (f,cl) -> (f, Array.to_list cl) + | _ -> (c,[]) + +let decompose_appvect c = + match kind c with + | App (f,cl) -> (f, cl) + | _ -> (c,[||]) + (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) @@ -305,16 +460,44 @@ let iter_with_binders g f n c = match kind c with | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c - | App (c,l) -> f n c; CArray.Fun1.iter f n l - | Evar (_,l) -> CArray.Fun1.iter f n l - | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl + | App (c,l) -> f n c; Array.Fun1.iter f n l + | Evar (_,l) -> Array.Fun1.iter f n l + | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(_,tl,bl)) -> - CArray.Fun1.iter f n tl; - CArray.Fun1.iter f (iterate g (Array.length tl) n) bl + Array.Fun1.iter f n tl; + Array.Fun1.iter f (iterate g (Array.length tl) n) bl | CoFix (_,(_,tl,bl)) -> - CArray.Fun1.iter f n tl; - CArray.Fun1.iter f (iterate g (Array.length tl) n) bl + Array.Fun1.iter f n tl; + Array.Fun1.iter f (iterate g (Array.length tl) n) bl + +(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate + subterms of [c] starting from [acc] and proceeding from left to + right according to the usual representation of the constructions as + [fold_constr] but 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 *) + +let fold_constr_with_binders g f n acc c = + match kind c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g n) (f n acc t) c + | Lambda (na,t,c) -> f (g n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (p,c) -> f n acc c + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd (* [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is @@ -346,7 +529,7 @@ let map f c = match kind c with else mkLetIn (na, b', t', k') | App (b,l) -> let b' = f b in - let l' = Array.smartmap f l in + let l' = Array.Smart.map f l in if b'==b && l'==l then c else mkApp (b', l') | Proj (p,t) -> @@ -354,23 +537,23 @@ let map f c = match kind c with if t' == t then c else mkProj (p, t') | Evar (e,l) -> - let l' = Array.smartmap f l in + let l' = Array.Smart.map f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) -> let b' = f b in let p' = f p in - let bl' = Array.smartmap f bl in + let bl' = Array.Smart.map f bl in if b'==b && p'==p && bl'==bl then c else mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap f tl in - let bl' = Array.smartmap f bl in + let tl' = Array.Smart.map f tl in + let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.smartmap f tl in - let bl' = Array.smartmap f bl in + let tl' = Array.Smart.map f tl in + let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) @@ -402,7 +585,7 @@ let fold_map f accu c = match kind c with else accu, mkLetIn (na, b', t', k') | App (b,l) -> let accu, b' = f accu b in - let accu, l' = Array.smartfoldmap f accu l in + let accu, l' = Array.Smart.fold_left_map f accu l in if b'==b && l'==l then accu, c else accu, mkApp (b', l') | Proj (p,t) -> @@ -410,23 +593,23 @@ let fold_map f accu c = match kind c with if t' == t then accu, c else accu, mkProj (p, t') | Evar (e,l) -> - let accu, l' = Array.smartfoldmap f accu l in + let accu, l' = Array.Smart.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') | Case (ci,p,b,bl) -> let accu, b' = f accu b in let accu, p' = f accu p in - let accu, bl' = Array.smartfoldmap f accu bl in + let accu, bl' = Array.Smart.fold_left_map f accu bl in if b'==b && p'==p && bl'==bl then accu, c else accu, mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> - let accu, tl' = Array.smartfoldmap f accu tl in - let accu, bl' = Array.smartfoldmap f accu bl in + let accu, tl' = Array.Smart.fold_left_map f accu tl in + let accu, bl' = Array.Smart.fold_left_map f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let accu, tl' = Array.smartfoldmap f accu tl in - let accu, bl' = Array.smartfoldmap f accu bl in + let accu, tl' = Array.Smart.fold_left_map f accu tl in + let accu, bl' = Array.Smart.fold_left_map f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkCoFix (ln,(lna,tl',bl')) @@ -462,7 +645,7 @@ let map_with_binders g f l c0 = match kind c0 with else mkLetIn (na, b', t', c') | App (c, al) -> let c' = f l c in - let al' = CArray.Fun1.smartmap f l al in + let al' = Array.Fun1.Smart.map f l al in if c' == c && al' == al then c0 else mkApp (c', al') | Proj (p, t) -> @@ -470,27 +653,32 @@ let map_with_binders g f l c0 = match kind c0 with if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> - let al' = CArray.Fun1.smartmap f l al in + let al' = Array.Fun1.Smart.map f l al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> let p' = f l p in let c' = f l c in - let bl' = CArray.Fun1.smartmap f l bl in + let bl' = Array.Fun1.Smart.map f l bl in if p' == p && c' == c && bl' == bl then c0 else mkCase (ci, p', c', bl') | Fix (ln, (lna, tl, bl)) -> - let tl' = CArray.Fun1.smartmap f l tl in + let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in - let bl' = CArray.Fun1.smartmap f l' bl in + let bl' = Array.Fun1.Smart.map f l' bl in if tl' == tl && bl' == bl then c0 else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = CArray.Fun1.smartmap f l tl in + let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in - let bl' = CArray.Fun1.smartmap f l' bl in + let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) +type instance_compare_fn = GlobRef.t -> int -> + Univ.Instance.t -> Univ.Instance.t -> bool + +type constr_compare_fn = int -> constr -> constr -> bool + (* [compare_head_gen_evar k1 k2 u s e eq leq c1 c2] compare [c1] and [c2] (using [k1] to expose the structure of [c1] and [k2] to expose the structure [c2]) using [eq] to compare the immediate subterms of @@ -502,35 +690,42 @@ let map_with_binders g f l c0 = match kind c0 with optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) -let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = +let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t1 t2 = match kind1 t1, kind2 t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 | Sort s1, Sort s2 -> leq_sorts s1 s2 - | Cast (c1,_,_), _ -> leq c1 t2 - | _, Cast (c2,_,_) -> leq t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 - | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 - | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) - | App (c1,l1), App (c2,l2) -> - Int.equal (Array.length l1) (Array.length l2) && - eq c1 c2 && Array.equal_norefl eq l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2 - | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 - | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 - | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 + | Cast (c1, _, _), _ -> leq nargs c1 t2 + | _, Cast (c2, _, _) -> leq nargs t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> eq 0 t1 t2 && leq 0 c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq 0 t1 t2 && eq 0 c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq 0 b1 b2 && eq 0 t1 t2 && leq nargs c1 c2 + (* Why do we suddenly make a special case for Cast here? *) + | App (Cast (c1, _, _), l1), _ -> leq nargs (mkApp (c1, l1)) t2 + | _, App (Cast (c2, _, _), l2) -> leq nargs t1 (mkApp (c2, l2)) + | App (c1, l1), App (c2, l2) -> + let len = Array.length l1 in + Int.equal len (Array.length l2) && + eq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 + | Const (c1,u1), Const (c2,u2) -> + (* The args length currently isn't used but may as well pass it. *) + Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (GlobRef.IndRef c1) nargs u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> + eq_constructor c1 c2 && leq_universes (GlobRef.ConstructRef c1) nargs u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2 + eq 0 p1 p2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> - Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 - && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 + && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - Int.equal ln1 ln2 && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 - | _ -> false + Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 + | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ + | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ + | CoFix _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -538,8 +733,8 @@ let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = application associativity, binders name and Cases annotations are not taken into account *) -let compare_head_gen_leq eq_universes leq_sorts eq leq t1 t2 = - compare_head_gen_leq_with kind kind eq_universes leq_sorts eq leq t1 t2 +let compare_head_gen_leq leq_universes leq_sorts eq leq t1 t2 = + compare_head_gen_leq_with kind kind leq_universes leq_sorts eq leq t1 t2 (* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed, [u] to @@ -556,7 +751,7 @@ let compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq t1 t2 = let compare_head_gen eq_universes eq_sorts eq t1 t2 = compare_head_gen_leq eq_universes eq_sorts eq eq t1 t2 -let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal +let compare_head = compare_head_gen (fun _ _ -> Univ.Instance.equal) Sorts.equal (*******************************) (* alpha conversion functions *) @@ -564,41 +759,41 @@ let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal (* alpha conversion : ignore print names and casts *) -let rec eq_constr m n = - (m == n) || compare_head_gen (fun _ -> Instance.equal) Sorts.equal eq_constr m n +let rec eq_constr nargs m n = + (m == n) || compare_head_gen (fun _ _ -> Instance.equal) Sorts.equal eq_constr nargs m n -let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) +let equal n m = eq_constr 0 m n (* to avoid tracing a recursive fun *) let eq_constr_univs univs m n = if m == n then true else - let eq_universes _ = UGraph.check_eq_instances univs in + let eq_universes _ _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in - let rec eq_constr' m n = - m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n - in compare_head_gen eq_universes eq_sorts eq_constr' m n + let rec eq_constr' nargs m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n + in compare_head_gen eq_universes eq_sorts eq_constr' 0 m n let leq_constr_univs univs m n = if m == n then true else - let eq_universes _ = UGraph.check_eq_instances univs in + let eq_universes _ _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let leq_sorts s1 s2 = s1 == s2 || UGraph.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in - let rec eq_constr' m n = - m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + let rec eq_constr' nargs m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n in - let rec compare_leq m n = - compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - compare_leq m n + let rec compare_leq nargs m n = + compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' nargs m n + and leq_constr' nargs m n = m == n || compare_leq nargs m n in + compare_leq 0 m n let eq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in - let eq_universes strict = UGraph.check_eq_instances univs in + let eq_universes _ _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else @@ -608,17 +803,17 @@ let eq_constr_univs_infer univs m n = (cstrs := Univ.enforce_eq u1 u2 !cstrs; true) in - let rec eq_constr' m n = - m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + let rec eq_constr' nargs m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n in - let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in + let res = compare_head_gen eq_universes eq_sorts eq_constr' 0 m n in res, !cstrs let leq_constr_univs_infer univs m n = if m == n then true, Constraint.empty else let cstrs = ref Constraint.empty in - let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in + let eq_universes _ _ l l' = UGraph.check_eq_instances univs l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else @@ -633,25 +828,22 @@ let leq_constr_univs_infer univs m n = let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in if UGraph.check_leq univs u1 u2 then true else - (cstrs := Univ.enforce_leq u1 u2 !cstrs; - true) + (try let c, _ = UGraph.enforce_leq_alg u1 u2 univs in + cstrs := Univ.Constraint.union c !cstrs; + true + with Univ.UniverseInconsistency _ -> false) in - let rec eq_constr' m n = - m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + let rec eq_constr' nargs m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n in - let rec compare_leq m n = - compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - let res = compare_leq m n in + let rec compare_leq nargs m n = + compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' nargs m n + and leq_constr' nargs m n = m == n || compare_leq nargs m n in + let res = compare_leq 0 m n in res, !cstrs -let always_true _ _ = true - let rec eq_constr_nounivs m n = - (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n - -(** We only use this function over blocks! *) -let tag t = Obj.tag (Obj.repr t) + (m == n) || compare_head_gen (fun _ _ _ _ -> true) (fun _ _ -> true) (fun _ -> eq_constr_nounivs) 0 m n let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= @@ -664,35 +856,50 @@ let constr_ord_int f t1 t2 = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in match kind t1, kind t2 with + | Cast (c1,_,_), _ -> f c1 t2 + | _, Cast (c2,_,_) -> f t1 c2 + (* Why this special case? *) + | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 + | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | Rel n1, Rel n2 -> Int.compare n1 n2 - | Meta m1, Meta m2 -> Int.compare m1 m2 + | Rel _, _ -> -1 | _, Rel _ -> 1 | Var id1, Var id2 -> Id.compare id1 id2 + | Var _, _ -> -1 | _, Var _ -> 1 + | Meta m1, Meta m2 -> Int.compare m1 m2 + | Meta _, _ -> -1 | _, Meta _ -> 1 + | Evar (e1,l1), Evar (e2,l2) -> + (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + | Evar _, _ -> -1 | _, Evar _ -> 1 | Sort s1, Sort s2 -> Sorts.compare s1 s2 - | Cast (c1,_,_), _ -> f c1 t2 - | _, Cast (c2,_,_) -> f t1 c2 + | Sort _, _ -> -1 | _, Sort _ -> 1 | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> (f =? f) t1 t2 c1 c2 + | Prod _, _ -> -1 | _, Prod _ -> 1 + | Lambda _, _ -> -1 | _, Lambda _ -> 1 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 - | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 - | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) + | LetIn _, _ -> -1 | _, LetIn _ -> 1 | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> - (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 - | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2 + | App _, _ -> -1 | _, App _ -> 1 + | Const (c1,u1), Const (c2,u2) -> Constant.CanOrd.compare c1 c2 + | Const _, _ -> -1 | _, Const _ -> 1 | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 + | Construct _, _ -> -1 | _, Construct _ -> 1 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 + | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 + | Fix _, _ -> -1 | _, Fix _ -> 1 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ((Int.compare =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 - | t1, t2 -> Int.compare (tag t1) (tag t2) + | CoFix _, _ -> -1 | _, CoFix _ -> 1 + | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 let rec compare m n= constr_ord_int compare m n @@ -776,7 +983,9 @@ let hasheq t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 - | _ -> false + | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ + | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ + | Fix _ | CoFix _), _ -> 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 *) @@ -1001,7 +1210,9 @@ let hcons = (* let hcons_types = hcons_constr *) -(*******) -(* Type of abstract machine values *) -(** FIXME: nothing to do there *) -type values +type rel_declaration = (constr, types) Context.Rel.Declaration.pt +type named_declaration = (constr, types) Context.Named.Declaration.pt +type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt +type rel_context = rel_declaration list +type named_context = named_declaration list +type compacted_context = compacted_declaration list diff --git a/kernel/constr.mli b/kernel/constr.mli index 76dbf55309..70acf19328 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** This file defines the most important datatype of Coq, namely kernel terms, @@ -13,20 +15,22 @@ open Names (** {6 Value under universe substitution } *) type 'a puniverses = 'a Univ.puniverses +[@@ocaml.deprecated "use Univ.puniverses"] (** {6 Simply type aliases } *) -type pconstant = constant puniverses -type pinductive = inductive puniverses -type pconstructor = constructor puniverses +type pconstant = Constant.t Univ.puniverses +type pinductive = inductive Univ.puniverses +type pconstructor = constructor Univ.puniverses (** {6 Existential variables } *) type existential_key = Evar.t +[@@ocaml.deprecated "use Evar.t"] (** {6 Existential variables } *) type metavariable = int (** {6 Case annotation } *) -type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle +type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle (** infer printing form from number of constructor *) type case_printing = { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) @@ -80,14 +84,14 @@ val mkVar : Id.t -> constr val mkMeta : metavariable -> constr (** Constructs an existential variable *) -type existential = existential_key * constr array +type existential = Evar.t * constr array val mkEvar : existential -> constr (** Construct a sort *) val mkSort : Sorts.t -> types val mkProp : types val mkSet : types -val mkType : Univ.universe -> types +val mkType : Univ.Universe.t -> types (** This defines the strategy to use for verifiying a Cast *) @@ -111,14 +115,14 @@ val mkLetIn : Name.t * constr * types * constr -> constr {%latex:$(f~t_1\dots f_n)$%}. *) val mkApp : constr * constr array -> constr -val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses -(** Constructs a constant *) -val mkConst : constant -> constr +(** Constructs a Constant.t *) +val mkConst : Constant.t -> constr val mkConstU : pconstant -> constr (** Constructs a projection application *) -val mkProj : (projection * constr) -> constr +val mkProj : (Projection.t * constr) -> constr (** Inductive types *) @@ -157,8 +161,26 @@ val mkCase : case_info * constr * constr * constr array -> constr where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) -type rec_declaration = Name.t array * types array * constr array -type fixpoint = (int array * int) * rec_declaration +type ('constr, 'types) prec_declaration = + Name.t array * 'types array * 'constr array +type ('constr, 'types) pfixpoint = + (int array * int) * ('constr, 'types) prec_declaration + (* The array of [int]'s tells for each component of the array of + mutual fixpoints the number of lambdas to skip before finding the + recursive argument (e.g., value is 2 in "fix f (x:A) (y:=t) (z:B) + (v:=u) (w:I) {struct w}"), telling to skip x and z and that w is + the recursive argument); + The second component [int] tells which component of the block is + returned *) + +type ('constr, 'types) pcofixpoint = + int * ('constr, 'types) prec_declaration + (* The component [int] tells which component of the block of + cofixpoint is returned *) + +type rec_declaration = (constr, types) prec_declaration + +type fixpoint = (constr, types) pfixpoint val mkFix : fixpoint -> constr (** If [funnames = [|f1,.....fn|]] @@ -172,7 +194,7 @@ val mkFix : fixpoint -> constr ... with fn = bn.] *) -type cofixpoint = int * rec_declaration +type cofixpoint = (constr, types) pcofixpoint val mkCoFix : cofixpoint -> constr @@ -180,13 +202,7 @@ val mkCoFix : cofixpoint -> constr (** [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 = - Name.t array * 'types array * 'constr array -type ('constr, 'types) pfixpoint = - (int array * int) * ('constr, 'types) prec_declaration -type ('constr, 'types) pcofixpoint = - int * ('constr, 'types) prec_declaration +type 'constr pexistential = Evar.t * 'constr array type ('constr, 'types, 'sort, 'univs) kind_of_term = | Rel of int (** Gallina-variable introduced by [forall], [fun], [let-in], [fix], or [cofix]. *) @@ -201,14 +217,14 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Cast of 'constr * cast_kind * 'types | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) - | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) + | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: - [F] itself is not {!App} - and [[|P1;..;Pn|]] is not empty. *) - | Const of (constant * 'univs) (** Gallina-variable that was introduced by Vernacular-command that extends the global environment + | Const of (Constant.t * 'univs) (** Gallina-variable that was introduced by Vernacular-command that extends the global environment (i.e. [Parameter], or [Axiom], or [Definition], or [Theorem] etc.) *) | Ind of (inductive * 'univs) (** A name of an inductive type defined by [Variant], [Inductive] or [Record] Vernacular-commands. *) @@ -216,7 +232,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr + | Proj of Projection.t * 'constr (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -225,6 +241,110 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = val kind : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term val of_kind : (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -> constr +(** {6 Simple case analysis} *) +val isRel : constr -> bool +val isRelN : int -> constr -> bool +val isVar : constr -> bool +val isVarId : Id.t -> constr -> bool +val isInd : constr -> bool +val isEvar : constr -> bool +val isMeta : constr -> bool +val isEvar_or_Meta : constr -> bool +val isSort : constr -> bool +val isCast : constr -> bool +val isApp : constr -> bool +val isLambda : constr -> bool +val isLetIn : constr -> bool +val isProd : constr -> bool +val isConst : constr -> bool +val isConstruct : constr -> bool +val isFix : constr -> bool +val isCoFix : constr -> bool +val isCase : constr -> bool +val isProj : constr -> bool + +val is_Prop : constr -> bool +val is_Set : constr -> bool +val isprop : constr -> bool +val is_Type : constr -> bool +val iskind : constr -> bool +val is_small : Sorts.t -> bool + +(** {6 Term destructors } *) +(** Destructor operations are partial functions and + @raise DestKO if the term has not the expected form. *) + +exception DestKO + +(** Destructs a de Bruijn index *) +val destRel : constr -> int + +(** Destructs an existential variable *) +val destMeta : constr -> metavariable + +(** Destructs a variable *) +val destVar : constr -> Id.t + +(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether + [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) +val destSort : constr -> Sorts.t + +(** Destructs a casted term *) +val destCast : constr -> constr * cast_kind * constr + +(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) +val destProd : types -> Name.t * types * types + +(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) +val destLambda : constr -> Name.t * types * constr + +(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) +val destLetIn : constr -> Name.t * constr * types * constr + +(** Destructs an application *) +val destApp : constr -> constr * constr array + +(** Decompose any term as an applicative term; the list of args can be empty *) +val decompose_app : constr -> constr * constr list + +(** Same as [decompose_app], but returns an array. *) +val decompose_appvect : constr -> constr * constr array + +(** Destructs a constant *) +val destConst : constr -> Constant.t Univ.puniverses + +(** Destructs an existential variable *) +val destEvar : constr -> existential + +(** Destructs a (co)inductive type *) +val destInd : constr -> inductive Univ.puniverses + +(** Destructs a constructor *) +val destConstruct : constr -> constructor Univ.puniverses + +(** 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 a projection *) +val destProj : constr -> Projection.t * constr + +(** 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 + +(** {6 Equality} *) + (** [equal a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val equal : constr -> constr -> bool @@ -252,6 +372,15 @@ val eq_constr_nounivs : constr -> constr -> bool (** Total ordering compatible with [equal] *) val compare : constr -> constr -> int +(** {6 Extension of Context with declarations on constr} *) + +type rel_declaration = (constr, types) Context.Rel.Declaration.pt +type named_declaration = (constr, types) Context.Named.Declaration.pt +type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt +type rel_context = rel_declaration list +type named_context = named_declaration list +type compacted_context = compacted_declaration list + (** {6 Functionals working on the immediate subterm of a construction } *) (** [fold f acc c] folds [f] on the immediate subterms of [c] @@ -294,31 +423,47 @@ val iter : (constr -> unit) -> constr -> unit val iter_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit +(** [iter_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 + subterms are processed is not specified *) + +val fold_constr_with_binders : + ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b + +type constr_compare_fn = int -> constr -> constr -> bool + (** [compare_head 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_head : (constr -> constr -> bool) -> constr -> constr -> bool +val compare_head : constr_compare_fn -> constr_compare_fn + +(** Convert a global reference applied to 2 instances. The int says + how many arguments are given (as we can only use cumulativity for + fully applied inductives/constructors) .*) +type instance_compare_fn = GlobRef.t -> int -> + Univ.Instance.t -> Univ.Instance.t -> bool -(** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed, [u] to compare universe - instances (the first boolean tells if they belong to a constant), [s] to - compare sorts; Cast's, binders name and Cases annotations are not taken - into account *) +(** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to + compare the immediate subterms of [c1] of [c2] if needed, [u] to + compare universe instances, [s] to compare sorts; Cast's, binders + name and Cases annotations are not taken into account *) -val compare_head_gen : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> +val compare_head_gen : instance_compare_fn -> (Sorts.t -> Sorts.t -> bool) -> - (constr -> constr -> bool) -> - constr -> constr -> bool + constr_compare_fn -> + constr_compare_fn val compare_head_gen_leq_with : (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> - (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> + instance_compare_fn -> (Sorts.t -> Sorts.t -> bool) -> - (constr -> constr -> bool) -> - (constr -> constr -> bool) -> - constr -> constr -> bool + constr_compare_fn -> + constr_compare_fn -> + constr_compare_fn (** [compare_head_gen_with k1 k2 u s f c1 c2] compares [c1] and [c2] like [compare_head_gen u s f c1 c2], except that [k1] (resp. [k2]) @@ -327,24 +472,24 @@ val compare_head_gen_leq_with : val compare_head_gen_with : (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> - (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> + instance_compare_fn -> (Sorts.t -> Sorts.t -> bool) -> - (constr -> constr -> bool) -> - constr -> constr -> bool + constr_compare_fn -> + constr_compare_fn (** [compare_head_gen_leq u s f fle c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] for conversion, [fle] for cumulativity, [u] to compare universe - instances (the first boolean tells if they belong to a constant), + instances (the first boolean tells if they belong to a Constant.t), [s] to compare sorts for for subtyping; Cast's, binders name and Cases annotations are not taken into account *) -val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> +val compare_head_gen_leq : instance_compare_fn -> (Sorts.t -> Sorts.t -> bool) -> - (constr -> constr -> bool) -> - (constr -> constr -> bool) -> - constr -> constr -> bool - + constr_compare_fn -> + constr_compare_fn -> + constr_compare_fn + (** {6 Hashconsing} *) val hash : constr -> int @@ -353,7 +498,3 @@ val case_info_hash : case_info -> int (*********************************************************************) val hcons : constr -> constr - -(**************************************) - -type values diff --git a/kernel/context.ml b/kernel/context.ml index 929324efec..4a7204b75c 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jean-Christophe Filliâtre out of names.ml as part of the @@ -41,8 +43,6 @@ struct | LocalAssum of Name.t * 'types (** name, type *) | LocalDef of Name.t * 'constr * 'types (** name, value, type *) - type t = (Constr.constr, Constr.types) pt - (** Return the name bound by a given declaration. *) let get_name = function | LocalAssum (na,_) @@ -149,13 +149,16 @@ struct | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (na, v, ty) -> LocalAssum (na, ty) + end (** Rel-context is represented as a list of declarations. Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list (** empty rel-context *) let empty = [] @@ -190,7 +193,7 @@ struct let equal eq l = List.equal (fun c -> Declaration.equal eq c) l (** Map all terms in a given rel-context. *) - let map f = List.smartmap (Declaration.map_constr f) + let map f = List.Smart.map (Declaration.map_constr f) (** Perform a given action on every declaration in a given rel-context. *) let iter f = List.iter (Declaration.iter_constr f) @@ -212,6 +215,8 @@ struct | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx in aux [] l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) @@ -239,8 +244,6 @@ struct | LocalAssum of Id.t * 'types (** identifier, type *) | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) - type t = (Constr.constr, Constr.types) pt - (** Return the identifier bound by a given declaration. *) let get_id = function | LocalAssum (id,_) -> id @@ -351,6 +354,10 @@ struct | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (id, v, ty) -> LocalAssum (id, ty) + let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> LocalAssum (f na, t) @@ -368,7 +375,6 @@ struct Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list (** empty named-context *) let empty = [] @@ -379,8 +385,9 @@ struct (** Return the number of {e local declarations} in a given named-context. *) let length = List.length -(** Return a declaration designated by a given de Bruijn index. - @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function +(** Return a declaration designated by a given identifier + @raise Not_found if the designated identifier is not present in the designated named-context. *) + let rec lookup id = function | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl | _ :: sign -> lookup id sign | [] -> raise Not_found @@ -389,7 +396,7 @@ struct let equal eq l = List.equal (fun c -> Declaration.equal eq c) l (** Map all terms in a given named-context. *) - let map f = List.smartmap (Declaration.map_constr f) + let map f = List.Smart.map (Declaration.map_constr f) (** Perform a given action on every declaration in a given named-context. *) let iter f = List.iter (Declaration.iter_constr f) @@ -406,6 +413,8 @@ struct let to_vars l = List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it @@ -426,8 +435,6 @@ module Compacted = | LocalAssum of Id.t list * 'types | LocalDef of Id.t list * 'constr * 'types - type t = (Constr.constr, Constr.types) pt - let map_constr f = function | LocalAssum (ids, ty) as decl -> let ty' = f ty in @@ -451,7 +458,6 @@ module Compacted = end type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list let fold f l ~init = List.fold_right f l init end diff --git a/kernel/context.mli b/kernel/context.mli index c3ecd8d4ea..2b0d36cb8c 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** The modules defined below represent a {e local context} @@ -33,8 +35,6 @@ sig | LocalAssum of Name.t * 'types (** name, type *) | LocalDef of Name.t * 'constr * 'types (** name, value, type *) - type t = (Constr.constr, Constr.types) pt - (** Return the name bound by a given declaration. *) val get_name : ('c, 't) pt -> Name.t @@ -85,13 +85,15 @@ sig val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt end (** Rel-context is represented as a list of declarations. Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list (** empty rel-context *) val empty : ('c, 't) pt @@ -130,6 +132,9 @@ sig and each {e local definition} is mapped to [false]. *) val to_tags : ('c, 't) pt -> bool list + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [extended_list mk n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args] where [mk] is used to build the corresponding variables. @@ -151,8 +156,6 @@ sig | LocalAssum of Id.t * 'types (** identifier, type *) | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) - type t = (Constr.constr, Constr.types) pt - (** Return the identifier bound by a given declaration. *) val get_id : ('c, 't) pt -> Id.t @@ -205,6 +208,9 @@ sig val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt + (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value. The function provided as the first parameter determines how to translate "names" to "ids". *) val of_rel_decl : (Name.t -> Id.t) -> ('c, 't) Rel.Declaration.pt -> ('c, 't) pt @@ -218,7 +224,6 @@ sig Inner-most declarations are at the beginning of the list. Outer-most declarations are at the end of the list. *) type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list (** empty named-context *) val empty : ('c, 't) pt @@ -253,6 +258,9 @@ sig (** Return the set of all identifiers bound in a given named-context. *) val to_vars : ('c, 't) pt -> Id.Set.t + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [to_instance Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named-context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it @@ -268,15 +276,12 @@ sig | LocalAssum of Id.t list * 'types | LocalDef of Id.t list * 'constr * 'types - type t = (Constr.constr, Constr.types) pt - val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt val of_named_decl : ('c, 't) Named.Declaration.pt -> ('c, 't) pt val to_named_context : ('c, 't) pt -> ('c, 't) Named.pt end type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list - type t = Declaration.t list val fold : (('c, 't) Declaration.pt -> 'a -> 'a) -> ('c, 't) pt -> init:'a -> 'a end diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index ca568fc6ec..7ef63c1860 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Bruno Barras as part of the rewriting of the conversion diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 248cd2b30e..67add5dd35 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names @@ -16,7 +18,7 @@ val empty : oracle If [oracle_order kn1 kn2] is true, then unfold kn1 first. Note: the oracle does not introduce incompleteness, it only tries to postpone unfolding of "opaque" constants. *) -val oracle_order : ('a -> constant) -> oracle -> bool -> +val oracle_order : ('a -> Constant.t) -> oracle -> bool -> 'a tableKey -> 'a tableKey -> bool (** Priority for the expansion of constant in the conversion test. @@ -30,14 +32,14 @@ val transparent : level (** Check whether a level is transparent *) val is_transparent : level -> bool -val get_strategy : oracle -> constant tableKey -> level +val get_strategy : oracle -> Constant.t tableKey -> level (** Sets the level of a constant. * Level of RelKey constant cannot be set. *) -val set_strategy : oracle -> constant tableKey -> level -> oracle +val set_strategy : oracle -> Constant.t tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) -val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a +val fold_strategy : (Constant.t tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a val get_transp_state : oracle -> transparent_state diff --git a/kernel/cooking.ml b/kernel/cooking.ml index b9e7ec1691..c06358054e 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jean-Christophe Filliâtre out of V6.3 file constants.ml @@ -17,8 +19,8 @@ open CErrors open Util open Names open Term +open Constr open Declarations -open Environ open Univ module NamedDecl = Context.Named.Declaration @@ -30,15 +32,15 @@ let pop_dirpath p = match DirPath.repr p with | _::l -> DirPath.make l let pop_mind kn = - let (mp,dir,l) = Names.repr_mind kn in - Names.make_mind mp (pop_dirpath dir) l + let (mp,dir,l) = MutInd.repr3 kn in + MutInd.make3 mp (pop_dirpath dir) l let pop_con con = - let (mp,dir,l) = Names.repr_con con in - Names.make_con mp (pop_dirpath dir) l + let (mp,dir,l) = Constant.repr3 con in + Constant.make3 mp (pop_dirpath dir) l type my_global_reference = - | ConstRef of constant + | ConstRef of Constant.t | IndRef of inductive | ConstructRef of constructor @@ -101,42 +103,38 @@ let expmod_constr cache modlist c = let share_univs = share_univs cache in let update_case_info = update_case_info cache in let rec substrec c = - match kind_of_term c with + match kind c with | Case (ci,p,t,br) -> - map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) + Constr.map substrec (mkCase (update_case_info ci modlist,p,t,br)) | Ind (ind,u) -> (try share_univs (IndRef ind) u modlist with - | Not_found -> map_constr substrec c) + | Not_found -> Constr.map substrec c) | Construct (cstr,u) -> (try share_univs (ConstructRef cstr) u modlist with - | Not_found -> map_constr substrec c) + | Not_found -> Constr.map substrec c) | Const (cst,u) -> (try share_univs (ConstRef cst) u modlist with - | Not_found -> map_constr substrec c) + | Not_found -> Constr.map substrec c) | Proj (p, c') -> - (try - let p' = share_univs (ConstRef (Projection.constant p)) Univ.Instance.empty modlist in - let make c = Projection.make c (Projection.unfolded p) in - match kind_of_term p' with - | Const (p',_) -> mkProj (make p', substrec c') - | App (f, args) -> - (match kind_of_term f with - | Const (p', _) -> mkProj (make p', substrec c') - | _ -> assert false) - | _ -> assert false - with Not_found -> map_constr substrec c) - - | _ -> map_constr substrec c + let map cst npars = + let _, newpars = Mindmap.find cst (snd modlist) in + pop_mind cst, npars + Array.length newpars + in + let p' = try Projection.map_npars map p with Not_found -> p in + let c'' = substrec c' in + if p == p' && c' == c'' then c else mkProj (p', c'') + + | _ -> Constr.map substrec c in if is_empty_modlist modlist then c @@ -151,9 +149,13 @@ let abstract_constant_body = type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = - constant_def * constant_type * projection_body option * - constant_universes * inline * Context.Named.t option +type result = { + cook_body : constant_def; + cook_type : types; + cook_universes : constant_universes; + cook_inline : inline; + cook_context : Constr.named_context option; +} let on_body ml hy f = function | Undef _ as x -> x @@ -162,48 +164,53 @@ let on_body ml hy f = function OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f { Opaqueproof.modlist = ml; abstract = hy } o) -let constr_of_def otab = function - | Undef _ -> assert false - | Def cs -> Mod_subst.force_constr cs - | OpaqueDef lc -> Opaqueproof.force_proof otab lc - let expmod_constr_subst cache modlist subst c = + let subst = Univ.make_instance_subst subst in let c = expmod_constr cache modlist c in Vars.subst_univs_level_constr subst c -let cook_constr { Opaqueproof.modlist ; abstract } c = +let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c = let cache = RefTable.create 13 in - let expmod = expmod_constr_subst cache modlist (pi2 abstract) in - let hyps = Context.Named.map expmod (pi1 abstract) in + let expmod = expmod_constr_subst cache modlist subst in + let hyps = Context.Named.map expmod vars in abstract_constant_body (expmod c) hyps -let lift_univs cb subst = +let lift_univs cb subst auctx0 = match cb.const_universes with - | Monomorphic_const ctx -> subst, (Monomorphic_const ctx) - | Polymorphic_const auctx -> - if (Univ.LMap.is_empty subst) then - subst, (Polymorphic_const auctx) + | Monomorphic_const ctx -> + assert (AUContext.is_empty auctx0); + subst, (Monomorphic_const ctx) + | Polymorphic_const auctx -> + (** Given a named instance [subst := u₀ ... uₙ₋₁] together with an abstract + context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length, + and another abstract context relative to the former context + [auctx := 0 ... m - 1 |= C'{u₀, ..., uₙ₋₁, 0, ..., m - 1}], + construct the lifted abstract universe context + [0 ... n - 1 n ... n + m - 1 |= + C{0, ... n - 1} ∪ + C'{0, ..., n - 1, n, ..., n + m - 1} ] + together with the instance + [u₀ ... uₙ₋₁ Var(0) ... Var (m - 1)]. + *) + if (Univ.Instance.is_empty subst) then + (** Still need to take the union for the constraints between globals *) + subst, (Polymorphic_const (AUContext.union auctx0 auctx)) else - let inst = Univ.AUContext.instance auctx in - let len = Univ.LMap.cardinal subst in - let subst = - Array.fold_left_i - (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc) - subst (Univ.Instance.to_array inst) - in - let auctx' = Univ.subst_univs_level_abstract_universe_context subst auctx in - subst, (Polymorphic_const auctx') - -let cook_constant ~hcons env { from = cb; info } = + let ainst = Univ.make_abstract_instance auctx in + let subst = Instance.append subst ainst in + let auctx' = Univ.subst_univs_level_abstract_universe_context (Univ.make_instance_subst subst) auctx in + subst, (Polymorphic_const (AUContext.union auctx0 auctx')) + +let cook_constant ~hcons { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in - let usubst, univs = lift_univs cb usubst in + let usubst, univs = lift_univs cb usubst abs_ctx in let expmod = expmod_constr_subst cache modlist usubst in let hyps = Context.Named.map expmod abstract in let map c = let c = abstract_constant_body (expmod c) hyps in - if hcons then hcons_constr c else c + if hcons then Constr.hcons c else c in let body = on_body modlist (hyps, usubst, abs_ctx) map @@ -214,50 +221,16 @@ let cook_constant ~hcons env { from = cb; info } = List.filter (fun decl' -> not (Id.equal (NamedDecl.get_id decl) (NamedDecl.get_id decl'))) hyps) hyps ~init:cb.const_hyps in - let typ = match cb.const_type with - | RegularArity t -> - let typ = - abstract_constant_type (expmod t) hyps in - RegularArity typ - | TemplateArity (ctx,s) -> - let t = mkArity (ctx,Type s.template_level) in - let typ = abstract_constant_type (expmod t) hyps in - let j = make_judge (constr_of_def (opaque_tables env) body) typ in - Typeops.make_polymorphic_if_constant_for_ind env j - in - let projection pb = - let c' = abstract_constant_body (expmod pb.proj_body) hyps in - let etab = abstract_constant_body (expmod (fst pb.proj_eta)) hyps in - let etat = abstract_constant_body (expmod (snd pb.proj_eta)) hyps in - let ((mind, _), _), n' = - try - let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in - match kind_of_term c' with - | App (f,l) -> (destInd f, Array.length l) - | Ind ind -> ind, 0 - | _ -> assert false - with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) - in - let typ = (* By invariant, a regular arity *) - match typ with RegularArity t -> t | TemplateArity _ -> assert false - in - let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in - { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; - proj_eta = etab, etat; - proj_type = ty'; proj_body = c' } - in - let univs = - match univs with - | Monomorphic_const ctx -> - Monomorphic_const (UContext.union (instantiate_univ_context abs_ctx) ctx) - | Polymorphic_const auctx -> - Polymorphic_const (AUContext.union abs_ctx auctx) - in - (body, typ, Option.map projection cb.const_proj, - univs, cb.const_inline_code, - Some const_hyps) - -(* let cook_constant_key = Profile.declare_profile "cook_constant" *) -(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) + let typ = abstract_constant_type (expmod cb.const_type) hyps in + { + cook_body = body; + cook_type = typ; + cook_universes = univs; + cook_inline = cb.const_inline_code; + cook_context = Some const_hyps; + } + +(* let cook_constant_key = CProfile.declare_profile "cook_constant" *) +(* let cook_constant = CProfile.profile2 cook_constant_key cook_constant *) let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 79a028d760..6ebe691b83 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -1,14 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open Declarations -open Environ (** {6 Cooking the constants. } *) @@ -16,12 +17,16 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool -type result = - constant_def * constant_type * projection_body option * - constant_universes * inline * Context.Named.t option +type result = { + cook_body : constant_def; + cook_type : types; + cook_universes : constant_universes; + cook_inline : inline; + cook_context : Constr.named_context option; +} -val cook_constant : hcons:bool -> env -> recipe -> result -val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr +val cook_constant : hcons:bool -> recipe -> result +val cook_constr : Opaqueproof.cooking_info -> constr -> constr (** {6 Utility functions used in module [Discharge]. } *) diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index d21ea9670f..bb9231d000 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Bruno Barras for Benjamin Grégoire as part of the @@ -14,19 +16,19 @@ open Util open Names -open Term -open Vm +open Vmvalues open Cemitcodes open Cbytecodes open Declarations -open Pre_env +open Environ open Cbytegen module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration -external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" -external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" +external eval_tcode : tcode -> atom array -> vm_global -> values array -> values = "coq_eval_tcode" + +type global_data = { mutable glob_len : int; mutable glob_val : values array } (*******************) (* Linkage du code *) @@ -37,91 +39,53 @@ external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" (* [global_data] contient les valeurs des constantes globales (axiomes,definitions), les annotations des switch et les structured constant *) -external global_data : unit -> values array = "get_coq_global_data" +let global_data = { + glob_len = 0; + glob_val = Array.make 4096 crazy_val; +} -(* [realloc_global_data n] augmente de n la taille de [global_data] *) -external realloc_global_data : int -> unit = "realloc_coq_global_data" +let get_global_data () = Vmvalues.vm_global global_data.glob_val -let check_global_data n = - if n >= Array.length (global_data()) then realloc_global_data n +let realloc_global_data n = + let n = min (2 * n + 0x100) Sys.max_array_length in + let ans = Array.make n crazy_val in + let src = global_data.glob_val in + let () = Array.blit src 0 ans 0 (Array.length src) in + global_data.glob_val <- ans -let num_global = ref 0 +let check_global_data n = + if n >= Array.length global_data.glob_val then realloc_global_data n let set_global v = - let n = !num_global in + let n = global_data.glob_len in check_global_data n; - (global_data()).(n) <- v; - incr num_global; + global_data.glob_val.(n) <- v; + global_data.glob_len <- global_data.glob_len + 1; n (* table pour les structured_constant et les annotations des switchs *) -let rec eq_structured_constant c1 c2 = match c1, c2 with -| Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2 -| Const_sorts _, _ -> false -| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 -| Const_ind _, _ -> false -| Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 -| Const_proj _, _ -> false -| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 -| Const_b0 _, _ -> false -| Const_bn (t1, a1), Const_bn (t2, a2) -> - Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2 -| Const_bn _, _ -> false -| Const_univ_level l1 , Const_univ_level l2 -> Univ.eq_levels l1 l2 -| Const_univ_level _ , _ -> false -| Const_type u1 , Const_type u2 -> Univ.Universe.equal u1 u2 -| Const_type _ , _ -> false - -let rec hash_structured_constant c = - let open Hashset.Combine in - match c with - | Const_sorts s -> combinesmall 1 (Sorts.hash s) - | Const_ind i -> combinesmall 2 (ind_hash i) - | Const_proj p -> combinesmall 3 (Constant.hash p) - | Const_b0 t -> combinesmall 4 (Int.hash t) - | Const_bn (t, a) -> - let fold h c = combine h (hash_structured_constant c) in - let h = Array.fold_left fold 0 a in - combinesmall 5 (combine (Int.hash t) h) - | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) - | Const_type u -> combinesmall 7 (Univ.Universe.hash u) - module SConstTable = Hashtbl.Make (struct type t = structured_constant let equal = eq_structured_constant let hash = hash_structured_constant end) -let eq_annot_switch asw1 asw2 = - let eq_ci ci1 ci2 = - eq_ind ci1.ci_ind ci2.ci_ind && - Int.equal ci1.ci_npar ci2.ci_npar && - Array.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls - in - let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in - eq_ci asw1.ci asw2.ci && - Array.equal eq_rlc asw1.rtbl asw2.rtbl && - (asw1.tailcall : bool) == asw2.tailcall - -let hash_annot_switch asw = - let open Hashset.Combine in - let h1 = Constr.case_info_hash asw.ci in - let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in - let h3 = if asw.tailcall then 1 else 0 in - combine3 h1 h2 h3 - module AnnotTable = Hashtbl.Make (struct type t = annot_switch let equal = eq_annot_switch let hash = hash_annot_switch end) +module ProjNameTable = Hashtbl.Make (Projection.Repr) + let str_cst_tbl : int SConstTable.t = SConstTable.create 31 let annot_tbl : int AnnotTable.t = AnnotTable.create 31 (* (annot_switch * int) Hashtbl.t *) +let proj_name_tbl : int ProjNameTable.t = ProjNameTable.create 31 + (*************************************************************) (*** Mise a jour des valeurs des variables et des constantes *) (*************************************************************) @@ -155,6 +119,13 @@ let slot_for_annot key = AnnotTable.add annot_tbl key n; n +let slot_for_proj_name key = + try ProjNameTable.find proj_name_tbl key + with Not_found -> + let n = set_global (val_of_proj_name key) in + ProjNameTable.add proj_name_tbl key n; + n + let rec slot_for_getglobal env kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk @@ -182,42 +153,42 @@ and slot_for_fv env fv = | None -> v_of_id id, Id.Set.empty | Some c -> val_of_constr (env_of_id id env) c, - Environ.global_vars_set (Environ.env_of_pre_env env) c in + Environ.global_vars_set env c in build_lazy_val cache (v, d); v in let val_of_rel i = val_of_rel (nb_rel env - i) in let idfun _ x = x in match fv with | FVnamed id -> - let nv = Pre_env.lookup_named_val id env in + let nv = lookup_named_val id env in begin match force_lazy_val nv with | None -> - env |> Pre_env.lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun + env |> lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> - let rv = Pre_env.lookup_rel_val i env in + let rv = lookup_rel_val i env in begin match force_lazy_val rv with | None -> - env.env_rel_context |> Context.Rel.lookup i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel + env |> lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end + | FVevar evk -> val_of_evar evk | FVuniv_var idu -> assert false and eval_to_patch env (buff,pl,fv) = - let patch = function - | Reloc_annot a, pos -> (pos, slot_for_annot a) - | Reloc_const sc, pos -> (pos, slot_for_str_cst sc) - | Reloc_getglobal kn, pos -> (pos, slot_for_getglobal env kn) + let slots = function + | Reloc_annot a -> slot_for_annot a + | Reloc_const sc -> slot_for_str_cst sc + | Reloc_getglobal kn -> slot_for_getglobal env kn + | Reloc_proj_name p -> slot_for_proj_name p in - let patches = List.map_left patch pl in - let buff = patch_int buff patches in + let tc = patch buff pl slots in let vm_env = Array.map (slot_for_fv env) fv in - let tc = tcode_of_code buff (length buff) in - eval_tcode tc vm_env + eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env and val_of_constr env c = - match compile true env c with + match compile ~fail_on_error:true env c with | Some v -> eval_to_patch env (to_memory v) | None -> assert false diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index 633cf0abdd..72c96b0b9f 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -1,18 +1,22 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* $Id$ *) open Names -open Term -open Pre_env +open Constr +open Environ -val val_of_constr : env -> constr -> values +val val_of_constr : env -> constr -> Vmvalues.values -val set_opaque_const : constant -> unit -val set_transparent_const : constant -> unit +val set_opaque_const : Constant.t -> unit +val set_transparent_const : Constant.t -> unit + +val get_global_data : unit -> Vmvalues.vm_global diff --git a/kernel/declarations.ml b/kernel/declarations.ml index f35438dfc4..0811eb72fd 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr (** This module defines the internal representation of global declarations. This includes global constants/axioms, mutual @@ -28,16 +30,14 @@ type engagement = set_predicativity *) type template_arity = { - template_param_levels : Univ.universe_level option list; - template_level : Univ.universe; + template_param_levels : Univ.Level.t option list; + template_level : Univ.Universe.t; } type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b -type constant_type = (types, Context.Rel.t * template_arity) declaration_arity - (** Inlining level of parameters at functor applications. None means no inlining *) @@ -46,18 +46,6 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) -(** Projections are a particular kind of constant: - always transparent. *) - -type projection_body = { - proj_ind : mutual_inductive; - proj_npars : int; - proj_arg : int; - proj_type : types; (* Type under params *) - proj_eta : constr * types; (* Eta-expanded term and type *) - proj_body : constr; (* For compatibility with VMs only, the match version *) -} - (* Global declarations (i.e. constants) can be either: *) type constant_def = | Undef of inline (** a global assumption *) @@ -65,8 +53,8 @@ type constant_def = | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) type constant_universes = - | Monomorphic_const of Univ.universe_context - | Polymorphic_const of Univ.abstract_universe_context + | Monomorphic_const of Univ.ContextSet.t + | Polymorphic_const of Univ.AUContext.t (** The [typing_flags] are instructions to the type-checker which modify its behaviour. The typing flags used in the type-checking @@ -76,17 +64,17 @@ type typing_flags = { check_guarded : bool; (** If [false] then fixed points and co-fixed points are assumed to be total. *) check_universes : bool; (** If [false] universe constraints are not checked *) + conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *) } (* some contraints are in constant_constraints, some other may be in * the OpaqueDef *) type constant_body = { - const_hyps : Context.Named.t; (** New: younger hyp at top *) + const_hyps : Constr.named_context; (** New: younger hyp at top *) const_body : constant_def; - const_type : constant_type; + const_type : types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; - const_proj : projection_body option; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which were used for @@ -111,17 +99,26 @@ v} *) (** Record information: - If the record is not primitive, then None - Otherwise, we get: + If the type is not a record, then NotRecord + If the type is a non-primitive record, then FakeRecord + If it is a primitive record, for every type in the block, we get: - The identifier for the binder name of the record in primitive projections. - The constants associated to each projection. - - The checked projection bodies. *) + - The projection types (under parameters). -type record_body = (Id.t * constant array * projection_body array) option + The kernel does not exploit the difference between [NotRecord] and + [FakeRecord]. It is mostly used by extraction, and should be extruded from + the kernel at some point. +*) + +type record_info = +| NotRecord +| FakeRecord +| PrimRecord of (Id.t * Label.t array * types array) array type regular_inductive_arity = { mind_user_arity : types; - mind_sort : sorts; + mind_sort : Sorts.t; } type inductive_arity = (regular_inductive_arity, template_arity) declaration_arity @@ -131,7 +128,7 @@ type one_inductive_body = { mind_typename : Id.t; (** Name of the type: [Ii] *) - mind_arity_ctxt : Context.Rel.t; (** Arity context of [Ii] with parameters: [forall params, Ui] *) + mind_arity_ctxt : Constr.rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity : inductive_arity; (** Arity sort and original user arity *) @@ -148,7 +145,7 @@ type one_inductive_body = { mind_nrealdecls : int; (** Length of realargs context (with let, no params) *) - mind_kelim : sorts_family list; (** List of allowed elimination sorts *) + mind_kelim : Sorts.family list; (** List of allowed elimination sorts *) mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) @@ -170,27 +167,32 @@ type one_inductive_body = { } type abstract_inductive_universes = - | Monomorphic_ind of Univ.universe_context - | Polymorphic_ind of Univ.abstract_universe_context - | Cumulative_ind of Univ.abstract_cumulativity_info + | Monomorphic_ind of Univ.ContextSet.t + | Polymorphic_ind of Univ.AUContext.t + | Cumulative_ind of Univ.ACumulativityInfo.t + +type recursivity_kind = + | Finite (** = inductive *) + | CoFinite (** = coinductive *) + | BiFinite (** = non-recursive, like in "Record" definitions *) type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) - mind_record : record_body option; (** The record information *) + mind_record : record_info; (** The record information *) - mind_finite : Decl_kinds.recursivity_kind; (** Whether the type is inductive or coinductive *) + mind_finite : recursivity_kind; (** Whether the type is inductive or coinductive *) mind_ntypes : int; (** Number of types in the block *) - mind_hyps : Context.Named.t; (** Section hypotheses on which the block depends *) + mind_hyps : Constr.named_context; (** Section hypotheses on which the block depends *) mind_nparams : int; (** Number of expected parameters including non-uniform ones (i.e. length of mind_params_ctxt w/o let-in) *) mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *) - mind_params_ctxt : Context.Rel.t; (** The context of parameters (includes let-in declaration) *) + mind_params_ctxt : Constr.rel_context; (** The context of parameters (includes let-in declaration) *) mind_universes : abstract_inductive_universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) @@ -214,12 +216,12 @@ type ('ty,'a) functorize = only for short module printing and for extraction. *) type with_declaration = - | WithMod of Id.t list * module_path - | WithDef of Id.t list * constr Univ.in_universe_context + | WithMod of Id.t list * ModPath.t + | WithDef of Id.t list * (constr * Univ.AUContext.t option) type module_alg_expr = - | MEident of module_path - | MEapply of module_alg_expr * module_path + | MEident of ModPath.t + | MEapply of module_alg_expr * ModPath.t | MEwith of module_alg_expr * with_declaration (** A component of a module structure *) @@ -252,16 +254,16 @@ and module_implementation = | Struct of module_signature (** interactive body *) | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *) -and module_body = - { mod_mp : module_path; (** absolute path of the module *) - mod_expr : module_implementation; (** implementation *) +and 'a generic_module_body = + { mod_mp : ModPath.t; (** absolute path of the module *) + mod_expr : 'a; (** implementation *) mod_type : module_signature; (** expanded type *) mod_type_alg : module_expression option; (** algebraic type *) mod_constraints : Univ.ContextSet.t; (** set of all universes constraints in the module *) mod_delta : Mod_subst.delta_resolver; (** quotiented set of equivalent constants and inductive names *) - mod_retroknowledge : Retroknowledge.action list } + mod_retroknowledge : 'a module_retroknowledge } (** For a module, there are five possible situations: - [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T] @@ -271,13 +273,19 @@ and module_body = - [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T] And of course, all these situations may be functors or not. *) -(** A [module_type_body] is just a [module_body] with no - implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge]. Its [mod_type_alg] contains +and module_body = module_implementation generic_module_body + +(** A [module_type_body] is just a [module_body] with no implementation and + also an empty [mod_retroknowledge]. Its [mod_type_alg] contains the algebraic definition of this module type, or [None] if it has been built interactively. *) -and module_type_body = module_body +and module_type_body = unit generic_module_body + +and _ module_retroknowledge = +| ModBodyRK : + Retroknowledge.action list -> module_implementation module_retroknowledge +| ModTypeRK : unit module_retroknowledge (** Extra invariants : @@ -286,5 +294,5 @@ and module_type_body = module_body - A module application is atomic, for instance ((M N) P) : * the head of [MEapply] can only be another [MEapply] or a [MEident] - * the argument of [MEapply] is now directly forced to be a [module_path]. + * the argument of [MEapply] is now directly forced to be a [ModPath.t]. *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 9a75b19937..bbe4bc0dcb 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Declarations @@ -15,9 +17,10 @@ module RelDecl = Context.Rel.Declaration (** Operations concernings types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) -let safe_flags = { +let safe_flags oracle = { check_guarded = true; check_universes = true; + conv_oracle = oracle; } (** {6 Arities } *) @@ -39,83 +42,24 @@ let map_decl_arity f g = function let hcons_template_arity ar = { template_param_levels = ar.template_param_levels; - (* List.smartmap (Option.smartmap Univ.hcons_univ_level) ar.template_param_levels; *) + (* List.Smart.map (Option.Smart.map Univ.hcons_univ_level) ar.template_param_levels; *) template_level = Univ.hcons_univ ar.template_level } (** {6 Constants } *) -let instantiate cb c = - match cb.const_universes with - | Monomorphic_const _ -> c - | Polymorphic_const ctx -> - Vars.subst_instance_constr (Univ.AUContext.instance ctx) c - let constant_is_polymorphic cb = match cb.const_universes with | Monomorphic_const _ -> false | Polymorphic_const _ -> true -let body_of_constant otab cb = match cb.const_body with - | Undef _ -> None - | Def c -> Some (instantiate cb (force_constr c)) - | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o)) - -let type_of_constant cb = - match cb.const_type with - | RegularArity t as x -> - let t' = instantiate cb t in - if t' == t then x else RegularArity t' - | TemplateArity _ as x -> x - -let constraints_of_constant otab cb = - match cb.const_universes with - | Polymorphic_const ctx -> - Univ.UContext.constraints (Univ.instantiate_univ_context ctx) - | Monomorphic_const ctx -> - Univ.Constraint.union - (Univ.UContext.constraints ctx) - (match cb.const_body with - | Undef _ -> Univ.empty_constraint - | Def c -> Univ.empty_constraint - | OpaqueDef o -> - Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o)) - -let universes_of_constant otab cb = - match cb.const_body with - | Undef _ | Def _ -> - begin - match cb.const_universes with - | Monomorphic_const ctx -> ctx - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx - end - | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints otab o in - match cb.const_universes with - | Monomorphic_const ctx -> - let uctxs = Univ.ContextSet.of_context ctx in - Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) - | Polymorphic_const ctx -> - assert(Univ.ContextSet.is_empty body_uctxs); - Univ.instantiate_univ_context ctx - -let universes_of_polymorphic_constant otab cb = - match cb.const_universes with - | Monomorphic_const _ -> Univ.UContext.empty - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx - let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true -let constant_polymorphic_instance cb = - match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.AUContext.instance ctx - let constant_polymorphic_context cb = match cb.const_universes with - | Monomorphic_const _ -> Univ.UContext.empty - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx + | Monomorphic_const _ -> Univ.AUContext.empty + | Polymorphic_const ctx -> ctx let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true @@ -126,12 +70,8 @@ let is_opaque cb = match cb.const_body with let subst_rel_declaration sub = RelDecl.map_constr (subst_mps sub) -let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) +let subst_rel_context sub = List.Smart.map (subst_rel_declaration sub) -let subst_template_cst_arity sub (ctx,s as arity) = - let ctx' = subst_rel_context sub ctx in - if ctx==ctx' then arity else (ctx',s) - let subst_const_type sub arity = if is_empty_subst sub then arity else subst_mps sub arity @@ -143,25 +83,18 @@ let subst_const_def sub def = match def with | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) -let subst_const_proj sub pb = - { pb with proj_ind = subst_mind sub pb.proj_ind; - proj_type = subst_mps sub pb.proj_type; - proj_body = subst_const_type sub pb.proj_body } - let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb else let body' = subst_const_def sub cb.const_body in - let type' = subst_decl_arity subst_const_type subst_template_cst_arity sub cb.const_type in - let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in + let type' = subst_const_type sub cb.const_type in if body' == cb.const_body && type' == cb.const_type - && proj' == cb.const_proj then cb + then cb else { const_hyps = []; const_body = body'; const_type = type'; - const_proj = proj'; const_body_code = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; @@ -175,36 +108,28 @@ let subst_const_body sub cb = themselves. But would it really bring substantial gains ? *) let hcons_rel_decl = - RelDecl.map_name Names.Name.hcons %> RelDecl.map_value Term.hcons_constr %> RelDecl.map_type Term.hcons_types + RelDecl.map_name Names.Name.hcons %> RelDecl.map_value Constr.hcons %> RelDecl.map_type Constr.hcons -let hcons_rel_context l = List.smartmap hcons_rel_decl l - -let hcons_regular_const_arity t = Term.hcons_constr t - -let hcons_template_const_arity (ctx, ar) = - (hcons_rel_context ctx, hcons_template_arity ar) - -let hcons_const_type = - map_decl_arity hcons_regular_const_arity hcons_template_const_arity +let hcons_rel_context l = List.Smart.map hcons_rel_decl l let hcons_const_def = function | Undef inl -> Undef inl | Def l_constr -> let constr = force_constr l_constr in - Def (from_val (Term.hcons_constr constr)) + Def (from_val (Constr.hcons constr)) | OpaqueDef _ as x -> x (* hashconsed when turned indirect *) let hcons_const_universes cbu = match cbu with | Monomorphic_const ctx -> - Monomorphic_const (Univ.hcons_universe_context ctx) + Monomorphic_const (Univ.hcons_universe_context_set ctx) | Polymorphic_const ctx -> Polymorphic_const (Univ.hcons_abstract_universe_context ctx) let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; - const_type = hcons_const_type cb.const_type; + const_type = Constr.hcons cb.const_type; const_universes = hcons_const_universes cb.const_universes } (** {6 Inductive types } *) @@ -246,7 +171,7 @@ let recarg_length p j = let (_,cstrs) = Rtree.dest_node p in Array.length (snd (Rtree.dest_node cstrs.(j-1))) -let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p +let subst_wf_paths sub p = Rtree.Smart.map (subst_recarg sub) p (** {7 Substitution of inductive declarations } *) @@ -266,10 +191,10 @@ let subst_mind_packet sub mbp = mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; - mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; + mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; @@ -278,14 +203,20 @@ let subst_mind_packet sub mbp = mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } -let subst_mind_record sub (id, ps, pb as r) = - let ps' = Array.smartmap (subst_constant sub) ps in - let pb' = Array.smartmap (subst_const_proj sub) pb in - if ps' == ps && pb' == pb then r - else (id, ps', pb') +let subst_mind_record sub r = match r with +| NotRecord -> NotRecord +| FakeRecord -> FakeRecord +| PrimRecord infos -> + let map (id, ps, pb as info) = + let pb' = Array.Smart.map (subst_mps sub) pb in + if pb' == pb then info + else (id, ps, pb') + in + let infos' = Array.Smart.map map infos in + if infos' == infos then r else PrimRecord infos' let subst_mind_body sub mib = - { mind_record = Option.smartmap (Option.smartmap (subst_mind_record sub)) mib.mind_record ; + { mind_record = subst_mind_record sub mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false); @@ -293,25 +224,17 @@ let subst_mind_body sub mib = mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; - mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; + mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } -let inductive_polymorphic_instance mib = - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind ctx -> Univ.AUContext.instance ctx - | Cumulative_ind cumi -> - Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) - let inductive_polymorphic_context mib = match mib.mind_universes with - | Monomorphic_ind _ -> Univ.UContext.empty - | Polymorphic_ind ctx -> Univ.instantiate_univ_context ctx - | Cumulative_ind cumi -> - Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) + | Monomorphic_ind _ -> Univ.AUContext.empty + | Polymorphic_ind ctx -> ctx + | Cumulative_ind cumi -> Univ.ACumulativityInfo.univ_context cumi let inductive_is_polymorphic mib = match mib.mind_universes with @@ -325,11 +248,30 @@ let inductive_is_cumulative mib = | Polymorphic_ind ctx -> false | Cumulative_ind cumi -> true +let inductive_make_projection ind mib ~proj_arg = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + Some (Names.Projection.Repr.make ind + ~proj_npars:mib.mind_nparams + ~proj_arg + (pi2 infos.(snd ind)).(proj_arg)) + +let inductive_make_projections ind mib = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + let projs = Array.mapi (fun proj_arg lab -> + Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) + (pi2 infos.(snd ind)) + in + Some projs + (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = - { mind_user_arity = Term.hcons_constr a.mind_user_arity; - mind_sort = Term.hcons_sorts a.mind_sort } + { mind_user_arity = Constr.hcons a.mind_user_arity; + mind_sort = Sorts.hcons a.mind_sort } (** Just as for constants, this hash-consing is quite partial *) @@ -339,36 +281,36 @@ let hcons_ind_arity = (** Substitution of inductive declarations *) let hcons_mind_packet oib = - let user = Array.smartmap Term.hcons_types oib.mind_user_lc in - let nf = Array.smartmap Term.hcons_types oib.mind_nf_lc in + let user = Array.Smart.map Constr.hcons oib.mind_user_lc in + let nf = Array.Smart.map Constr.hcons oib.mind_nf_lc in (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *) let nf = if Array.equal (==) user nf then user else nf in { oib with mind_typename = Names.Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; mind_arity = hcons_ind_arity oib.mind_arity; - mind_consnames = Array.smartmap Names.Id.hcons oib.mind_consnames; + mind_consnames = Array.Smart.map Names.Id.hcons oib.mind_consnames; mind_user_lc = user; mind_nf_lc = nf } let hcons_mind_universes miu = match miu with - | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context ctx) + | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context_set ctx) | Polymorphic_ind ctx -> Polymorphic_ind (Univ.hcons_abstract_universe_context ctx) | Cumulative_ind cui -> Cumulative_ind (Univ.hcons_abstract_cumulativity_info cui) let hcons_mind mib = { mib with - mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; + mind_packets = Array.Smart.map hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; mind_universes = hcons_mind_universes mib.mind_universes } (** {6 Stm machinery } *) let string_of_side_effect { Entries.eff } = match eff with - | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")" + | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.Constant.to_string c ^ ")" | Entries.SEscheme (cl,_) -> - "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")" + "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.Constant.to_string c) cl) ^ ")" (** Hashconsing of modules *) @@ -397,7 +339,7 @@ let rec hcons_structure_field_body sb = match sb with let mb' = hcons_module_body mb in if mb == mb' then sb else SFBmodule mb' | SFBmodtype mb -> - let mb' = hcons_module_body mb in + let mb' = hcons_module_type mb in if mb == mb' then sb else SFBmodtype mb' and hcons_structure_body sb = @@ -407,13 +349,13 @@ and hcons_structure_body sb = let sfb' = hcons_structure_field_body sfb in if l == l' && sfb == sfb' then fb else (l', sfb') in - List.smartmap map sb + List.Smart.map map sb and hcons_module_signature ms = - hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms + hcons_functorize hcons_module_type hcons_structure_body hcons_module_signature ms and hcons_module_expression me = - hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me + hcons_functorize hcons_module_type hcons_module_alg_expr hcons_module_expression me and hcons_module_implementation mip = match mip with | Abstract -> Abstract @@ -425,9 +367,11 @@ and hcons_module_implementation mip = match mip with if ms == ms' then mip else Struct ms | FullStruct -> FullStruct -and hcons_module_body mb = +and hcons_generic_module_body : + 'a. ('a -> 'a) -> 'a generic_module_body -> 'a generic_module_body = + fun hcons_impl mb -> let mp' = mb.mod_mp in - let expr' = hcons_module_implementation mb.mod_expr in + let expr' = hcons_impl mb.mod_expr in let type' = hcons_module_signature mb.mod_type in let type_alg' = mb.mod_type_alg in let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in @@ -452,3 +396,9 @@ and hcons_module_body mb = mod_delta = delta'; mod_retroknowledge = retroknowledge'; } + +and hcons_module_body mb = + hcons_generic_module_body hcons_module_implementation mb + +and hcons_module_type mb = + hcons_generic_module_body (fun () -> ()) mb diff --git a/kernel/declareops.mli b/kernel/declareops.mli index d698d88b4b..f91e69807f 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Declarations @@ -27,29 +29,14 @@ val subst_const_body : substitution -> constant_body -> constant_body val constant_has_body : constant_body -> bool -val constant_polymorphic_instance : constant_body -> universe_instance -val constant_polymorphic_context : constant_body -> universe_context +val constant_polymorphic_context : constant_body -> AUContext.t (** Is the constant polymorphic? *) val constant_is_polymorphic : constant_body -> bool -(** Accessing const_body, forcing access to opaque proof term if needed. - Only use this function if you know what you're doing. *) - -val body_of_constant : - Opaqueproof.opaquetab -> constant_body -> Term.constr option -val type_of_constant : constant_body -> constant_type -val constraints_of_constant : - Opaqueproof.opaquetab -> constant_body -> Univ.constraints -val universes_of_constant : - Opaqueproof.opaquetab -> constant_body -> Univ.universe_context - (** Return the universe context, in case the definition is polymorphic, otherwise the context is empty. *) -val universes_of_polymorphic_constant : - Opaqueproof.opaquetab -> constant_body -> Univ.universe_context - val is_opaque : constant_body -> bool (** Side effects *) @@ -72,18 +59,22 @@ val subst_wf_paths : substitution -> wf_paths -> wf_paths val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body -val inductive_polymorphic_instance : mutual_inductive_body -> universe_instance -val inductive_polymorphic_context : mutual_inductive_body -> universe_context +val inductive_polymorphic_context : mutual_inductive_body -> AUContext.t (** Is the inductive polymorphic? *) val inductive_is_polymorphic : mutual_inductive_body -> bool (** Is the inductive cumulative? *) val inductive_is_cumulative : mutual_inductive_body -> bool +val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj_arg:int -> + Names.Projection.Repr.t option +val inductive_make_projections : Names.inductive -> mutual_inductive_body -> + Names.Projection.Repr.t array option + (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) -val safe_flags : typing_flags +val safe_flags : Conv_oracle.oracle -> typing_flags (** {6 Hash-consing} *) @@ -94,3 +85,4 @@ val safe_flags : typing_flags val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body val hcons_module_body : module_body -> module_body +val hcons_module_type : module_type_body -> module_type_body diff --git a/kernel/entries.mli b/kernel/entries.ml index 3fa25c142a..40873bea76 100644 --- a/kernel/entries.mli +++ b/kernel/entries.ml @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr (** This module defines the entry types for global declarations. This information is entered in the environments. This includes global @@ -35,9 +37,9 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; *) type inductive_universes = - | Monomorphic_ind_entry of Univ.universe_context - | Polymorphic_ind_entry of Univ.universe_context - | Cumulative_ind_entry of Univ.cumulativity_info + | Monomorphic_ind_entry of Univ.ContextSet.t + | Polymorphic_ind_entry of Univ.UContext.t + | Cumulative_ind_entry of Univ.CumulativityInfo.t type one_inductive_entry = { mind_entry_typename : Id.t; @@ -47,11 +49,11 @@ type one_inductive_entry = { mind_entry_lc : constr list } type mutual_inductive_entry = { - mind_entry_record : (Id.t option) option; - (** Some (Some id): primitive record with id the binder name of the record - in projections. + mind_entry_record : (Id.t array option) option; + (** Some (Some ids): primitive records with ids the binder name of each + record in their respective projections. Not used by the kernel. Some None: non-primitive record *) - mind_entry_finite : Decl_kinds.recursivity_kind; + mind_entry_finite : Declarations.recursivity_kind; mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list; mind_entry_universes : inductive_universes; @@ -64,31 +66,38 @@ type mutual_inductive_entry = { type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation +type constant_universes_entry = + | Monomorphic_const_entry of Univ.ContextSet.t + | Polymorphic_const_entry of Univ.UContext.t + +type 'a in_constant_universes_entry = 'a * constant_universes_entry + type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) - const_entry_secctx : Context.Named.t option; + const_entry_secctx : Constr.named_context option; (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; - const_entry_polymorphic : bool; - const_entry_universes : Univ.universe_context; + const_entry_universes : constant_universes_entry; const_entry_opaque : bool; const_entry_inline_code : bool } +type section_def_entry = { + secdef_body : constr; + secdef_secctx : Constr.named_context option; + secdef_feedback : Stateid.t option; + secdef_type : types option; +} + type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Context.Named.t option * bool * types Univ.in_universe_context * inline - -type projection_entry = { - proj_entry_ind : mutual_inductive; - proj_entry_arg : int } + Constr.named_context option * types in_constant_universes_entry * inline type 'a constant_entry = | DefinitionEntry of 'a definition_entry | ParameterEntry of parameter_entry - | ProjectionEntry of projection_entry (** {6 Modules } *) @@ -109,11 +118,11 @@ type seff_env = [ `Nothing (* The proof term and its universes. Same as the constant_body's but not in an ephemeron *) - | `Opaque of Constr.t * Univ.universe_context_set ] + | `Opaque of Constr.t * Univ.ContextSet.t ] type side_eff = - | SEsubproof of constant * Declarations.constant_body * seff_env - | SEscheme of (inductive * constant * Declarations.constant_body * seff_env) list * string + | SEsubproof of Constant.t * Declarations.constant_body * seff_env + | SEscheme of (inductive * Constant.t * Declarations.constant_body * seff_env) list * string type side_effect = { from_env : Declarations.structure_body CEphemeron.key; diff --git a/kernel/environ.ml b/kernel/environ.ml index dd204c7d59..e7efa5e2c9 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Author: Jean-Christophe Filliâtre as part of the rebuilding of Coq @@ -23,26 +25,210 @@ open CErrors open Util open Names -open Term +open Constr open Vars open Declarations -open Pre_env open Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* The type of environments. *) -type named_context_val = Pre_env.named_context_val +(* The key attached to each constant is used by the VM to retrieve previous *) +(* evaluations of the constant. It is essentially an index in the symbols table *) +(* used by the VM. *) +type key = int CEphemeron.key option ref + +(** Linking information for the native compiler. *) + +type link_info = + | Linked of string + | LinkedInteractive of string + | NotLinked + +type constant_key = constant_body * (link_info ref * key) + +type mind_key = mutual_inductive_body * link_info ref + +type globals = { + env_constants : constant_key Cmap_env.t; + env_inductives : mind_key Mindmap_env.t; + env_modules : module_body MPmap.t; + env_modtypes : module_type_body MPmap.t; +} + +type stratification = { + env_universes : UGraph.t; + env_engagement : engagement +} + +type val_kind = + | VKvalue of (Vmvalues.values * Id.Set.t) CEphemeron.key + | VKnone + +type lazy_val = val_kind ref + +let force_lazy_val vk = match !vk with +| VKnone -> None +| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None + +let dummy_lazy_val () = ref VKnone +let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) + +type named_context_val = { + env_named_ctx : Constr.named_context; + env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t; +} + +type rel_context_val = { + env_rel_ctx : Constr.rel_context; + env_rel_map : (Constr.rel_declaration * lazy_val) Range.t; +} + +type env = { + env_globals : globals; + env_named_context : named_context_val; (* section variables *) + env_rel_context : rel_context_val; + env_nb_rel : int; + env_stratification : stratification; + env_typing_flags : typing_flags; + retroknowledge : Retroknowledge.retroknowledge; + indirect_pterms : Opaqueproof.opaquetab; +} + +let empty_named_context_val = { + env_named_ctx = []; + env_named_map = Id.Map.empty; +} + +let empty_rel_context_val = { + env_rel_ctx = []; + env_rel_map = Range.empty; +} + +let empty_env = { + env_globals = { + env_constants = Cmap_env.empty; + env_inductives = Mindmap_env.empty; + env_modules = MPmap.empty; + env_modtypes = MPmap.empty}; + env_named_context = empty_named_context_val; + env_rel_context = empty_rel_context_val; + env_nb_rel = 0; + env_stratification = { + env_universes = UGraph.initial_universes; + env_engagement = PredicativeSet }; + env_typing_flags = Declareops.safe_flags Conv_oracle.empty; + retroknowledge = Retroknowledge.initial_retroknowledge; + indirect_pterms = Opaqueproof.empty_opaquetab } + + +(* Rel context *) + +let push_rel_context_val d ctx = { + env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx; + env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map; +} + +let match_rel_context_val ctx = match ctx.env_rel_ctx with +| [] -> None +| decl :: rem -> + let (_, lval) = Range.hd ctx.env_rel_map in + let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in + Some (decl, lval, ctx) + +let push_rel d env = + { env with + env_rel_context = push_rel_context_val d env.env_rel_context; + env_nb_rel = env.env_nb_rel + 1 } + +let lookup_rel n env = + try fst (Range.get env.env_rel_context.env_rel_map (n - 1)) + with Invalid_argument _ -> raise Not_found + +let lookup_rel_val n env = + try snd (Range.get env.env_rel_context.env_rel_map (n - 1)) + with Invalid_argument _ -> raise Not_found + +let rel_skipn n ctx = { + env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx; + env_rel_map = Range.skipn n ctx.env_rel_map; +} + +let env_of_rel n env = + { env with + env_rel_context = rel_skipn n env.env_rel_context; + env_nb_rel = env.env_nb_rel - n + } + +(* Named context *) + +let push_named_context_val_val d rval ctxt = +(* assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *) + { + env_named_ctx = Context.Named.add d ctxt.env_named_ctx; + env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; + } + +let push_named_context_val d ctxt = + push_named_context_val_val d (ref VKnone) ctxt + +let match_named_context_val c = match c.env_named_ctx with +| [] -> None +| decl :: ctx -> + let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in + let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in + let cval = { env_named_ctx = ctx; env_named_map = map } in + Some (decl, v, cval) + +let map_named_val f ctxt = + let open Context.Named.Declaration in + let fold accu d = + let d' = map_constr f d in + let accu = + if d == d' then accu + else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu + in + (accu, d') + in + let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in + if map == ctxt.env_named_map then ctxt + else { env_named_ctx = ctx; env_named_map = map } + +let push_named d env = + {env with env_named_context = push_named_context_val d env.env_named_context} + +let lookup_named id env = + fst (Id.Map.find id env.env_named_context.env_named_map) + +let lookup_named_val id env = + snd(Id.Map.find id env.env_named_context.env_named_map) + +let lookup_named_ctxt id ctxt = + fst (Id.Map.find id ctxt.env_named_map) + +let fold_constants f env acc = + Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_constants acc + +(* Global constants *) + +let lookup_constant_key kn env = + Cmap_env.find kn env.env_globals.env_constants -type env = Pre_env.env +let lookup_constant kn env = + fst (Cmap_env.find kn env.env_globals.env_constants) -let pre_env env = env -let env_of_pre_env env = env -let oracle env = env.env_conv_oracle -let set_oracle env o = { env with env_conv_oracle = o } +(* Mutual Inductives *) +let lookup_mind kn env = + fst (Mindmap_env.find kn env.env_globals.env_inductives) -let empty_named_context_val = empty_named_context_val +let lookup_mind_key kn env = + Mindmap_env.find kn env.env_globals.env_inductives -let empty_env = empty_env +let oracle env = env.env_typing_flags.conv_oracle +let set_oracle env o = + let env_typing_flags = { env.env_typing_flags with conv_oracle = o } in + { env with env_typing_flags } let engagement env = env.env_stratification.env_engagement let typing_flags env = env.env_typing_flags @@ -58,26 +244,21 @@ let deactivated_guard env = not (typing_flags env).check_guarded let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context -let rel_context env = env.env_rel_context +let rel_context env = env.env_rel_context.env_rel_ctx let opaque_tables env = env.indirect_pterms let set_opaque_tables env indirect_pterms = { env with indirect_pterms } let empty_context env = - match env.env_rel_context, env.env_named_context.env_named_ctx with + match env.env_rel_context.env_rel_ctx, env.env_named_context.env_named_ctx with | [], [] -> true | _ -> false (* Rel context *) -let lookup_rel n env = - Context.Rel.lookup n env.env_rel_context - let evaluable_rel n env = is_local_def (lookup_rel n env) let nb_rel env = env.env_nb_rel -let push_rel = push_rel - let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = @@ -86,13 +267,12 @@ let push_rec_types (lna,typarray,_) env = let fold_rel_context f env ~init = let rec fold_right env = - match env.env_rel_context with - | [] -> init - | rd::rc -> + match match_rel_context_val env.env_rel_context with + | None -> init + | Some (rd, _, rc) -> let env = { env with env_rel_context = rc; - env_rel_val = List.tl env.env_rel_val; env_nb_rel = env.env_nb_rel - 1 } in f env rd (fold_right env) in fold_right env @@ -101,24 +281,16 @@ let fold_rel_context f env ~init = let named_context_of_val c = c.env_named_ctx -(* [map_named_val f ctxt] apply [f] to the body and the type of - each declarations. - *** /!\ *** [f t] should be convertible with t *) -let map_named_val = map_named_val +let ids_of_named_context_val c = Id.Map.domain c.env_named_map let empty_named_context = Context.Named.empty -let push_named = push_named let push_named_context = List.fold_right push_named -let push_named_context_val = push_named_context_val let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val -let lookup_named = lookup_named -let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map) - let eq_named_context_val c1 c2 = c1 == c2 || Context.Named.equal Constr.equal (named_context_of_val c1) (named_context_of_val c2) @@ -140,16 +312,21 @@ let evaluable_named id env = let reset_with_named_context ctxt env = { env with env_named_context = ctxt; - env_rel_context = Context.Rel.empty; - env_rel_val = []; + env_rel_context = empty_rel_context_val; env_nb_rel = 0 } let reset_context = reset_with_named_context empty_named_context_val let pop_rel_context n env = + let rec skip n ctx = + if Int.equal n 0 then ctx + else match match_rel_context_val ctx with + | None -> invalid_arg "List.skipn" + | Some (_, _, ctx) -> skip (pred n) ctx + in let ctxt = env.env_rel_context in { env with - env_rel_context = List.skipn n ctxt; + env_rel_context = skip n ctxt; env_nb_rel = env.env_nb_rel - n } let fold_named_context f env ~init = @@ -172,7 +349,10 @@ let map_universes f env = let s = env.env_stratification in { env with env_stratification = { s with env_universes = f s.env_universes } } - + +let set_universes env u = + { env with env_stratification = { env.env_stratification with env_universes = u } } + let add_constraints c env = if Univ.Constraint.is_empty c then env else map_universes (UGraph.merge_constraints c) env @@ -212,8 +392,6 @@ let set_typing_flags c env = (* Unsafe *) (* Global constants *) -let lookup_constant = lookup_constant - let no_link_info = NotLinked let add_constant_key kn cb linkinfo env = @@ -230,14 +408,7 @@ let add_constant kn cb env = let constraints_of cb u = match cb.const_universes with | Monomorphic_const _ -> Univ.Constraint.empty - | Polymorphic_const ctx -> - Univ.UContext.constraints (Univ.subst_instance_context u ctx) - -let map_regular_arity f = function - | RegularArity a as ar -> - let a' = f a in - if a' == a then ar else RegularArity a' - | TemplateArity _ -> assert false + | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx (* constant_type gives the type of a constant *) let constant_type env (kn,u) = @@ -246,45 +417,18 @@ let constant_type env (kn,u) = | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty | Polymorphic_const ctx -> let csts = constraints_of cb u in - (map_regular_arity (subst_instance_constr u) cb.const_type, csts) - -let constant_instance env kn = - let cb = lookup_constant kn env in - match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.AUContext.instance ctx + (subst_instance_constr u cb.const_type, csts) let constant_context env kn = let cb = lookup_constant kn env in match cb.const_universes with - | Monomorphic_const _ -> Univ.UContext.empty - | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx + | Monomorphic_const _ -> Univ.AUContext.empty + | Polymorphic_const ctx -> ctx -type const_evaluation_result = NoBody | Opaque | IsProj +type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result -let constant_value env (kn,u) = - let cb = lookup_constant kn env in - if cb.const_proj = None then - match cb.const_body with - | Def l_body -> - begin - match cb.const_universes with - | Monomorphic_const _ -> - (Mod_subst.force_constr l_body, Univ.Constraint.empty) - | Polymorphic_const _ -> - let csts = constraints_of cb u in - (subst_instance_constr u (Mod_subst.force_constr l_body), csts) - end - | OpaqueDef _ -> raise (NotEvaluableConst Opaque) - | Undef _ -> raise (NotEvaluableConst NoBody) - else raise (NotEvaluableConst IsProj) - -let constant_opt_value env cst = - try Some (constant_value env cst) - with NotEvaluableConst _ -> None - let constant_value_and_type env (kn, u) = let cb = lookup_constant kn env in if Declareops.constant_is_polymorphic cb then @@ -294,7 +438,7 @@ let constant_value_and_type env (kn, u) = | OpaqueDef _ -> None | Undef _ -> None in - b', map_regular_arity (subst_instance_constr u) cb.const_type, cst + b', subst_instance_constr u cb.const_type, cst else let b' = match cb.const_body with | Def l_body -> Some (Mod_subst.force_constr l_body) @@ -310,7 +454,7 @@ let constant_value_and_type env (kn, u) = let constant_type_in env (kn,u) = let cb = lookup_constant kn env in if Declareops.constant_is_polymorphic cb then - map_regular_arity (subst_instance_constr u) cb.const_type + subst_instance_constr u cb.const_type else cb.const_type let constant_value_in env (kn,u) = @@ -344,28 +488,26 @@ let polymorphic_pconstant (cst,u) env = let type_in_type_constant cst env = not (lookup_constant cst env).const_typing_flags.check_universes -let template_polymorphic_constant cst env = - match (lookup_constant cst env).const_type with - | TemplateArity _ -> true - | RegularArity _ -> false - -let template_polymorphic_pconstant (cst,u) env = - if not (Univ.Instance.is_empty u) then false - else template_polymorphic_constant cst env - -let lookup_projection cst env = - match (lookup_constant (Projection.constant cst) env).const_proj with - | Some pb -> pb - | None -> anomaly (Pp.str "lookup_projection: constant is not a projection.") - -let is_projection cst env = - match (lookup_constant cst env).const_proj with - | Some _ -> true - | None -> false +let lookup_projection p env = + let mind,i = Projection.inductive p in + let mib = lookup_mind mind env in + (if not (Int.equal mib.mind_nparams (Projection.npars p)) + then anomaly ~label:"lookup_projection" Pp.(str "Bad number of parameters on projection.")); + match mib.mind_record with + | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,_,typs = infos.(i) in + typs.(Projection.arg p) + +let get_projection env ind ~proj_arg = + let mib = lookup_mind (fst ind) env in + Declareops.inductive_make_projection ind mib ~proj_arg + +let get_projections env ind = + let mib = lookup_mind (fst ind) env in + Declareops.inductive_make_projections ind mib (* Mutual Inductives *) -let lookup_mind = lookup_mind - let polymorphic_ind (mind,i) env = Declareops.inductive_is_polymorphic (lookup_mind mind env) @@ -385,11 +527,11 @@ let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env -let add_mind_key kn mind_key env = +let add_mind_key kn (mind, _ as mind_key) env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in let new_globals = { env.env_globals with - env_inductives = new_inds } in + env_inductives = new_inds; } in { env with env_globals = new_globals } let add_mind kn mib env = @@ -411,7 +553,7 @@ let lookup_constructor_variables (ind,_) env = (* Returns the list of global variables in a term *) let vars_of_global env constr = - match kind_of_term constr with + match kind constr with Var id -> Id.Set.singleton id | Const (kn, _) -> lookup_constant_variables kn env | Ind (ind, _) -> lookup_inductive_variables ind env @@ -422,12 +564,12 @@ let vars_of_global env constr = let global_vars_set env constr = let rec filtrec acc c = let acc = - match kind_of_term c with + match kind c with | Var _ | Const _ | Ind _ | Construct _ -> Id.Set.union (vars_of_global env c) acc | _ -> acc in - Term.fold_constr filtrec acc c + Constr.fold filtrec acc c in filtrec Id.Set.empty constr @@ -498,14 +640,10 @@ let j_type j = j.uj_type type 'types punsafe_type_judgment = { utj_val : 'types; - utj_type : sorts } + utj_type : Sorts.t } type unsafe_type_judgment = types punsafe_type_judgment -(*s Compilation of global declaration *) - -let compile_constant_body = Cbytegen.compile_constant_body false - exception Hyp_not_found let apply_to_hyp ctxt id f = @@ -558,127 +696,9 @@ let register_one env field entry = let register env field entry = match field with | KInt31 (grp, Int31Type) -> - let i31c = match kind_of_term entry with + let i31c = match kind entry with | Ind i31t -> mkConstructUi (i31t, 1) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") in register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry | field -> register_one env field entry - -(* the Environ.register function syncrhonizes the proactive and reactive - retroknowledge. *) -let dispatch = - - (* subfunction used for static decompilation of int31 (after a vm_compute, - see pretyping/vnorm.ml for more information) *) - let constr_of_int31 = - let nth_digit_plus_one i n = (* calculates the nth (starting with 0) - digit of i and adds 1 to it - (nth_digit_plus_one 1 3 = 2) *) - if Int.equal (i land (1 lsl n)) 0 then - 1 - else - 2 - in - fun ind -> fun digit_ind -> fun tag -> - let array_of_int i = - Array.init 31 (fun n -> mkConstruct - (digit_ind, nth_digit_plus_one i (30-n))) - in - (* We check that no bit above 31 is set to one. This assertion used to - fail in the VM, and led to conversion tests failing at Qed. *) - assert (Int.equal (tag lsr 31) 0); - mkApp(mkConstruct(ind, 1), array_of_int tag) - in - - (* subfunction which dispatches the compiling information of an - int31 operation which has a specific vm instruction (associates - it to the name of the coq definition in the reactive retroknowledge) *) - let int31_op n op prim kn = - { empty_reactive_info with - vm_compiling = Some (Cbytegen.op_compilation n op kn); - native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn)); - } - in - -fun rk value field -> - (* subfunction which shortens the (very common) dispatch of operations *) - let int31_op_from_const n op prim = - match kind_of_term value with - | Const kn -> int31_op n op prim kn - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") - in - let int31_binop_from_const op prim = int31_op_from_const 2 op prim in - let int31_unop_from_const op prim = int31_op_from_const 1 op prim in - match field with - | KInt31 (grp, Int31Type) -> - let int31bit = - (* invariant : the type of bits is registered, otherwise the function - would raise Not_found. The invariant is enforced in safe_typing.ml *) - match field with - | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) - | _ -> anomaly ~label:"Environ.register" - (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") - in - let i31bit_type = - match kind_of_term int31bit with - | Ind (i31bit_type,_) -> i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "Int31Bits should be an inductive type.") - in - let int31_decompilation = - match kind_of_term value with - | Ind (i31t,_) -> - constr_of_int31 i31t i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "should be an inductive type.") - in - { empty_reactive_info with - vm_decompile_const = Some int31_decompilation; - vm_before_match = Some Cbytegen.int31_escape_before_match; - native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); - } - | KInt31 (_, Int31Constructor) -> - { empty_reactive_info with - vm_constant_static = Some Cbytegen.compile_structured_int31; - vm_constant_dynamic = Some Cbytegen.dynamic_int31_compilation; - native_constant_static = Some Nativelambda.compile_static_int31; - native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; - } - | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 - Primitives.Int31add - | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 - Primitives.Int31addc - | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 - Primitives.Int31addcarryc - | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 - Primitives.Int31sub - | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 - Primitives.Int31subc - | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const - Cbytecodes.Ksubcarrycint31 Primitives.Int31subcarryc - | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 - Primitives.Int31mul - | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 - Primitives.Int31mulc - | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 - Primitives.Int31div21 - | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 - Primitives.Int31diveucl - | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 - Primitives.Int31addmuldiv - | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 - Primitives.Int31compare - | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 - Primitives.Int31head0 - | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 - Primitives.Int31tail0 - | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 - Primitives.Int31lor - | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 - Primitives.Int31land - | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 - Primitives.Int31lxor - | _ -> empty_reactive_info - -let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/environ.mli b/kernel/environ.mli index f8887d8e83..f45b7be821 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -1,15 +1,17 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term -open Declarations +open Constr open Univ +open Declarations (** Unsafe environments. We define here a datatype for environments. Since typing is not yet defined, it is not possible to check the @@ -26,23 +28,63 @@ open Univ - a set of universe constraints - a flag telling if Set is, can be, or cannot be set impredicative *) +type lazy_val + +val build_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) -> unit +val force_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) option +val dummy_lazy_val : unit -> lazy_val + +(** Linking information for the native compiler *) +type link_info = + | Linked of string + | LinkedInteractive of string + | NotLinked + +type key = int CEphemeron.key option ref + +type constant_key = constant_body * (link_info ref * key) + +type mind_key = mutual_inductive_body * link_info ref + +type globals +(** globals = constants + projections + inductive types + modules + module-types *) + +type stratification = { + env_universes : UGraph.t; + env_engagement : engagement +} +type named_context_val = private { + env_named_ctx : Constr.named_context; + env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t; +} +type rel_context_val = private { + env_rel_ctx : Constr.rel_context; + env_rel_map : (Constr.rel_declaration * lazy_val) Range.t; +} + +type env = private { + env_globals : globals; + env_named_context : named_context_val; (* section variables *) + env_rel_context : rel_context_val; + env_nb_rel : int; + env_stratification : stratification; + env_typing_flags : typing_flags; + retroknowledge : Retroknowledge.retroknowledge; + indirect_pterms : Opaqueproof.opaquetab; +} -type env -val pre_env : env -> Pre_env.env -val env_of_pre_env : Pre_env.env -> env val oracle : env -> Conv_oracle.oracle val set_oracle : env -> Conv_oracle.oracle -> env -type named_context_val val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t -val rel_context : env -> Context.Rel.t -val named_context : env -> Context.Named.t +val rel_context : env -> Constr.rel_context +val named_context : env -> Constr.named_context val named_context_val : env -> named_context_val val opaque_tables : env -> Opaqueproof.opaquetab @@ -61,25 +103,28 @@ val empty_context : env -> bool (** {5 Context of de Bruijn variables ([rel_context]) } *) val nb_rel : env -> int -val push_rel : Context.Rel.Declaration.t -> env -> env -val push_rel_context : Context.Rel.t -> env -> env +val push_rel : Constr.rel_declaration -> env -> env +val push_rel_context : Constr.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 *) -val lookup_rel : int -> env -> Context.Rel.Declaration.t +val lookup_rel : int -> env -> Constr.rel_declaration +val lookup_rel_val : int -> env -> lazy_val val evaluable_rel : int -> env -> bool +val env_of_rel : int -> env -> env (** {6 Recurrence on [rel_context] } *) val fold_rel_context : - (env -> Context.Rel.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a + (env -> Constr.rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a (** {5 Context of variables (section variables and goal assumptions) } *) -val named_context_of_val : named_context_val -> Context.Named.t -val val_of_named_context : Context.Named.t -> named_context_val +val named_context_of_val : named_context_val -> Constr.named_context +val val_of_named_context : Constr.named_context -> named_context_val val empty_named_context_val : named_context_val +val ids_of_named_context_val : named_context_val -> Id.Set.t (** [map_named_val f ctxt] apply [f] to the body and the type of @@ -88,18 +133,19 @@ val empty_named_context_val : named_context_val val map_named_val : (constr -> constr) -> named_context_val -> named_context_val -val push_named : Context.Named.Declaration.t -> env -> env -val push_named_context : Context.Named.t -> env -> env +val push_named : Constr.named_declaration -> env -> env +val push_named_context : Constr.named_context -> env -> env val push_named_context_val : - Context.Named.Declaration.t -> named_context_val -> named_context_val + Constr.named_declaration -> named_context_val -> named_context_val (** Looks up in the context of local vars referred by names ([named_context]) raises [Not_found] if the Id.t is not found *) -val lookup_named : variable -> env -> Context.Named.Declaration.t -val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t +val lookup_named : variable -> env -> Constr.named_declaration +val lookup_named_val : variable -> env -> lazy_val +val lookup_named_ctxt : variable -> named_context_val -> Constr.named_declaration val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option @@ -107,11 +153,13 @@ val named_body : variable -> env -> constr option (** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : - (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a + (env -> Constr.named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + +val set_universes : env -> UGraph.t -> env (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : - ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a + ('a -> Constr.named_declaration -> 'a) -> init:'a -> env -> 'a (** This forgets named and rel contexts *) val reset_context : env -> env @@ -122,26 +170,26 @@ val reset_with_named_context : named_context_val -> env -> env (** This removes the [n] last declarations from the rel context *) val pop_rel_context : int -> env -> env +(** Useful for printing *) +val fold_constants : (Constant.t -> constant_body -> 'a -> 'a) -> env -> 'a -> 'a + (** {5 Global constants } {6 Add entries to global environment } *) -val add_constant : constant -> constant_body -> env -> env -val add_constant_key : constant -> constant_body -> Pre_env.link_info -> +val add_constant : Constant.t -> constant_body -> env -> env +val add_constant_key : Constant.t -> constant_body -> link_info -> env -> env +val lookup_constant_key : Constant.t -> env -> constant_key (** 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 +val lookup_constant : Constant.t -> env -> constant_body +val evaluable_constant : Constant.t -> env -> bool (** New-style polymorphism *) -val polymorphic_constant : constant -> env -> bool +val polymorphic_constant : Constant.t -> env -> bool val polymorphic_pconstant : pconstant -> env -> bool -val type_in_type_constant : constant -> env -> bool - -(** Old-style polymorphism *) -val template_polymorphic_constant : constant -> env -> bool -val template_polymorphic_pconstant : pconstant -> env -> bool +val type_in_type_constant : Constant.t -> env -> bool (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if @@ -149,41 +197,40 @@ val template_polymorphic_pconstant : pconstant -> env -> bool body and [NotEvaluableConst IsProj] if [c] is a projection and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque | IsProj +type const_evaluation_result = NoBody | Opaque exception NotEvaluableConst of const_evaluation_result -val constant_value : env -> constant puniverses -> constr constrained -val constant_type : env -> constant puniverses -> constant_type constrained +val constant_type : env -> Constant.t puniverses -> types constrained -val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option -val constant_value_and_type : env -> constant puniverses -> - constr option * constant_type * Univ.constraints +val constant_value_and_type : env -> Constant.t puniverses -> + constr option * types * Univ.Constraint.t (** The universe context associated to the constant, empty if not polymorphic *) -val constant_context : env -> constant -> Univ.universe_context -(** The universe isntance associated to the constant, empty if not - polymorphic *) -val constant_instance : env -> constant -> Univ.universe_instance +val constant_context : env -> Constant.t -> Univ.AUContext.t (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) -val constant_value_in : env -> constant puniverses -> constr -val constant_type_in : env -> constant puniverses -> constant_type -val constant_opt_value_in : env -> constant puniverses -> constr option +val constant_value_in : env -> Constant.t puniverses -> constr +val constant_type_in : env -> Constant.t puniverses -> types +val constant_opt_value_in : env -> Constant.t puniverses -> constr option (** {6 Primitive projections} *) -val lookup_projection : Names.projection -> env -> projection_body -val is_projection : constant -> env -> bool +(** Checks that the number of parameters is correct. *) +val lookup_projection : Names.Projection.t -> env -> types + +val get_projection : env -> inductive -> proj_arg:int -> Names.Projection.Repr.t option +val get_projections : env -> inductive -> Names.Projection.Repr.t array option (** {5 Inductive types } *) -val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env -val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env +val lookup_mind_key : MutInd.t -> env -> mind_key +val add_mind_key : MutInd.t -> mind_key -> env -> env +val add_mind : MutInd.t -> mutual_inductive_body -> env -> env (** 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 +val lookup_mind : MutInd.t -> env -> mutual_inductive_body (** New-style polymorphism *) val polymorphic_ind : inductive -> env -> bool @@ -201,20 +248,20 @@ val add_modtype : module_type_body -> env -> env (** [shallow_add_module] does not add module components *) val shallow_add_module : module_body -> env -> env -val lookup_module : module_path -> env -> module_body -val lookup_modtype : module_path -> env -> module_type_body +val lookup_module : ModPath.t -> env -> module_body +val lookup_modtype : ModPath.t -> env -> module_type_body (** {5 Universe constraints } *) (** Add universe constraints to the environment. - @raises UniverseInconsistency + @raise UniverseInconsistency . *) -val add_constraints : Univ.constraints -> env -> env +val add_constraints : Univ.Constraint.t -> env -> env (** Check constraints are satifiable in the environment. *) -val check_constraints : Univ.constraints -> env -> bool -val push_context : ?strict:bool -> Univ.universe_context -> env -> env -val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env +val check_constraints : Univ.Constraint.t -> env -> bool +val push_context : ?strict:bool -> Univ.UContext.t -> env -> env +val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env val set_engagement : engagement -> env -> env @@ -234,7 +281,7 @@ val vars_of_global : env -> constr -> Id.Set.t val really_needed : env -> Id.Set.t -> Id.Set.t (** like [really_needed] but computes a well ordered named context *) -val keep_hyps : env -> Id.Set.t -> Context.Named.t +val keep_hyps : env -> Id.Set.t -> Constr.named_context (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is @@ -253,24 +300,20 @@ val j_type : ('constr, 'types) punsafe_judgment -> 'types type 'types punsafe_type_judgment = { utj_val : 'types; - utj_type : sorts } + utj_type : Sorts.t } type unsafe_type_judgment = types punsafe_type_judgment -(** {6 Compilation of global declaration } *) - -val compile_constant_body : env -> constant_universes -> constant_def -> Cemitcodes.body_code option - exception Hyp_not_found (** [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 -> - (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> + (Constr.named_context -> Constr.named_declaration -> Constr.named_context -> Constr.named_declaration) -> named_context_val -val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val +val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declaration) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val @@ -278,10 +321,11 @@ open Retroknowledge (** functions manipulating the retroknowledge @author spiwack *) val retroknowledge : (retroknowledge->'a) -> env -> 'a +[@@ocaml.deprecated "Use the record projection."] val registered : env -> field -> bool val register : env -> field -> Retroknowledge.entry -> env (** Native compiler *) -val no_link_info : Pre_env.link_info +val no_link_info : link_info diff --git a/kernel/esubst.ml b/kernel/esubst.ml index ac2b3f9d59..9fc3b11d78 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Bruno Barras for Coq V7.0, Mar 2001 *) @@ -17,6 +19,8 @@ open Util (*********************) (* Explicit lifts and basic operations *) +(* Invariant to preserve in this module: no lift contains two consecutive + [ELSHFT] nor two consecutive [ELLFT]. *) type lift = | ELID | ELSHFT of lift * int (* ELSHFT(l,n) == lift of n, then apply lift l *) @@ -26,15 +30,15 @@ type lift = 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 +let el_shft_rec n = function + | ELSHFT(el,k) -> ELSHFT(el,k+n) | el -> ELSHFT(el,n) let el_shft n el = if Int.equal n 0 then el else el_shft_rec n el (* cross n binders *) -let rec el_liftn_rec n = function +let el_liftn_rec n = function | ELID -> ELID - | ELLFT(k,el) -> el_liftn_rec (n+k) el + | ELLFT(k,el) -> ELLFT(n+k, el) | el -> ELLFT(n, el) let el_liftn n el = if Int.equal n 0 then el else el_liftn_rec n el @@ -130,13 +134,36 @@ let rec exp_rel lams k subs = let expand_rel k subs = exp_rel 0 k subs +let rec subs_map f = function +| ESID _ as s -> s +| CONS (x, s) -> CONS (Array.map f x, subs_map f s) +| SHIFT (n, s) -> SHIFT (n, subs_map f s) +| LIFT (n, s) -> LIFT (n, subs_map f s) + +let rec lift_subst mk_cl s1 s2 = match s1 with +| ELID -> subs_map (fun c -> mk_cl ELID c) s2 +| ELSHFT(s, k) -> subs_shft(k, lift_subst mk_cl s s2) +| ELLFT (k, s) -> + match s2 with + | CONS(x,s') -> + CONS(CArray.Fun1.map mk_cl s1 x, lift_subst mk_cl s1 s') + | ESID n -> lift_subst mk_cl s (ESID (n + k)) + | SHIFT(k',s') -> + if k<k' + then subs_shft(k, lift_subst mk_cl s (subs_shft(k'-k, s'))) + else subs_shft(k', lift_subst mk_cl (el_liftn (k-k') s) s') + | LIFT(k',s') -> + if k<k' + then subs_liftn k (lift_subst mk_cl s (subs_liftn (k'-k) s')) + else subs_liftn k' (lift_subst mk_cl (el_liftn (k-k') s) s') + let rec comp mk_cl s1 s2 = match (s1, s2) with | _, ESID _ -> s1 | ESID _, _ -> s2 | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) | _, CONS(x,s') -> - CONS(CArray.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') + CONS(Array.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') | CONS(x,s), SHIFT(k,s') -> let lg = Array.length x in if k == lg then comp mk_cl s s' diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 95a2e71c2c..475b64f472 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** Explicit substitutions *) @@ -54,7 +56,11 @@ val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs (** {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. *) + - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. + + Invariant ensured by the private flag: no lift contains two consecutive + [ELSHFT] nor two consecutive [ELLFT]. +*) type lift = private | ELID | ELSHFT of lift * int @@ -66,3 +72,10 @@ val el_liftn : int -> lift -> lift val el_lift : lift -> lift val reloc_rel : int -> lift -> int val is_lift_id : lift -> bool + +(** Lift applied to substitution: [lift_subst mk_clos el s] computes a + substitution equivalent to applying el then s. Argument + mk_clos is used when a closure has to be created, i.e. when + el is applied on an element of s. +*) +val lift_subst : (lift -> 'a -> 'b) -> lift -> 'a subs -> 'b subs diff --git a/kernel/evar.ml b/kernel/evar.ml index e63665f519..bbe143092b 100644 --- a/kernel/evar.ml +++ b/kernel/evar.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) type t = int @@ -13,6 +15,7 @@ let unsafe_of_int x = x let compare = Int.compare let equal = Int.equal let hash = Int.hash +let print x = Pp.(str "?X" ++ int x) module Set = Int.Set module Map = Int.Map diff --git a/kernel/evar.mli b/kernel/evar.mli index eee6680fb8..d14cdce27a 100644 --- a/kernel/evar.mli +++ b/kernel/evar.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** This module defines existential variables, which are isomorphic to [int]. @@ -30,5 +32,8 @@ val compare : t -> t -> int val hash : t -> int (** Hash over existential variables. *) +val print : t -> Pp.t +(** Printing representation *) + module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 04971f83dc..d7eb865e0a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open CErrors @@ -11,6 +13,7 @@ open Util open Names open Univ open Term +open Constr open Vars open Declarations open Declareops @@ -117,24 +120,14 @@ let mind_check_names mie = (* Typing the arities and constructor types *) -(* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties -*) -let is_unit constrsinfos = - match constrsinfos with (* One info = One constructor *) - | [level] -> is_type0m_univ level - | [] -> (* type without constructors *) true - | _ -> false - let infos_and_sort env t = let rec aux env t max = let t = whd_all env t in - match kind_of_term t with + match kind t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in - let max = Universe.sup max (univ_of_sort varj.utj_type) in + let max = Universe.sup max (Sorts.univ_of_sort varj.utj_type) in aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max @@ -168,13 +161,12 @@ let infer_constructor_packet env_ar_par params lc = let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) - let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in + let lc'' = Array.map (fun j -> Term.it_mkProd_or_LetIn j.utj_val params) jlc in (* compute the max of the sorts of the products of the constructors types *) let levels = List.map (infos_and_sort env_ar_par) lc in - let isunit = is_unit levels in let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in let level = List.fold_left (fun max l -> Universe.sup max l) min levels in - (lc'', (isunit, level)) + (lc'', level) (* If indices matter *) let cumulate_arity_large_levels env sign = @@ -183,7 +175,7 @@ let cumulate_arity_large_levels env sign = match d with | LocalAssum (_,t) -> let tj = infer_type env t in - let u = univ_of_sort tj.utj_type in + let u = Sorts.univ_of_sort tj.utj_type in (Universe.sup u lev, push_rel d env) | LocalDef _ -> lev, push_rel d env) @@ -199,8 +191,8 @@ let is_impredicative env u = let param_ccls paramsctxt = let fold acc = function | (LocalAssum (_, p)) -> - (let c = strip_prod_assum p in - match kind_of_term c with + (let c = Term.strip_prod_assum p in + match kind c with | Sort (Type u) -> Univ.Universe.level u | _ -> None) :: acc | LocalDef _ -> acc @@ -208,7 +200,7 @@ let param_ccls paramsctxt = List.fold_left fold [] paramsctxt (* Check arities and constructors *) -let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : Term.types) numparams is_arity = +let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : types) numparams is_arity = let numchecked = ref 0 in let basic_check ev tp = if !numchecked < numparams then () else conv_leq ev tp (subst tp); @@ -233,22 +225,32 @@ let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : Ter (* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) let check_subtyping cumi paramsctxt env_ar inds = let numparams = Context.Rel.nhyps paramsctxt in - let sbsubst = CumulativityInfo.subtyping_susbst cumi in - let dosubst = subst_univs_level_constr sbsubst in let uctx = CumulativityInfo.univ_context cumi in - let instance_other = Univ.subst_univs_level_instance sbsubst (Univ.UContext.instance uctx) in - let constraints_other = Univ.subst_univs_level_constraints sbsubst (Univ.UContext.constraints uctx) in + let new_levels = Array.init (UContext.size uctx) (Level.make DirPath.empty) in + let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) + LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels + in + let dosubst = subst_univs_level_constr lmap in + let instance_other = Instance.of_array new_levels in + let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in let uctx_other = Univ.UContext.make (instance_other, constraints_other) in let env = Environ.push_context uctx env_ar in let env = Environ.push_context uctx_other env in - let env = push_context (CumulativityInfo.subtyp_context cumi) env in + let subtyp_constraints = + CumulativityInfo.leq_constraints cumi + (UContext.instance uctx) instance_other + Constraint.empty + in + let env = Environ.add_constraints subtyp_constraints env in (* process individual inductive types: *) Array.iter (fun (id,cn,lc,(sign,arity)) -> match arity with | RegularArity (_, full_arity, _) -> check_subtyping_arity_constructor env dosubst full_arity numparams true; Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc - | TemplateArity _ -> () + | TemplateArity _ -> + anomaly ~label:"check_subtyping" + Pp.(str "template polymorphism and cumulative polymorphism are not compatible") ) inds (* Type-check an inductive definition. Does not check positivity @@ -264,13 +266,12 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) - let univctx = + let env' = match mie.mind_entry_universes with - | Monomorphic_ind_entry ctx -> ctx - | Polymorphic_ind_entry ctx -> ctx - | Cumulative_ind_entry cumi -> Univ.CumulativityInfo.univ_context cumi + | Monomorphic_ind_entry ctx -> push_context_set ctx env + | Polymorphic_ind_entry ctx -> push_context ctx env + | Cumulative_ind_entry cumi -> push_context (Univ.CumulativityInfo.univ_context cumi) env in - let env' = push_context univctx env in let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows building the environment of arities and to share *) @@ -288,7 +289,7 @@ let typecheck_inductive env mie = (** We have an algebraic universe as the conclusion of the arity, typecheck the dummy Π ctx, Prop and do a special case for the conclusion. *) - let proparity = infer_type env_params (mkArity (ctx, prop_sort)) in + let proparity = infer_type env_params (mkArity (ctx, Sorts.prop)) in let (cctx, _) = destArity proparity.utj_val in (* Any universe is well-formed, we don't need to check [s] here *) mkArity (cctx, s) @@ -342,7 +343,7 @@ let typecheck_inductive env mie = (* Compute/check the sorts of the inductive types *) let inds = - Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,clev)) -> + Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,clev) -> let infu = (** Inferred level, with parameters and constructors. *) match inf_level with @@ -350,7 +351,7 @@ let typecheck_inductive env mie = | None -> clev in let full_polymorphic () = - let defu = Term.univ_of_sort def_level in + let defu = Sorts.univ_of_sort def_level in let is_natural = type_in_type env || (UGraph.check_leq (universes env') infu defu) in @@ -413,7 +414,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor of Context.Rel.t * int + | LocalNotConstructor of Constr.rel_context * int | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -468,7 +469,7 @@ let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = | LocalDef _ :: paramdecls -> check param_index (paramdecl_index+1) paramdecls | _::paramdecls -> - match kind_of_term (whd_all env params.(param_index)) with + match kind (whd_all env params.(param_index)) with | Rel w when Int.equal w paramdecl_index -> check (param_index-1) (paramdecl_index+1) paramdecls | _ -> @@ -495,7 +496,7 @@ if Int.equal nmr 0 then 0 else | (_,[]) -> assert false (* |paramsctxt|>=nmr *) | (lp, LocalDef _ :: paramsctxt) -> find k (index-1) (lp,paramsctxt) | (p::lp,_::paramsctxt) -> - ( match kind_of_term (whd_all env p) with + ( match kind (whd_all env p) with | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,paramsctxt) | _ -> k) in find 0 (n-1) (lpar,List.rev paramsctxt) @@ -526,7 +527,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in - match kind_of_term c' with + match kind c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b @@ -555,7 +556,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( more generally, the arrows may be dependent). *) let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_all env c) in - match kind_of_term x with + match kind x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in (** If one of the inductives of the mutually inductive @@ -663,7 +664,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( and check_constructors ienv check_head nmr c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_all env c) in - match kind_of_term x with + match kind x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in @@ -710,7 +711,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( best-effort fashion. *) let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = let ntypes = Array.length inds in - let recursive = finite != Decl_kinds.BiFinite in + let recursive = finite != BiFinite in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let ra_env_ar = Array.rev_to_list rc in let nparamsctxt = Context.Rel.length paramsctxt in @@ -746,7 +747,7 @@ let allowed_sorts is_smashed s = as well. *) all_sorts else - match family_of_sort s with + match Sorts.family s with (* Type: all elimination allowed: above and below *) | InType -> all_sorts (* Smashed Set is necessarily impredicative: forbids large elimination *) @@ -785,69 +786,47 @@ exception UndefinableExpansion build an expansion function. The term built is expecting to be substituted first by a substitution of the form [params, x : ind params] *) -let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params - mind_consnrealdecls mind_consnrealargs paramslet ctx = - let mp, dp, l = repr_mind kn in +let compute_projections (kn, i as ind) mib = + let pkt = mib.mind_packets.(i) in + let u = match mib.mind_universes with + | Monomorphic_ind _ -> Univ.Instance.empty + | Polymorphic_ind auctx -> Univ.make_abstract_instance auctx + | Cumulative_ind acumi -> Univ.make_abstract_instance (Univ.ACumulativityInfo.univ_context acumi) + in + let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in + let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in + let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not matching with a parameter context. *) - let indty, paramsletsubst = - (* [ty] = [Ind inst] is typed in context [params] *) - let inst = Context.Rel.to_extended_vect mkRel 0 paramslet in - let ty = mkApp (mkIndU indu, inst) in + let paramsletsubst = (* [Ind inst] is typed in context [params-wo-let] *) - let inst' = rel_list 0 nparamargs in + let inst' = rel_list 0 mib.mind_nparams in (* {params-wo-let |- subst:params] *) let subst = subst_of_rel_context_instance paramslet inst' in (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *) let subst = (* For the record parameter: *) mkRel 1 :: List.map (lift 1) subst in - ty, subst - in - let ci = - let print_info = - { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in - { ci_ind = ind; - ci_npar = nparamargs; - ci_cstr_ndecls = mind_consnrealdecls; - ci_cstr_nargs = mind_consnrealargs; - ci_pp_info = print_info } - in - let len = List.length ctx in - let x = Name x in - let compat_body ccl i = - (* [ccl] is defined in context [params;x:indty] *) - (* [ccl'] is defined in context [params;x:indty;x:indty] *) - let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 indty, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in - let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in - it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params + subst in - let projections decl (i, j, kns, pbs, subst, letsubst) = + let projections decl (i, j, labs, pbs, letsubst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) let c = liftn 1 j c in (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] - to [params, x:I |- c(params,proj1 x,..,projj x)] *) - let c1 = substl subst c in - (* From [params, x:I |- subst:field1,..,fieldj] - to [params, x:I |- subst:field1,..,fieldj+1] where [subst] - is represented with instance of field1 last *) - let subst = c1 :: subst in - (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *) let c2 = substl letsubst c in (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in - (i, j+1, kns, pbs, subst, letsubst) + (i, j+1, labs, pbs, letsubst) | LocalAssum (na,t) -> match na with | Name id -> - let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) let t = liftn 1 j t in @@ -856,32 +835,27 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params let projty = substl letsubst t in (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) - let ty = substl subst t in - let term = mkProj (Projection.make kn true, mkRel 1) in let fterm = mkProj (Projection.make kn false, mkRel 1) in - let compat = compat_body ty (j - 1) in - let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in - let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in - let body = { proj_ind = fst ind; proj_npars = nparamargs; - proj_arg = i; proj_type = projty; proj_eta = etab, etat; - proj_body = compat } in - (i + 1, j + 1, kn :: kns, body :: pbs, - fterm :: subst, fterm :: letsubst) + (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in - let (_, _, kns, pbs, subst, letsubst) = - List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst) + let (_, _, labs, pbs, letsubst) = + List.fold_right projections ctx (0, 1, [], [], paramsletsubst) in - Array.of_list (List.rev kns), + Array.of_list (List.rev labs), Array.of_list (List.rev pbs) let abstract_inductive_universes iu = match iu with | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) | Polymorphic_ind_entry ctx -> - let (inst, auctx) = Univ.abstract_universes ctx in (inst, Polymorphic_ind auctx) + let (inst, auctx) = Univ.abstract_universes ctx in + let inst = Univ.make_instance_subst inst in + (inst, Polymorphic_ind auctx) | Cumulative_ind_entry cumi -> - let (inst, acumi) = Univ.abstract_cumulativity_info cumi in (inst, Cumulative_ind acumi) + let (inst, acumi) = Univ.abstract_cumulativity_info cumi in + let inst = Univ.make_instance_subst inst in + (inst, Cumulative_ind acumi) let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in @@ -915,11 +889,11 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let ar = {template_param_levels = paramlevs; template_level = lev} in TemplateArity ar, all_sorts | RegularArity (info,ar,defs) -> - let s = sort_of_univ defs in + let s = Sorts.sort_of_univ defs in let kelim = allowed_sorts info s in let ar = RegularArity { mind_user_arity = Vars.subst_univs_level_constr substunivs ar; - mind_sort = sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in + mind_sort = Sorts.sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in ar, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in @@ -953,36 +927,9 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in - let pkt = packets.(0) in - let isrecord = - match isrecord with - | Some (Some rid) when pkt.mind_kelim == all_sorts - && Array.length pkt.mind_consnames == 1 - && pkt.mind_consnrealargs.(0) > 0 -> - (** The elimination criterion ensures that all projections can be defined. *) - let u = - let process auctx = - subst_univs_level_instance substunivs (Univ.AUContext.instance auctx) - in - match aiu with - | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind auctx -> process auctx - | Cumulative_ind acumi -> process (Univ.ACumulativityInfo.univ_context acumi) - in - let indsp = ((kn, 0), u) in - let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in - (try - let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - let kns, projs = - compute_projections indsp pkt.mind_typename rid nparamargs paramsctxt - pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields - in Some (Some (rid, kns, projs)) - with UndefinableExpansion -> Some None) - | Some _ -> Some None - | None -> None - in - (* Build the mutual inductive *) - { mind_record = isrecord; + let mib = + (* Build the mutual inductive *) + { mind_record = NotRecord; mind_ntypes = ntypes; mind_finite = isfinite; mind_hyps = hyps; @@ -994,6 +941,27 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r mind_private = prv; mind_typing_flags = Environ.typing_flags env; } + in + let record_info = match isrecord with + | Some (Some rid) -> + let is_record pkt = + pkt.mind_kelim == all_sorts + && Array.length pkt.mind_consnames == 1 + && pkt.mind_consnrealargs.(0) > 0 + in + (** The elimination criterion ensures that all projections can be defined. *) + if Array.for_all is_record packets then + let map i id = + let labs, projs = compute_projections (kn, i) mib in + (id, labs, projs) + in + try PrimRecord (Array.mapi map rid) + with UndefinableExpansion -> FakeRecord + else FakeRecord + | Some None -> FakeRecord + | None -> NotRecord + in + { mib with mind_record = record_info } (************************************************************************) (************************************************************************) diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index e4b7c086af..cb09cfa827 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Declarations open Environ open Entries @@ -34,14 +36,9 @@ exception InductiveError of inductive_error (** The following function does checks on inductive declarations. *) -val check_inductive : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body +val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body (** The following enforces a system compatible with the univalent model *) val enforce_indices_matter : unit -> unit val is_indices_matter : unit -> bool - -val compute_projections : pinductive -> Id.t -> Id.t -> - int -> Context.Rel.t -> int array -> int array -> - Context.Rel.t -> Context.Rel.t -> - (constant array * projection_body array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index e3fb472be1..4d13a5fcb8 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -1,16 +1,18 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open CErrors open Util open Names open Univ -open Term +open Constr open Vars open Declarations open Declareops @@ -30,22 +32,22 @@ let lookup_mind_specif env (kn,tyi) = let find_rectype env c = let (t, l) = decompose_app (whd_all env c) in - match kind_of_term t with + match kind t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = let (t, l) = decompose_app (whd_all env c) in - match kind_of_term t with + match kind t with | Ind ind - when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_all env c) in - match kind_of_term t with + match kind t with | Ind ind - when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == CoFinite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams @@ -54,9 +56,7 @@ let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = - let process auctx = - Univ.UContext.constraints (Univ.subst_instance_context u auctx) - in + let process auctx = Univ.AUContext.instantiate u auctx in match mib.mind_universes with | Monomorphic_ind _ -> Univ.Constraint.empty | Polymorphic_ind auctx -> process auctx @@ -83,7 +83,7 @@ let instantiate_params full t u args sign = let (rem_args, subs, ty) = Context.Rel.fold_outside (fun decl (largs,subs,ty) -> - match (decl, largs, kind_of_term ty) with + match (decl, largs, kind ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) @@ -96,9 +96,9 @@ let instantiate_params full t u args sign = substl subs ty let full_inductive_instantiate mib u params sign = - let dummy = prop_sort in - let t = mkArity (Vars.subst_instance_context u sign,dummy) in - fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) + let dummy = Sorts.prop in + let t = Term.mkArity (Vars.subst_instance_context u sign,dummy) in + fst (Term.destArity (instantiate_params true t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in @@ -130,11 +130,6 @@ where Remark: Set (predicative) is encoded as Type(0) *) -let sort_as_univ = function -| Type u -> u -| Prop Null -> Universe.type0m -| Prop Pos -> Universe.type0 - (* Template polymorphism *) (* cons_subst add the mapping [u |-> su] in subst if [u] is not *) @@ -168,7 +163,7 @@ let make_subst env = (* arity is a global level which, at typing time, will be enforce *) (* to be greater than the level of the argument; this is probably *) (* a useless extra constraint *) - let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in + let s = Sorts.univ_of_sort (snd (dest_arity env (Lazy.force a))) in make (cons_subst u s subst) (sign, exp, args) | LocalAssum (na,t) :: sign, Some u::exp, [] -> (* No more argument here: we add the remaining universes to the *) @@ -194,11 +189,11 @@ let instantiate_universes env ctx ar argsorts = let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in let ty = (* Singleton type not containing types are interpretable in Prop *) - if is_type0m_univ level then prop_sort + if is_type0m_univ level then Sorts.prop (* Non singleton type not containing types are interpretable in Set *) - else if is_type0_univ level then set_sort + else if is_type0_univ level then Sorts.set (* This is a Type with constraints *) - else Type level + else Sorts.Type level in (ctx, ty) @@ -213,9 +208,9 @@ let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps = (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. the situation where a non-Prop singleton inductive becomes Prop when applied to Prop params *) - if not polyprop && not (is_type0m_univ ar.template_level) && is_prop_sort s + if not polyprop && not (is_type0m_univ ar.template_level) && Sorts.is_prop s then raise (SingletonInductiveBecomesProp mip.mind_typename); - mkArity (List.rev ctx,s) + Term.mkArity (List.rev ctx,s) let type_of_inductive env pind = type_of_inductive_gen env pind [||] @@ -235,9 +230,9 @@ let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args = (* The max of an array of universes *) -let cumulate_constructor_univ u = function - | Prop Null -> u - | Prop Pos -> Universe.sup Universe.type0 u +let cumulate_constructor_univ u = let open Sorts in function + | Prop -> u + | Set -> Universe.sup Universe.type0 u | Type u' -> Universe.sup u u' let max_inductive_sort = @@ -278,8 +273,8 @@ let type_of_constructors (ind,u) (mib,mip) = let inductive_sort_family mip = match mip.mind_arity with - | RegularArity s -> family_of_sort s.mind_sort - | TemplateArity _ -> InType + | RegularArity s -> Sorts.family s.mind_sort + | TemplateArity _ -> Sorts.InType let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip @@ -293,24 +288,25 @@ let elim_sorts (_,mip) = mip.mind_kelim let is_private (mib,_) = mib.mind_private = Some true let is_primitive_record (mib,_) = match mib.mind_record with - | Some (Some _) -> true - | _ -> false + | PrimRecord _ -> true + | NotRecord | FakeRecord -> false let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in - applist + Term.applist (mkIndU ind, List.map (lift mip.mind_nrealdecls) params @ Context.Rel.to_extended_list mkRel 0 realargs) (* This exception is local *) -exception LocalArity of (sorts_family * sorts_family * arity_error) option +exception LocalArity of (Sorts.family * Sorts.family * arity_error) option let check_allowed_sort ksort specif = + let open Sorts in let eq_ksort s = match ksort, s with | InProp, InProp | InSet, InSet | InType, InType -> true | _ -> false in - if not (List.exists eq_ksort (elim_sorts specif)) then + if not (CList.exists eq_ksort (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) @@ -318,7 +314,7 @@ let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity ind specif params in let rec srec env pt ar = let pt' = whd_all env pt in - match kind_of_term pt', ar with + match kind pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> let () = try conv env a1 a1' @@ -327,8 +323,8 @@ let is_correct_arity env c pj ind specif params = (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (LocalAssum (na1,a1)) env in - let ksort = match kind_of_term (whd_all env' a2) with - | Sort s -> family_of_sort s + let ksort = match kind (whd_all env' a2) with + | Sort s -> Sorts.family s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in let _ = @@ -353,22 +349,22 @@ let is_correct_arity env c pj ind specif params = let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,u,specif,params) cty in - let (cstrsign,ccl) = decompose_prod_assum typi in + let (cstrsign,ccl) = Term.decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstructU (cstr,u),lparams@(Context.Rel.to_extended_list mkRel 0 cstrsign)) in + let dep_cstr = Term.applist (mkConstructU (cstr,u),lparams@(Context.Rel.to_extended_list mkRel 0 cstrsign)) in vargs @ [dep_cstr] in - let base = lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in - it_mkProd_or_LetIn base cstrsign in + let base = Term.lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in + Term.it_mkProd_or_LetIn base cstrsign in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type env n p c realargs = - whd_betaiota env (lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c]))) + whd_betaiota env (Term.lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c]))) let type_case_branches env (pind,largs) pj c = let specif = lookup_mind_specif env (fst pind) in @@ -591,7 +587,7 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let rec ienv_decompose_prod (env,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in - match kind_of_term c' with + match kind c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b @@ -623,7 +619,7 @@ compute the number of recursive arguments. *) let get_recargs_approx env tree ind args = let rec build_recargs (env, ra_env as ienv) tree c = let x,largs = decompose_app (whd_all env c) in - match kind_of_term x with + match kind x with | Prod (na,b,d) -> assert (List.is_empty largs); build_recargs (ienv_push_var ienv (na, b, mk_norec)) tree d @@ -682,7 +678,7 @@ let get_recargs_approx env tree ind args = and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = let x,largs = decompose_app (whd_all env c) in - match kind_of_term x with + match kind x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in @@ -711,7 +707,7 @@ let restrict_spec env spec p = let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in let i,args = decompose_app (whd_all env s) in - match kind_of_term i with + match kind i with | Ind i -> begin match spec with | Dead_code -> spec @@ -732,7 +728,7 @@ let restrict_spec env spec p = let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_all renv.env t) in - match kind_of_term f with + match kind f with | Rel k -> subterm_var k renv | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in @@ -775,7 +771,7 @@ let rec subterm_specif renv stack t = 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 + let sign,strippedBody = Term.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 @@ -789,7 +785,7 @@ let rec subterm_specif renv stack t = | Lambda (x,a,b) -> let () = assert (List.is_empty l) in - let spec,stack' = extract_stack renv a stack in + let spec,stack' = extract_stack stack in subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) @@ -797,21 +793,21 @@ let rec subterm_specif renv stack t = | Proj (p, c) -> let subt = subterm_specif renv stack c in - (match subt with - | Subterm (s, wf) -> - (* We take the subterm specs of the constructor of the record *) - let wf_args = (dest_subterms wf).(0) in - (* We extract the tree of the projected argument *) - let kn = Projection.constant p in - let cb = lookup_constant kn renv.env in - let pb = Option.get cb.const_proj in - let n = pb.proj_arg in - Subterm (Strict, List.nth wf_args n) - | Dead_code -> Dead_code - | Not_subterm -> Not_subterm) + (match subt with + | Subterm (s, wf) -> + (* We take the subterm specs of the constructor of the record *) + let wf_args = (dest_subterms wf).(0) in + (* We extract the tree of the projected argument *) + let n = Projection.arg p in + spec_of_tree (List.nth wf_args n) + | Dead_code -> Dead_code + | Not_subterm -> Not_subterm) + + | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ + | Construct _ | CoFix _ -> Not_subterm + (* Other terms are not subterms *) - | _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) @@ -820,7 +816,7 @@ and stack_element_specif = function |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h |SArg x -> x -and extract_stack renv a = function +and extract_stack = function | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t @@ -851,7 +847,7 @@ let error_illegal_rec_call renv fx (arg_renv,arg) = let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) -let filter_stack_domain env ci p stack = +let filter_stack_domain env p stack = let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) @@ -859,11 +855,13 @@ let filter_stack_domain env ci p stack = else let env = push_rel_context absctx env in let rec filter_stack env ar stack = let t = whd_all env ar in - match stack, kind_of_term t with + match stack, kind t with | elt :: stack', Prod (n,a,c0) -> let d = LocalAssum (n,a) in + let ctx, a = dest_prod_assum env a in + let env = push_rel_context ctx env in let ty, args = decompose_app (whd_all env a) in - let elt = match kind_of_term ty with + let elt = match kind ty with | Ind ind -> let spec' = stack_element_specif elt in (match (Lazy.force spec') with @@ -894,7 +892,7 @@ let check_one_fix renv recpos trees def = if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in - match kind_of_term f with + match kind f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p && p < renv.rel_min+nfi then @@ -924,7 +922,7 @@ let check_one_fix renv recpos trees def = | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> - check_rec_call renv stack (applist(lift p c,l)) + check_rec_call renv stack (Term.applist(lift p c,l)) end | Case (ci,p,c_0,lrest) -> @@ -934,7 +932,7 @@ let check_one_fix renv recpos trees def = let case_spec = branches_specif renv (lazy_subterm_specif renv [] c_0) ci in let stack' = push_stack_closures renv l stack in - let stack' = filter_stack_domain renv.env ci p stack' in + let stack' = filter_stack_domain renv.env p 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 @@ -970,14 +968,14 @@ let check_one_fix renv recpos trees def = if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - let value = (applist(constant_value_in renv.env cu, l)) in + let value = (Term.applist(constant_value_in renv.env cu, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> let () = assert (List.is_empty l) in check_rec_call renv [] a ; - let spec, stack' = extract_stack renv a stack in + let spec, stack' = extract_stack stack in check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> @@ -1007,7 +1005,7 @@ let check_one_fix renv recpos trees def = | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with (FixGuardError _) -> - check_rec_call renv stack (applist(c,l)) + check_rec_call renv stack (Term.applist(c,l)) end | Sort _ -> @@ -1022,7 +1020,7 @@ let check_one_fix renv recpos trees def = if Int.equal decr 0 then check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else - match kind_of_term body with + match kind body with | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in @@ -1053,7 +1051,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) let rec check_occur env n def = - match kind_of_term (whd_all env def) with + match kind (whd_all env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in @@ -1063,6 +1061,9 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in + let mib,_ = lookup_mind_specif env (out_punivs mind) in + if mib.mind_finite != Finite then + raise_err env i (RecursionNotOnInductiveType a); (mind, (env', b)) else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") @@ -1094,8 +1095,8 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = () (* -let cfkey = Profile.declare_profile "check_fix";; -let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; +let cfkey = CProfile.declare_profile "check_fix";; +let check_fix env fix = CProfile.profile3 cfkey check_fix env fix;; *) (************************************************************************) @@ -1108,7 +1109,7 @@ let anomaly_ill_typed () = let rec codomain_is_coind env c = let b = whd_all env c in - match kind_of_term b with + match kind b with | Prod (x,a,b) -> codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> @@ -1120,7 +1121,7 @@ let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_all env t) in - match kind_of_term c with + match kind c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) @@ -1192,8 +1193,8 @@ let check_one_cofix env nbfix def deftype = | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args - - | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ + | Ind _ | Fix _ | Proj _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 0dfa8db00e..3c1464c6c9 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Univ open Declarations open Environ @@ -32,23 +34,23 @@ type mind_specif = mutual_inductive_body * one_inductive_body val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) -val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list +val ind_subst : MutInd.t -> mutual_inductive_body -> Instance.t -> constr list -val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t +val inductive_paramdecls : mutual_inductive_body puniverses -> Constr.rel_context -val instantiate_inductive_constraints : - mutual_inductive_body -> universe_instance -> constraints +val instantiate_inductive_constraints : + mutual_inductive_body -> Instance.t -> Constraint.t val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained -val constrained_type_of_inductive_knowing_parameters : +val constrained_type_of_inductive_knowing_parameters : env -> mind_specif puniverses -> types Lazy.t array -> types constrained val type_of_inductive : env -> mind_specif puniverses -> types -val type_of_inductive_knowing_parameters : +val type_of_inductive_knowing_parameters : env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types -val elim_sorts : mind_specif -> sorts_family list +val elim_sorts : mind_specif -> Sorts.family list val is_private : mind_specif -> bool val is_primitive_record : mind_specif -> bool @@ -65,7 +67,7 @@ val arities_of_constructors : pinductive -> mind_specif -> types array val type_of_constructors : pinductive -> mind_specif -> types array (** Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array +val arities_of_specif : MutInd.t puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int @@ -85,9 +87,9 @@ val build_branches_type : constr list -> constr -> types array (** Return the arity of an inductive type *) -val mind_arity : one_inductive_body -> Context.Rel.t * sorts_family +val mind_arity : one_inductive_body -> Constr.rel_context * Sorts.family -val inductive_sort_family : one_inductive_body -> sorts_family +val inductive_sort_family : one_inductive_body -> Sorts.family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) @@ -111,10 +113,10 @@ val check_cofix : env -> cofixpoint -> unit exception SingletonInductiveBecomesProp of Id.t -val max_inductive_sort : sorts array -> universe +val max_inductive_sort : Sorts.t array -> Universe.t -val instantiate_universes : env -> Context.Rel.t -> - template_arity -> constr Lazy.t array -> Context.Rel.t * sorts +val instantiate_universes : env -> Constr.rel_context -> + template_arity -> constr Lazy.t array -> Constr.rel_context * Sorts.t (** {6 Debug} *) @@ -135,6 +137,6 @@ 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 -val lambda_implicit_lift : int -> Constr.constr -> Term.constr +val lambda_implicit_lift : int -> constr -> constr -val abstract_mind_lc : int -> Int.t -> Constr.constr array -> Constr.constr array +val abstract_mind_lc : int -> Int.t -> constr array -> constr array diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0813315b5b..07a02f6ef5 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -5,28 +5,34 @@ UGraph Esubst Sorts Evar -Constr Context +Constr Vars Term Mod_subst Cbytecodes Copcodes Cemitcodes -Nativevalues -Primitives Opaqueproof +Declarations +Entries +Vmvalues +Nativevalues +CPrimitives Declareops Retroknowledge Conv_oracle -Pre_env -Cbytegen -Nativelambda -Nativecode -Nativelib Environ CClosure Reduction +Clambda +Nativelambda +Cbytegen +Nativecode +Nativelib +Csymtable +Vm +Vconv Nativeconv Type_errors Modops @@ -39,7 +45,3 @@ Subtyping Mod_typing Nativelibrary Safe_typing -Vm -Csymtable -Declarations -Vconv diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 7b660939b5..b35b9dda31 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Claudio Sacerdoti from contents of term.ml, names.ml and @@ -16,20 +18,20 @@ open Pp open Util open Names -open Term +open Constr (* For Inline, the int is an inlining level, and the constr (if present) is the term into which we should inline. *) type delta_hint = - | Inline of int * constr option - | Equiv of kernel_name + | Inline of int * (Univ.AUContext.t * constr) option + | Equiv of KerName.t -(* NB: earlier constructor Prefix_equiv of module_path +(* NB: earlier constructor Prefix_equiv of ModPath.t is now stored in a separate table, see Deltamap.t below *) module Deltamap = struct - type t = module_path MPmap.t * delta_hint KNmap.t + type t = ModPath.t MPmap.t * delta_hint KNmap.t let empty = MPmap.empty, KNmap.empty let is_empty (mm, km) = MPmap.is_empty mm && KNmap.is_empty km @@ -45,7 +47,7 @@ module Deltamap = struct end (* Invariant: in the [delta_hint] map, an [Equiv] should only - relate [kernel_name] with the same label (and section dirpath). *) + relate [KerName.t] with the same label (and section dirpath). *) type delta_resolver = Deltamap.t @@ -65,7 +67,7 @@ module Umap = struct let join map1 map2 = fold add_mp add_mbi map1 map2 end -type substitution = (module_path * delta_resolver) Umap.t +type substitution = (ModPath.t * delta_resolver) Umap.t let empty_subst = Umap.empty @@ -76,21 +78,21 @@ let is_empty_subst = Umap.is_empty let string_of_hint = function | Inline (_,Some _) -> "inline(Some _)" | Inline _ -> "inline()" - | Equiv kn -> string_of_kn kn + | Equiv kn -> KerName.to_string kn let debug_string_of_delta resolve = let kn_to_string kn hint l = - (string_of_kn kn ^ "=>" ^ string_of_hint hint) :: l + (KerName.to_string kn ^ "=>" ^ string_of_hint hint) :: l in let mp_to_string mp mp' l = - (string_of_mp mp ^ "=>" ^ string_of_mp mp') :: l + (ModPath.to_string mp ^ "=>" ^ ModPath.to_string mp') :: l in let l = Deltamap.fold mp_to_string kn_to_string resolve [] in String.concat ", " (List.rev l) 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 one_pair (mp,reso) = (ModPath.to_string mp,debug_string_of_delta reso) in + let mp_one_pair mp0 p l = (ModPath.to_string mp0, one_pair p)::l in let mbi_one_pair mbi p l = (MBId.debug_to_string mbi, one_pair p)::l in Umap.fold mp_one_pair mbi_one_pair sub [] @@ -117,7 +119,7 @@ let debug_pr_subst sub = let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc)) let add_kn_delta_resolver kn kn' = - assert (Label.equal (label kn) (label kn')); + assert (Label.equal (KerName.label kn) (KerName.label kn')); Deltamap.add_kn kn (Equiv kn') let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2 @@ -156,7 +158,7 @@ let find_prefix resolve mp = (** Applying a resolver to a kernel name *) -exception Change_equiv_to_inline of (int * constr) +exception Change_equiv_to_inline of (int * (Univ.AUContext.t * constr)) let solve_delta_kn resolve kn = try @@ -165,12 +167,12 @@ let solve_delta_kn resolve kn = | 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 mp,dir,l = KerName.repr kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else - make_kn new_mp dir l + KerName.make new_mp dir l let kn_of_delta resolve kn = try solve_delta_kn resolve kn @@ -242,18 +244,18 @@ let subst_mp sub mp = | Some (mp',_) -> mp' let subst_kn_delta sub kn = - let mp,dir,l = repr_kn kn in + let mp,dir,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',resolve) -> - solve_delta_kn resolve (make_kn mp' dir l) + solve_delta_kn resolve (KerName.make mp' dir l) | None -> kn let subst_kn sub kn = - let mp,dir,l = repr_kn kn in + let mp,dir,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',_) -> - (make_kn mp' dir l) + (KerName.make mp' dir l) | None -> kn exception No_subst @@ -298,9 +300,10 @@ let subst_con0 sub (cst,u) = let knu = KerName.make mpu dir l in let knc = if mpu == mpc then knu else KerName.make mpc dir l in match search_delta_inline resolve knu knc with - | Some t -> + | Some (ctx, t) -> (* In case of inlining, discard the canonical part (cf #2608) *) - Constant.make1 knu, t + let () = assert (Int.equal (Univ.AUContext.size ctx) (Univ.Instance.length u)) in + Constant.make1 knu, Vars.subst_instance_constr u t | None -> let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc @@ -329,6 +332,12 @@ let subst_constant sub con = try fst (subst_con0 sub (con,Univ.Instance.empty)) with No_subst -> con +let subst_proj_repr sub p = + Projection.Repr.map (subst_mind sub) p + +let subst_proj sub p = + Projection.map (subst_mind sub) p + (* 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" @@ -340,14 +349,10 @@ let subst_evaluable_reference subst = function let rec map_kn f f' c = let func = map_kn f f' in - match kind_of_term c with + match kind c with | Const kn -> (try snd (f' kn) with No_subst -> c) | Proj (p,t) -> - let p' = - try - Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p - with No_subst -> p - in + let p' = Projection.map f p in let t' = func t in if p' == p && t' == t then c else mkProj (p', t') @@ -365,7 +370,7 @@ let rec map_kn f f' c = in let p' = func p in let ct' = func ct in - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else @@ -394,21 +399,21 @@ let rec map_kn f f' c = else mkLetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap func tl in - let bl' = Array.smartmap func bl in + let tl' = Array.Smart.map func tl in + let bl' = Array.Smart.map func bl in if (bl == bl'&& tl == tl') then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.smartmap func tl in - let bl' = Array.smartmap func bl in + let tl' = Array.Smart.map func tl in + let bl' = Array.Smart.map func bl in if (bl == bl'&& tl == tl') then c else mkCoFix (ln,(lna,tl',bl')) | _ -> c @@ -419,7 +424,7 @@ let subst_mps sub c = let rec replace_mp_in_mp mpfrom mpto mp = match mp with - | _ when mp_eq mp mpfrom -> mpto + | _ when ModPath.equal mp mpfrom -> mpto | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1 == mp1' then mp @@ -427,14 +432,14 @@ let rec replace_mp_in_mp mpfrom mpto mp = | _ -> mp let replace_mp_in_kn mpfrom mpto kn = - let mp,dir,l = repr_kn kn in + let mp,dir,l = KerName.repr kn in let mp'' = replace_mp_in_mp mpfrom mpto mp in if mp==mp'' then kn - else make_kn mp'' dir l + else KerName.make mp'' dir l let rec mp_in_mp mp mp1 = match mp1 with - | _ when mp_eq mp1 mp -> true + | _ when ModPath.equal mp1 mp -> true | MPdot (mp2,l) -> mp_in_mp mp mp2 | _ -> false @@ -446,7 +451,7 @@ let subset_prefixed_by mp resolver = match hint with | Inline _ -> rslv | Equiv _ -> - if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv + if mp_in_mp mp (KerName.modpath kn) then Deltamap.add_kn kn hint rslv else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver @@ -480,7 +485,7 @@ let gen_subst_delta_resolver dom subst resolver = | 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 (lev,Some (ctx, t)) -> Inline (lev,Some (ctx, subst_mps subst t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv @@ -515,7 +520,7 @@ let add_delta_resolver resolver1 resolver2 = let substition_prefixed_by k mp subst = let mp_prefixmp kmp (mp_to,reso) sub = - if mp_in_mp mp kmp && not (mp_eq mp kmp) then + if mp_in_mp mp kmp && not (ModPath.equal 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 diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 3cd02fb9f8..2e5211c770 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -1,15 +1,17 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** {6 [Mod_subst] } *) open Names -open Term +open Constr (** {6 Delta resolver} *) @@ -20,44 +22,44 @@ type delta_resolver val empty_delta_resolver : delta_resolver val add_mp_delta_resolver : - module_path -> module_path -> delta_resolver -> delta_resolver + ModPath.t -> ModPath.t -> delta_resolver -> delta_resolver val add_kn_delta_resolver : - kernel_name -> kernel_name -> delta_resolver -> delta_resolver + KerName.t -> KerName.t -> delta_resolver -> delta_resolver val add_inline_delta_resolver : - kernel_name -> (int * constr option) -> delta_resolver -> delta_resolver + KerName.t -> (int * (Univ.AUContext.t * constr) option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver (** Effect of a [delta_resolver] on a module path, on a kernel name *) -val mp_of_delta : delta_resolver -> module_path -> module_path -val kn_of_delta : delta_resolver -> kernel_name -> kernel_name +val mp_of_delta : delta_resolver -> ModPath.t -> ModPath.t +val kn_of_delta : delta_resolver -> KerName.t -> KerName.t (** Build a constant whose canonical part is obtained via a resolver *) -val constant_of_delta_kn : delta_resolver -> kernel_name -> constant +val constant_of_delta_kn : delta_resolver -> KerName.t -> Constant.t (** Same, but a 2nd resolver is tried if the 1st one had no effect *) val constant_of_deltas_kn : - delta_resolver -> delta_resolver -> kernel_name -> constant + delta_resolver -> delta_resolver -> KerName.t -> Constant.t (** Same for inductive names *) -val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive +val mind_of_delta_kn : delta_resolver -> KerName.t -> MutInd.t val mind_of_deltas_kn : - delta_resolver -> delta_resolver -> kernel_name -> mutual_inductive + delta_resolver -> delta_resolver -> KerName.t -> MutInd.t (** Extract the set of inlined constant in the resolver *) -val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list +val inline_of_delta : int option -> delta_resolver -> (int * KerName.t) list (** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *) -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 +val mp_in_delta : ModPath.t -> delta_resolver -> bool +val con_in_delta : Constant.t -> delta_resolver -> bool +val mind_in_delta : MutInd.t -> delta_resolver -> bool (** {6 Substitution} *) @@ -72,15 +74,15 @@ val is_empty_subst : substitution -> bool composition. Most often this is not what you want. For sequential composition, try [join (map_mbid mp delta) subs] **) val add_mbid : - MBId.t -> module_path -> delta_resolver -> substitution -> substitution + MBId.t -> ModPath.t -> delta_resolver -> substitution -> substitution val add_mp : - module_path -> module_path -> delta_resolver -> substitution -> substitution + ModPath.t -> ModPath.t -> delta_resolver -> substitution -> substitution (** map_* create a new substitution [arg2/arg1]\{arg3\} *) val map_mbid : - MBId.t -> module_path -> delta_resolver -> substitution + MBId.t -> ModPath.t -> delta_resolver -> substitution val map_mp : - module_path -> module_path -> delta_resolver -> substitution + ModPath.t -> ModPath.t -> delta_resolver -> substitution (** sequential composition: [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] @@ -107,9 +109,9 @@ val subst_substituted : substitution -> 'a substituted -> 'a substituted (**/**) (* debugging *) val debug_string_of_subst : substitution -> string -val debug_pr_subst : substitution -> Pp.std_ppcmds +val debug_pr_subst : substitution -> Pp.t val debug_string_of_delta : delta_resolver -> string -val debug_pr_delta : delta_resolver -> Pp.std_ppcmds +val debug_pr_delta : delta_resolver -> Pp.t (**/**) (** [subst_mp sub mp] guarantees that whenever the result of the @@ -117,10 +119,10 @@ val debug_pr_delta : delta_resolver -> Pp.std_ppcmds as well [==] *) val subst_mp : - substitution -> module_path -> module_path + substitution -> ModPath.t -> ModPath.t val subst_mind : - substitution -> mutual_inductive -> mutual_inductive + substitution -> MutInd.t -> MutInd.t val subst_ind : substitution -> inductive -> inductive @@ -128,10 +130,10 @@ val subst_ind : val subst_pind : substitution -> pinductive -> pinductive val subst_kn : - substitution -> kernel_name -> kernel_name + substitution -> KerName.t -> KerName.t val subst_con : - substitution -> pconstant -> constant * constr + substitution -> pconstant -> Constant.t * constr val subst_pcon : substitution -> pconstant -> pconstant @@ -140,10 +142,13 @@ val subst_pcon_term : substitution -> pconstant -> pconstant * constr val subst_con_kn : - substitution -> constant -> constant * constr + substitution -> Constant.t -> Constant.t * constr -val subst_constant : - substitution -> constant -> constant +val subst_constant : + substitution -> Constant.t -> Constant.t + +val subst_proj_repr : substitution -> Projection.Repr.t -> Projection.Repr.t +val subst_proj : substitution -> Projection.t -> Projection.t (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? @@ -154,7 +159,7 @@ val subst_evaluable_reference : substitution -> evaluable_global_reference -> evaluable_global_reference (** [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 +val replace_mp_in_kn : ModPath.t -> ModPath.t -> KerName.t -> KerName.t (** [subst_mps sub c] performs the substitution [sub] on all kernel names appearing in [c] *) @@ -171,6 +176,5 @@ val occur_mbid : MBId.t -> substitution -> bool val repr_substituted : 'a substituted -> substitution list option * 'a -val force_constr : Term.constr substituted -> Term.constr -val subst_constr : - substitution -> Term.constr substituted -> Term.constr substituted +val force_constr : constr substituted -> constr +val subst_constr : substitution -> constr substituted -> constr substituted diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index f53ef6f569..d63dc057b4 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of @@ -72,59 +74,44 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = (* 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 uctx = Declareops.universes_of_constant (opaque_tables env) cb in - let uctx = (* Context of the spec *) - match cb.const_universes with - | Monomorphic_const _ -> uctx - | Polymorphic_const auctx -> - Univ.instantiate_univ_context auctx - in - let c', univs, ctx' = - if not (Declareops.constant_is_polymorphic cb) then - let env' = Environ.push_context ~strict:true uctx env' in - let env' = Environ.push_context ~strict:true ctx env' in - let c',cst = match cb.const_body with - | Undef _ | OpaqueDef _ -> - let j = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst' = Reduction.infer_conv_leq env' (Environ.universes env') - j.uj_type typ in - j.uj_val, cst' - | Def cs -> - let c' = Mod_subst.force_constr cs in - c, Reduction.infer_conv env' (Environ.universes env') c c' - in c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) - else - let cus, ccst = Univ.UContext.dest uctx in - let newus, cst = Univ.UContext.dest ctx in - let () = - if not (Univ.Instance.length cus == Univ.Instance.length newus) then - error_incorrect_with_constraint lab - in - let inst = Univ.Instance.append cus newus in - let csti = Univ.enforce_eq_instances cus newus cst in - let csta = Univ.Constraint.union csti ccst in - let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in - let () = if not (UGraph.check_constraints cst (Environ.universes env')) then - error_incorrect_with_constraint lab - in + let c', univs, ctx' = + match cb.const_universes, ctx with + | Monomorphic_const _, None -> + let c',cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val, cst' + | Def cs -> + let c' = Mod_subst.force_constr cs in + c, Reduction.infer_conv env' (Environ.universes env') c c' + in + c', Monomorphic_const Univ.ContextSet.empty, cst + | Polymorphic_const uctx, Some ctx -> + let () = + if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then + error_incorrect_with_constraint lab + in + (** Terms are compared in a context with De Bruijn universe indices *) + let env' = Environ.push_context ~strict:false (Univ.AUContext.repr uctx) env in let cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in - let typ = Vars.subst_instance_constr cus typ in + let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in cst' | Def cs -> - let c' = Vars.subst_instance_constr cus (Mod_subst.force_constr cs) in + let c' = Mod_subst.force_constr cs in let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in cst' in if not (Univ.Constraint.is_empty cst) then error_incorrect_with_constraint lab; - let subst, ctx = Univ.abstract_universes ctx in - Vars.subst_univs_level_constr subst c, Polymorphic_const ctx, Univ.ContextSet.empty + c, Polymorphic_const ctx, Univ.Constraint.empty + | _ -> error_incorrect_with_constraint lab in let def = Def (Mod_subst.from_val c') in (* let ctx' = Univ.UContext.make (newus, cst) in *) @@ -133,7 +120,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = const_body = def; const_universes = univs ; const_body_code = Option.map Cemitcodes.from_val - (compile_constant_body env' cb.const_universes def) } + (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else @@ -176,16 +163,10 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = let mb_mp1 = lookup_module mp1 env in let mtb_mp1 = module_type_of_module mb_mp1 in let cst = match old.mod_expr with - | Abstract -> - begin - try - let mtb_old = module_type_of_module old in - let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in - Univ.ContextSet.add_constraints chk_cst old.mod_constraints - with Failure _ -> - (* TODO: where can a Failure come from ??? *) - error_incorrect_with_constraint lab - end + | Abstract -> + let mtb_old = module_type_of_module old in + let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in + Univ.ContextSet.add_constraints chk_cst old.mod_constraints | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; old.mod_constraints @@ -239,11 +220,11 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Reduction.NotConvertible -> error_incorrect_with_constraint lab let check_with env mp (sign,alg,reso,cst) = function - |WithDef(idl,c) -> + |WithDef(idl, (c, ctx)) -> let struc = destr_nofunctor sign in - let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in - NoFunctor struc', MEwith (alg,wd'), reso, cst+++cst' + let struc', c', cst' = check_with_def env struc (idl, (c, ctx)) mp reso in + let wd' = WithDef (idl, (c', ctx)) in + NoFunctor struc', MEwith (alg,wd'), reso, Univ.ContextSet.add_constraints cst' cst |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in @@ -274,7 +255,9 @@ let rec translate_mse env mpo inl = function |MEident mp1 as me -> let mb = match mpo with |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false - |None -> lookup_modtype mp1 env + |None -> + let mt = lookup_modtype mp1 env in + module_body_of_type mt.mod_mp mt in mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> @@ -291,9 +274,11 @@ let mk_mod mp e ty cst reso = mod_type_alg = None; mod_constraints = cst; mod_delta = reso; - mod_retroknowledge = [] } + mod_retroknowledge = ModBodyRK []; } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso +let mk_modtype mp ty cst reso = + let mb = mk_mod mp Abstract ty cst reso in + { mb with mod_expr = (); mod_retroknowledge = ModTypeRK } let rec translate_mse_funct env mpo inl mse = function |[] -> @@ -329,6 +314,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; + mod_retroknowledge = ModBodyRK []; (** cst from module body typing, cst' from subtyping, constraints from module type. *) diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index dcabb13346..e74f455efe 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Declarations @@ -21,16 +23,16 @@ open Names *) val translate_module : - env -> module_path -> inline -> module_entry -> module_body + env -> ModPath.t -> inline -> module_entry -> module_body (** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] cannot be [None] (and of course [mod_expr] is [Abstract]). *) val translate_modtype : - env -> module_path -> inline -> module_type_entry -> module_type_body + env -> ModPath.t -> inline -> module_type_entry -> module_type_body (** Low-level function for translating a module struct entry : - - We translate to a module when a [module_path] is given, + - We translate to a module when a [ModPath.t] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept mostly for @@ -40,14 +42,14 @@ type 'alg translation = module_signature * 'alg * delta_resolver * Univ.ContextSet.t val translate_mse : - env -> module_path option -> inline -> module_struct_entry -> + env -> ModPath.t option -> inline -> module_struct_entry -> module_alg_expr translation (** From an already-translated (or interactive) implementation and an (optional) signature entry, produces a final [module_body] *) val finalize_module : - env -> module_path -> (module_expression option) translation -> + env -> ModPath.t -> (module_expression option) translation -> (module_type_entry * inline) option -> module_body @@ -55,5 +57,5 @@ val finalize_module : module type given to an Include *) val translate_mse_incl : - bool -> env -> module_path -> inline -> module_struct_entry -> + bool -> env -> ModPath.t -> inline -> module_struct_entry -> unit translation diff --git a/kernel/modops.ml b/kernel/modops.ml index 24be46933e..98a9973117 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of @@ -17,7 +19,7 @@ open Util open Names -open Term +open Constr open Declarations open Declareops open Environ @@ -45,11 +47,10 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | NoTypeConstraintExpected | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.constraints + | IncompatibleConstraints of Univ.AUContext.t type module_typing_error = | SignatureMismatch of @@ -59,7 +60,7 @@ type module_typing_error = | NotAFunctor | IsAFunctor | IncompatibleModuleTypes of module_type_body * module_type_body - | NotEqualModulePaths of module_path * module_path + | NotEqualModulePaths of ModPath.t * ModPath.t | NoSuchLabel of Label.t | IncompatibleLabels of Label.t * Label.t | NotAModule of string @@ -68,7 +69,7 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string - | IncludeRestrictedFunctor of module_path + | IncludeRestrictedFunctor of ModPath.t exception ModuleTypingError of module_typing_error @@ -128,10 +129,10 @@ let destr_nofunctor = function |NoFunctor a -> a |MoreFunctor _ -> error_is_a_functor () -let rec functor_smartmap fty f0 funct = match funct with +let rec functor_smart_map fty f0 funct = match funct with |MoreFunctor (mbid,ty,e) -> let ty' = fty ty in - let e' = functor_smartmap fty f0 e in + let e' = functor_smart_map fty f0 e in if ty==ty' && e==e' then funct else MoreFunctor (mbid,ty',e') |NoFunctor a -> let a' = f0 a in if a==a' then funct else NoFunctor a' @@ -143,11 +144,12 @@ let rec functor_iter fty f0 = function (** {6 Misc operations } *) let module_type_of_module mb = - { mb with mod_expr = Abstract; mod_type_alg = None } + { mb with mod_expr = (); mod_type_alg = None; + mod_retroknowledge = ModTypeRK; } let module_body_of_type mp mtb = - assert (mtb.mod_expr == Abstract); - { mtb with mod_mp = mp } + { mtb with mod_expr = Abstract; mod_mp = mp; + mod_retroknowledge = ModBodyRK []; } let check_modpath_equiv env mp1 mp2 = if ModPath.equal mp1 mp2 then () @@ -194,9 +196,10 @@ let rec subst_structure sub do_delta sign = let mtb' = subst_modtype sub do_delta mtb in if mtb==mtb' then orig else (l,SFBmodtype mtb') in - List.smartmap subst_body sign + List.Smart.map subst_body sign -and subst_body is_mod sub do_delta mb = +and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun is_mod sub subst_impl do_delta mb -> let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in let mp' = subst_mp sub mp in let sub = @@ -205,11 +208,8 @@ and subst_body is_mod sub do_delta mb = else add_mp mp mp' empty_delta_resolver sub in let ty' = subst_signature sub do_delta ty in - let me' = - implem_smartmap - (subst_signature sub id_delta) (subst_expression sub id_delta) me - in - let aty' = Option.smartmap (subst_expression sub id_delta) aty in + let me' = subst_impl sub me in + let aty' = Option.Smart.map (subst_expression sub id_delta) aty in let delta' = do_delta mb.mod_delta sub in if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta then mb @@ -221,9 +221,14 @@ and subst_body is_mod sub do_delta mb = mod_type_alg = aty'; mod_delta = delta' } -and subst_module sub do_delta mb = subst_body true sub do_delta mb +and subst_module sub do_delta mb = + subst_body true sub subst_impl do_delta mb + +and subst_impl sub me = + implem_smartmap + (subst_signature sub id_delta) (subst_expression sub id_delta) me -and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb +and subst_modtype sub do_delta mtb = subst_body false sub (fun _ () -> ()) do_delta mtb and subst_expr sub do_delta seb = match seb with |MEident mp -> @@ -239,12 +244,12 @@ and subst_expr sub do_delta seb = match seb with if meb==meb' && wdb==wdb' then seb else MEwith(meb',wdb') and subst_expression sub do_delta = - functor_smartmap + functor_smart_map (subst_modtype sub do_delta) (subst_expr sub do_delta) and subst_signature sub do_delta = - functor_smartmap + functor_smart_map (subst_modtype sub do_delta) (subst_structure sub do_delta) @@ -260,15 +265,15 @@ let subst_structure subst = subst_structure subst do_delta_codom (* spiwack: here comes the function which takes care of importing the retroknowledge declared in the library *) (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) -let add_retroknowledge mp = +let add_retroknowledge = let perform rkaction env = match rkaction with - |Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) -> + | Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) -> Environ.register env f e - |_ -> + | _ -> CErrors.anomaly ~label:"Modops.add_retroknowledge" (Pp.str "had to import an unsupported kind of term.") in - fun lclrk env -> + fun (ModBodyRK lclrk) env -> (* The order of the declaration matters, for instance (and it's at the time this comment is being written, the only relevent instance) the int31 type registration absolutely needs int31 bits to be registered. @@ -304,7 +309,7 @@ and add_module mb linkinfo env = let env = Environ.shallow_add_module mb env in match mb.mod_type with |NoFunctor struc -> - add_retroknowledge mp mb.mod_retroknowledge + add_retroknowledge mb.mod_retroknowledge (add_structure mp struc mb.mod_delta linkinfo env) |MoreFunctor _ -> env @@ -397,10 +402,11 @@ let inline_delta_resolver env inl mp mbid mtb delta = | Undef _ | OpaqueDef _ -> l | Def body -> let constr = Mod_subst.force_constr body in - add_inline_delta_resolver kn (lev, Some constr) l + let ctx = Declareops.constant_polymorphic_context constant in + add_inline_delta_resolver kn (lev, Some (ctx, constr)) l with Not_found -> - error_no_such_label_sub (con_label con) - (string_of_mp (con_modpath con)) + error_no_such_label_sub (Constant.label con) + (ModPath.to_string (Constant.modpath con)) in make_inline delta constants @@ -567,7 +573,7 @@ let rec is_bounded_expr l = function is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr | _ -> false -let rec clean_module l mb = +let rec clean_module_body l mb = let impl, typ = mb.mod_expr, mb.mod_type in let typ' = clean_signature l typ in let impl' = match impl with @@ -577,19 +583,25 @@ let rec clean_module l mb = if typ==typ' && impl==impl' then mb else { mb with mod_type=typ'; mod_expr=impl' } +and clean_module_type l mb = + let (), typ = mb.mod_expr, mb.mod_type in + let typ' = clean_signature l typ in + if typ==typ' then mb + else { mb with mod_type=typ' } + and clean_field l field = match field with |(lab,SFBmodule mb) -> - let mb' = clean_module l mb in + let mb' = clean_module_body l mb in if mb==mb' then field else (lab,SFBmodule mb') |_ -> field -and clean_structure l = List.smartmap (clean_field l) +and clean_structure l = List.Smart.map (clean_field l) and clean_signature l = - functor_smartmap (clean_module l) (clean_structure l) + functor_smart_map (clean_module_type l) (clean_structure l) and clean_expression l = - functor_smartmap (clean_module l) (fun me -> me) + functor_smart_map (clean_module_type l) (fun me -> me) let rec collect_mbid l sign = match sign with |MoreFunctor (mbid,ty,m) -> @@ -613,14 +625,16 @@ let join_constant_body except otab cb = | _ -> () let join_structure except otab s = - let rec join_module mb = - implem_iter join_signature join_expression mb.mod_expr; + let rec join_module : 'a. 'a generic_module_body -> unit = fun mb -> Option.iter join_expression mb.mod_type_alg; join_signature mb.mod_type and join_field (l,body) = match body with |SFBconst sb -> join_constant_body except otab sb |SFBmind _ -> () - |SFBmodule m |SFBmodtype m -> join_module m + |SFBmodule m -> + implem_iter join_signature join_expression m.mod_expr; + join_module m + |SFBmodtype m -> join_module m and join_structure struc = List.iter join_field struc and join_signature sign = functor_iter join_module join_structure sign diff --git a/kernel/modops.mli b/kernel/modops.mli index 4a150d54bd..8e7e618fcd 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Environ open Declarations open Entries @@ -26,9 +28,9 @@ val destr_nofunctor : ('ty,'a) functorize -> 'a (** Conversions between [module_body] and [module_type_body] *) val module_type_of_module : module_body -> module_type_body -val module_body_of_type : module_path -> module_type_body -> module_body +val module_body_of_type : ModPath.t -> module_type_body -> module_body -val check_modpath_equiv : env -> module_path -> module_path -> unit +val check_modpath_equiv : env -> ModPath.t -> ModPath.t -> unit val implem_smartmap : (module_signature -> module_signature) -> @@ -43,29 +45,29 @@ val subst_structure : substitution -> structure_body -> structure_body (** {6 Adding to an environment } *) val add_structure : - module_path -> structure_body -> delta_resolver -> env -> env + ModPath.t -> structure_body -> delta_resolver -> env -> env (** adds a module and its components, but not the constraints *) val add_module : module_body -> env -> env (** same as add_module, but for a module whose native code has been linked by the native compiler. The linking information is updated. *) -val add_linked_module : module_body -> Pre_env.link_info -> env -> env +val add_linked_module : module_body -> link_info -> env -> env (** same, for a module type *) -val add_module_type : module_path -> module_type_body -> env -> env +val add_module_type : ModPath.t -> module_type_body -> env -> env (** {6 Strengthening } *) -val strengthen : module_type_body -> module_path -> module_type_body +val strengthen : module_type_body -> ModPath.t -> module_type_body val inline_delta_resolver : - env -> inline -> module_path -> MBId.t -> module_type_body -> + env -> inline -> ModPath.t -> MBId.t -> module_type_body -> delta_resolver -> delta_resolver -val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body +val strengthen_and_subst_mb : module_body -> ModPath.t -> bool -> module_body -val subst_modtype_and_resolver : module_type_body -> module_path -> +val subst_modtype_and_resolver : module_type_body -> ModPath.t -> module_type_body (** {6 Cleaning a module expression from bounded parts } @@ -104,11 +106,10 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | NoTypeConstraintExpected | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.constraints + | IncompatibleConstraints of Univ.AUContext.t type module_typing_error = | SignatureMismatch of @@ -118,7 +119,7 @@ type module_typing_error = | NotAFunctor | IsAFunctor | IncompatibleModuleTypes of module_type_body * module_type_body - | NotEqualModulePaths of module_path * module_path + | NotEqualModulePaths of ModPath.t * ModPath.t | NoSuchLabel of Label.t | IncompatibleLabels of Label.t * Label.t | NotAModule of string @@ -127,7 +128,7 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string - | IncludeRestrictedFunctor of module_path + | IncludeRestrictedFunctor of ModPath.t exception ModuleTypingError of module_typing_error @@ -153,4 +154,4 @@ val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a -val error_include_restricted_functor : module_path -> 'a +val error_include_restricted_functor : ModPath.t -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index e524f4258d..e1d70e8111 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* File created around Apr 1994 for CiC V5.10.5 by Chet Murthy collecting @@ -15,7 +17,7 @@ the module system, Aug 2002 *) (* Abstraction over the type of constant for module inlining by Claudio Sacerdoti, Nov 2004 *) -(* Miscellaneous features or improvements by Hugo Herbelin, +(* Miscellaneous features or improvements by Hugo Herbelin, Élie Soubiran, ... *) open Pp @@ -113,8 +115,7 @@ struct module Self_Hashcons = struct - type _t = t - type t = _t + type nonrec t = t type u = Id.t -> Id.t let hashcons hident = function | Name id -> Name (hident id) @@ -180,6 +181,8 @@ struct | [] -> "<>" | sl -> String.concat "." (List.rev_map Id.to_string sl) + let print dp = str (to_string dp) + let initial = [default_module_name] module Hdir = Hashcons.Hlist(Id) @@ -236,8 +239,7 @@ struct module Self_Hashcons = struct - type _t = t - type t = _t + type nonrec t = t type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t) let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) let eq ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = @@ -362,7 +364,6 @@ module MPmap = CMap.Make(ModPath) module KerName = struct type t = { - canary : Canary.t; modpath : ModPath.t; dirpath : DirPath.t; knlabel : Label.t; @@ -370,16 +371,14 @@ module KerName = struct (** Lazily computed hash. If unset, it is set to negative values. *) } - let canary = Canary.obj - type kernel_name = t let make modpath dirpath knlabel = - { modpath; dirpath; knlabel; refhash = -1; canary; } + { modpath; dirpath; knlabel; refhash = -1; } let repr kn = (kn.modpath, kn.dirpath, kn.knlabel) let make2 modpath knlabel = - { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; canary; } + { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; } let modpath kn = kn.modpath let label kn = kn.knlabel @@ -435,7 +434,7 @@ module KerName = struct * (string -> string) let hashcons (hmod,hdir,hstr) kn = let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in - { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; } + { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; } let eq kn1 kn2 = kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath && kn1.knlabel == kn2.knlabel @@ -699,16 +698,6 @@ end module Constrmap = Map.Make(ConstructorOrdered) module Constrmap_env = Map.Make(ConstructorOrdered_env) -(* Better to have it here that in closure, since used in grammar.cma *) -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -let eq_egr e1 e2 = match e1, e2 with - EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 - | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 - | _, _ -> false - (** {6 Hash-consing of name objects } *) module Hind = Hashcons.Make( @@ -768,110 +757,155 @@ let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 (*******************************************************************) (** Compatibility layers *) -(** Backward compatibility for [Id] *) +type mod_bound_id = MBId.t +let eq_constant_key = Constant.UserOrd.equal -type identifier = Id.t +(** Compatibility layer for [ModPath] *) -let id_eq = Id.equal -let id_ord = Id.compare -let string_of_id = Id.to_string -let id_of_string = Id.of_string +type module_path = ModPath.t = + | MPfile of DirPath.t + | MPbound of MBId.t + | MPdot of module_path * Label.t -module Idset = Id.Set -module Idmap = Id.Map -module Idpred = Id.Pred +(** Compatibility layer for [Constant] *) -(** Compatibility layer for [Name] *) +module Projection = +struct + module Repr = struct + type t = + { proj_ind : inductive; + proj_npars : int; + proj_arg : int; + proj_name : Label.t; } -let name_eq = Name.equal + let make proj_ind ~proj_npars ~proj_arg proj_name = + {proj_ind;proj_npars;proj_arg;proj_name} -(** Compatibility layer for [DirPath] *) + let inductive c = c.proj_ind -type dir_path = DirPath.t -let dir_path_ord = DirPath.compare -let dir_path_eq = DirPath.equal -let make_dirpath = DirPath.make -let repr_dirpath = DirPath.repr -let empty_dirpath = DirPath.empty -let is_empty_dirpath = DirPath.is_empty -let string_of_dirpath = DirPath.to_string -let initial_dir = DirPath.initial + let mind c = fst c.proj_ind -(** Compatibility layer for [MBId] *) + let constant c = KerPair.change_label (mind c) c.proj_name -type mod_bound_id = MBId.t -let mod_bound_id_ord = MBId.compare -let mod_bound_id_eq = MBId.equal -let make_mbid = MBId.make -let repr_mbid = MBId.repr -let debug_string_of_mbid = MBId.debug_to_string -let string_of_mbid = MBId.to_string -let id_of_mbid = MBId.to_id - -(** Compatibility layer for [Label] *) - -type label = Id.t -let mk_label = Label.make -let string_of_label = Label.to_string -let pr_label = Label.print -let id_of_label = Label.to_id -let label_of_id = Label.of_id -let eq_label = Label.equal + let label c = c.proj_name -(** Compatibility layer for [ModPath] *) + let npars c = c.proj_npars -type module_path = ModPath.t = - | MPfile of DirPath.t - | MPbound of MBId.t - | MPdot of module_path * Label.t -let check_bound_mp = ModPath.is_bound -let string_of_mp = ModPath.to_string -let mp_ord = ModPath.compare -let mp_eq = ModPath.equal -let initial_path = ModPath.initial - -(** Compatibility layer for [KerName] *) - -type kernel_name = KerName.t -let make_kn = KerName.make -let repr_kn = KerName.repr -let modpath = KerName.modpath -let label = KerName.label -let string_of_kn = KerName.to_string -let pr_kn = KerName.print -let kn_ord = KerName.compare + let arg c = c.proj_arg -(** Compatibility layer for [Constant] *) + let equal a b = + eq_ind a.proj_ind b.proj_ind && Int.equal a.proj_arg b.proj_arg + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + + module SyntacticOrd = struct + let compare a b = + let c = ind_syntactic_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_syntactic_ind a.proj_ind b.proj_ind -type constant = Constant.t + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + end + module CanOrd = struct + let compare a b = + let c = ind_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + end + module UserOrd = struct + let compare a b = + let c = ind_user_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + let equal a b = + a.proj_arg == b.proj_arg && eq_user_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_user_hash p.proj_ind) + end + + let compare a b = + let c = ind_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + module Self_Hashcons = struct + type nonrec t = t + type u = (inductive -> inductive) * (Id.t -> Id.t) + let hashcons (hind,hid) p = + { proj_ind = hind p.proj_ind; + proj_npars = p.proj_npars; + proj_arg = p.proj_arg; + proj_name = hid p.proj_name } + let eq p p' = + p == p' || (p.proj_ind == p'.proj_ind && p.proj_npars == p'.proj_npars && p.proj_arg == p'.proj_arg && p.proj_name == p'.proj_name) + let hash = hash + end + module HashRepr = Hashcons.Make(Self_Hashcons) + let hcons = Hashcons.simple_hcons HashRepr.generate HashRepr.hcons (hcons_ind,Id.hcons) + + let map_npars f p = + let ind = fst p.proj_ind in + let npars = p.proj_npars in + let ind', npars' = f ind npars in + if ind == ind' && npars == npars' then p + else {p with proj_ind = (ind',snd p.proj_ind); proj_npars = npars'} + + let map f p = map_npars (fun mind n -> f mind, n) p + + let to_string p = Constant.to_string (constant p) + let print p = Constant.print (constant p) + end + + type t = Repr.t * bool -module Projection = -struct - type t = constant * bool - let make c b = (c, b) - let constant = fst + let mind (c,_) = Repr.mind c + let inductive (c,_) = Repr.inductive c + let npars (c,_) = Repr.npars c + let arg (c,_) = Repr.arg c + let constant (c,_) = Repr.constant c + let label (c,_) = Repr.label c + let repr = fst let unfolded = snd let unfold (c, b as p) = if b then p else (c, true) - let equal (c, b) (c', b') = Constant.equal c c' && b == b' - let hash (c, b) = (if b then 0 else 1) + Constant.hash c + let equal (c, b) (c', b') = Repr.equal c c' && b == b' + + let hash (c, b) = (if b then 0 else 1) + Repr.hash c module SyntacticOrd = struct let compare (c, b) (c', b') = - if b = b' then Constant.SyntacticOrd.compare c c' else -1 + if b = b' then Repr.SyntacticOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Repr.SyntacticOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.SyntacticOrd.hash c + end + module CanOrd = struct + let compare (c, b) (c', b') = + if b = b' then Repr.CanOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = - x == x' || b = b' && Constant.SyntacticOrd.equal c c' - let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c + x == x' || b = b' && Repr.CanOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.CanOrd.hash c end module Self_Hashcons = struct - type _t = t - type t = _t - type u = Constant.t -> Constant.t + type nonrec t = t + type u = Repr.t -> Repr.t let hashcons hc (c,b) = (hc c,b) let eq ((c,b) as x) ((c',b') as y) = x == y || (c == c' && b == b') @@ -880,15 +914,19 @@ struct module HashProjection = Hashcons.Make(Self_Hashcons) - let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con + let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons Repr.hcons let compare (c, b) (c', b') = - if b == b' then Constant.CanOrd.compare c c' + if b == b' then Repr.compare c c' else if b then 1 else -1 let map f (c, b as x) = - let c' = f c in - if c' == c then x else (c', b) + let c' = Repr.map f c in + if c' == c then x else (c', b) + + let map_npars f (c, b as x) = + let c' = Repr.map_npars f c in + if c' == c then x else (c', b) let to_string p = Constant.to_string (constant p) let print p = Constant.print (constant p) @@ -897,39 +935,39 @@ end type projection = Projection.t -let constant_of_kn = Constant.make1 -let constant_of_kn_equiv = Constant.make -let make_con = Constant.make3 -let repr_con = Constant.repr3 -let canonical_con = Constant.canonical -let user_con = Constant.user -let con_label = Constant.label -let con_modpath = Constant.modpath -let eq_constant = Constant.equal -let eq_constant_key = Constant.UserOrd.equal -let con_ord = Constant.CanOrd.compare -let con_user_ord = Constant.UserOrd.compare -let string_of_con = Constant.to_string -let pr_con = Constant.print -let debug_string_of_con = Constant.debug_to_string -let debug_pr_con = Constant.debug_print -let con_with_label = Constant.change_label - -(** Compatibility layer for [MutInd] *) - -type mutual_inductive = MutInd.t -let mind_of_kn = MutInd.make1 -let mind_of_kn_equiv = MutInd.make -let make_mind = MutInd.make3 -let canonical_mind = MutInd.canonical -let user_mind = MutInd.user -let repr_mind = MutInd.repr3 -let mind_label = MutInd.label -let mind_modpath = MutInd.modpath -let eq_mind = MutInd.equal -let mind_ord = MutInd.CanOrd.compare -let mind_user_ord = MutInd.UserOrd.compare -let string_of_mind = MutInd.to_string -let pr_mind = MutInd.print -let debug_string_of_mind = MutInd.debug_to_string -let debug_pr_mind = MutInd.debug_print +module GlobRef = struct + + type t = + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of Constant.t (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) + + let equal gr1 gr2 = + gr1 == gr2 || match gr1,gr2 with + | ConstRef con1, ConstRef con2 -> Constant.equal con1 con2 + | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2 + | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2 + | VarRef v1, VarRef v2 -> Id.equal v1 v2 + | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false + +end + +type global_reference = GlobRef.t +[@@ocaml.deprecated "Alias for [GlobRef.t]"] + +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + +(* Better to have it here that in closure, since used in grammar.cma *) +let eq_egr e1 e2 = match e1, e2 with + EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 + | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 + | _, _ -> false + +(** Located identifiers and objects with syntax. *) + +type lident = Id.t CAst.t +type lname = Name.t CAst.t +type lstring = string CAst.t diff --git a/kernel/names.mli b/kernel/names.mli index 74d63c0cea..1cdf5c2402 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** This file defines a lot of different notions of names used pervasively in @@ -40,24 +42,21 @@ sig (** Hash over identifiers. *) val is_valid : string -> bool - (** Check that a string may be converted to an identifier. - @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + (** Check that a string may be converted to an identifier. *) val of_bytes : bytes -> t val of_string : string -> t (** Converts a string into an identifier. - @raise UserError if the string is invalid as an identifier. - @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + @raise UserError if the string is invalid as an identifier. *) val of_string_soft : string -> t (** Same as {!of_string} except that any string made of supported UTF-8 characters is accepted. - @raise UserError if the string is invalid as an UTF-8 string. - @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) + @raise UserError if the string is invalid as an UTF-8 string. *) val to_string : t -> string (** Converts a identifier into an string. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Pretty-printer. *) module Set : Set.S with type elt = t @@ -105,7 +104,7 @@ sig val hcons : t -> t (** Hashconsing over names. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Pretty-printer (print "_" for [Anonymous]. *) end @@ -113,6 +112,8 @@ end (** {6 Type aliases} *) type name = Name.t = Anonymous | Name of Id.t +[@@ocaml.deprecated "Use Name.t"] + type variable = Id.t type module_ident = Id.t @@ -157,6 +158,7 @@ sig val hcons : t -> t (** Hashconsing of directory paths. *) + val print : t -> Pp.t end (** {6 Names of structure elements } *) @@ -187,7 +189,7 @@ sig val to_id : t -> Id.t (** Conversion to an identifier. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Pretty-printer. *) module Set : Set.S with type elt = t @@ -286,7 +288,7 @@ sig val debug_to_string : t -> string (** Same as [to_string], but outputs information related to debug. *) - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t (** Comparisons *) val compare : t -> t -> int @@ -298,7 +300,6 @@ module KNset : CSig.SetS with type elt = KerName.t module KNpred : Predicate.S with type elt = KerName.t module KNmap : Map.ExtS with type key = KerName.t and module Set := KNset - (** {6 Constant Names } *) module Constant: @@ -365,9 +366,9 @@ sig (** Displaying *) val to_string : t -> string - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t val debug_to_string : t -> string - val debug_print : t -> Pp.std_ppcmds + val debug_print : t -> Pp.t end @@ -447,9 +448,9 @@ sig (** Displaying *) val to_string : t -> string - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t val debug_to_string : t -> string - val debug_print : t -> Pp.std_ppcmds + val debug_print : t -> Pp.t end @@ -499,14 +500,6 @@ val constructor_user_hash : constructor -> int val constructor_syntactic_ord : constructor -> constructor -> int val constructor_syntactic_hash : constructor -> int -(** Better to have it here that in Closure, since required in grammar.cma *) -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -val eq_egr : evaluable_global_reference -> evaluable_global_reference - -> bool - (** {6 Hash-consing } *) val hcons_con : Constant.t -> Constant.t @@ -539,185 +532,85 @@ val eq_constant_key : Constant.t -> Constant.t -> bool (** equalities on constant and inductive names (for the checker) *) val eq_con_chk : Constant.t -> Constant.t -> bool +[@@ocaml.deprecated "Same as [Constant.UserOrd.equal]."] + val eq_ind_chk : inductive -> inductive -> bool (** {6 Deprecated functions. For backward compatibility.} *) -(** {5 Identifiers} *) - -type identifier = Id.t -(** @deprecated Alias for [Id.t] *) - -val string_of_id : identifier -> string -(** @deprecated Same as [Id.to_string]. *) - -val id_of_string : string -> identifier -(** @deprecated Same as [Id.of_string]. *) - -val id_ord : identifier -> identifier -> int -(** @deprecated Same as [Id.compare]. *) - -val id_eq : identifier -> identifier -> bool -(** @deprecated Same as [Id.equal]. *) - -module Idset : Set.S with type elt = identifier and type t = Id.Set.t -(** @deprecated Same as [Id.Set]. *) - -module Idpred : Predicate.S with type elt = identifier and type t = Id.Pred.t -(** @deprecated Same as [Id.Pred]. *) - -module Idmap : module type of Id.Map -(** @deprecated Same as [Id.Map]. *) - -(** {5 Directory paths} *) - -type dir_path = DirPath.t -(** @deprecated Alias for [DirPath.t]. *) - -val dir_path_ord : dir_path -> dir_path -> int -(** @deprecated Same as [DirPath.compare]. *) - -val dir_path_eq : dir_path -> dir_path -> bool -(** @deprecated Same as [DirPath.equal]. *) - -val make_dirpath : module_ident list -> dir_path -(** @deprecated Same as [DirPath.make]. *) - -val repr_dirpath : dir_path -> module_ident list -(** @deprecated Same as [DirPath.repr]. *) - -val empty_dirpath : dir_path -(** @deprecated Same as [DirPath.empty]. *) - -val is_empty_dirpath : dir_path -> bool -(** @deprecated Same as [DirPath.is_empty]. *) - -val string_of_dirpath : dir_path -> string -(** @deprecated Same as [DirPath.to_string]. *) - -val initial_dir : DirPath.t -(** @deprecated Same as [DirPath.initial]. *) - -(** {5 Labels} *) - -type label = Label.t -(** Alias type *) - -val mk_label : string -> label -(** @deprecated Same as [Label.make]. *) - -val string_of_label : label -> string -(** @deprecated Same as [Label.to_string]. *) - -val pr_label : label -> Pp.std_ppcmds -(** @deprecated Same as [Label.print]. *) - -val label_of_id : Id.t -> label -(** @deprecated Same as [Label.of_id]. *) - -val id_of_label : label -> Id.t -(** @deprecated Same as [Label.to_id]. *) - -val eq_label : label -> label -> bool -(** @deprecated Same as [Label.equal]. *) - -(** {5 Unique bound module names} *) - type mod_bound_id = MBId.t -(** Alias type. *) - -val mod_bound_id_ord : mod_bound_id -> mod_bound_id -> int -(** @deprecated Same as [MBId.compare]. *) - -val mod_bound_id_eq : mod_bound_id -> mod_bound_id -> bool -(** @deprecated Same as [MBId.equal]. *) - -val make_mbid : DirPath.t -> Id.t -> mod_bound_id -(** @deprecated Same as [MBId.make]. *) - -val repr_mbid : mod_bound_id -> int * Id.t * DirPath.t -(** @deprecated Same as [MBId.repr]. *) - -val id_of_mbid : mod_bound_id -> Id.t -(** @deprecated Same as [MBId.to_id]. *) - -val string_of_mbid : mod_bound_id -> string -(** @deprecated Same as [MBId.to_string]. *) - -val debug_string_of_mbid : mod_bound_id -> string -(** @deprecated Same as [MBId.debug_to_string]. *) - -(** {5 Names} *) - -val name_eq : name -> name -> bool -(** @deprecated Same as [Name.equal]. *) - +[@@ocaml.deprecated "Same as [MBId.t]."] (** {5 Module paths} *) type module_path = ModPath.t = | MPfile of DirPath.t | MPbound of MBId.t - | MPdot of module_path * Label.t -(** @deprecated Alias type *) - -val mp_ord : module_path -> module_path -> int -(** @deprecated Same as [ModPath.compare]. *) - -val mp_eq : module_path -> module_path -> bool -(** @deprecated Same as [ModPath.equal]. *) - -val check_bound_mp : module_path -> bool -(** @deprecated Same as [ModPath.is_bound]. *) - -val string_of_mp : module_path -> string -(** @deprecated Same as [ModPath.to_string]. *) - -val initial_path : module_path -(** @deprecated Same as [ModPath.initial]. *) + | MPdot of ModPath.t * Label.t +[@@ocaml.deprecated "Alias type"] -(** {5 Kernel names} *) - -type kernel_name = KerName.t -(** @deprecated Alias type *) - -val make_kn : ModPath.t -> DirPath.t -> Label.t -> kernel_name -(** @deprecated Same as [KerName.make]. *) - -val repr_kn : kernel_name -> module_path * DirPath.t * Label.t -(** @deprecated Same as [KerName.repr]. *) - -val modpath : kernel_name -> module_path -(** @deprecated Same as [KerName.modpath]. *) - -val label : kernel_name -> Label.t -(** @deprecated Same as [KerName.label]. *) - -val string_of_kn : kernel_name -> string -(** @deprecated Same as [KerName.to_string]. *) - -val pr_kn : kernel_name -> Pp.std_ppcmds -(** @deprecated Same as [KerName.print]. *) +module Projection : sig + module Repr : sig + type t + + val make : inductive -> proj_npars:int -> proj_arg:int -> Label.t -> t + + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + module CanOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + module UserOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + + val constant : t -> Constant.t + (** Don't use this if you don't have to. *) + + val inductive : t -> inductive + val mind : t -> MutInd.t + val npars : t -> int + val arg : t -> int + val label : t -> Label.t -val kn_ord : kernel_name -> kernel_name -> int -(** @deprecated Same as [KerName.compare]. *) + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int -(** {5 Constant names} *) + val map : (MutInd.t -> MutInd.t) -> t -> t + val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t -type constant = Constant.t -(** @deprecated Alias type *) + val print : t -> Pp.t + val to_string : t -> string + end + type t (* = Repr.t * bool *) -module Projection : sig - type t - - val make : constant -> bool -> t + val make : Repr.t -> bool -> t + val repr : t -> Repr.t module SyntacticOrd : sig val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end + module CanOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end - val constant : t -> constant + val constant : t -> Constant.t + val mind : t -> MutInd.t + val inductive : t -> inductive + val npars : t -> int + val arg : t -> int + val label : t -> Label.t val unfolded : t -> bool val unfold : t -> t @@ -727,110 +620,46 @@ module Projection : sig (** Hashconsing of projections. *) val compare : t -> t -> int - - val map : (constant -> constant) -> t -> t + + val map : (MutInd.t -> MutInd.t) -> t -> t + val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t val to_string : t -> string - val print : t -> Pp.std_ppcmds + val print : t -> Pp.t end type projection = Projection.t +[@@ocaml.deprecated "Alias for [Projection.t]"] -val constant_of_kn_equiv : KerName.t -> KerName.t -> constant -(** @deprecated Same as [Constant.make] *) - -val constant_of_kn : KerName.t -> constant -(** @deprecated Same as [Constant.make1] *) - -val make_con : ModPath.t -> DirPath.t -> Label.t -> constant -(** @deprecated Same as [Constant.make3] *) - -val repr_con : constant -> ModPath.t * DirPath.t * Label.t -(** @deprecated Same as [Constant.repr3] *) - -val user_con : constant -> KerName.t -(** @deprecated Same as [Constant.user] *) - -val canonical_con : constant -> KerName.t -(** @deprecated Same as [Constant.canonical] *) +(** {6 Global reference is a kernel side type for all references together } *) -val con_modpath : constant -> ModPath.t -(** @deprecated Same as [Constant.modpath] *) +(* XXX: Should we define GlobRefCan GlobRefUser? *) +module GlobRef : sig -val con_label : constant -> Label.t -(** @deprecated Same as [Constant.label] *) - -val eq_constant : constant -> constant -> bool -(** @deprecated Same as [Constant.equal] *) - -val con_ord : constant -> constant -> int -(** @deprecated Same as [Constant.CanOrd.compare] *) - -val con_user_ord : constant -> constant -> int -(** @deprecated Same as [Constant.UserOrd.compare] *) - -val con_with_label : constant -> Label.t -> constant -(** @deprecated Same as [Constant.change_label] *) - -val string_of_con : constant -> string -(** @deprecated Same as [Constant.to_string] *) - -val pr_con : constant -> Pp.std_ppcmds -(** @deprecated Same as [Constant.print] *) - -val debug_pr_con : constant -> Pp.std_ppcmds -(** @deprecated Same as [Constant.debug_print] *) - -val debug_string_of_con : constant -> string -(** @deprecated Same as [Constant.debug_to_string] *) - -(** {5 Mutual Inductive names} *) - -type mutual_inductive = MutInd.t -(** @deprecated Alias type *) - -val mind_of_kn : KerName.t -> mutual_inductive -(** @deprecated Same as [MutInd.make1] *) - -val mind_of_kn_equiv : KerName.t -> KerName.t -> mutual_inductive -(** @deprecated Same as [MutInd.make] *) - -val make_mind : ModPath.t -> DirPath.t -> Label.t -> mutual_inductive -(** @deprecated Same as [MutInd.make3] *) - -val user_mind : mutual_inductive -> KerName.t -(** @deprecated Same as [MutInd.user] *) - -val canonical_mind : mutual_inductive -> KerName.t -(** @deprecated Same as [MutInd.canonical] *) - -val repr_mind : mutual_inductive -> ModPath.t * DirPath.t * Label.t -(** @deprecated Same as [MutInd.repr3] *) - -val eq_mind : mutual_inductive -> mutual_inductive -> bool -(** @deprecated Same as [MutInd.equal] *) - -val mind_ord : mutual_inductive -> mutual_inductive -> int -(** @deprecated Same as [MutInd.CanOrd.compare] *) + type t = + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of Constant.t (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) -val mind_user_ord : mutual_inductive -> mutual_inductive -> int -(** @deprecated Same as [MutInd.UserOrd.compare] *) + val equal : t -> t -> bool -val mind_label : mutual_inductive -> Label.t -(** @deprecated Same as [MutInd.label] *) +end -val mind_modpath : mutual_inductive -> ModPath.t -(** @deprecated Same as [MutInd.modpath] *) +type global_reference = GlobRef.t +[@@ocaml.deprecated "Alias for [GlobRef.t]"] -val string_of_mind : mutual_inductive -> string -(** @deprecated Same as [MutInd.to_string] *) +(** Better to have it here that in Closure, since required in grammar.cma *) +(* XXX: Move to a module *) +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t -val pr_mind : mutual_inductive -> Pp.std_ppcmds -(** @deprecated Same as [MutInd.print] *) +val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool -val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds -(** @deprecated Same as [MutInd.debug_print] *) +(** Located identifiers and objects with syntax. *) -val debug_string_of_mind : mutual_inductive -> string -(** @deprecated Same as [MutInd.debug_to_string] *) +type lident = Id.t CAst.t +type lname = Name.t CAst.t +type lstring = string CAst.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index eb238941b7..cc35a70cbf 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1,20 +1,22 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open CErrors open Names -open Term +open Constr open Declarations open Util open Nativevalues open Nativeinstr open Nativelambda -open Pre_env +open Environ [@@@ocaml.warning "-32-37"] @@ -25,7 +27,7 @@ to OCaml code. *) (** Local names **) (* The first component is there for debugging purposes only *) -type lname = { lname : name; luid : int } +type lname = { lname : Name.t; luid : int } let eq_lname ln1 ln2 = Int.equal ln1.luid ln2.luid @@ -48,27 +50,29 @@ let fresh_lname n = (** Global names **) type gname = - | Gind of string * pinductive (* prefix, inductive name *) - | Gconstruct of string * pconstructor (* prefix, constructor name *) - | Gconstant of string * pconstant (* prefix, constant name *) - | Gproj of string * constant (* prefix, constant name *) - | Gcase of label option * int - | Gpred of label option * int - | Gfixtype of label option * int - | Gnorm of label option * int - | Gnormtbl of label option * int + | Gind of string * inductive (* prefix, inductive name *) + | Gconstruct of string * constructor (* prefix, constructor name *) + | Gconstant of string * Constant.t (* prefix, constant name *) + | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *) + | Gcase of Label.t option * int + | Gpred of Label.t option * int + | Gfixtype of Label.t option * int + | Gnorm of Label.t option * int + | Gnormtbl of Label.t option * int | Ginternal of string | Grel of int - | Gnamed of identifier + | Gnamed of Id.t let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> - String.equal s1 s2 && Univ.eq_puniverses eq_ind ind1 ind2 + String.equal s1 s2 && eq_ind ind1 ind2 | Gconstruct (s1, c1), Gconstruct (s2, c2) -> - String.equal s1 s2 && Univ.eq_puniverses eq_constructor c1 c2 + String.equal s1 s2 && eq_constructor c1 c2 | Gconstant (s1, c1), Gconstant (s2, c2) -> - String.equal s1 s2 && Univ.eq_puniverses Constant.equal c1 c2 + String.equal s1 s2 && Constant.equal c1 c2 + | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) -> + String.equal s1 s2 && eq_ind ind1 ind2 && Int.equal i1 i2 | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2 | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2 @@ -84,7 +88,9 @@ let eq_gname gn1 gn2 = | Ginternal s1, Ginternal s2 -> String.equal s1 s2 | Grel i1, Grel i2 -> Int.equal i1 i2 | Gnamed id1, Gnamed id2 -> Id.equal id1 id2 - | _ -> false + | (Gind _| Gconstruct _ | Gconstant _ | Gproj _ | Gcase _ | Gpred _ + | Gfixtype _ | Gnorm _ | Gnormtbl _ | Ginternal _ | Grel _ | Gnamed _), _ -> + false let dummy_gname = Grel 0 @@ -92,12 +98,12 @@ let dummy_gname = open Hashset.Combine let gname_hash gn = match gn with -| Gind (s, (ind,u)) -> - combinesmall 1 (combine3 (String.hash s) (ind_hash ind) (Univ.Instance.hash u)) -| Gconstruct (s, (c,u)) -> - combinesmall 2 (combine3 (String.hash s) (constructor_hash c) (Univ.Instance.hash u)) -| Gconstant (s, (c,u)) -> - combinesmall 3 (combine3 (String.hash s) (Constant.hash c) (Univ.Instance.hash u)) +| Gind (s, ind) -> + combinesmall 1 (combine (String.hash s) (ind_hash ind)) +| Gconstruct (s, c) -> + combinesmall 2 (combine (String.hash s) (constructor_hash c)) +| Gconstant (s, c) -> + combinesmall 3 (combine (String.hash s) (Constant.hash c)) | Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) | Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) | Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i)) @@ -106,7 +112,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 9 (String.hash s) | Grel i -> combinesmall 10 (Int.hash i) | Gnamed id -> combinesmall 11 (Id.hash id) -| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p)) +| Gproj (s, p, i) -> combinesmall 12 (combine (String.hash s) (combine (ind_hash p) i)) let case_ctr = ref (-1) @@ -142,14 +148,15 @@ let fresh_gnormtbl l = type symbol = | SymbValue of Nativevalues.t - | SymbSort of sorts - | SymbName of name - | SymbConst of constant + | SymbSort of Sorts.t + | SymbName of Name.t + | SymbConst of Constant.t | SymbMatch of annot_sw | SymbInd of inductive | SymbMeta of metavariable - | SymbEvar of existential + | SymbEvar of Evar.t | SymbLevel of Univ.Level.t + | SymbProj of (inductive * int) let dummy_symb = SymbValue (dummy_value ()) @@ -162,9 +169,9 @@ let eq_symbol sy1 sy2 = | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2 | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2 | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2 - | SymbEvar (evk1,args1), SymbEvar (evk2,args2) -> - Evar.equal evk1 evk2 && Array.for_all2 eq_constr args1 args2 + | SymbEvar evk1, SymbEvar evk2 -> Evar.equal evk1 evk2 | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2 + | SymbProj (i1, k1), SymbProj (i2, k2) -> eq_ind i1 i2 && Int.equal k1 k2 | _, _ -> false let hash_symbol symb = @@ -176,11 +183,9 @@ let hash_symbol symb = | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw) | SymbInd ind -> combinesmall 6 (ind_hash ind) | SymbMeta m -> combinesmall 7 m - | SymbEvar (evk,args) -> - let evh = Evar.hash evk in - let hl = Array.fold_left (fun h t -> combine h (Constr.hash t)) evh args in - combinesmall 8 hl + | SymbEvar evk -> combinesmall 8 (Evar.hash evk) | SymbLevel l -> combinesmall 9 (Univ.Level.hash l) + | SymbProj (i, k) -> combinesmall 10 (combine (ind_hash i) k) module HashedTypeSymbol = struct type t = symbol @@ -243,6 +248,11 @@ let get_level tbl i = | SymbLevel u -> u | _ -> anomaly (Pp.str "get_level failed.") +let get_proj tbl i = + match tbl.(i) with + | SymbProj p -> p + | _ -> anomaly (Pp.str "get_proj failed.") + let push_symbol x = try HashtblSymbol.find symb_tbl x with Not_found -> @@ -266,9 +276,8 @@ type primitive = | Mk_fix of rec_pos * int | Mk_cofix of int | Mk_rel of int - | Mk_var of identifier + | Mk_var of Id.t | Mk_proj - | Is_accu | Is_int | Cast_accu | Upd_cofix @@ -296,7 +305,7 @@ type primitive = | MLmagic | MLarrayget | Mk_empty_instance - | Coq_primitive of Primitives.t * (prefix * constant) option + | Coq_primitive of CPrimitives.t * (prefix * Constant.t) option let eq_primitive p1 p2 = match p1, p2 with @@ -309,7 +318,6 @@ let eq_primitive p1 p2 = | Mk_cofix i1, Mk_cofix i2 -> Int.equal i1 i2 | Mk_rel i1, Mk_rel i2 -> Int.equal i1 i2 | Mk_var id1, Mk_var id2 -> Id.equal id1 id2 - | Is_accu, Is_accu -> true | Cast_accu, Cast_accu -> true | Upd_cofix, Upd_cofix -> true | Force_cofix, Force_cofix -> true @@ -335,7 +343,6 @@ let primitive_hash = function combinesmall 8 (Int.hash i) | Mk_var id -> combinesmall 9 (Id.hash id) - | Is_accu -> 10 | Is_int -> 11 | Cast_accu -> 12 | Upd_cofix -> 13 @@ -361,9 +368,9 @@ let primitive_hash = function | MLsub -> 33 | MLmul -> 34 | MLmagic -> 35 - | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim) + | Coq_primitive (prim, None) -> combinesmall 36 (CPrimitives.hash prim) | Coq_primitive (prim, Some (prefix,kn)) -> - combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim)) + combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) | Mk_proj -> 38 | MLarrayget -> 39 | Mk_empty_instance -> 40 @@ -386,6 +393,7 @@ type mllambda = | MLsetref of string * mllambda | MLsequence of mllambda * mllambda | MLarray of mllambda array + | MLisaccu of string * inductive * mllambda and mllam_branches = ((constructor * lname option array) list * mllambda) array @@ -457,7 +465,12 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = | MLarray arr1, MLarray arr2 -> Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2 - | _, _ -> false + | MLisaccu (s1, ind1, ml1), MLisaccu (s2, ind2, ml2) -> + String.equal s1 s2 && eq_ind ind1 ind2 && + eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 + | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ | + MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ | + MLsetref _ | MLsequence _ | MLarray _ | MLisaccu _), _ -> false and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 = let eq_def (_,args1,ml1) (_,args2,ml2) = @@ -532,6 +545,8 @@ let rec hash_mllambda gn n env t = combinesmall 14 (combine hml hml') | MLarray arr -> combinesmall 15 (hash_mllambda_array gn n env 1 arr) + | MLisaccu (s, ind, c) -> + combinesmall 16 (combine (String.hash s) (combine (ind_hash ind) (hash_mllambda gn n env c))) and hash_mllambda_letrec gn n env init defs = let hash_def (_,args,ml) = @@ -598,6 +613,7 @@ let fv_lam l = | MLsetref(_,l) -> aux l bind fv | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv) | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv + | MLisaccu (_, _, body) -> aux body bind fv in aux l LNset.empty LNset.empty @@ -625,7 +641,7 @@ let decompose_MLlam c = (*s Global declaration *) type global = -(* | Gtblname of gname * identifier array *) +(* | Gtblname of gname * Id.t array *) | Gtblnorm of gname * lname array * mllambda array | Gtblfixtype of gname * lname array * mllambda array | Glet of gname * mllambda @@ -732,7 +748,7 @@ type env = env_bound : int; (* length of env_rel *) (* free variables *) env_urel : (int * mllambda) list ref; (* list of unbound rel *) - env_named : (identifier * mllambda) list ref; + env_named : (Id.t * mllambda) list ref; env_univ : lname option} let empty_env univ () = @@ -887,6 +903,10 @@ let get_level_code i = MLapp (MLglobal (Ginternal "get_level"), [|MLglobal symbols_tbl_name; MLint i|]) +let get_proj_code i = + MLapp (MLglobal (Ginternal "get_proj"), + [|MLglobal symbols_tbl_name; MLint i|]) + type rlist = | Rnil | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' @@ -921,7 +941,7 @@ let merge_branches t = type prim_aux = - | PAprim of string * constant * Primitives.t * prim_aux array + | PAprim of string * Constant.t * CPrimitives.t * prim_aux array | PAml of mllambda let add_check cond args = @@ -988,11 +1008,11 @@ let compile_prim decl cond paux = | Int31lt -> if Sys.word_size = 64 then app_prim Mk_bool [|(app_prim MLlt (args_to_int args))|] - else app_prim (Coq_primitive (Primitives.Int31lt,None)) args + else app_prim (Coq_primitive (CPrimitives.Int31lt,None)) args | Int31le -> if Sys.word_size = 64 then app_prim Mk_bool [|(app_prim MLle (args_to_int args))|] - else app_prim (Coq_primitive (Primitives.Int31le, None)) args + else app_prim (Coq_primitive (CPrimitives.Int31le, None)) args | Int31lsl -> of_int (mk_lsl (args_to_int args)) | Int31lsr -> of_int (mk_lsr (args_to_int args)) | Int31land -> of_int (mk_land (args_to_int args)) @@ -1047,11 +1067,12 @@ let ml_of_instance instance u = let tyn = fresh_lname Anonymous in let i = push_symbol (SymbMeta mv) in MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|]) - | Levar(ev,ty) -> + | Levar(evk,ty,args) -> let tyn = fresh_lname Anonymous in - let i = push_symbol (SymbEvar ev) in + let i = push_symbol (SymbEvar evk) in + let args = MLarray(Array.map (ml_of_lam env l) args) in MLlet(tyn, ml_of_lam env l ty, - MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn|])) + MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn; args|])) | Lprod(dom,codom) -> let dom = ml_of_lam env l dom in let codom = ml_of_lam env l codom in @@ -1068,10 +1089,10 @@ let ml_of_instance instance u = MLlet(lname,def,body) | Lapp(f,args) -> MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args) - | Lconst (prefix,c) -> - let args = ml_of_instance env.env_univ (snd c) in - mkMLapp (MLglobal(Gconstant (prefix,c))) args - | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) + | Lconst (prefix, (c, u)) -> + let args = ml_of_instance env.env_univ u in + mkMLapp (MLglobal(Gconstant (prefix, c))) args + | Lproj (prefix, ind, i) -> MLglobal(Gproj (prefix, ind, i)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux @@ -1127,7 +1148,7 @@ let ml_of_instance instance u = mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|] | Lif(t,bt,bf) -> MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf) - | Lfix ((rec_pos,start), (ids, tt, tb)) -> + | Lfix ((rec_pos, inds, start), (ids, tt, tb)) -> (* let type_f fvt = [| type fix |] let norm_f1 fv f1 .. fn params1 = body1 .. @@ -1196,8 +1217,9 @@ let ml_of_instance instance u = let paramsi = t_params.(i) in let reci = MLlocal (paramsi.(rec_pos.(i))) in let pargsi = Array.map (fun id -> MLlocal id) paramsi in + let (prefix, ind) = inds.(i) in let body = - MLif(MLapp(MLprimitive Is_accu,[|reci|]), + MLif(MLisaccu (prefix, ind, reci), mkMLapp (MLapp(MLprimitive (Mk_fix(rec_pos,i)), [|mk_type; mk_norm|])) @@ -1281,17 +1303,17 @@ let ml_of_instance instance u = MLconstruct(prefix,cn,args) | Lconstruct (prefix, (cn,u)) -> let uargs = ml_of_instance env.env_univ u in - mkMLapp (MLglobal (Gconstruct (prefix, (cn,u)))) uargs + mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs | Luint v -> (match v with | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | UintDigits (prefix,cn,ds) -> - let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in + let c = MLglobal (Gconstruct (prefix, cn)) in let ds = Array.map (ml_of_lam env l) ds in let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in MLapp(i31, ds) | UintDecomp (prefix,cn,t) -> - let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in + let c = MLglobal (Gconstruct (prefix, cn)) in let t = ml_of_lam env l t in MLapp (MLprimitive Decomp_uint, [|c;t|])) | Lval v -> @@ -1304,9 +1326,9 @@ let ml_of_instance instance u = in let uarg = MLapp(MLprimitive MLmagic, [|uarg|]) in MLapp(MLprimitive Mk_sort, [|get_sort_code i; uarg|]) - | Lind (prefix, pind) -> - let uargs = ml_of_instance env.env_univ (snd pind) in - mkMLapp (MLglobal (Gind (prefix, pind))) uargs + | Lind (prefix, (ind, u)) -> + let uargs = ml_of_instance env.env_univ u in + mkMLapp (MLglobal (Gind (prefix, ind))) uargs | Llazy -> MLglobal (Ginternal "lazy") | Lforce -> MLglobal (Ginternal "Lazy.force") @@ -1359,6 +1381,7 @@ let subst s l = | MLsetref(s,l1) -> MLsetref(s,aux l1) | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2) | MLarray arr -> MLarray (Array.map aux arr) + | MLisaccu (s, ind, l) -> MLisaccu (s, ind, aux l) in aux l @@ -1456,7 +1479,7 @@ let optimize gdef l = let b1 = optimize s b1 in let b2 = optimize s b2 in begin match t, b2 with - | MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs) + | MLisaccu (_, _, l1), MLmatch(annot, l2, _, bs) when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs) | _, _ -> MLif(t, b1, b2) end @@ -1468,6 +1491,7 @@ let optimize gdef l = | MLsetref(r,l) -> MLsetref(r, optimize s l) | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2) | MLarray arr -> MLarray (Array.map (optimize s) arr) + | MLisaccu (pf, ind, l) -> MLisaccu (pf, ind, optimize s l) in optimize LNmap.empty l @@ -1504,7 +1528,7 @@ let string_of_dirpath = function (* OCaml as a module identifier. *) let string_of_dirpath s = "N"^string_of_dirpath s -let mod_uid_of_dirpath dir = string_of_dirpath (repr_dirpath dir) +let mod_uid_of_dirpath dir = string_of_dirpath (DirPath.repr dir) let link_info_of_dirpath dir = Linked (mod_uid_of_dirpath dir ^ ".") @@ -1523,30 +1547,30 @@ let string_of_label_def l = let rec list_of_mp acc = function | MPdot (mp,l) -> list_of_mp (string_of_label l::acc) mp | MPfile dp -> - let dp = repr_dirpath dp in + let dp = DirPath.repr dp in string_of_dirpath dp :: acc - | MPbound mbid -> ("X"^string_of_id (id_of_mbid mbid))::acc + | MPbound mbid -> ("X"^string_of_id (MBId.to_id mbid))::acc let list_of_mp mp = list_of_mp [] mp let string_of_kn kn = - let (mp,dp,l) = repr_kn kn in + let (mp,dp,l) = KerName.repr kn in let mp = list_of_mp mp in String.concat "_" mp ^ "_" ^ string_of_label l -let string_of_con c = string_of_kn (user_con c) -let string_of_mind mind = string_of_kn (user_mind mind) +let string_of_con c = string_of_kn (Constant.user c) +let string_of_mind mind = string_of_kn (MutInd.user mind) let string_of_gname g = match g with - | Gind (prefix, ((mind,i), _)) -> + | Gind (prefix, (mind, i)) -> Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i - | Gconstruct (prefix, (((mind, i), j), _)) -> + | Gconstruct (prefix, ((mind, i), j)) -> Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) - | Gconstant (prefix, (c,_)) -> + | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) - | Gproj (prefix, c) -> - Format.sprintf "%sproj_%s" prefix (string_of_con c) + | Gproj (prefix, (mind, n), i) -> + Format.sprintf "%sproj_%s_%i_%i" prefix (string_of_mind mind) n i | Gcase (l,i) -> Format.sprintf "case_%s_%i" (string_of_label_def l) i | Gpred (l,i) -> @@ -1630,19 +1654,23 @@ let pp_mllam fmt l = pp_mllam fmt arr.(len-1) end; Format.fprintf fmt "|]@]" - + | MLisaccu (prefix, (mind, i), c) -> + let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in + Format.fprintf fmt + "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n true@\n| _ ->@\n false@\nend@]" + pp_mllam c accu and pp_letrec fmt defs = let len = Array.length defs in - let pp_one_rec i (fn, argsn, body) = + let pp_one_rec (fn, argsn, body) = Format.fprintf fmt "%a%a =@\n %a" pp_lname fn pp_ldecls argsn pp_mllam body in Format.fprintf fmt "@[let rec "; - pp_one_rec 0 defs.(0); + pp_one_rec defs.(0); for i = 1 to len - 1 do Format.fprintf fmt "@\nand "; - pp_one_rec i defs.(i) + pp_one_rec defs.(i) done; and pp_blam fmt l = @@ -1723,7 +1751,6 @@ let pp_mllam fmt l = | Mk_var id -> Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id) | Mk_proj -> Format.fprintf fmt "mk_proj_accu" - | Is_accu -> Format.fprintf fmt "is_accu" | Is_int -> Format.fprintf fmt "is_int" | Cast_accu -> Format.fprintf fmt "cast_accu" | Upd_cofix -> Format.fprintf fmt "upd_cofix" @@ -1752,11 +1779,10 @@ let pp_mllam fmt l = | MLarrayget -> Format.fprintf fmt "Array.get" | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty" | Coq_primitive (op,None) -> - Format.fprintf fmt "no_check_%s" (Primitives.to_string op) + Format.fprintf fmt "no_check_%s" (CPrimitives.to_string op) | Coq_primitive (op, Some (prefix,kn)) -> - let u = Univ.Instance.empty in - Format.fprintf fmt "%s %a" (Primitives.to_string op) - pp_mllam (MLglobal (Gconstant (prefix,(kn,u)))) + Format.fprintf fmt "%s %a" (CPrimitives.to_string op) + pp_mllam (MLglobal (Gconstant (prefix, kn))) in Format.fprintf fmt "@[%a@]" pp_mllam l @@ -1831,7 +1857,7 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = in let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in let auxdefs = List.fold_right get_named_val fv_named auxdefs in - let lvl = Context.Rel.length env.env_rel_context in + let lvl = Context.Rel.length (rel_context env) in let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in let aux_name = fresh_lname Anonymous in @@ -1839,8 +1865,8 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = and compile_rel env sigma univ auxdefs n = let open Context.Rel.Declaration in - let decl = Context.Rel.lookup n env.env_rel_context in - let n = Context.Rel.length env.env_rel_context - n in + let decl = lookup_rel n env in + let n = List.length (rel_context env) - n in match decl with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in @@ -1860,27 +1886,25 @@ and compile_named env sigma univ auxdefs id = Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = - match cb.const_proj with - | None -> - let u = + let no_univs = match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.AUContext.instance ctx + | Monomorphic_const _ -> true + | Polymorphic_const ctx -> Int.equal (Univ.AUContext.size ctx) 0 in begin match cb.const_body with | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); - let is_lazy = is_lazy prefix t in + let is_lazy = is_lazy env prefix t in let code = if is_lazy then mk_lazy code else code in let name = if interactive then LinkedInteractive prefix else Linked prefix in - let l = con_label con in + let l = Constant.label con in let auxdefs,code = - if Univ.Instance.is_empty u then compile_with_fv env sigma None [] (Some l) code + if no_univs then compile_with_fv env sigma None [] (Some l) code else let univ = fresh_univ () in let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in @@ -1888,54 +1912,23 @@ let compile_constant env sigma prefix ~interactive con cb = in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); let code = - optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs) + optimize_stk (Glet(Gconstant ("", con),code)::auxdefs) in if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); code, name | _ -> let i = push_symbol (SymbConst con) in let args = - if Univ.Instance.is_empty u then [|get_const_code i; MLarray [||]|] + if no_univs then [|get_const_code i; MLarray [||]|] else [|get_const_code i|] in (* let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const) *) - [Glet(Gconstant ("",(con,u)), mkMLapp (MLprimitive Mk_const) args)], + [Glet(Gconstant ("", con), mkMLapp (MLprimitive Mk_const) args)], if interactive then LinkedInteractive prefix else Linked prefix end - | Some pb -> - let u = Univ.Instance.empty in - let mind = pb.proj_ind in - let ind = (mind,0) in - let mib = lookup_mind mind env in - let oib = mib.mind_packets.(0) in - let tbl = oib.mind_reloc_tbl in - (* Building info *) - let prefix = get_mind_prefix env mind in - let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; - ci_cstr_nargs = [|0|]; - ci_cstr_ndecls = [||] (*FIXME*); - ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in - let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; - asw_reloc = tbl; asw_finite = true } in - let c_uid = fresh_lname Anonymous in - let _, arity = tbl.(0) in - let ci_uid = fresh_lname Anonymous in - let cargs = Array.init arity - (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) - in - let i = push_symbol (SymbConst con) in - let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in - let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in - let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in - let gn = Gproj ("",con) in - let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in - let arg = fargs.(pb.proj_npars) in - Glet(Gconstant ("",(con,u)), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal - arg|]))):: - [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) @@ -1957,18 +1950,20 @@ let is_code_loaded ~interactive name = if is_loaded_native_file s then true else (name := NotLinked; false) -let param_name = Name (id_of_string "params") -let arg_name = Name (id_of_string "arg") +let param_name = Name (Id.of_string "params") +let arg_name = Name (Id.of_string "arg") -let compile_mind prefix ~interactive mb mind stack = - let u = Declareops.inductive_polymorphic_instance mb in +let compile_mind mb mind stack = + let u = Declareops.inductive_polymorphic_context mb in + (** Generate data for every block *) let f i stack ob = - let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in - let j = push_symbol (SymbInd (mind,i)) in - let name = Gind ("", ((mind, i), u)) in + let ind = (mind, i) in + let gtype = Gtype(ind, Array.map snd ob.mind_reloc_tbl) in + let j = push_symbol (SymbInd ind) in + let name = Gind ("", ind) in let accu = let args = - if Univ.Instance.is_empty u then + if Int.equal (Univ.AUContext.size u) 0 then [|get_ind_code j; MLarray [||]|] else [|get_ind_code j|] in @@ -1979,12 +1974,43 @@ let compile_mind prefix ~interactive mb mind stack = Array.init nparams (fun i -> {lname = param_name; luid = i}) in let add_construct j acc (_,arity) = let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in - let c = (mind,i), (j+1) in - Glet(Gconstruct ("",(c,u)), + let c = ind, (j+1) in + Glet(Gconstruct ("", c), mkMLlam (Array.append params args) (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in - Array.fold_left_i add_construct (gtype::accu::stack) ob.mind_reloc_tbl + let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in + let add_proj proj_arg acc pb = + let tbl = ob.mind_reloc_tbl in + (* Building info *) + let ci = { ci_ind = ind; ci_npar = nparams; + ci_cstr_nargs = [|0|]; + ci_cstr_ndecls = [||] (*FIXME*); + ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in + let asw = { asw_ind = ind; asw_prefix = ""; asw_ci = ci; + asw_reloc = tbl; asw_finite = true } in + let c_uid = fresh_lname Anonymous in + let cf_uid = fresh_lname Anonymous in + let _, arity = tbl.(0) in + let ci_uid = fresh_lname Anonymous in + let cargs = Array.init arity + (fun i -> if Int.equal i proj_arg then Some ci_uid else None) + in + let i = push_symbol (SymbProj (ind, j)) in + let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in + let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in + let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in + let gn = Gproj ("", ind, proj_arg) in + Glet (gn, mkMLlam [|c_uid|] code) :: acc + in + let projs = match mb.mind_record with + | NotRecord | FakeRecord -> [] + | PrimRecord info -> + let _, _, pbs = info.(i) in + Array.fold_left_i add_proj [] pbs + in + projs @ constructors @ gtype :: accu :: stack in Array.fold_left_i f stack mb.mind_packets @@ -2005,7 +2031,7 @@ let compile_mind_deps env prefix ~interactive then init else let comp_stack = - compile_mind prefix ~interactive mib mind comp_stack + compile_mind mib mind comp_stack in let name = if interactive then LinkedInteractive prefix @@ -2017,24 +2043,22 @@ let compile_mind_deps env prefix ~interactive (* This function compiles all necessary dependencies of t, and generates code in reverse order, as well as linking information updates *) -let rec compile_deps env sigma prefix ~interactive init t = - match kind_of_term t with +let compile_deps env sigma prefix ~interactive init t = + let rec aux env lvl init t = + match kind t with | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind | Const c -> - let c,u = get_alias env c in - let cb,(nameref,_) = lookup_constant_key c env in - let (_, (_, const_updates)) = init in - if is_code_loaded ~interactive nameref - || (Cmap_env.mem c const_updates) - then init - else + let c,u = get_alias env c in + let cb,(nameref,_) = lookup_constant_key c env in + let (_, (_, const_updates)) = init in + if is_code_loaded ~interactive nameref + || (Cmap_env.mem c const_updates) + then init + else let comp_stack, (mind_updates, const_updates) = - match cb.const_proj, cb.const_body with - | None, Def t -> - compile_deps env sigma prefix ~interactive init (Mod_subst.force_constr t) - | Some pb, _ -> - let mind = pb.proj_ind in - compile_mind_deps env prefix ~interactive init mind + match cb.const_body with + | Def t -> + aux env lvl init (Mod_subst.force_constr t) | _ -> init in let code, name = @@ -2045,13 +2069,31 @@ let rec compile_deps env sigma prefix ~interactive init t = comp_stack, (mind_updates, const_updates) | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind | Proj (p,c) -> - let term = mkApp (mkConst (Projection.constant p), [|c|]) in - compile_deps env sigma prefix ~interactive init term + let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in + aux env lvl init c | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in - fold_constr (compile_deps env sigma prefix ~interactive) init t - | _ -> fold_constr (compile_deps env sigma prefix ~interactive) init t + fold_constr_with_binders succ (aux env) lvl init t + | Var id -> + let open Context.Named.Declaration in + begin match lookup_named id env with + | LocalDef (_,t,_) -> + aux env lvl init t + | _ -> init + end + | Rel n when n > lvl -> + let open Context.Rel.Declaration in + let decl = lookup_rel n env in + let env = env_of_rel n env in + begin match decl with + | LocalDef (_,t,_) -> + aux env lvl init t + | LocalAssum _ -> init + end + | _ -> fold_constr_with_binders succ (aux env) lvl init t + in + aux env 0 init t let compile_constant_field env prefix con acc cb = let (gl, _) = @@ -2060,9 +2102,9 @@ let compile_constant_field env prefix con acc cb = in gl@acc -let compile_mind_field prefix mp l acc mb = +let compile_mind_field mp l acc mb = let mind = MutInd.make2 mp l in - compile_mind prefix ~interactive:false mb mind acc + compile_mind mb mind acc let mk_open s = Gopen s diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index ae6fb1bd6b..96efa7faa5 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -1,14 +1,16 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term open Names +open Constr open Declarations -open Pre_env +open Environ open Nativelambda (** This file defines the mllambda code generation phase of the native @@ -32,11 +34,11 @@ val clear_symbols : unit -> unit val get_value : symbols -> int -> Nativevalues.t -val get_sort : symbols -> int -> sorts +val get_sort : symbols -> int -> Sorts.t -val get_name : symbols -> int -> name +val get_name : symbols -> int -> Name.t -val get_const : symbols -> int -> constant +val get_const : symbols -> int -> Constant.t val get_match : symbols -> int -> Nativevalues.annot_sw @@ -44,10 +46,12 @@ val get_ind : symbols -> int -> inductive val get_meta : symbols -> int -> metavariable -val get_evar : symbols -> int -> existential +val get_evar : symbols -> int -> Evar.t val get_level : symbols -> int -> Univ.Level.t +val get_proj : symbols -> int -> inductive * int + val get_symbols : unit -> symbols type code_location_update @@ -60,20 +64,20 @@ val empty_updates : code_location_updates val register_native_file : string -> unit -val compile_constant_field : env -> string -> constant -> +val compile_constant_field : env -> string -> Constant.t -> global list -> constant_body -> global list -val compile_mind_field : string -> module_path -> label -> +val compile_mind_field : ModPath.t -> Label.t -> global list -> mutual_inductive_body -> global list val mk_conv_code : env -> evars -> string -> constr -> constr -> linkable_code val mk_norm_code : env -> evars -> string -> constr -> linkable_code -val mk_library_header : dir_path -> global list +val mk_library_header : DirPath.t -> global list -val mod_uid_of_dirpath : dir_path -> string +val mod_uid_of_dirpath : DirPath.t -> string -val link_info_of_dirpath : dir_path -> link_info +val link_info_of_dirpath : DirPath.t -> link_info val update_locations : code_location_updates -> unit diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index d2f050d3bc..931b8bbc86 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open CErrors @@ -54,13 +56,18 @@ and conv_accu env pb lvl k1 k2 cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu else let cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu in - List.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu + Array.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu and conv_atom env pb lvl a1 a2 cu = if a1 == a2 then cu else match a1, a2 with - | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false + | Ameta (m1,_), Ameta (m2,_) -> + if Int.equal m1 m2 then cu else raise NotConvertible + | Aevar (ev1,_,args1), Aevar (ev2,_,args2) -> + if Evar.equal ev1 ev2 then + Array.fold_right2 (conv_val env CONV lvl) args1 args2 cu + else raise NotConvertible | Arel i1, Arel i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Aind (ind1,u1), Aind (ind2,u2) -> @@ -107,12 +114,12 @@ and conv_atom env pb lvl a1 a2 cu = let cu = conv_val env CONV lvl d1 d2 cu in let v = mk_rel_accu lvl in conv_val env pb (lvl + 1) (d1 v) (d2 v) cu - | Aproj(p1,ac1), Aproj(p2,ac2) -> - if not (Constant.equal p1 p2) then raise NotConvertible + | Aproj((ind1, i1), ac1), Aproj((ind2, i2), ac2) -> + if not (eq_ind ind1 ind2 && Int.equal i1 i2) then raise NotConvertible else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ - | Aproj _, _ -> raise NotConvertible + | Aproj _, _ | Ameta _, _ | Aevar _, _ -> raise NotConvertible (* Precondition length t1 = length f1 = length f2 = length t2 *) and conv_fix env lvl t1 f1 t2 f2 cu = @@ -128,11 +135,21 @@ and conv_fix env lvl t1 f1 t2 f2 cu = else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in aux 0 cu +let warn_no_native_compiler = + let open Pp in + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + (fun () -> strbrk "Native compiler is disabled," ++ + strbrk " falling back to VM conversion test.") + let native_conv_gen pb sigma env univs t1 t2 = - let penv = Environ.pre_env env in + if not Coq_config.native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else let ml_filename, prefix = get_ml_filename () in - let code, upds = mk_conv_code penv sigma prefix t1 t2 in - match compile ml_filename code with + let code, upds = mk_conv_code env sigma prefix t1 t2 in + match compile ml_filename code ~profile:false with | (true, fn) -> begin if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); @@ -146,19 +163,8 @@ let native_conv_gen pb sigma env univs t1 t2 = end | _ -> anomaly (Pp.str "Compilation failure.") -let warn_no_native_compiler = - let open Pp in - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - (fun () -> strbrk "Native compiler is disabled," ++ - strbrk " falling back to VM conversion test.") - (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = - if Coq_config.no_native_compiler then begin - warn_no_native_compiler (); - vm_conv cv_pb env t1 t2 - end - else let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli index fbbcce7449..2111739d5e 100644 --- a/kernel/nativeconv.mli +++ b/kernel/nativeconv.mli @@ -1,11 +1,13 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open Reduction open Nativelambda diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index cb79877e8b..5075bd3d14 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -1,12 +1,14 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Nativevalues (** This file defines the lambda code for the native compiler. It has been @@ -20,22 +22,22 @@ type uint = | UintDecomp of prefix * constructor * lambda and lambda = - | Lrel of name * int - | Lvar of identifier + | Lrel of Name.t * int + | Lvar of Id.t | Lmeta of metavariable * lambda (* type *) - | Levar of existential * lambda (* type *) + | Levar of Evar.t * lambda (* type *) * lambda array (* arguments *) | Lprod of lambda * lambda - | Llam of name array * lambda - | Llet of name * lambda * lambda + | Llam of Name.t array * lambda + | Llet of Name.t * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * pconstant - | Lproj of prefix * constant (* prefix, projection name *) - | Lprim of prefix * constant * Primitives.t * lambda array + | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) + | Lprim of prefix * Constant.t * CPrimitives.t * lambda array | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) | Lif of lambda * lambda * lambda - | Lfix of (int array * int) * fix_decl - | Lcofix of int * fix_decl + | Lfix of (int array * (string * inductive) array * int) * fix_decl + | Lcofix of int * fix_decl (* must be in eta-expanded form *) | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor name, constructor tag, arguments *) (* A fully applied constructor *) @@ -43,11 +45,15 @@ and lambda = (* A partially applied constructor *) | Luint of uint | Lval of Nativevalues.t - | Lsort of sorts + | Lsort of Sorts.t | Lind of prefix * pinductive | Llazy | Lforce -and lam_branches = (constructor * name array * lambda) array +(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation +to be correct. Otherwise, memoization of previous evaluations will be applied +again to extra arguments (see #7333). *) -and fix_decl = name array * lambda array * lambda array +and lam_branches = (constructor * Name.t array * lambda) array + +and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 508112b35d..cec0ee57d5 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -1,16 +1,18 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Util open Names open Esubst -open Term +open Constr open Declarations -open Pre_env +open Environ open Nativevalues open Nativeinstr @@ -83,9 +85,9 @@ let get_const_prefix env c = (* A generic map function *) -let map_lam_with_binders g f n lam = +let rec map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in @@ -100,10 +102,10 @@ let map_lam_with_binders g f n lam = if body == body' && def == def' then lam else Llet(id,def',body') | Lapp(fct,args) -> let fct' = f n fct in - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if fct == fct' && args == args' then lam else mkLapp fct' args' | Lprim(prefix,kn,op,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Lprim(prefix,kn,op,args') | Lcase(annot,t,a,br) -> let t' = f n t in @@ -114,7 +116,7 @@ let map_lam_with_binders g f n lam = if Array.is_empty ids then f n body else f (g (Array.length ids) n) body in if body == body' then b else (cn,ids,body') in - let br' = Array.smartmap on_b br in + let br' = Array.Smart.map on_b br in if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br') | Lif(t,bt,bf) -> let t' = f n t in @@ -122,18 +124,31 @@ let map_lam_with_binders g f n lam = let bf' = f n bf in if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> - let ltypes' = Array.smartmap (f n) ltypes in - let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lfix(init,(ids,ltypes',lbodies')) | Lcofix(init,(ids,ltypes,lbodies)) -> - let ltypes' = Array.smartmap (f n) ltypes in - let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lcofix(init,(ids,ltypes',lbodies')) | Lmakeblock(prefix,cn,tag,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(prefix,cn,tag,args') + | Luint u -> + let u' = map_uint g f n u in + if u == u' then lam else Luint u' + +and map_uint g f n u = + match u with + | UintVal _ -> u + | UintDigits(prefix,c,args) -> + let args' = Array.Smart.map (f n) args in + if args == args' then u else UintDigits(prefix,c,args') + | UintDecomp(prefix,c,a) -> + let a' = f n a in + if a == a' then u else UintDecomp(prefix,c,a') (*s Lift and substitution *) @@ -162,7 +177,7 @@ let rec lam_exsubst subst lam = let lam_subst_args subst args = if is_subs_id subst then args - else Array.smartmap (lam_exsubst subst) args + else Array.Smart.map (lam_exsubst subst) args (** Simplification of lambda expression *) @@ -257,7 +272,7 @@ and simplify_app substf f substa args = (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) -and simplify_args subst args = Array.smartmap (simplify subst) args +and simplify_args subst args = Array.Smart.map (simplify subst) args and reduce_lapp substf lids body substa largs = match lids, largs with @@ -281,15 +296,17 @@ let is_value lc = match lc with | Lval _ -> true | Lmakeblock(_,_,_,args) when Array.is_empty args -> true + | Luint (UintVal _) -> true | _ -> false - + let get_value lc = match lc with | Lval v -> v - | Lmakeblock(_,_,tag,args) when Array.is_empty args -> + | Lmakeblock(_,_,tag,args) when Array.is_empty args -> Nativevalues.mk_int tag + | Luint (UintVal i) -> Nativevalues.mk_uint i | _ -> raise Not_found - + let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) @@ -316,54 +333,13 @@ let rec get_alias env (kn, u as p) = (*i Global environment *) -let global_env = ref empty_env - -let set_global_env env = global_env := env - let get_names decl = let decl = Array.of_list decl in Array.map fst decl -(* Rel Environment *) -module Vect = - struct - type 'a t = { - mutable elems : 'a array; - mutable size : int; - } - - let make n a = { - elems = Array.make n a; - size = 0; - } - - let extend v = - if Int.equal v.size (Array.length v.elems) then - let new_size = min (2*v.size) Sys.max_array_length in - if new_size <= v.size then invalid_arg "Vect.extend"; - let new_elems = Array.make new_size v.elems.(0) in - Array.blit v.elems 0 new_elems 0 (v.size); - v.elems <- new_elems - - let push v a = - extend v; - v.elems.(v.size) <- a; - v.size <- v.size + 1 - - let popn v n = - v.size <- max 0 (v.size - n) - - let pop v = popn v 1 - - let get_last v n = - if v.size <= n then invalid_arg "Vect.get:index out of bounds"; - v.elems.(v.size - n - 1) - - end - let empty_args = [||] -module Renv = +module Cache = struct module ConstrHash = @@ -377,61 +353,35 @@ module Renv = type constructor_info = tag * int * int (* nparam nrealargs *) - type t = { - name_rel : name Vect.t; - construct_tbl : constructor_info ConstrTable.t; - - } - - - let make () = { - name_rel = Vect.make 16 Anonymous; - construct_tbl = ConstrTable.create 111 - } - - let push_rel env id = Vect.push env.name_rel id - - let push_rels env ids = - Array.iter (push_rel env) ids - - let pop env = Vect.pop env.name_rel - - let popn env n = - for _i = 1 to n do pop env done - - let get env n = - Lrel (Vect.get_last env.name_rel (n-1), n) - - let get_construct_info env c = - try ConstrTable.find env.construct_tbl c + let get_construct_info cache env c : constructor_info = + try ConstrTable.find cache c with Not_found -> let ((mind,j), i) = c in - let oib = lookup_mind mind !global_env in + let oib = lookup_mind mind env in let oip = oib.mind_packets.(j) in let tag,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in let r = (tag, nparams, arity) in - ConstrTable.add env.construct_tbl c r; + ConstrTable.add cache c r; r end -(* What about pattern matching ?*) -let is_lazy prefix t = - match kind_of_term t with +let is_lazy env prefix t = + match kind t with | App (f,args) -> - begin match kind_of_term f with + begin match kind f with | Construct (c,_) -> let entry = mkInd (fst c) in (try let _ = - Retroknowledge.get_native_before_match_info (!global_env).retroknowledge + Retroknowledge.get_native_before_match_info env.retroknowledge entry prefix c Llazy; in false with Not_found -> true) | _ -> true end - | LetIn _ -> true + | LetIn _ | Case _ | Proj _ -> true | _ -> false let evar_value sigma ev = sigma.evars_val ev @@ -447,93 +397,107 @@ let empty_evars = let empty_ids = [||] -let rec lambda_of_constr env sigma c = - match kind_of_term c with +(** Extract the inductive type over which a fixpoint is decreasing *) +let rec get_fix_struct env i t = match kind (Reduction.whd_all env t) with +| Prod (na, dom, t) -> + if Int.equal i 0 then + let dom = Reduction.whd_all env dom in + let (dom, _) = decompose_appvect dom in + match kind dom with + | Ind (ind, _) -> ind + | _ -> assert false + else + let env = Environ.push_rel (RelDecl.LocalAssum (na, dom)) env in + get_fix_struct env (i - 1) t +| _ -> assert false + +let rec lambda_of_constr cache env sigma c = + match kind c with | Meta mv -> let ty = meta_type sigma mv in - Lmeta (mv, lambda_of_constr env sigma ty) + Lmeta (mv, lambda_of_constr cache env sigma ty) - | Evar ev -> + | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> let ty = evar_type sigma ev in - Levar(ev, lambda_of_constr env sigma ty) - | Some t -> lambda_of_constr env sigma t) + let args = Array.map (lambda_of_constr cache env sigma) args in + Levar(evk, lambda_of_constr cache env sigma ty, args) + | Some t -> lambda_of_constr cache env sigma t) - | Cast (c, _, _) -> lambda_of_constr env sigma c + | Cast (c, _, _) -> lambda_of_constr cache env sigma c - | Rel i -> Renv.get env i + | Rel i -> Lrel (RelDecl.get_name (Environ.lookup_rel i env), i) | Var id -> Lvar id | Sort s -> Lsort s | Ind (ind,u as pind) -> - let prefix = get_mind_prefix !global_env (fst ind) in + let prefix = get_mind_prefix env (fst ind) in Lind (prefix, pind) | Prod(id, dom, codom) -> - let ld = lambda_of_constr env sigma dom in - Renv.push_rel env id; - let lc = lambda_of_constr env sigma codom in - Renv.pop env; + let ld = lambda_of_constr cache env sigma dom in + let env = Environ.push_rel (RelDecl.LocalAssum (id, dom)) env in + let lc = lambda_of_constr cache env sigma codom in Lprod(ld, Llam([|id|], lc)) | Lambda _ -> - let params, body = decompose_lam c in + let params, body = Term.decompose_lam c in + let fold (na, t) env = Environ.push_rel (RelDecl.LocalAssum (na, t)) env in + let env = List.fold_right fold params env in + let lb = lambda_of_constr cache env sigma body in let ids = get_names (List.rev params) in - Renv.push_rels env ids; - let lb = lambda_of_constr env sigma body in - Renv.popn env (Array.length ids); mkLlam ids lb - | LetIn(id, def, _, body) -> - let ld = lambda_of_constr env sigma def in - Renv.push_rel env id; - let lb = lambda_of_constr env sigma body in - Renv.pop env; + | LetIn(id, def, t, body) -> + let ld = lambda_of_constr cache env sigma def in + let env = Environ.push_rel (RelDecl.LocalDef (id, def, t)) env in + let lb = lambda_of_constr cache env sigma body in Llet(id, ld, lb) - | App(f, args) -> lambda_of_app env sigma f args + | App(f, args) -> lambda_of_app cache env sigma f args - | Const _ -> lambda_of_app env sigma c empty_args + | Const _ -> lambda_of_app cache env sigma c empty_args - | Construct _ -> lambda_of_app env sigma c empty_args + | Construct _ -> lambda_of_app cache env sigma c empty_args | Proj (p, c) -> - let kn = Projection.constant p in - mkLapp (Lproj (get_const_prefix !global_env kn, kn)) [|lambda_of_constr env sigma c|] + let ind = Projection.inductive p in + let prefix = get_mind_prefix env (fst ind) in + mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in - let mib = lookup_mind mind !global_env in + let mib = lookup_mind mind env in let oib = mib.mind_packets.(i) in let tbl = oib.mind_reloc_tbl in (* Building info *) - let prefix = get_mind_prefix !global_env mind in + let prefix = get_mind_prefix env mind in let annot_sw = { asw_ind = ind; asw_ci = ci; asw_reloc = tbl; - asw_finite = mib.mind_finite <> Decl_kinds.CoFinite; + asw_finite = mib.mind_finite <> CoFinite; asw_prefix = prefix} in (* translation of the argument *) - let la = lambda_of_constr env sigma a in + let la = lambda_of_constr cache env sigma a in let entry = mkInd ind in let la = try - Retroknowledge.get_native_before_match_info (!global_env).retroknowledge + Retroknowledge.get_native_before_match_info (env).retroknowledge entry prefix (ind,1) la with Not_found -> la in (* translation of the type *) - let lt = lambda_of_constr env sigma t in + let lt = lambda_of_constr cache env sigma t in (* translation of branches *) let mk_branch i b = let cn = (ind,i+1) in let _, arity = tbl.(i) in - let b = lambda_of_constr env sigma b in + let b = lambda_of_constr cache env sigma b in if Int.equal arity 0 then (cn, empty_ids, b) else match b with @@ -546,85 +510,90 @@ let rec lambda_of_constr env sigma c = let bs = Array.mapi mk_branch branches in Lcase(annot_sw, lt, la, bs) - | Fix(rec_init,(names,type_bodies,rec_bodies)) -> - let ltypes = lambda_of_args env sigma 0 type_bodies in - Renv.push_rels env names; - let lbodies = lambda_of_args env sigma 0 rec_bodies in - Renv.popn env (Array.length names); - Lfix(rec_init, (names, ltypes, lbodies)) + | Fix((pos, i), (names,type_bodies,rec_bodies)) -> + let ltypes = lambda_of_args cache env sigma 0 type_bodies in + let map i t = + let ind = get_fix_struct env i t in + let prefix = get_mind_prefix env (fst ind) in + (prefix, ind) + in + let inds = Array.map2 map pos type_bodies in + let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in + let lbodies = lambda_of_args cache env sigma 0 rec_bodies in + Lfix((pos, inds, i), (names, ltypes, lbodies)) | CoFix(init,(names,type_bodies,rec_bodies)) -> - let ltypes = lambda_of_args env sigma 0 type_bodies in - Renv.push_rels env names; - let lbodies = lambda_of_args env sigma 0 rec_bodies in - Renv.popn env (Array.length names); + let rec_bodies = Array.map2 (Reduction.eta_expand env) rec_bodies type_bodies in + let ltypes = lambda_of_args cache env sigma 0 type_bodies in + let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in + let lbodies = lambda_of_args cache env sigma 0 rec_bodies in Lcofix(init, (names, ltypes, lbodies)) -and lambda_of_app env sigma f args = - match kind_of_term f with +and lambda_of_app cache env sigma f args = + match kind f with | Const (kn,u as c) -> - let kn,u = get_alias !global_env c in - let cb = lookup_constant kn !global_env in + let kn,u = get_alias env c in + let cb = lookup_constant kn env in (try - let prefix = get_const_prefix !global_env kn in + let prefix = get_const_prefix env kn in (* We delay the compilation of arguments to avoid an exponential behavior *) let f = Retroknowledge.get_native_compiling_info - (!global_env).retroknowledge (mkConst kn) prefix in - let args = lambda_of_args env sigma 0 args in + (env).retroknowledge (mkConst kn) prefix in + let args = lambda_of_args cache env sigma 0 args in f args with Not_found -> begin match cb.const_body with | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then - lambda_of_app env sigma (Mod_subst.force_constr csubst) args + lambda_of_app cache env sigma (Mod_subst.force_constr csubst) args else - let prefix = get_const_prefix !global_env kn in + let prefix = get_const_prefix env kn in let t = - if is_lazy prefix (Mod_subst.force_constr csubst) then + if is_lazy env prefix (Mod_subst.force_constr csubst) then mkLapp Lforce [|Lconst (prefix, (kn,u))|] else Lconst (prefix, (kn,u)) in - mkLapp t (lambda_of_args env sigma 0 args) + mkLapp t (lambda_of_args cache env sigma 0 args) | OpaqueDef _ | Undef _ -> - let prefix = get_const_prefix !global_env kn in - mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args env sigma 0 args) + let prefix = get_const_prefix env kn in + mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) end) | Construct (c,u) -> - let tag, nparams, arity = Renv.get_construct_info env c in + let tag, nparams, arity = Cache.get_construct_info cache env c in let expected = nparams + arity in let nargs = Array.length args in - let prefix = get_mind_prefix !global_env (fst (fst c)) in + let prefix = get_mind_prefix env (fst (fst c)) in if Int.equal nargs expected then try try Retroknowledge.get_native_constant_static_info - (!global_env).retroknowledge + (env).retroknowledge f args with NotClosed -> assert (Int.equal nparams 0); (* should be fine for int31 *) - let args = lambda_of_args env sigma nparams args in + let args = lambda_of_args cache env sigma nparams args in Retroknowledge.get_native_constant_dynamic_info - (!global_env).retroknowledge f prefix c args + (env).retroknowledge f prefix c args with Not_found -> - let args = lambda_of_args env sigma nparams args in - makeblock !global_env c u tag args + let args = lambda_of_args cache env sigma nparams args in + makeblock env c u tag args else - let args = lambda_of_args env sigma 0 args in + let args = lambda_of_args cache env sigma 0 args in (try Retroknowledge.get_native_constant_dynamic_info - (!global_env).retroknowledge f prefix c args + (env).retroknowledge f prefix c args with Not_found -> mkLapp (Lconstruct (prefix, (c,u))) args) | _ -> - let f = lambda_of_constr env sigma f in - let args = lambda_of_args env sigma 0 args in + let f = lambda_of_constr cache env sigma f in + let args = lambda_of_args cache env sigma 0 args in mkLapp f args -and lambda_of_args env sigma start args = +and lambda_of_args cache env sigma start args = let nargs = Array.length args in if start < nargs then Array.init (nargs - start) - (fun i -> lambda_of_constr env sigma args.(start + i)) + (fun i -> lambda_of_constr cache env sigma args.(start + i)) else empty_args let optimize lam = @@ -637,11 +606,8 @@ let optimize lam = lam let lambda_of_constr env sigma c = - set_global_env env; - let env = Renv.make () in - let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context in - Renv.push_rels env (Array.of_list ids); - let lam = lambda_of_constr env sigma c in + let cache = Cache.ConstrTable.create 91 in + let lam = lambda_of_constr cache env sigma c in (* if Flags.vm_draw_opt () then begin (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); @@ -656,7 +622,7 @@ let compile_static_int31 fc args = if not fc then raise Not_found else Luint (UintVal (Uint31.of_int (Array.fold_left - (fun temp_i -> fun t -> match kind_of_term t with + (fun temp_i -> fun t -> match kind t with | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args))) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index bfa3bf9418..efe1700cd7 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term -open Pre_env +open Constr +open Environ open Nativeinstr (** This file defines the lambda code generation phase of the native compiler *) @@ -18,13 +20,13 @@ type evars = val empty_evars : evars -val decompose_Llam : lambda -> Names.name array * lambda -val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda +val decompose_Llam : lambda -> Name.t array * lambda +val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda -val is_lazy : prefix -> constr -> bool +val is_lazy : env -> prefix -> constr -> bool val mk_lazy : lambda -> lambda -val get_mind_prefix : env -> mutual_inductive -> string +val get_mind_prefix : env -> MutInd.t -> string val get_alias : env -> pconstant -> pconstant @@ -38,5 +40,5 @@ val compile_dynamic_int31 : bool -> prefix -> constructor -> lambda array -> val before_match_int31 : inductive -> bool -> prefix -> constructor -> lambda -> lambda -val compile_prim : Primitives.t -> constant -> bool -> prefix -> lambda array -> +val compile_prim : CPrimitives.t -> Constant.t -> bool -> prefix -> lambda array -> lambda diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 02e02b031a..f784509b6f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Util open Nativevalues @@ -64,7 +66,8 @@ let warn_native_compiler_failed = in CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print -let call_compiler ml_filename = +let call_compiler ?profile:(profile=false) ml_filename = + let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in @@ -74,14 +77,37 @@ let call_compiler ml_filename = let remove f = if Sys.file_exists f then Sys.remove f in remove link_filename; remove (f ^ ".cmi"); + let initial_args = + if Dynlink.is_native then + ["opt"; "-shared"] + else + ["ocamlc"; "-c"] + in + let profile_args = + if profile then + ["-g"] + else + [] + in + let flambda_args = + if Coq_config.caml_version_nums >= [4;3;0] && Dynlink.is_native then + (* We play safe for now, and use the native compiler + with -Oclassic, however it is likely that `native_compute` + users can benefit from tweaking here. + *) + ["-Oclassic"] + else + [] + in let args = - (if Dynlink.is_native then "opt" else "ocamlc") - ::(if Dynlink.is_native then "-shared" else "-c") - ::"-o"::link_filename - ::"-rectypes" - ::"-w"::"a" - ::include_dirs - @ ["-impl"; ml_filename] in + initial_args @ + profile_args @ + flambda_args @ + ("-o"::link_filename + ::"-rectypes" + ::"-w"::"a" + ::include_dirs) @ + ["-impl"; ml_filename] in if !Flags.debug then Feedback.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (ocamlfind ()) args in @@ -95,9 +121,9 @@ let call_compiler ml_filename = warn_native_compiler_failed (Inr e); false, link_filename -let compile fn code = +let compile fn code ~profile:profile = write_ml_code fn code; - let r = call_compiler fn in + let r = call_compiler ~profile fn in if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; r @@ -134,9 +160,8 @@ let call_linker ?(fatal=true) prefix f upds = register_native_file prefix with Dynlink.Error e as exn -> let exn = CErrors.push exn in - let msg = "Dynlink error, " ^ Dynlink.error_message e in - if fatal then (Feedback.msg_error (Pp.str msg); iraise exn) - else if !Flags.debug then Feedback.msg_debug (Pp.str msg)); + if fatal then iraise exn + else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); match upds with Some upds -> update_locations upds | _ -> () let link_library ~prefix ~dirname ~basename = diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index e8b51dc366..25adcf224b 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Nativecode @@ -19,9 +21,9 @@ val load_obj : (string -> unit) ref val get_ml_filename : unit -> string * string -val compile : string -> global list -> bool * string +val compile : string -> global list -> profile:bool -> bool * string -val compile_library : Names.dir_path -> global list -> string -> bool +val compile_library : Names.DirPath.t -> global list -> string -> bool val call_linker : ?fatal:bool -> string -> string -> code_location_updates option -> unit diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 3e273dde20..edce9367fc 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -1,14 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names open Declarations -open Environ open Mod_subst open Modops open Nativecode @@ -26,17 +27,17 @@ let rec translate_mod prefix mp env mod_expr acc = and translate_field prefix mp env acc (l,x) = match x with | SFBconst cb -> - let con = make_con mp empty_dirpath l in + let con = Constant.make3 mp DirPath.empty l in (if !Flags.debug then let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in Feedback.msg_debug (Pp.str msg)); - compile_constant_field (pre_env env) prefix con acc cb + compile_constant_field env prefix con acc cb | SFBmind mb -> (if !Flags.debug then let id = mb.mind_packets.(0).mind_typename in let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in Feedback.msg_debug (Pp.str msg)); - compile_mind_field prefix mp l acc mb + compile_mind_field mp l acc mb | SFBmodule md -> let mp = md.mod_mp in (if !Flags.debug then diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli index f327ba224a..31e5255fc4 100644 --- a/kernel/nativelibrary.mli +++ b/kernel/nativelibrary.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names open Declarations @@ -13,5 +15,5 @@ open Nativecode (** This file implements separate compilation for libraries in the native compiler *) -val dump_library : module_path -> dir_path -> env -> module_signature -> +val dump_library : ModPath.t -> DirPath.t -> env -> module_signature -> global list * symbols diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 7463a30feb..91f6add1c3 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -1,14 +1,17 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term -open Names -open CErrors + open Util +open CErrors +open Names +open Constr (** This module defines the representation of values internally used by the native compiler *) @@ -51,42 +54,43 @@ type atom = | Arel of int | Aconstant of pconstant | Aind of pinductive - | Asort of sorts - | Avar of identifier + | Asort of Sorts.t + | Avar of Id.t | Acase of annot_sw * accumulator * t * (t -> t) | Afix of t array * t array * rec_pos * int (* types, bodies, rec_pos, pos *) | Acofix of t array * t array * int * t | Acofixe of t array * t array * int * t - | Aprod of name * t * (t -> t) + | Aprod of Name.t * t * (t -> t) | Ameta of metavariable * t - | Aevar of existential * t - | Aproj of constant * accumulator + | Aevar of Evar.t * t * t array + | Aproj of (inductive * int) * accumulator let accumulate_tag = 0 -let accumulate_code (k:accumulator) (x:t) = - let o = Obj.repr k in - let osize = Obj.size o in - let r = Obj.new_block accumulate_tag (osize + 1) in - for i = 0 to osize - 1 do - Obj.set_field r i (Obj.field o i) - done; - Obj.set_field r osize (Obj.repr x); - (Obj.obj r:t) - -let rec accumulate (x:t) = - accumulate_code (Obj.magic accumulate) x - -let mk_accu_gen rcode (a:atom) = -(* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) - let r = Obj.new_block 0 3 in - Obj.set_field r 0 (Obj.field (Obj.magic rcode) 0); - Obj.set_field r 1 (Obj.field (Obj.magic rcode) 1); - Obj.set_field r 2 (Obj.magic a); - (Obj.magic r:t);; - -let mk_accu (a:atom) = mk_accu_gen accumulate a +(** Unique pointer used to drive the accumulator function *) +let ret_accu = Obj.repr (ref ()) + +type accu_val = { mutable acc_atm : atom; acc_arg : Obj.t list } + +let mk_accu (a : atom) : t = + let rec accumulate data x = + if x == ret_accu then Obj.repr data + else + let data = { data with acc_arg = x :: data.acc_arg } in + let ans = Obj.repr (accumulate data) in + let () = Obj.set_tag ans accumulate_tag in + ans + in + let acc = { acc_atm = a; acc_arg = [] } in + let ans = Obj.repr (accumulate acc) in + (** FIXME: use another representation for accumulators, this causes naked + pointers. *) + let () = Obj.set_tag ans accumulate_tag in + (Obj.obj ans : t) + +let get_accu (k : accumulator) = + (Obj.magic k : Obj.t -> accu_val) ret_accu let mk_rel_accu i = mk_accu (Arel i) @@ -111,8 +115,9 @@ let mk_ind_accu ind u = mk_accu (Aind (ind,Univ.Instance.of_array u)) let mk_sort_accu s u = + let open Sorts in match s with - | Prop _ -> mk_accu (Asort s) + | Prop | Set -> mk_accu (Asort s) | Type s -> let u = Univ.Instance.of_array u in let s = Univ.subst_instance_universe u s in @@ -130,39 +135,34 @@ let mk_prod_accu s dom codom = let mk_meta_accu mv ty = mk_accu (Ameta (mv,ty)) -let mk_evar_accu ev ty = - mk_accu (Aevar (ev,ty)) +let mk_evar_accu ev ty args = + mk_accu (Aevar (ev,ty,args)) let mk_proj_accu kn c = mk_accu (Aproj (kn,c)) let atom_of_accu (k:accumulator) = - (Obj.magic (Obj.field (Obj.magic k) 2) : atom) + (get_accu k).acc_atm let set_atom_of_accu (k:accumulator) (a:atom) = - Obj.set_field (Obj.magic k) 2 (Obj.magic a) + (get_accu k).acc_atm <- a let accu_nargs (k:accumulator) = - let nargs = Obj.size (Obj.magic k) - 3 in -(* if nargs < 0 then Format.eprintf "nargs = %i\n" nargs; *) - assert (nargs >= 0); - nargs + List.length (get_accu k).acc_arg let args_of_accu (k:accumulator) = - let nargs = accu_nargs k in - let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in - let t = Array.init nargs f in - Array.to_list t + let acc = (get_accu k).acc_arg in + (Obj.magic (Array.of_list acc) : t array) let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag let mk_fix_accu rec_pos pos types bodies = - mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) + mk_accu (Afix(types,bodies,rec_pos, pos)) let mk_cofix_accu pos types norm = - mk_accu_gen accumulate (Acofix(types,norm,pos,(Obj.magic 0 : t))) + mk_accu (Acofix(types,norm,pos,(Obj.magic 0 : t))) let upd_cofix (cofix :t) (cofix_fun : t) = let atom = atom_of_accu (Obj.magic cofix) in @@ -177,11 +177,10 @@ let force_cofix (cofix : t) = let atom = atom_of_accu accu in match atom with | Acofix(typ,norm,pos,f) -> - let f = ref f in - let args = List.rev (args_of_accu accu) in - List.iter (fun x -> f := !f x) args; - let v = !f (Obj.magic ()) in - set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); + let args = args_of_accu accu in + let f = Array.fold_right (fun arg f -> f arg) args f in + let v = f (Obj.magic ()) in + set_atom_of_accu accu (Acofixe(typ,norm,pos,v)); v | Acofixe(_,_,_,v) -> v | _ -> cofix diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 49b1e122d5..6bbf15160c 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -1,11 +1,13 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open Names (** This modules defines the representation of values internally used by @@ -43,33 +45,33 @@ type atom = | Arel of int | Aconstant of pconstant | Aind of pinductive - | Asort of sorts - | Avar of identifier + | Asort of Sorts.t + | Avar of Id.t | Acase of annot_sw * accumulator * t * (t -> t) | Afix of t array * t array * rec_pos * int | Acofix of t array * t array * int * t | Acofixe of t array * t array * int * t - | Aprod of name * t * (t -> t) + | Aprod of Name.t * t * (t -> t) | Ameta of metavariable * t - | Aevar of existential * t - | Aproj of constant * accumulator + | Aevar of Evar.t * t (* type *) * t array (* arguments *) + | Aproj of (inductive * int) * accumulator (* Constructors *) val mk_accu : atom -> t val mk_rel_accu : int -> t val mk_rels_accu : int -> int -> t array -val mk_constant_accu : constant -> Univ.Level.t array -> t +val mk_constant_accu : Constant.t -> Univ.Level.t array -> t val mk_ind_accu : inductive -> Univ.Level.t array -> t -val mk_sort_accu : sorts -> Univ.Level.t array -> t -val mk_var_accu : identifier -> t +val mk_sort_accu : Sorts.t -> Univ.Level.t array -> t +val mk_var_accu : Id.t -> t val mk_sw_accu : annot_sw -> accumulator -> t -> (t -> t) -val mk_prod_accu : name -> t -> t -> t +val mk_prod_accu : Name.t -> t -> t -> t val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t -val mk_evar_accu : existential -> t -> t -val mk_proj_accu : constant -> accumulator -> t +val mk_evar_accu : Evar.t -> t -> t array -> t +val mk_proj_accu : (inductive * int) -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t val mk_const : tag -> t @@ -84,7 +86,7 @@ val napply : t -> t array -> t val dummy_value : unit -> t val atom_of_accu : accumulator -> atom -val args_of_accu : accumulator -> t list +val args_of_accu : accumulator -> t array val accu_nargs : accumulator -> int val cast_accu : t -> accumulator @@ -108,9 +110,6 @@ type kind_of_value = val kind_of_value : t -> kind_of_value -(* *) -val is_accu : t -> bool - val str_encode : 'a -> string val str_decode : string -> 'a diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 5e20c1b514..f8b71e4564 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -1,14 +1,16 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names open Univ -open Term +open Constr open Mod_subst type work_list = (Instance.t * Id.t array) Cmap.t * @@ -16,8 +18,8 @@ type work_list = (Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t } -type proofterm = (constr * Univ.universe_context_set) Future.computation + abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } +type proofterm = (constr * Univ.ContextSet.t) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) | Direct of cooking_info list * proofterm @@ -78,12 +80,12 @@ let subst_opaque sub = function let iter_direct_opaque f = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> - Direct (d,Future.chain ~pure:true cu (fun (c, u) -> f c; c, u)) + Direct (d,Future.chain cu (fun (c, u) -> f c; c, u)) let discharge_direct_opaque ~cook_constr ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") | Direct (d,cu) -> - Direct (ci::d,Future.chain ~pure:true cu (fun (c, u) -> cook_constr c, u)) + Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) let join_opaque { opaque_val = prfs; opaque_dir = odp } = function | Direct (_,cu) -> ignore(Future.join cu) @@ -105,7 +107,7 @@ let force_proof { opaque_val = prfs; opaque_dir = odp } = function | Indirect (l,dp,i) -> let pt = if DirPath.equal dp odp - then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst + then Future.chain (snd (Int.Map.find i prfs)) fst else !get_opaque dp i in let c = Future.force pt in force_constr (List.fold_right subst_substituted l (from_val c)) @@ -120,25 +122,25 @@ let force_constraints { opaque_val = prfs; opaque_dir = odp } = function | Some u -> Future.force u let get_constraints { opaque_val = prfs; opaque_dir = odp } = function - | Direct (_,cu) -> Some(Future.chain ~pure:true cu snd) + | Direct (_,cu) -> Some(Future.chain cu snd) | Indirect (_,dp,i) -> if DirPath.equal dp odp - then Some(Future.chain ~pure:true (snd (Int.Map.find i prfs)) snd) + then Some(Future.chain (snd (Int.Map.find i prfs)) snd) else !get_univ dp i let get_proof { opaque_val = prfs; opaque_dir = odp } = function - | Direct (_,cu) -> Future.chain ~pure:true cu fst + | Direct (_,cu) -> Future.chain cu fst | Indirect (l,dp,i) -> let pt = if DirPath.equal dp odp - then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst + then Future.chain (snd (Int.Map.find i prfs)) fst else !get_opaque dp i in - Future.chain ~pure:true pt (fun c -> + Future.chain pt (fun c -> force_constr (List.fold_right subst_substituted l (from_val c))) module FMap = Future.UUIDMap -let a_constr = Future.from_val (Term.mkRel 1) +let a_constr = Future.from_val (mkRel 1) let a_univ = Future.from_val Univ.ContextSet.empty let a_discharge : cooking_info list = [] diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index a0418a022f..5ea6da649b 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Mod_subst (** This module implements the handling of opaque proof terms. @@ -19,7 +21,7 @@ open Mod_subst When it is [turn_indirect] the data is relocated to an opaque table and the [opaque] is turned into an index. *) -type proofterm = (constr * Univ.universe_context_set) Future.computation +type proofterm = (constr * Univ.ContextSet.t) Future.computation type opaquetab type opaque @@ -36,10 +38,10 @@ val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab (** From a [opaque] back to a [constr]. This might use the indirect opaque accessor configured below. *) val force_proof : opaquetab -> opaque -> constr -val force_constraints : opaquetab -> opaque -> Univ.universe_context_set -val get_proof : opaquetab -> opaque -> Term.constr Future.computation +val force_constraints : opaquetab -> opaque -> Univ.ContextSet.t +val get_proof : opaquetab -> opaque -> constr Future.computation val get_constraints : - opaquetab -> opaque -> Univ.universe_context_set Future.computation option + opaquetab -> opaque -> Univ.ContextSet.t Future.computation option val subst_opaque : substitution -> opaque -> opaque val iter_direct_opaque : (constr -> unit) -> opaque -> opaque @@ -49,7 +51,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t } + abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } (* The type has two caveats: 1) cook_constr is defined after @@ -63,7 +65,7 @@ val join_opaque : opaquetab -> opaque -> unit val dump : opaquetab -> Constr.t Future.computation array * - Univ.universe_context_set Future.computation array * + Univ.ContextSet.t Future.computation array * cooking_info list array * int Future.UUIDMap.t @@ -75,7 +77,7 @@ val dump : opaquetab -> *) val set_indirect_opaque_accessor : - (DirPath.t -> int -> Term.constr Future.computation) -> unit + (DirPath.t -> int -> constr Future.computation) -> unit val set_indirect_univ_accessor : - (DirPath.t -> int -> Univ.universe_context_set Future.computation option) -> unit + (DirPath.t -> int -> Univ.ContextSet.t Future.computation option) -> unit diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml deleted file mode 100644 index 7b4fb4e869..0000000000 --- a/kernel/pre_env.ml +++ /dev/null @@ -1,188 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Created by Benjamin Grégoire out of environ.ml for better - modularity in the design of the bytecode virtual evaluation - machine, Dec 2005 *) -(* Bug fix by Jean-Marc Notin *) - -(* This file defines the type of kernel environments *) - -open Util -open Names -open Term -open Declarations - -module NamedDecl = Context.Named.Declaration - -(* The type of environments. *) - -(* The key attached to each constant is used by the VM to retrieve previous *) -(* evaluations of the constant. It is essentially an index in the symbols table *) -(* used by the VM. *) -type key = int CEphemeron.key option ref - -(** Linking information for the native compiler. *) - -type link_info = - | Linked of string - | LinkedInteractive of string - | NotLinked - -type constant_key = constant_body * (link_info ref * key) - -type mind_key = mutual_inductive_body * link_info ref - -type globals = { - env_constants : constant_key Cmap_env.t; - env_inductives : mind_key Mindmap_env.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t} - -type stratification = { - env_universes : UGraph.t; - env_engagement : engagement -} - -type val_kind = - | VKvalue of (values * Id.Set.t) CEphemeron.key - | VKnone - -type lazy_val = val_kind ref - -let force_lazy_val vk = match !vk with -| VKnone -> None -| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None - -let dummy_lazy_val () = ref VKnone -let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) - -type named_context_val = { - env_named_ctx : Context.Named.t; - env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; -} - -type env = { - env_globals : globals; (* globals = constants + inductive types + modules + module-types *) - env_named_context : named_context_val; (* section variables *) - env_rel_context : Context.Rel.t; - env_rel_val : lazy_val list; - env_nb_rel : int; - env_stratification : stratification; - env_typing_flags : typing_flags; - env_conv_oracle : Conv_oracle.oracle; - retroknowledge : Retroknowledge.retroknowledge; - indirect_pterms : Opaqueproof.opaquetab; -} - -let empty_named_context_val = { - env_named_ctx = []; - env_named_map = Id.Map.empty; -} - -let empty_env = { - env_globals = { - env_constants = Cmap_env.empty; - env_inductives = Mindmap_env.empty; - env_modules = MPmap.empty; - env_modtypes = MPmap.empty}; - env_named_context = empty_named_context_val; - env_rel_context = Context.Rel.empty; - env_rel_val = []; - env_nb_rel = 0; - env_stratification = { - env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet }; - env_typing_flags = Declareops.safe_flags; - env_conv_oracle = Conv_oracle.empty; - retroknowledge = Retroknowledge.initial_retroknowledge; - indirect_pterms = Opaqueproof.empty_opaquetab } - - -(* Rel context *) - -let nb_rel env = env.env_nb_rel - -let push_rel d env = - let rval = ref VKnone in - { env with - env_rel_context = Context.Rel.add d env.env_rel_context; - env_rel_val = rval :: env.env_rel_val; - env_nb_rel = env.env_nb_rel + 1 } - -let lookup_rel_val n env = - try List.nth env.env_rel_val (n - 1) - with Failure _ -> raise Not_found - -let env_of_rel n env = - { env with - env_rel_context = Util.List.skipn n env.env_rel_context; - env_rel_val = Util.List.skipn n env.env_rel_val; - env_nb_rel = env.env_nb_rel - n - } - -(* Named context *) - -let push_named_context_val_val d rval ctxt = -(* assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *) - { - env_named_ctx = Context.Named.add d ctxt.env_named_ctx; - env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; - } - -let push_named_context_val d ctxt = - push_named_context_val_val d (ref VKnone) ctxt - -let match_named_context_val c = match c.env_named_ctx with -| [] -> None -| decl :: ctx -> - let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in - let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in - let cval = { env_named_ctx = ctx; env_named_map = map } in - Some (decl, v, cval) - -let map_named_val f ctxt = - let open Context.Named.Declaration in - let fold accu d = - let d' = map_constr f d in - let accu = - if d == d' then accu - else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu - in - (accu, d') - in - let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in - if map == ctxt.env_named_map then ctxt - else { env_named_ctx = ctx; env_named_map = map } - -let push_named d env = - {env with env_named_context = push_named_context_val d env.env_named_context} - -let lookup_named id env = - fst (Id.Map.find id env.env_named_context.env_named_map) - -let lookup_named_val id env = - snd(Id.Map.find id env.env_named_context.env_named_map) - -(* Warning all the names should be different *) -let env_of_named id env = env - -(* Global constants *) - -let lookup_constant_key kn env = - Cmap_env.find kn env.env_globals.env_constants - -let lookup_constant kn env = - fst (Cmap_env.find kn env.env_globals.env_constants) - -(* Mutual Inductives *) -let lookup_mind kn env = - fst (Mindmap_env.find kn env.env_globals.env_inductives) - -let lookup_mind_key kn env = - Mindmap_env.find kn env.env_globals.env_inductives diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli deleted file mode 100644 index f2a009b868..0000000000 --- a/kernel/pre_env.mli +++ /dev/null @@ -1,96 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Term -open Declarations - -(** The type of environments. *) - -type link_info = - | Linked of string - | LinkedInteractive of string - | NotLinked - -type key = int CEphemeron.key option ref - -type constant_key = constant_body * (link_info ref * key) - -type mind_key = mutual_inductive_body * link_info ref - -type globals = { - env_constants : constant_key Cmap_env.t; - env_inductives : mind_key Mindmap_env.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t} - -type stratification = { - env_universes : UGraph.t; - env_engagement : engagement -} - -type lazy_val - -val force_lazy_val : lazy_val -> (values * Id.Set.t) option -val dummy_lazy_val : unit -> lazy_val -val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit - -type named_context_val = private { - env_named_ctx : Context.Named.t; - env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; -} - -type env = { - env_globals : globals; - env_named_context : named_context_val; - env_rel_context : Context.Rel.t; - env_rel_val : lazy_val list; - env_nb_rel : int; - env_stratification : stratification; - env_typing_flags : typing_flags; - env_conv_oracle : Conv_oracle.oracle; - retroknowledge : Retroknowledge.retroknowledge; - indirect_pterms : Opaqueproof.opaquetab; -} - -val empty_named_context_val : named_context_val - -val empty_env : env - -(** Rel context *) - -val nb_rel : env -> int -val push_rel : Context.Rel.Declaration.t -> env -> env -val lookup_rel_val : int -> env -> lazy_val -val env_of_rel : int -> env -> env - -(** Named context *) - -val push_named_context_val : - Context.Named.Declaration.t -> named_context_val -> named_context_val -val push_named_context_val_val : - Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val -val match_named_context_val : - named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option -val map_named_val : - (constr -> constr) -> named_context_val -> named_context_val - -val push_named : Context.Named.Declaration.t -> env -> env -val lookup_named : Id.t -> env -> Context.Named.Declaration.t -val lookup_named_val : Id.t -> env -> lazy_val -val env_of_named : Id.t -> env -> env - -(** Global constants *) - - -val lookup_constant_key : constant -> env -> constant_key -val lookup_constant : constant -> env -> constant_body - -(** Mutual Inductives *) -val lookup_mind_key : mutual_inductive -> env -> mind_key -val lookup_mind : mutual_inductive -> env -> mutual_inductive_body diff --git a/kernel/reduction.ml b/kernel/reduction.ml index de4efbba93..c701b53fe4 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created under Benjamin Werner account by Bruno Barras to implement @@ -18,7 +20,7 @@ open CErrors open Util open Names -open Term +open Constr open Vars open Environ open CClosure @@ -51,18 +53,20 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + | (Zproj p1::s1, Zproj p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 - | (_,_) -> false in + | [], _ :: _ + | (Zproj _ | ZcaseT _ | Zfix _) :: _, _ -> false + in compare_rec 0 stk1 stk2 type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of constant * lift + | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -80,7 +84,7 @@ let map_lift (l : lift) (v : fconstr array) = match v with | [|c0; c1|] -> [|(l, c0); (l, c1)|] | [|c0; c1; c2|] -> [|(l, c0); (l, c1); (l, c2)|] | [|c0; c1; c2; c3|] -> [|(l, c0); (l, c1); (l, c2); (l, c3)|] -| v -> CArray.Fun1.map (fun l t -> (l, t)) l v +| v -> Array.Fun1.map (fun l t -> (l, t)) l v let pure_stack lfts stk = let rec pure_rec lfts stk = @@ -92,8 +96,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (map_lift l a) pstk) - | (Zproj (n,m,c), (l,pstk)) -> - (l, Zlproj (c,l)::pstk) + | (Zproj p, (l,pstk)) -> + (l, Zlproj (p,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -107,51 +111,60 @@ let pure_stack lfts stk = (****************************************************************************) let whd_betaiota env t = - match kind_of_term t with + match kind t with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | App (c, _) -> - begin match kind_of_term c with + begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | LetIn _ -> t - | _ -> whd_val (create_clos_infos betaiota env) (inject t) + | _ -> whd_val (create_clos_infos betaiota env) (create_tab ()) (inject t) end - | _ -> whd_val (create_clos_infos betaiota env) (inject t) + | _ -> whd_val (create_clos_infos betaiota env) (create_tab ()) (inject t) let nf_betaiota env t = - norm_val (create_clos_infos betaiota env) (inject t) + norm_val (create_clos_infos betaiota env) (create_tab ()) (inject t) let whd_betaiotazeta env x = - match kind_of_term x with - | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| + match kind x with + | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x | App (c, _) -> - begin match kind_of_term c with + begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ | Const _ -> x - | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) + | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ + | Case _ | Fix _ | CoFix _ | Proj _ -> + whd_val (create_clos_infos betaiotazeta env) (create_tab ()) (inject x) end - | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) + | Rel _ | Cast _ | LetIn _ | Case _ | Proj _ -> + whd_val (create_clos_infos betaiotazeta env) (create_tab ()) (inject x) let whd_all env t = - match kind_of_term t with + match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | App (c, _) -> - begin match kind_of_term c with + begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ -> t - | _ -> whd_val (create_clos_infos all env) (inject t) + | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ + | Const _ |Case _ | Fix _ | CoFix _ | Proj _ -> + whd_val (create_clos_infos all env) (create_tab ()) (inject t) end - | _ -> whd_val (create_clos_infos all env) (inject t) + | Rel _ | Cast _ | LetIn _ | Case _ | Proj _ | Const _ | Var _ -> + whd_val (create_clos_infos all env) (create_tab ()) (inject t) let whd_allnolet env t = - match kind_of_term t with + match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | App (c, _) -> - begin match kind_of_term c with + begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ -> t - | _ -> whd_val (create_clos_infos allnolet env) (inject t) + | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | App _ + | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> + whd_val (create_clos_infos allnolet env) (create_tab ()) (inject t) end - | _ -> whd_val (create_clos_infos allnolet env) (inject t) + | Rel _ | Cast _ | Case _ | Proj _ | Const _ | Var _ -> + whd_val (create_clos_infos allnolet env) (create_tab ()) (inject t) (********************************************************************) (* Conversion *) @@ -189,33 +202,78 @@ let is_cumul = function CUMUL -> true | CONV -> false type 'a universe_compare = { (* Might raise NotConvertible *) - compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; + compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; - conv_inductives : conv_pb -> (Declarations.mutual_inductive_body * int) -> Univ.Instance.t -> int -> - Univ.Instance.t -> int -> 'a -> 'a; - conv_constructors : (Declarations.mutual_inductive_body * int * int) -> - Univ.Instance.t -> int -> Univ.Instance.t -> int -> 'a -> 'a; - } + compare_cumul_instances : conv_pb -> Univ.Variance.t array -> + Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a } type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.Constraint.t let sort_cmp_universes env pb s0 s1 (u, check) = - (check.compare env pb s0 s1 u, check) + (check.compare_sorts env pb s0 s1 u, check) (* [flex] should be true for constants, false for inductive types and constructors. *) let convert_instances ~flex u u' (s, check) = (check.compare_instances ~flex u u' s, check) - -let convert_inductives cv_pb ind u1 sv1 u2 sv2 (s, check) = - (check.conv_inductives cv_pb ind u1 sv1 u2 sv2 s, check) -let convert_constructors cons u1 sv1 u2 sv2 (s, check) = - (check.conv_constructors cons u1 sv1 u2 sv2 s, check) +let get_cumulativity_constraints cv_pb variance u u' = + match cv_pb with + | CONV -> + Univ.enforce_eq_variance_instances variance u u' Univ.Constraint.empty + | CUMUL -> + Univ.enforce_leq_variance_instances variance u u' Univ.Constraint.empty + +let inductive_cumulativity_arguments (mind,ind) = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + +let convert_inductives_gen cmp_instances cmp_cumul cv_pb (mind,ind) nargs u1 u2 s = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); + s + | Declarations.Polymorphic_ind _ -> + cmp_instances u1 u2 s + | Declarations.Cumulative_ind cumi -> + let num_param_arity = inductive_cumulativity_arguments (mind,ind) in + if not (Int.equal num_param_arity nargs) then + cmp_instances u1 u2 s + else + cmp_cumul cv_pb (Univ.ACumulativityInfo.variance cumi) u1 u2 s + +let convert_inductives cv_pb ind nargs u1 u2 (s, check) = + convert_inductives_gen (check.compare_instances ~flex:false) check.compare_cumul_instances + cv_pb ind nargs u1 u2 s, check + +let constructor_cumulativity_arguments (mind, ind, ctor) = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(ctor - 1) + +let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u2 s = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); + s + | Declarations.Polymorphic_ind _ -> + cmp_instances u1 u2 s + | Declarations.Cumulative_ind cumi -> + let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in + if not (Int.equal num_cnstr_args nargs) then + cmp_instances u1 u2 s + else + (** By invariant, both constructors have a common supertype, + so they are convertible _at that type_. *) + let variance = Array.make (Univ.Instance.length u1) Univ.Variance.Irrelevant in + cmp_cumul CONV variance u1 u2 s + +let convert_constructors ctor nargs u1 u2 (s, check) = + convert_constructors_gen (check.compare_instances ~flex:false) check.compare_cumul_instances + ctor nargs u1 u2 s, check let conv_table_key infos k1 k2 cuniv = if k1 == k2 then cuniv else @@ -239,7 +297,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (eq_constant c1 c2) then + if not (Projection.Repr.equal c1 c2) then raise NotConvertible else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> @@ -256,173 +314,132 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv else raise NotConvertible -let rec no_arg_available = function - | [] -> true - | Zupdate _ :: stk -> no_arg_available stk - | Zshift _ :: stk -> no_arg_available stk - | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk - | Zproj _ :: _ -> true - | ZcaseT _ :: _ -> true - | Zfix _ :: _ -> true - -let rec no_nth_arg_available n = function - | [] -> true - | Zupdate _ :: stk -> no_nth_arg_available n stk - | Zshift _ :: stk -> no_nth_arg_available n stk - | Zapp v :: stk -> - let k = Array.length v in - if n >= k then no_nth_arg_available (n-k) stk - else false - | Zproj _ :: _ -> true - | ZcaseT _ :: _ -> true - | Zfix _ :: _ -> true - -let rec no_case_available = function - | [] -> true - | Zupdate _ :: stk -> no_case_available stk - | Zshift _ :: stk -> no_case_available stk - | Zapp _ :: stk -> no_case_available stk - | Zproj (_,_,p) :: _ -> false - | ZcaseT _ :: _ -> false - | Zfix _ :: _ -> true - -let in_whnf (t,stk) = - match fterm_of t with - | (FLetIn _ | FCaseT _ | FApp _ - | FCLOS _ | FLIFT _ | FCast _) -> false - | FLambda _ -> no_arg_available stk - | FConstruct _ -> no_case_available stk - | FCoFix _ -> no_case_available stk - | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk - | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true - | FLOCKED -> assert false - -let unfold_projection infos p c = - let unf = Projection.unfolded p in - if unf || RedFlags.red_set infos.i_flags (RedFlags.fCONST (Projection.constant p)) then - (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with - | Some pb -> - let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - Projection.constant p) in - Some (c, s) - | None -> None) - else None +type conv_tab = { + cnv_inf : clos_infos; + lft_tab : fconstr infos_tab; + rgt_tab : fconstr infos_tab; +} +(** Invariant: for any tl ∈ lft_tab and tr ∈ rgt_tab, there is no mutable memory + location contained both in tl and in tr. *) + +(** The same heap separation invariant must hold for the fconstr arguments + passed to each respective side of the conversion function below. *) (* Conversion between [lft1]term1 and [lft2]term2 *) -let rec ccnv env cv_pb l2r infos lft1 lft2 term1 term2 cuniv = - eqappr env cv_pb l2r 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 env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = +and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = Control.check_for_interrupt (); (* First head reduce both terms *) - let whd = whd_stack (infos_with_reds infos betaiotazeta) in - let rec whd_both (t1,stk1) (t2,stk2) = - let st1' = whd t1 stk1 in - let st2' = whd t2 stk2 in - (* Now, whd_stack on term2 might have modified st1 (due to sharing), - and st1 might not be in whnf anymore. If so, we iterate ccnv. *) - if in_whnf st1' then (st1',st2') else whd_both st1' st2' in - let ((hd1,v1),(hd2,v2)) = whd_both st1 st2 in - let appr1 = (lft1,(hd1,v1)) and appr2 = (lft2,(hd2,v2)) in - (* compute the lifts that apply to the head of the term (hd1 and hd2) *) - let el1 = el_stack lft1 v1 in - let el2 = el_stack lft2 v2 in + let ninfos = infos_with_reds infos.cnv_inf betaiotazeta in + let (hd1, v1 as appr1) = whd_stack ninfos infos.lft_tab (fst st1) (snd st1) in + let (hd2, v2 as appr2) = whd_stack ninfos infos.rgt_tab (fst st2) (snd st2) in + let appr1 = (lft1, appr1) and appr2 = (lft2, appr2) in + (** We delay the computation of the lifts that apply to the head of the term + with [el_stack] inside the branches where they are actually used. *) match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> - (match kind_of_term a1, kind_of_term a2 with + (match kind a1, kind a2 with | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); - sort_cmp_universes (env_of_infos infos) cv_pb s1 s2 cuniv + sort_cmp_universes (env_of_infos infos.cnv_inf) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m - then convert_stacks env l2r 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 Evar.equal ev1 ev2 then - let cuniv = convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv in - convert_vect env l2r infos el1 el2 + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let cuniv = 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) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in if Int.equal (reloc_rel n el1) (reloc_rel m el2) - then convert_stacks env l2r 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 - let cuniv = conv_table_key infos fl1 fl2 cuniv in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + let cuniv = conv_table_key infos.cnv_inf fl1 fl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with NotConvertible | Univ.UniverseInconsistency _ -> (* else the oracle tells which constant is to be expanded *) - let oracle = CClosure.oracle_of_infos infos in + let oracle = CClosure.oracle_of_infos infos.cnv_inf in let (app1,app2) = if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then - match unfold_reference infos fl1 with + match unfold_reference infos.cnv_inf infos.lft_tab fl1 with | Some def1 -> ((lft1, (def1, v1)), appr2) | None -> - (match unfold_reference infos fl2 with + (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with | Some def2 -> (appr1, (lft2, (def2, v2))) | None -> raise NotConvertible) else - match unfold_reference infos fl2 with + match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with | Some def2 -> (appr1, (lft2, (def2, v2))) | None -> - (match unfold_reference infos fl1 with + (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with | Some def1 -> ((lft1, (def1, v1)), appr2) | None -> raise NotConvertible) in - eqappr env cv_pb l2r infos app1 app2 cuniv) + eqappr cv_pb l2r infos app1 app2 cuniv) | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, which will happen naturally if the terms c1, c2 are not in constructor form *) - (match unfold_projection infos p1 c1 with - | Some (def1,s1) -> - eqappr env cv_pb l2r infos (lft1, (def1, (s1 :: v1))) appr2 cuniv + (match unfold_projection infos.cnv_inf p1 with + | Some s1 -> + eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv | None -> - match unfold_projection infos p2 c2 with - | Some (def2,s2) -> - eqappr env cv_pb l2r infos appr1 (lft2, (def2, (s2 :: v2))) cuniv + match unfold_projection infos.cnv_inf p2 with + | Some s2 -> + eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) && compare_stack_shape v1 v2 then - let u1 = ccnv env CONV l2r infos el1 el2 c1 c2 cuniv in - convert_stacks env l2r infos lft1 lft2 v1 v2 u1 + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 u1 else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> - (match unfold_projection infos p1 c1 with - | Some (def1,s1) -> - eqappr env cv_pb l2r infos (lft1, (def1, (s1 :: v1))) appr2 cuniv + (match unfold_projection infos.cnv_inf p1 with + | Some s1 -> + eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv | None -> (match t2 with | FFlex fl2 -> - (match unfold_reference infos fl2 with + (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with | Some def2 -> - eqappr env cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv + eqappr cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv | None -> raise NotConvertible) | _ -> raise NotConvertible)) | (t1, FProj (p2,c2)) -> - (match unfold_projection infos p2 c2 with - | Some (def2,s2) -> - eqappr env cv_pb l2r infos appr1 (lft2, (def2, (s2 :: v2))) cuniv + (match unfold_projection infos.cnv_inf p2 with + | Some s2 -> + eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> (match t1 with | FFlex fl1 -> - (match unfold_reference infos fl1 with + (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with | Some def1 -> - eqappr env cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv + eqappr cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv | None -> raise NotConvertible) | _ -> raise NotConvertible)) @@ -434,15 +451,19 @@ and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in - let cuniv = ccnv env CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv env CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in + ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) - let cuniv = ccnv env CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv env cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let cuniv = 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 cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -452,7 +473,7 @@ and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given unreduced term (FLambda).") in let (_,_ty1,bd1) = destFLambda mk_clos hd1 in - eqappr env CONV l2r infos + eqappr CONV l2r infos (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> let () = match v2 with @@ -461,34 +482,43 @@ and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given unreduced term (FLambda).") in let (_,_ty2,bd2) = destFLambda mk_clos hd2 in - eqappr env CONV l2r infos + 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, c2) -> - (match unfold_reference infos fl1 with + (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with | Some def1 -> - eqappr env cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv + (** By virtue of the previous case analyses, we know [c2] is rigid. + Conversion check to rigid terms eventually implies full weak-head + reduction, so instead of repeatedly performing small-step + unfoldings, we perform reduction with all flags on. *) + let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in + let r1 = whd_stack (infos_with_reds infos.cnv_inf all) infos.lft_tab def1 v1 in + eqappr cv_pb l2r infos (lft1, r1) appr2 cuniv | None -> match c2 with | FConstruct ((ind2,j2),u2) -> (try let v2, v1 = - eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1) - in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) | (c1, FFlex fl2) -> - (match unfold_reference infos fl2 with + (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with | Some def2 -> - eqappr env cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv + (** Symmetrical case of above. *) + let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in + let r2 = whd_stack (infos_with_reds infos.cnv_inf all) infos.rgt_tab def2 v2 in + eqappr cv_pb l2r infos appr1 (lft2, r2) cuniv | None -> match c1 with | FConstruct ((ind1,j1),u1) -> (try let v1, v2 = - eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2) - in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) @@ -497,52 +527,45 @@ and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if eq_ind ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else - let mind = Environ.lookup_mind (fst ind1) env in - let cuniv = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - convert_instances ~flex:false u1 u2 cuniv - | Declarations.Cumulative_ind cumi -> - convert_inductives cv_pb (mind, snd ind1) u1 (CClosure.stack_args_size v1) - u2 (CClosure.stack_args_size v2) cuniv - in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + let mind = Environ.lookup_mind (fst ind1) (info_env infos.cnv_inf) in + let nargs = CClosure.stack_args_size v1 in + if not (Int.equal nargs (CClosure.stack_args_size v2)) + then raise NotConvertible + else + let cuniv = convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else - let mind = Environ.lookup_mind (fst ind1) env in - let cuniv = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - convert_instances ~flex:false u1 u2 cuniv - | Declarations.Cumulative_ind _ -> - convert_constructors - (mind, snd ind1, j1) u1 (CClosure.stack_args_size v1) - u2 (CClosure.stack_args_size v2) cuniv - in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + let mind = Environ.lookup_mind (fst ind1) (info_env infos.cnv_inf) in + let nargs = CClosure.stack_args_size v1 in + if not (Int.equal nargs (CClosure.stack_args_size v2)) + then raise NotConvertible + else + let cuniv = convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Eta expansion of records *) | (FConstruct ((ind1,j1),u1), _) -> (try let v1, v2 = - eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2) - in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (_, FConstruct ((ind2,j2),u2)) -> (try let v2, v1 = - eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1) - in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> @@ -553,11 +576,13 @@ and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = 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 cuniv = convert_vect env l2r infos el1 el2 fty1 fty2 cuniv in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - convert_vect env l2r infos + convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> @@ -568,28 +593,30 @@ and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = 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 cuniv = convert_vect env l2r infos el1 el2 fty1 fty2 cuniv in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - convert_vect env l2r infos + convert_vect l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in - convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) - | (FLOCKED,_) | (_,FLOCKED) ) -> assert false + | (FLOCKED,_) | (_,FLOCKED) ) | (FCast _, _) | (_, FCast _) -> assert false - (* In all other cases, terms are not convertible *) - | _ -> raise NotConvertible + | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ + | FProd _ | FEvar _), _ -> raise NotConvertible -and convert_stacks env l2r infos lft1 lft2 stk1 stk2 cuniv = +and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks - (fun (l1,t1) (l2,t2) cuniv -> ccnv env CONV l2r infos l1 l2 t1 t2 cuniv) + (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) (eq_ind) lft1 stk1 lft2 stk2 cuniv -and convert_vect env l2r 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 Int.equal lv1 lv2 @@ -597,7 +624,7 @@ and convert_vect env l2r infos lft1 lft2 v1 v2 cuniv = let rec fold n cuniv = if n >= lv1 then cuniv else - let cuniv = ccnv env CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in + let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in fold (n+1) cuniv in fold 0 cuniv else raise NotConvertible @@ -605,7 +632,12 @@ and convert_vect env l2r infos lft1 lft2 v1 v2 cuniv = let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in - ccnv env cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs + let infos = { + cnv_inf = infos; + lft_tab = create_tab (); + rgt_tab = create_tab (); + } in + ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs let check_eq univs u u' = @@ -615,25 +647,21 @@ let check_leq univs u u' = if not (UGraph.check_leq univs u u') then raise NotConvertible let check_sort_cmp_universes env pb s0 s1 univs = - match (s0,s1) with - | (Prop c1, Prop c2) when is_cumul pb -> - begin match c1, c2 with - | Null, _ | _, Pos -> () (* Prop <= Set *) - | _ -> raise NotConvertible - end - | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible - | (Prop c1, Type u) -> - if not (type_in_type env) then - let u0 = univ_of_sort s0 in - (match pb with - | CUMUL -> check_leq univs u0 u - | CONV -> check_eq univs u0 u) - | (Type u, Prop c) -> raise NotConvertible - | (Type u1, Type u2) -> - if not (type_in_type env) then - (match pb with - | CUMUL -> check_leq univs u1 u2 - | CONV -> check_eq univs u1 u2) + let open Sorts in + if not (type_in_type env) then + let check_pb u0 u1 = + match pb with + | CUMUL -> check_leq univs u0 u1 + | CONV -> check_eq univs u0 u1 + in + match (s0,s1) with + | Prop, Prop | Set, Set -> () + | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible + | Set, Prop -> raise NotConvertible + | Set, Type u -> check_pb Univ.type0_univ u + | Type u, Prop -> raise NotConvertible + | Type u, Set -> check_pb u Univ.type0_univ + | Type u0, Type u1 -> check_pb u0 u1 let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs @@ -643,87 +671,15 @@ let check_convert_instances ~flex u u' univs = else raise NotConvertible (* general conversion and inference functions *) -let infer_check_conv_inductives - infer_check_convert_instances - infer_check_inductive_instances - cv_pb (mind, ind) u1 sv1 u2 sv2 univs = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - infer_check_convert_instances ~flex:false u1 u2 univs - | Declarations.Cumulative_ind cumi -> - let num_param_arity = - mind.Declarations.mind_nparams + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs - in - if not (num_param_arity = sv1 && num_param_arity = sv2) then - infer_check_convert_instances ~flex:false u1 u2 univs - else - infer_check_inductive_instances cv_pb cumi u1 u2 univs - -let infer_check_conv_constructors - infer_check_convert_instances - infer_check_inductive_instances - (mind, ind, cns) u1 sv1 u2 sv2 univs = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> - infer_check_convert_instances ~flex:false u1 u2 univs - | Declarations.Cumulative_ind cumi -> - let num_cnstr_args = - let nparamsctxt = - mind.Declarations.mind_nparams + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs - (* Context.Rel.length mind.Declarations.mind_params_ctxt *) in - nparamsctxt + mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(cns - 1) - in - if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then - infer_check_convert_instances ~flex:false u1 u2 univs - else - infer_check_inductive_instances CONV cumi u1 u2 univs - -let check_inductive_instances cv_pb cumi u u' univs = - let length_ind_instance = - Univ.Instance.length - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) - in - let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in - if not ((length_ind_instance = Univ.Instance.length u) && - (length_ind_instance = Univ.Instance.length u')) then - anomaly (Pp.str "Invalid inductive subtyping encountered!") - else - let comp_cst = - let comp_subst = (Univ.Instance.append u u') in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) - in - let comp_cst = - match cv_pb with - CONV -> - let comp_cst' = - let comp_subst = (Univ.Instance.append u' u) in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) - in - Univ.Constraint.union comp_cst comp_cst' - | CUMUL -> comp_cst - in - if (UGraph.check_constraints comp_cst univs) then univs - else raise NotConvertible - -let check_conv_inductives cv_pb ind u1 sv1 u2 sv2 univs = - infer_check_conv_inductives - check_convert_instances - check_inductive_instances - cv_pb ind u1 sv1 u2 sv2 univs - -let check_conv_constructors cns u1 sv1 u2 sv2 univs = - infer_check_conv_constructors - check_convert_instances - check_inductive_instances - cns u1 sv1 u2 sv2 univs +let check_inductive_instances cv_pb variance u1 u2 univs = + let csts = get_cumulativity_constraints cv_pb variance u1 u2 in + if (UGraph.check_constraints csts univs) then univs + else raise NotConvertible let checked_universes = - { compare = checked_sort_cmp_universes; + { compare_sorts = checked_sort_cmp_universes; compare_instances = check_convert_instances; - conv_inductives = check_conv_inductives; - conv_constructors = check_conv_constructors} + compare_cumul_instances = check_inductive_instances; } let infer_eq (univs, cstrs as cuniv) u u' = if UGraph.check_eq univs u u' then cuniv @@ -733,29 +689,27 @@ let infer_eq (univs, cstrs as cuniv) u u' = let infer_leq (univs, cstrs as cuniv) u u' = if UGraph.check_leq univs u u' then cuniv else - let cstrs' = Univ.enforce_leq u u' cstrs in - univs, cstrs' + let cstrs', _ = UGraph.enforce_leq_alg u u' univs in + univs, Univ.Constraint.union cstrs cstrs' let infer_cmp_universes env pb s0 s1 univs = - match (s0,s1) with - | (Prop c1, Prop c2) when is_cumul pb -> - begin match c1, c2 with - | Null, _ | _, Pos -> univs (* Prop <= Set *) - | _ -> raise NotConvertible - end - | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible - | (Prop c1, Type u) -> - let u0 = univ_of_sort s0 in - (match pb with - | CUMUL -> infer_leq univs u0 u - | CONV -> infer_eq univs u0 u) - | (Type u, Prop c) -> raise NotConvertible - | (Type u1, Type u2) -> - if not (type_in_type env) then - (match pb with - | CUMUL -> infer_leq univs u1 u2 - | CONV -> infer_eq univs u1 u2) - else univs + if type_in_type env + then univs + else + let open Sorts in + let infer_pb u0 u1 = + match pb with + | CUMUL -> infer_leq univs u0 u1 + | CONV -> infer_eq univs u0 u1 + in + match (s0,s1) with + | Prop, Prop | Set, Set -> univs + | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs + | Set, Prop -> raise NotConvertible + | Set, Type u -> infer_pb Univ.type0_univ u + | Type u, Prop -> raise NotConvertible + | Type u, Set -> infer_pb u Univ.type0_univ + | Type u0, Type u1 -> infer_pb u0 u1 let infer_convert_instances ~flex u u' (univs,cstrs) = let cstrs' = @@ -765,51 +719,14 @@ let infer_convert_instances ~flex u u' (univs,cstrs) = else Univ.enforce_eq_instances u u' cstrs in (univs, cstrs') -let infer_inductive_instances cv_pb cumi u u' (univs, cstrs) = - let length_ind_instance = - Univ.Instance.length - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) - in - let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in - if not ((length_ind_instance = Univ.Instance.length u) && - (length_ind_instance = Univ.Instance.length u')) then - anomaly (Pp.str "Invalid inductive subtyping encountered!") - else - let comp_cst = - let comp_subst = (Univ.Instance.append u u') in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) - in - let comp_cst = - match cv_pb with - CONV -> - let comp_cst' = - let comp_subst = (Univ.Instance.append u' u) in - Univ.UContext.constraints - (Univ.subst_instance_context comp_subst ind_subtypctx) in - Univ.Constraint.union comp_cst comp_cst' - | CUMUL -> comp_cst - in - (univs, Univ.Constraint.union cstrs comp_cst) - - -let infer_conv_inductives cv_pb ind u1 sv1 u2 sv2 univs = - infer_check_conv_inductives - infer_convert_instances - infer_inductive_instances - cv_pb ind u1 sv1 u2 sv2 univs - -let infer_conv_constructors cns u1 sv1 u2 sv2 univs = - infer_check_conv_constructors - infer_convert_instances - infer_inductive_instances - cns u1 sv1 u2 sv2 univs - -let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = - { compare = infer_cmp_universes; +let infer_inductive_instances cv_pb variance u1 u2 (univs,csts') = + let csts = get_cumulativity_constraints cv_pb variance u1 u2 in + (univs, Univ.Constraint.union csts csts') + +let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = + { compare_sorts = infer_cmp_universes; compare_instances = infer_convert_instances; - conv_inductives = infer_conv_inductives; - conv_constructors = infer_conv_constructors} + compare_cumul_instances = infer_inductive_instances; } let gen_conv cv_pb l2r reds env evars univs t1 t2 = let b = @@ -825,8 +742,8 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then - let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in - Profile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs + let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in + CProfile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs else gen_conv cv_pb l2r reds env evars univs let conv = gen_conv CONV @@ -852,8 +769,8 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = (* Profiling *) let infer_conv_universes = if Flags.profile then - let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" in - Profile.profile8 infer_conv_universes_key infer_conv_universes + let infer_conv_universes_key = CProfile.declare_profile "infer_conv_universes" in + CProfile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) @@ -864,45 +781,27 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 -(* This reference avoids always having to link C code with the kernel *) -let vm_conv = ref (fun cv_pb env -> - gen_conv cv_pb env ~evars:((fun _->None), universes env)) - -let warn_bytecode_compiler_failed = - let open Pp in - CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler" - (fun () -> strbrk "Bytecode compiler failed, " ++ - strbrk "falling back to standard conversion") - -let set_vm_conv (f:conv_pb -> Term.types kernel_conversion_function) = vm_conv := f -let vm_conv cv_pb env t1 t2 = - try - !vm_conv cv_pb env t1 t2 - with Not_found | Invalid_argument _ -> - warn_bytecode_compiler_failed (); - gen_conv cv_pb env t1 t2 - let default_conv cv_pb ?(l2r=false) env t1 t2 = gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL (* -let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; +let convleqkey = CProfile.declare_profile "Kernel_reduction.conv_leq";; let conv_leq env t1 t2 = - Profile.profile4 convleqkey conv_leq env t1 t2;; + CProfile.profile4 convleqkey conv_leq env t1 t2;; -let convkey = Profile.declare_profile "Kernel_reduction.conv";; +let convkey = CProfile.declare_profile "Kernel_reduction.conv";; let conv env t1 t2 = - Profile.profile4 convleqkey conv env t1 t2;; + CProfile.profile4 convleqkey conv env t1 t2;; *) (* Application with on-the-fly reduction *) let beta_applist c l = let rec app subst c l = - match kind_of_term c, l with + match kind c, l with | Lambda(_,_,c), arg::l -> app (arg::subst) c l - | _ -> applist (substl subst c, l) in + | _ -> Term.applist (substl subst c, l) in app [] c l let beta_appvect c v = beta_applist c (Array.to_list v) @@ -910,7 +809,7 @@ let beta_appvect c v = beta_applist c (Array.to_list v) let beta_app c a = beta_applist c [a] (* Compatibility *) -let betazeta_appvect = lambda_appvect_assum +let betazeta_appvect = Term.lambda_appvect_assum (********************************************************************) (* Special-Purpose Reduction *) @@ -923,19 +822,31 @@ let betazeta_appvect = lambda_appvect_assum * error message. *) let hnf_prod_app env t n = - match kind_of_term (whd_all env t) with + match kind (whd_all env t) with | Prod (_,_,b) -> subst1 n b | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product.") let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl +let hnf_prod_applist_assum env n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Too many arguments.") + else match kind (whd_allnolet env t), l with + | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _, [] -> anomaly (Pp.str "Not enough arguments.") + | _ -> anomaly (Pp.str "Not enough prod/let's.") in + app n [] c l + (* Dealing with arities *) let dest_prod env = let rec decrec env m c = let t = whd_all env c in - match kind_of_term t with + match kind t with | Prod (n,a,c0) -> let d = LocalAssum (n,a) in decrec (push_rel d env) (Context.Rel.add d m) c0 @@ -943,21 +854,31 @@ let dest_prod env = in decrec env Context.Rel.empty +let dest_lam env = + let rec decrec env m c = + let t = whd_all env c in + match kind t with + | Lambda (n,a,c0) -> + let d = LocalAssum (n,a) in + decrec (push_rel d env) (Context.Rel.add d m) c0 + | _ -> m,t + in + decrec env Context.Rel.empty + (* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_allnolet env ty in - match kind_of_term rty with + match kind rty with | Prod (x,t,c) -> let d = LocalAssum (x,t) in prodec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (Context.Rel.add d l) c - | Cast (c,_,_) -> prodec_rec env l c | _ -> let rty' = whd_all env rty in - if Term.eq_constr rty' rty then l, rty + if Constr.equal rty' rty then l, rty else prodec_rec env l rty' in prodec_rec env Context.Rel.empty @@ -965,14 +886,13 @@ let dest_prod_assum env = let dest_lam_assum env = let rec lamec_rec env l ty = let rty = whd_allnolet env ty in - match kind_of_term rty with + match kind rty with | Lambda (x,t,c) -> let d = LocalAssum (x,t) in lamec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (Context.Rel.add d l) c - | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty in lamec_rec env Context.Rel.empty @@ -981,7 +901,7 @@ exception NotArity let dest_arity env c = let l, c = dest_prod_assum env c in - match kind_of_term c with + match kind c with | Sort s -> l,s | _ -> raise NotArity @@ -990,3 +910,12 @@ let is_arity env c = let _ = dest_arity env c in true with NotArity -> false + +let eta_expand env t ty = + let ctxt, codom = dest_prod env ty in + let ctxt',t = dest_lam env t in + let d = Context.Rel.nhyps ctxt - Context.Rel.nhyps ctxt' in + let eta_args = List.rev_map mkRel (List.interval 1 d) in + let t = Term.applistc (Vars.lift d t) eta_args in + let t = Term.it_mkLambda_or_LetIn t (List.firstn d ctxt) in + Term.it_mkLambda_or_LetIn t ctxt' diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 253c0874f2..581e8bd88a 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -1,12 +1,14 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open Environ (*********************************************************************** @@ -35,23 +37,26 @@ type 'a extended_conversion_function = type conv_pb = CONV | CUMUL -type 'a universe_compare = +type 'a universe_compare = { (* Might raise NotConvertible *) - compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; + compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; - conv_inductives : conv_pb -> (Declarations.mutual_inductive_body * int) -> Univ.Instance.t -> int -> - Univ.Instance.t -> int -> 'a -> 'a; - conv_constructors : (Declarations.mutual_inductive_body * int * int) -> - Univ.Instance.t -> int -> Univ.Instance.t -> int -> 'a -> 'a; - } + compare_cumul_instances : conv_pb -> Univ.Variance.t array -> + Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a } type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.Constraint.t -val sort_cmp_universes : env -> conv_pb -> sorts -> sorts -> +val get_cumulativity_constraints : conv_pb -> Univ.Variance.t array -> + Univ.Instance.t -> Univ.Instance.t -> Univ.Constraint.t + +val inductive_cumulativity_arguments : (Declarations.mutual_inductive_body * int) -> int +val constructor_cumulativity_arguments : (Declarations.mutual_inductive_body * int * int) -> int + +val sort_cmp_universes : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a * 'a universe_compare -> 'a * 'a universe_compare (* [flex] should be true for constants, false for inductive types and @@ -82,10 +87,6 @@ val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function -(** option for conversion *) -val set_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit -val vm_conv : conv_pb -> types kernel_conversion_function - val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function val default_conv_leq : ?l2r:bool -> types kernel_conversion_function @@ -103,19 +104,26 @@ val beta_app : constr -> constr -> constr (** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types +(** In [hnf_prod_applist_assum n c args], [c] is supposed to (whd-)reduce to + the form [∀Γ.t] with [Γ] of length [n] and possibly with let-ins; it + returns [t] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. *) +val hnf_prod_applist_assum : env -> int -> types -> constr list -> types + (** Compatibility alias for Term.lambda_appvect_assum *) val betazeta_appvect : int -> constr -> constr array -> constr (*********************************************************************** s Recognizing products and arities modulo reduction *) -val dest_prod : env -> types -> Context.Rel.t * types -val dest_prod_assum : env -> types -> Context.Rel.t * types -val dest_lam_assum : env -> types -> Context.Rel.t * types +val dest_prod : env -> types -> Constr.rel_context * types +val dest_prod_assum : env -> types -> Constr.rel_context * types +val dest_lam : env -> constr -> Constr.rel_context * constr +val dest_lam_assum : env -> constr -> Constr.rel_context * constr exception NotArity -val dest_arity : env -> types -> arity (* raises NotArity if not an arity *) +val dest_arity : env -> types -> Term.arity (* raises NotArity if not an arity *) val is_arity : env -> types -> bool -val warn_bytecode_compiler_failed : ?loc:Loc.t -> unit -> unit +val eta_expand : env -> constr -> types -> constr diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 5fbd914f3f..34f62defb8 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Arnaud Spiwack, May 2007 *) @@ -14,7 +16,7 @@ for evaluation in the bytecode virtual machine *) open Names -open Term +open Constr (* The retroknowledge defines a bijective correspondance between some [entry]-s (which are, in fact, merely terms) and [field]-s which @@ -23,22 +25,6 @@ open Term (* aliased type for clarity purpose*) type entry = Constr.t -(* [field]-s are the roles the kernel can learn of. *) -type nat_field = - | NatType - | NatPlus - | NatTimes - -type n_field = - | NPositive - | NType - | NTwice - | NTwicePlusOne - | NPhi - | NPhiInv - | NPlus - | NTimes - type int31_field = | Int31Bits | Int31Type @@ -67,9 +53,6 @@ type int31_field = | Int31Lxor type field = - (* | KEq - | KNat of nat_field - | KN of n_field *) | KInt31 of string*int31_field @@ -102,22 +85,20 @@ module Reactive = Map.Make (EntryOrd) type reactive_info = {(*information required by the compiler of the VM *) vm_compiling : (*fastcomputation flag -> continuation -> result *) - (bool->Cbytecodes.comp_env->constr array -> - int->Cbytecodes.bytecodes->Cbytecodes.bytecodes) + (bool -> Cinstr.lambda array -> Cinstr.lambda) option; vm_constant_static : (*fastcomputation flag -> constructor -> args -> result*) - (bool->constr array->Cbytecodes.structured_constant) + (bool -> constr array -> Cinstr.lambda) option; vm_constant_dynamic : (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) - (bool->Cbytecodes.comp_env->Cbytecodes.block array->int-> - Cbytecodes.bytecodes->Cbytecodes.bytecodes) + (bool -> Cinstr.lambda array -> Cinstr.lambda) option; (* fastcomputation flag -> cont -> result *) - vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option; + vm_before_match : (bool -> Cinstr.lambda -> Cinstr.lambda) option; (* tag (= compiled int for instance) -> result *) - vm_decompile_const : (int -> Term.constr) option; + vm_decompile_const : (int -> constr) option; native_compiling : (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 18a12a4ef1..02d961d893 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr type retroknowledge @@ -16,21 +18,6 @@ type entry = Constr.t (** the following types correspond to the different "things" the kernel can learn about.*) -type nat_field = - | NatType - | NatPlus - | NatTimes - -type n_field = - | NPositive - | NType - | NTwice - | NTwicePlusOne - | NPhi - | NPhiInv - | NPlus - | NTimes - type int31_field = | Int31Bits | Int31Type @@ -59,13 +46,8 @@ type int31_field = | Int31Lxor type field = - -(** | KEq - | KNat of nat_field - | KN of n_field *) | KInt31 of string*int31_field - (** This type represent an atomic action of the retroknowledge. It is stored in the compiled libraries As per now, there is only the possibility of registering things @@ -82,9 +64,8 @@ val initial_retroknowledge : retroknowledge and the continuation cont of the bytecode compilation returns the compilation of id in cont if it has a specific treatment or raises Not_found if id should be compiled as usual *) -val get_vm_compiling_info : retroknowledge -> entry -> Cbytecodes.comp_env -> - constr array -> - int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes +val get_vm_compiling_info : retroknowledge -> entry -> + Cinstr.lambda array -> Cinstr.lambda (*Given an identifier id (usually Construct _) and its argument array, returns a function that tries an ad-hoc optimisated compilation (in the case of the 31-bit integers it means compiling them @@ -93,8 +74,7 @@ val get_vm_compiling_info : retroknowledge -> entry -> Cbytecodes.comp_env -> CBytecodes.NotClosed if the term is not a closed constructor pattern (a constant for the compiler) *) val get_vm_constant_static_info : retroknowledge -> entry -> - constr array -> - Cbytecodes.structured_constant + constr array -> Cinstr.lambda (*Given an identifier id (usually Construct _ ) its argument array and a continuation, returns the compiled version @@ -102,22 +82,20 @@ val get_vm_constant_static_info : retroknowledge -> entry -> 31-bit integers, that would be the dynamic compilation into integers) or raises Not_found if id should be compiled as usual *) val get_vm_constant_dynamic_info : retroknowledge -> entry -> - Cbytecodes.comp_env -> - Cbytecodes.block array -> - int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes + Cinstr.lambda array -> Cinstr.lambda (** 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 +val get_vm_before_match_info : retroknowledge -> entry -> Cinstr.lambda + -> Cinstr.lambda (** 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 +val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> constr val get_native_compiling_info : retroknowledge -> entry -> Nativeinstr.prefix -> @@ -136,7 +114,7 @@ val get_native_before_match_info : retroknowledge -> entry -> Nativeinstr.lambda -> Nativeinstr.lambda -(** the following functions are solely used in Pre_env and Environ to implement +(** the following functions are solely used in Environ and Safe_typing to implement the functions register and unregister (and mem) of Environ *) val add_field : retroknowledge -> field -> entry -> retroknowledge val mem : retroknowledge -> field -> bool @@ -148,22 +126,20 @@ val find : retroknowledge -> field -> entry type reactive_info = {(*information required by the compiler of the VM *) vm_compiling : (*fastcomputation flag -> continuation -> result *) - (bool->Cbytecodes.comp_env->constr array -> - int->Cbytecodes.bytecodes->Cbytecodes.bytecodes) + (bool -> Cinstr.lambda array -> Cinstr.lambda) option; vm_constant_static : (*fastcomputation flag -> constructor -> args -> result*) - (bool->constr array->Cbytecodes.structured_constant) + (bool -> constr array -> Cinstr.lambda) option; vm_constant_dynamic : (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) - (bool->Cbytecodes.comp_env->Cbytecodes.block array->int-> - Cbytecodes.bytecodes->Cbytecodes.bytecodes) + (bool -> Cinstr.lambda array -> Cinstr.lambda) option; (* fastcomputation flag -> cont -> result *) - vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option; + vm_before_match : (bool -> Cinstr.lambda -> Cinstr.lambda) option; (* tag (= compiled int for instance) -> result *) - vm_decompile_const : (int -> Term.constr) option; + vm_decompile_const : (int -> constr) option; native_compiling : (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ed4c7d57ad..f87ec9e023 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jean-Christophe Filliâtre as part of the rebuilding of @@ -57,6 +59,7 @@ etc. *) +open CErrors open Util open Names open Declarations @@ -114,7 +117,7 @@ module DPMap = Map.Make(DirPath) type safe_environment = { env : Environ.env; - modpath : module_path; + modpath : ModPath.t; modvariant : modvariant; modresolver : Mod_subst.delta_resolver; paramresolver : Mod_subst.delta_resolver; @@ -125,7 +128,7 @@ type safe_environment = future_cst : Univ.ContextSet.t Future.computation list; engagement : engagement option; required : vodigest DPMap.t; - loads : (module_path * module_body) list; + loads : (ModPath.t * module_body) list; local_retroknowledge : Retroknowledge.action list; native_symbols : Nativecode.symbols DPMap.t } @@ -143,7 +146,7 @@ let rec library_dp_of_senv senv = let empty_environment = { env = Environ.empty_env; - modpath = initial_path; + modpath = ModPath.initial; modvariant = NONE; modresolver = Mod_subst.empty_delta_resolver; paramresolver = Mod_subst.empty_delta_resolver; @@ -160,7 +163,7 @@ let empty_environment = let is_initial senv = match senv.revstruct, senv.modvariant with - | [], NONE -> ModPath.equal senv.modpath initial_path + | [], NONE -> ModPath.equal senv.modpath ModPath.initial | _ -> false let delta_of_senv senv = senv.modresolver,senv.paramresolver @@ -249,14 +252,14 @@ let universes_of_private eff = in match cb.const_universes with | Monomorphic_const ctx -> - (Univ.ContextSet.of_context ctx) :: acc + ctx :: acc | Polymorphic_const _ -> acc ) acc l | Entries.SEsubproof (c, cb, e) -> match cb.const_universes with | Monomorphic_const ctx -> - (Univ.ContextSet.of_context ctx) :: acc + ctx :: acc | Polymorphic_const _ -> acc ) [] (Term_typing.uniq_seff eff) @@ -382,23 +385,9 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let c,typ,univs = - match Term_typing.translate_local_def senv.revstruct senv.env id de with - | c, typ, Monomorphic_const ctx -> c, typ, ctx - | _, _, Polymorphic_const _ -> assert false - in - let poly = de.Entries.const_entry_polymorphic in - let univs = Univ.ContextSet.of_context univs in - let c, univs = match c with - | Def c -> Mod_subst.force_constr c, univs - | OpaqueDef o -> - Opaqueproof.force_proof (Environ.opaque_tables senv.env) o, - Univ.ContextSet.union univs - (Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o) - | _ -> assert false in - let senv' = push_context_set poly univs senv in - let env'' = safe_push_named (LocalDef (id,c,typ)) senv'.env in - univs, {senv' with env=env''} + let c, typ = Term_typing.translate_local_def senv.env id de in + let env'' = safe_push_named (LocalDef (id, c, typ)) senv.env in + { senv with env = env'' } let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in @@ -424,9 +413,8 @@ let labels_of_mib mib = let globalize_constant_universes env cb = match cb.const_universes with - | Monomorphic_const ctx -> - let cstrs = Univ.ContextSet.of_context ctx in - Now (false, cstrs) :: + | Monomorphic_const cstrs -> + Now (false, cstrs) :: (match cb.const_body with | (Undef _ | Def _) -> [] | OpaqueDef lc -> @@ -442,7 +430,7 @@ let globalize_constant_universes env cb = let globalize_mind_universes mb = match mb.mind_universes with | Monomorphic_ind ctx -> - [Now (false, Univ.ContextSet.of_context ctx)] + [Now (false, ctx)] | Polymorphic_ind _ -> [Now (true, Univ.ContextSet.empty)] | Cumulative_ind _ -> [Now (true, Univ.ContextSet.empty)] @@ -457,8 +445,8 @@ let constraints_of_sfb env sfb = It also performs the corresponding [add_constraints]. *) type generic_name = - | C of constant - | I of mutual_inductive + | C of Constant.t + | I of MutInd.t | M (** name already known, cf the mod_mp field *) | MT (** name already known, cf the mod_mp field *) @@ -492,12 +480,16 @@ let add_field ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) +type 'a effect_entry = +| EffectEntry : private_constants effect_entry +| PureEntry : unit effect_entry + type global_declaration = - | ConstantEntry of bool * private_constants Entries.constant_entry + | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration | GlobalRecipe of Cooking.recipe type exported_private_constant = - constant * private_constants Entries.constant_entry * private_constant_role + Constant.t * private_constant_role let add_constant_aux no_section senv (kn, cb) = let l = pi3 (Constant.repr3 kn) in @@ -516,35 +508,34 @@ let add_constant_aux no_section senv (kn, cb) = let senv'' = match cb.const_body with | Undef (Some lev) -> update_resolver - (Mod_subst.add_inline_delta_resolver (user_con kn) (lev,None)) senv' + (Mod_subst.add_inline_delta_resolver (Constant.user kn) (lev,None)) senv' | _ -> senv' in senv'' +let export_private_constants ~in_section ce senv = + let exported, ce = Term_typing.export_side_effects senv.revstruct senv.env ce in + let bodies = List.map (fun (kn, cb, _) -> (kn, cb)) exported in + let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in + let no_section = not in_section in + let senv = List.fold_left (add_constant_aux no_section) senv bodies in + (ce, exported), senv + let add_constant dir l decl senv = - let kn = make_con senv.modpath dir l in + let kn = Constant.make3 senv.modpath dir l in let no_section = DirPath.is_empty dir in - let seff_to_export, decl = - match decl with - | ConstantEntry (true, ce) -> - let exports, ce = - Term_typing.export_side_effects senv.revstruct senv.env ce in - exports, ConstantEntry (false, ce) - | _ -> [], decl - in - let senv = - List.fold_left (add_constant_aux no_section) senv - (List.map (fun (kn,cb,_,_) -> kn, cb) seff_to_export) in let senv = let cb = match decl with - | ConstantEntry (export_seff,ce) -> - Term_typing.translate_constant senv.revstruct senv.env kn ce + | ConstantEntry (EffectEntry, ce) -> + Term_typing.translate_constant (Term_typing.SideEffects senv.revstruct) senv.env kn ce + | ConstantEntry (PureEntry, ce) -> + Term_typing.translate_constant Term_typing.Pure senv.env kn ce | GlobalRecipe r -> let cb = Term_typing.translate_recipe senv.env kn r in if no_section then Declareops.hcons_const_body cb else cb in add_constant_aux no_section senv (kn, cb) in - (kn, List.map (fun (kn,_,ce,r) -> kn, ce, r) seff_to_export), senv + kn, senv (** Insertion of inductive types *) @@ -558,7 +549,7 @@ let check_mind mie lab = let add_mind dir l mie senv = let () = check_mind mie l in - let kn = make_mind senv.modpath dir l in + let kn = MutInd.make3 senv.modpath dir l in let mib = Term_typing.translate_mind senv.env kn mie in let mib = match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib @@ -570,7 +561,7 @@ let add_mind dir l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in - let mtb = Declareops.hcons_module_body mtb in + let mtb = Declareops.hcons_module_type mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' @@ -673,18 +664,21 @@ let build_module_body params restype senv = (struc,None,senv.modresolver,senv.univ) restype' in let mb' = functorize_module params mb in - { mb' with mod_retroknowledge = senv.local_retroknowledge } + { mb' with mod_retroknowledge = ModBodyRK senv.local_retroknowledge } (** Returning back to the old pre-interactive-module environment, with one extra component and some updated fields (constraints, required, etc) *) +let allow_delayed_constants = ref false + let propagate_senv newdef newenv newresolver senv oldsenv = let now_cst, later_cst = List.partition Future.is_val senv.future_cst in (* This asserts that after Paral-ITP, standard vo compilation is behaving * exctly as before: the same universe constraints are added to modules *) - if !Flags.compilation_mode = Flags.BuildVo && - !Flags.async_proofs_mode = Flags.APoff then assert(later_cst = []); + if not !allow_delayed_constants && later_cst <> [] then + CErrors.anomaly ~label:"safe_typing" + Pp.(str "True Future.t were created for opaque constants even if -async-proofs is off"); { oldsenv with env = newenv; modresolver = newresolver; @@ -728,12 +722,12 @@ let end_module l restype senv = let build_mtb mp sign cst delta = { mod_mp = mp; - mod_expr = Abstract; + mod_expr = (); mod_type = sign; mod_type_alg = None; mod_constraints = cst; mod_delta = delta; - mod_retroknowledge = [] } + mod_retroknowledge = ModTypeRK } let end_modtype l senv = let mp = senv.modpath in @@ -849,11 +843,11 @@ let export ?except senv dir = mod_type_alg = None; mod_constraints = senv.univ; mod_delta = senv.modresolver; - mod_retroknowledge = senv.local_retroknowledge + mod_retroknowledge = ModBodyRK senv.local_retroknowledge } in let ast, symbols = - if !Flags.native_compiler then + if !Flags.output_native_objects then Nativelibrary.dump_library mp dir senv.env str else [], Nativecode.empty_symbols in @@ -903,9 +897,11 @@ let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) +[@@@ocaml.warning "-3"] (** universal lifting, used for the "get" operations mostly *) let retroknowledge f senv = Environ.retroknowledge f (env_of_senv senv) +[@@@ocaml.warning "+3"] let register field value by_clause senv = (* todo : value closed, by_clause safe, by_clause of the proper type*) @@ -921,16 +917,12 @@ let register field value by_clause senv = but it is meant to become a replacement for environ.register *) let register_inline kn senv = let open Environ in - let open Pre_env in if not (evaluable_constant kn senv.env) then CErrors.user_err Pp.(str "Register inline: an evaluable constant is expected"); - let env = pre_env senv.env in - let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in + let env = senv.env in + let cb = lookup_constant kn env in let cb = {cb with const_inline_code = true} in - let new_constants = Cmap_env.add kn (cb,r) env.env_globals.env_constants in - let new_globals = { env.env_globals with env_constants = new_constants } in - let env = { env with env_globals = new_globals } in - { senv with env = env_of_pre_env env } + let env = add_constant kn cb env in { senv with env} let add_constraints c = add_constraints @@ -960,3 +952,125 @@ Would this be correct with respect to undo's and stuff ? let set_strategy e k l = { e with env = (Environ.set_oracle e.env (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) } + +(** Register retroknowledge hooks *) + +open Retroknowledge + +(* the Environ.register function synchronizes the proactive and reactive + retroknowledge. *) +let dispatch = + + (* subfunction used for static decompilation of int31 (after a vm_compute, + see pretyping/vnorm.ml for more information) *) + let constr_of_int31 = + let nth_digit_plus_one i n = (* calculates the nth (starting with 0) + digit of i and adds 1 to it + (nth_digit_plus_one 1 3 = 2) *) + if Int.equal (i land (1 lsl n)) 0 then + 1 + else + 2 + in + fun ind -> fun digit_ind -> fun tag -> + let array_of_int i = + Array.init 31 (fun n -> Constr.mkConstruct + (digit_ind, nth_digit_plus_one i (30-n))) + in + (* We check that no bit above 31 is set to one. This assertion used to + fail in the VM, and led to conversion tests failing at Qed. *) + assert (Int.equal (tag lsr 31) 0); + Constr.mkApp(Constr.mkConstruct(ind, 1), array_of_int tag) + in + + (* subfunction which dispatches the compiling information of an + int31 operation which has a specific vm instruction (associates + it to the name of the coq definition in the reactive retroknowledge) *) + let int31_op n op prim kn = + { empty_reactive_info with + vm_compiling = Some (Clambda.compile_prim n op kn); + native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn)); + } + in + +fun rk value field -> + (* subfunction which shortens the (very common) dispatch of operations *) + let int31_op_from_const n op prim = + match Constr.kind value with + | Constr.Const kn -> int31_op n op prim kn + | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") + in + let int31_binop_from_const op prim = int31_op_from_const 2 op prim in + let int31_unop_from_const op prim = int31_op_from_const 1 op prim in + match field with + | KInt31 (grp, Int31Type) -> + let int31bit = + (* invariant : the type of bits is registered, otherwise the function + would raise Not_found. The invariant is enforced in safe_typing.ml *) + match field with + | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) + | _ -> anomaly ~label:"Environ.register" + (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") + in + let i31bit_type = + match Constr.kind int31bit with + | Constr.Ind (i31bit_type,_) -> i31bit_type + | _ -> anomaly ~label:"Environ.register" + (Pp.str "Int31Bits should be an inductive type.") + in + let int31_decompilation = + match Constr.kind value with + | Constr.Ind (i31t,_) -> + constr_of_int31 i31t i31bit_type + | _ -> anomaly ~label:"Environ.register" + (Pp.str "should be an inductive type.") + in + { empty_reactive_info with + vm_decompile_const = Some int31_decompilation; + vm_before_match = Some Clambda.int31_escape_before_match; + native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); + } + | KInt31 (_, Int31Constructor) -> + { empty_reactive_info with + vm_constant_static = Some Clambda.compile_structured_int31; + vm_constant_dynamic = Some Clambda.dynamic_int31_compilation; + native_constant_static = Some Nativelambda.compile_static_int31; + native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; + } + | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 + CPrimitives.Int31add + | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 + CPrimitives.Int31addc + | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 + CPrimitives.Int31addcarryc + | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 + CPrimitives.Int31sub + | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 + CPrimitives.Int31subc + | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const + Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc + | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 + CPrimitives.Int31mul + | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 + CPrimitives.Int31mulc + | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 + CPrimitives.Int31div21 + | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 + CPrimitives.Int31diveucl + | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 + CPrimitives.Int31addmuldiv + | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 + CPrimitives.Int31compare + | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 + CPrimitives.Int31head0 + | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 + CPrimitives.Int31tail0 + | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 + CPrimitives.Int31lor + | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 + CPrimitives.Int31land + | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 + CPrimitives.Int31lxor + | _ -> empty_reactive_info + +let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 5bb8ceb1a5..aca77ccd13 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names @@ -60,16 +62,16 @@ val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) -val private_con_of_con : safe_environment -> constant -> private_constant -val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant +val private_con_of_con : safe_environment -> Constant.t -> private_constant +val private_con_of_scheme : kind:string -> safe_environment -> (inductive * Constant.t) list -> private_constant val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : Environ.env -> Constr.constr -> private_constants -> Constr.constr val inline_private_constants_in_definition_entry : - Environ.env -> private_constants Entries.definition_entry -> private_constants Entries.definition_entry + Environ.env -> private_constants Entries.definition_entry -> unit Entries.definition_entry -val universes_of_private : private_constants -> Univ.universe_context_set list +val universes_of_private : private_constants -> Univ.ContextSet.t list val is_curmod_library : safe_environment -> bool @@ -84,55 +86,62 @@ val is_joined_environment : safe_environment -> bool (** Insertion of local declarations (Local or Variables) *) val push_named_assum : - (Id.t * Term.types * bool (* polymorphic *)) + (Id.t * Constr.types * bool (* polymorphic *)) Univ.in_universe_context_set -> safe_transformer0 (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) val push_named_def : - Id.t * private_constants Entries.definition_entry -> Univ.universe_context_set safe_transformer + Id.t * Entries.section_def_entry -> safe_transformer0 (** Insertion of global axioms or definitions *) +type 'a effect_entry = +| EffectEntry : private_constants effect_entry +| PureEntry : unit effect_entry + type global_declaration = - (* bool: export private constants *) - | ConstantEntry of bool * private_constants Entries.constant_entry + | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration | GlobalRecipe of Cooking.recipe type exported_private_constant = - constant * private_constants Entries.constant_entry * private_constant_role + Constant.t * private_constant_role + +val export_private_constants : in_section:bool -> + private_constants Entries.definition_entry -> + (unit Entries.definition_entry * exported_private_constant list) safe_transformer (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) val add_constant : DirPath.t -> Label.t -> global_declaration -> - (constant * exported_private_constant list) safe_transformer + Constant.t safe_transformer (** Adding an inductive type *) val add_mind : DirPath.t -> Label.t -> Entries.mutual_inductive_entry -> - mutual_inductive safe_transformer + MutInd.t safe_transformer (** Adding a module or a module type *) val add_module : Label.t -> Entries.module_entry -> Declarations.inline -> - (module_path * Mod_subst.delta_resolver) safe_transformer + (ModPath.t * Mod_subst.delta_resolver) safe_transformer val add_modtype : Label.t -> Entries.module_type_entry -> Declarations.inline -> - module_path safe_transformer + ModPath.t safe_transformer (** Adding universe constraints *) val push_context_set : - bool -> Univ.universe_context_set -> safe_transformer0 + bool -> Univ.ContextSet.t -> safe_transformer0 val push_context : - bool -> Univ.universe_context -> safe_transformer0 + bool -> Univ.UContext.t -> safe_transformer0 val add_constraints : - Univ.constraints -> safe_transformer0 + Univ.Constraint.t -> safe_transformer0 (* (\** Generator of universes *\) *) (* val next_universe : int safe_transformer *) @@ -143,29 +152,33 @@ val set_typing_flags : Declarations.typing_flags -> safe_transformer0 (** {6 Interactive module functions } *) -val start_module : Label.t -> module_path safe_transformer +val start_module : Label.t -> ModPath.t safe_transformer -val start_modtype : Label.t -> module_path safe_transformer +val start_modtype : Label.t -> ModPath.t safe_transformer val add_module_parameter : MBId.t -> Entries.module_struct_entry -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer +(** Traditional mode: check at end of module that no future was + created. *) +val allow_delayed_constants : bool ref + (** The optional result type is given without its functorial part *) val end_module : Label.t -> (Entries.module_struct_entry * Declarations.inline) option -> - (module_path * MBId.t list * Mod_subst.delta_resolver) safe_transformer + (ModPath.t * MBId.t list * Mod_subst.delta_resolver) safe_transformer -val end_modtype : Label.t -> (module_path * MBId.t list) safe_transformer +val end_modtype : Label.t -> (ModPath.t * MBId.t list) safe_transformer val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer -val current_modpath : safe_environment -> module_path +val current_modpath : safe_environment -> ModPath.t -val current_dirpath : safe_environment -> dir_path +val current_dirpath : safe_environment -> DirPath.t (** {6 Libraries : loading and saving compilation units } *) @@ -175,26 +188,26 @@ type native_library = Nativecode.global list val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.symbols -val start_library : DirPath.t -> module_path safe_transformer +val start_library : DirPath.t -> ModPath.t safe_transformer val export : ?except:Future.UUIDSet.t -> safe_environment -> DirPath.t -> - module_path * compiled_library * native_library + ModPath.t * compiled_library * native_library (* Constraints are non empty iff the file is a vi2vo *) -val import : compiled_library -> Univ.universe_context_set -> vodigest -> - module_path safe_transformer +val import : compiled_library -> Univ.ContextSet.t -> vodigest -> + ModPath.t safe_transformer (** {6 Safe typing judgments } *) type judgment -val j_val : judgment -> Term.constr -val j_type : judgment -> Term.constr +val j_val : judgment -> Constr.constr +val j_type : judgment -> Constr.constr (** The safe typing of a term returns a typing judgment. *) -val typing : safe_environment -> Term.constr -> judgment +val typing : safe_environment -> Constr.constr -> judgment (** {6 Queries } *) @@ -208,11 +221,12 @@ val delta_of_senv : open Retroknowledge val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a +[@@ocaml.deprecated "Use the projection of Environ.env"] val register : - field -> Retroknowledge.entry -> Term.constr -> safe_transformer0 + field -> Retroknowledge.entry -> Constr.constr -> safe_transformer0 -val register_inline : constant -> safe_transformer0 +val register_inline : Constant.t -> safe_transformer0 val set_strategy : - safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment + safe_environment -> Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_environment diff --git a/kernel/sorts.ml b/kernel/sorts.ml index cf5207e8dc..a7bb08f5b6 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -1,29 +1,30 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Univ -type contents = Pos | Null - type family = InProp | InSet | InType type t = - | Prop of contents (* proposition types *) - | Type of universe + | Prop + | Set + | Type of Universe.t -let prop = Prop Null -let set = Prop Pos +let prop = Prop +let set = Set let type1 = Type type1_univ let univ_of_sort = function | Type u -> u - | Prop Pos -> Universe.type0 - | Prop Null -> Universe.type0m + | Set -> Universe.type0 + | Prop -> Universe.type0m let sort_of_univ u = if is_type0m_univ u then prop @@ -32,36 +33,34 @@ let sort_of_univ u = let compare s1 s2 = if s1 == s2 then 0 else - match s1, s2 with - | Prop c1, Prop c2 -> - begin match c1, c2 with - | Pos, Pos | Null, Null -> 0 - | Pos, Null -> -1 - | Null, Pos -> 1 - end - | Type u1, Type u2 -> Universe.compare u1 u2 - | Prop _, Type _ -> -1 - | Type _, Prop _ -> 1 + match s1, s2 with + | Prop, Prop -> 0 + | Prop, _ -> -1 + | Set, Prop -> 1 + | Set, Set -> 0 + | Set, _ -> -1 + | Type u1, Type u2 -> Universe.compare u1 u2 + | Type _, _ -> -1 let equal s1 s2 = Int.equal (compare s1 s2) 0 let is_prop = function - | Prop Null -> true + | Prop -> true | Type u when Universe.equal Universe.type0m u -> true | _ -> false let is_set = function - | Prop Pos -> true + | Set -> true | Type u when Universe.equal Universe.type0 u -> true | _ -> false let is_small = function - | Prop _ -> true + | Prop | Set -> true | Type u -> is_small_univ u let family = function - | Prop Null -> InProp - | Prop Pos -> InSet + | Prop -> InProp + | Set -> InSet | Type u when is_type0m_univ u -> InProp | Type u when is_type0_univ u -> InSet | Type _ -> InType @@ -71,15 +70,11 @@ let family_equal = (==) open Hashset.Combine let hash = function -| Prop p -> - let h = match p with - | Pos -> 0 - | Null -> 1 - in - combinesmall 1 h -| Type u -> - let h = Univ.Universe.hash u in - combinesmall 2 h + | Prop -> combinesmall 1 0 + | Set -> combinesmall 1 1 + | Type u -> + let h = Univ.Universe.hash u in + combinesmall 2 h module List = struct let mem = List.memq @@ -91,7 +86,7 @@ module Hsorts = struct type _t = t type t = _t - type u = universe -> universe + type u = Universe.t -> Universe.t let hashcons huniv = function | Type u as c -> @@ -99,7 +94,7 @@ module Hsorts = if u' == u then c else Type u' | s -> s let eq s1 s2 = match (s1,s2) with - | (Prop c1, Prop c2) -> c1 == c2 + | Prop, Prop | Set, Set -> true | (Type u1, Type u2) -> u1 == u2 |_ -> false diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 3426d6fd3c..cac6229b91 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -1,20 +1,21 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** {6 The sorts of CCI. } *) -type contents = Pos | Null - type family = InProp | InSet | InType type t = -| Prop of contents (** Prop and Set *) -| Type of Univ.universe (** Type *) + | Prop + | Set + | Type of Univ.Universe.t val set : t val prop : t @@ -38,5 +39,5 @@ module List : sig val intersect : family list -> family list -> family list end -val univ_of_sort : t -> Univ.universe -val sort_of_univ : Univ.universe -> t +val univ_of_sort : t -> Univ.Universe.t +val sort_of_univ : Univ.Universe.t -> t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 44a1e6191a..74042f9e04 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of @@ -12,10 +14,10 @@ (* This module checks subtyping of module types *) (*i*) -open Util open Names open Univ -open Term +open Util +open Constr open Declarations open Declareops open Reduction @@ -63,11 +65,11 @@ let empty_labmap = { objs = Label.Map.empty; mods = Label.Map.empty } let get_obj mp map l = try Label.Map.find l map.objs - with Not_found -> error_no_such_label_sub l (string_of_mp mp) + with Not_found -> error_no_such_label_sub l (ModPath.to_string mp) let get_mod mp map l = try Label.Map.find l map.mods - with Not_found -> error_no_such_label_sub l (string_of_mp mp) + with Not_found -> error_no_such_label_sub l (ModPath.to_string mp) let make_labmap mp list = let add_one (l,e) map = @@ -77,13 +79,11 @@ let make_labmap mp list = | SFBmodule mb -> { map with mods = Label.Map.add l (Module mb) map.mods } | SFBmodtype mtb -> { map with mods = Label.Map.add l (Modtype mtb) map.mods } in - List.fold_right add_one list empty_labmap + CList.fold_right add_one list empty_labmap -let check_conv_error error why cst poly u f env a1 a2 = +let check_conv_error error why cst poly f env a1 a2 = try - let a1 = Vars.subst_instance_constr u a1 in - let a2 = Vars.subst_instance_constr u a2 in let cst' = f env (Environ.universes env) a1 a2 in if poly then if Constraint.is_empty cst' then cst @@ -92,69 +92,53 @@ let check_conv_error error why cst poly u f env a1 a2 = with NotConvertible -> error why | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) +let check_polymorphic_instance error env auctx1 auctx2 = + if not (Univ.AUContext.size auctx1 == Univ.AUContext.size auctx2) then + error IncompatibleInstances + else if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + error (IncompatibleConstraints auctx1) + else + Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env + (* for now we do not allow reorderings *) let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= let kn1 = KerName.make2 mp1 l in let kn2 = KerName.make2 mp2 l in let error why = error_signature_mismatch l spec2 why in - let check_conv why cst poly u f = check_conv_error error why cst poly u f in + let check_conv why cst poly f = check_conv_error error why cst poly f in let mib1 = match info1 with | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let u = - let process inst inst' = - if Univ.Instance.equal inst inst' then inst else error IncompatibleInstances - in + let env, inst = match mib1.mind_universes, mib2.mind_universes with - | Monomorphic_ind _, Monomorphic_ind _ -> Univ.Instance.empty + | Monomorphic_ind _, Monomorphic_ind _ -> env, Univ.Instance.empty | Polymorphic_ind auctx, Polymorphic_ind auctx' -> - process - (Univ.AUContext.instance auctx) (Univ.AUContext.instance auctx') + let env = check_polymorphic_instance error env auctx auctx' in + env, Univ.make_abstract_instance auctx' | Cumulative_ind cumi, Cumulative_ind cumi' -> - process - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) - (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi')) + (** Currently there is no way to control variance of inductive types, but + just in case we require that they are in a subtyping relation. *) + let () = + let v = ACumulativityInfo.variance cumi in + let v' = ACumulativityInfo.variance cumi' in + if not (Array.for_all2 Variance.check_subtype v' v) then + CErrors.anomaly Pp.(str "Variance of " ++ KerName.print kn1 ++ + str " is not compatible with the one of " ++ KerName.print kn2) + in + let auctx = Univ.ACumulativityInfo.univ_context cumi in + let auctx' = Univ.ACumulativityInfo.univ_context cumi' in + let env = check_polymorphic_instance error env auctx auctx' in + env, Univ.make_abstract_instance auctx' | _ -> error (CumulativeStatusExpected (Declareops.inductive_is_cumulative mib2)) in let mib2 = Declareops.subst_mind_body subst2 mib2 in - let check_inductive_type cst name env t1 t2 = - - (* Due to template polymorphism, the conclusions of - t1 and t2, if in Type, are generated as the least upper bounds - of the types of the constructors. - - By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U - |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each - universe in the conclusion of t1 has an bounding universe in - the conclusion of t2, so that we don't need to check the - subtyping of the conclusions of t1 and t2. - - Even if we'd like to recheck it, the inference of constraints - is not designed to deal with algebraic constraints of the form - max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy - to recheck it (in short, we would need the actual graph of - constraints as input while type checking is currently designed - to output a set of constraints instead) *) - - (* So we cheat and replace the subtyping problem on algebraic - constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n) - (that we know are necessary true) by trivial constraints that - the constraint generator knows how to deal with *) - - let (ctx1,s1) = dest_arity env t1 in - let (ctx2,s2) = dest_arity env t2 in - let s1,s2 = - match s1, s2 with - | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort - | (Prop _, Type _) | (Type _,Prop _) -> - error (NotConvertibleInductiveField name) - | _ -> (s1, s2) in + let check_inductive_type cst name t1 t2 = check_conv (NotConvertibleInductiveField name) - cst (inductive_is_polymorphic mib1) u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + cst (inductive_is_polymorphic mib1) infer_conv_leq env t1 t2 in let check_packet cst p1 p2 = @@ -172,24 +156,23 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) - let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in - let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in - let cst = Constraint.union cst1 (Constraint.union cst2 cst) in - let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in + let ty1 = type_of_inductive env ((mib1, p1), inst) in + let ty2 = type_of_inductive env ((mib2, p2), inst) in + let cst = check_inductive_type cst p2.mind_typename ty1 ty2 in cst in - let mind = mind_of_kn kn1 in + let mind = MutInd.make1 kn1 in let check_cons_types i cst p1 p2 = Array.fold_left3 (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst - (inductive_is_polymorphic mib1) u infer_conv env t1 t2) + (inductive_is_polymorphic mib1) infer_conv env t1 t2) cst p2.mind_consnames - (arities_of_specif (mind,u) (mib1,p1)) - (arities_of_specif (mind,u) (mib2,p2)) + (arities_of_specif (mind, inst) (mib1, p1)) + (arities_of_specif (mind, inst) (mib2, p2)) in let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in - check (fun mib -> mib.mind_finite<>Decl_kinds.CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x); + check (fun mib -> mib.mind_finite<>CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x); check (fun mib -> mib.mind_ntypes) Int.equal (fun x -> InductiveNumbersFieldExpected x); assert (List.is_empty mib1.mind_hyps && List.is_empty mib2.mind_hyps); assert (Array.length mib1.mind_packets >= 1 @@ -211,9 +194,10 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 else error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) - check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x); - if mib1.mind_record <> None then begin - let rec names_prod_letin t = match kind_of_term t with + (** FIXME: this check looks nonsense *) + check (fun mib -> mib.mind_record <> NotRecord) (==) (fun x -> RecordFieldExpected x); + if mib1.mind_record <> NotRecord then begin + let rec names_prod_letin t = match kind t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t @@ -240,57 +224,12 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 cst -let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = +let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let error why = error_signature_mismatch l spec2 why in - let check_conv cst poly u f = check_conv_error error cst poly u f in - let check_type poly u cst env t1 t2 = - + let check_conv cst poly f = check_conv_error error cst poly f in + let check_type poly cst env t1 t2 = let err = NotConvertibleTypeField (env, t1, t2) in - - (* If the type of a constant is generated, it may mention - non-variable algebraic universes that the general conversion - algorithm is not ready to handle. Anyway, generated types of - constants are functions of the body of the constant. If the - bodies are the same in environments that are subtypes one of - the other, the types are subtypes too (i.e. if Gamma <= Gamma', - Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). - Hence they don't have to be checked again *) - - let t1,t2 = - if isArity t2 then - let (ctx2,s2) = destArity t2 in - match s2 with - | Type v when not (is_univ_variable v) -> - (* The type in the interface is inferred and is made of algebraic - universes *) - begin try - let (ctx1,s1) = dest_arity env t1 in - match s1 with - | Type u when not (is_univ_variable u) -> - (* Both types are inferred, no need to recheck them. We - cheat and collapse the types to Prop *) - mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) - | Prop _ -> - (* The type in the interface is inferred, it may be the case - that the type in the implementation is smaller because - the body is more reduced. We safely collapse the upper - type to Prop *) - mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) - | Type _ -> - (* The type in the interface is inferred and the type in the - implementation is not inferred or is inferred but from a - more reduced body so that it is just a variable. Since - 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 NoTypeConstraintExpected - with NotArity -> - error err end - | _ -> - t1,t2 - else - (t1,t2) in - check_conv err cst poly u infer_conv_leq env t1 t2 + check_conv err cst poly infer_conv_leq env t1 t2 in match info1 with | Constant cb1 -> @@ -298,48 +237,21 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking universes *) - let poly = - if not (Declareops.constant_is_polymorphic cb1 - == Declareops.constant_is_polymorphic cb2) then - error (PolymorphicStatusExpected (Declareops.constant_is_polymorphic cb2)) - else Declareops.constant_is_polymorphic cb2 - in - let cst', env', u = + let poly, env = match cb1.const_universes, cb2.const_universes with | Monomorphic_const _, Monomorphic_const _ -> - cst, env, Univ.Instance.empty + false, env | Polymorphic_const auctx1, Polymorphic_const auctx2 -> - begin - let ctx1 = Univ.instantiate_univ_context auctx1 in - let ctx2 = Univ.instantiate_univ_context auctx2 in - let inst1, ctx1 = Univ.UContext.dest ctx1 in - let inst2, ctx2 = Univ.UContext.dest ctx2 in - if not (Univ.Instance.length inst1 == Univ.Instance.length inst2) then - error IncompatibleInstances - else - let cstrs = Univ.enforce_eq_instances inst1 inst2 cst in - let cstrs = Univ.Constraint.union cstrs ctx2 in - try - (* The environment with the expected universes plus equality - of the body instances with the expected instance *) - let ctxi = Univ.Instance.append inst1 inst2 in - let ctx = Univ.UContext.make (ctxi, cstrs) in - let env = Environ.push_context ctx env in - (* Check that the given definition does not add any constraint over - the expected ones, so that it can be used in place of - the original. *) - if UGraph.check_constraints ctx1 (Environ.universes env) then - cstrs, env, inst2 - else error (IncompatibleConstraints ctx1) - with Univ.UniverseInconsistency incon -> - error (IncompatibleUniverses incon) - end - | _ -> assert false + true, check_polymorphic_instance error env auctx1 auctx2 + | Monomorphic_const _, Polymorphic_const _ -> + error (PolymorphicStatusExpected true) + | Polymorphic_const _, Monomorphic_const _ -> + error (PolymorphicStatusExpected false) in (* Now check 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 poly u cst env' typ1 typ2 in + let typ1 = cb1.const_type in + let typ2 = cb2.const_type in + let cst = check_type poly cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible transparent constant. @@ -356,40 +268,19 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = Anyway [check_conv] will handle that afterwards. *) let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in - check_conv NotConvertibleBodyField cst poly u infer_conv env' c1 c2)) + check_conv NotConvertibleBodyField cst poly infer_conv env c1 c2)) | IndType ((kn,i),mind1) -> - ignore (CErrors.user_err Pp.(str @@ + CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by an inductive type. Hint: you can rename the " ^ "inductive type and give a definition to map the old name to the new " ^ - "name.")); - let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in - if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let u1 = inductive_polymorphic_instance mind1 in - let arity1,cst1 = constrained_type_of_inductive env - ((mind1,mind1.mind_packets.(i)),u1) in - let cst2 = - Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in - let cst = Constraint.union cst (Constraint.union cst1 cst2) in - let error = NotConvertibleTypeField (env, arity1, typ2) in - check_conv error cst false Univ.Instance.empty infer_conv_leq env arity1 typ2 - | IndConstr (((kn,i),j) as cstr,mind1) -> - ignore (CErrors.user_err Pp.(str @@ + "name.") + | IndConstr (((kn,i),j),mind1) -> + CErrors.user_err Pp.(str @@ "The kernel does not recognize yet that a parameter can be " ^ "instantiated by a constructor. Hint: you can rename the " ^ "constructor and give a definition to map the old name to the new " ^ - "name.")); - let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in - if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let u1 = inductive_polymorphic_instance mind1 in - let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in - let cst2 = - Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in - let ty2 = Typeops.type_of_constant_type env cb2.const_type in - let cst = Constraint.union cst (Constraint.union cst1 cst2) in - let error = NotConvertibleTypeField (env, ty1, ty2) in - check_conv error cst false Univ.Instance.empty infer_conv env ty1 ty2 + "name.") let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in @@ -401,7 +292,7 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= let check_one_body cst (l,spec2) = match spec2 with | SFBconst cb2 -> - check_constant cst env mp1 l (get_obj mp1 map1 l) + check_constant cst env l (get_obj mp1 map1 l) cb2 spec2 subst1 subst2 | SFBmind mib2 -> check_inductive cst env mp1 l (get_obj mp1 map1 l) @@ -461,7 +352,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mod_type = subst_signature subst1 body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; - mod_retroknowledge = []; + mod_retroknowledge = ModBodyRK []; mod_delta = mtb1.mod_delta} env in check_structure cst env body_t1 body_t2 equiv subst1 subst2 diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index 6590d7e712..4e755e42ff 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -1,15 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Univ open Declarations open Environ -val check_subtypes : env -> module_type_body -> module_type_body -> constraints - - +val check_subtypes : env -> module_type_body -> module_type_body -> Constraint.t diff --git a/kernel/term.ml b/kernel/term.ml index 0e0af2f59d..4851a9c0d0 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Util @@ -11,335 +13,16 @@ open Pp open CErrors open Names open Vars +open Constr -(**********************************************************************) -(** Redeclaration of types from module Constr *) -(**********************************************************************) - -type contents = Sorts.contents = Pos | Null - -type sorts = Sorts.t = - | Prop of contents (** Prop and Set *) - | Type of Univ.universe (** Type *) - +(* Deprecated *) type sorts_family = Sorts.family = InProp | InSet | InType +[@@ocaml.deprecated "Alias for Sorts.family"] -type constr = Constr.t -(** Alias types, for compatibility. *) - -type types = Constr.t -(** Same as [constr], for documentation purposes. *) - -type existential_key = Constr.existential_key -type existential = Constr.existential - -type metavariable = Constr.metavariable - -type case_style = Constr.case_style = - LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle - -type case_printing = Constr.case_printing = - { ind_tags : bool list; cstr_tags : bool list array; style : case_style } - -type case_info = Constr.case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; - ci_cstr_nargs : int array; - ci_pp_info : case_printing - } - -type cast_kind = Constr.cast_kind = - VMcast | NATIVEcast | DEFAULTcast | REVERTcast - -(********************************************************************) -(* Constructions as implemented *) -(********************************************************************) - -type rec_declaration = Constr.rec_declaration -type fixpoint = Constr.fixpoint -type cofixpoint = Constr.cofixpoint -type 'constr pexistential = 'constr Constr.pexistential -type ('constr, 'types) prec_declaration = - ('constr, 'types) Constr.prec_declaration -type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint -type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint -type 'a puniverses = 'a Univ.puniverses - -(** Simply type aliases *) -type pconstant = constant puniverses -type pinductive = inductive puniverses -type pconstructor = constructor puniverses - -type ('constr, 'types, 'sort, 'univs) kind_of_term = - ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = - | Rel of int - | Var of Id.t - | Meta of metavariable - | Evar of 'constr pexistential - | Sort of 'sort - | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array - | Const of (constant * 'univs) - | Ind of (inductive * 'univs) - | Construct of (constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr - -type values = Constr.values - -(**********************************************************************) -(** Redeclaration of functions from module Constr *) -(**********************************************************************) - -let set_sort = Sorts.set -let prop_sort = Sorts.prop -let type1_sort = Sorts.type1 -let sorts_ord = Sorts.compare -let is_prop_sort = Sorts.is_prop -let family_of_sort = Sorts.family -let univ_of_sort = Sorts.univ_of_sort -let sort_of_univ = Sorts.sort_of_univ - -(** {6 Term constructors. } *) - -let mkRel = Constr.mkRel -let mkVar = Constr.mkVar -let mkMeta = Constr.mkMeta -let mkEvar = Constr.mkEvar -let mkSort = Constr.mkSort -let mkProp = Constr.mkProp -let mkSet = Constr.mkSet -let mkType = Constr.mkType -let mkCast = Constr.mkCast -let mkProd = Constr.mkProd -let mkLambda = Constr.mkLambda -let mkLetIn = Constr.mkLetIn -let mkApp = Constr.mkApp -let mkConst = Constr.mkConst -let mkProj = Constr.mkProj -let mkInd = Constr.mkInd -let mkConstruct = Constr.mkConstruct -let mkConstU = Constr.mkConstU -let mkIndU = Constr.mkIndU -let mkConstructU = Constr.mkConstructU -let mkConstructUi = Constr.mkConstructUi -let mkCase = Constr.mkCase -let mkFix = Constr.mkFix -let mkCoFix = Constr.mkCoFix - -(**********************************************************************) -(** Aliases of functions from module Constr *) -(**********************************************************************) - -let eq_constr = Constr.equal -let eq_constr_univs = Constr.eq_constr_univs -let leq_constr_univs = Constr.leq_constr_univs -let eq_constr_nounivs = Constr.eq_constr_nounivs - -let kind_of_term = Constr.kind -let compare = Constr.compare -let constr_ord = compare -let fold_constr = Constr.fold -let map_puniverses = Constr.map_puniverses -let map_constr = Constr.map -let map_constr_with_binders = Constr.map_with_binders -let iter_constr = Constr.iter -let iter_constr_with_binders = Constr.iter_with_binders -let compare_constr = Constr.compare_head -let hash_constr = Constr.hash -let hcons_sorts = Sorts.hcons -let hcons_constr = Constr.hcons -let hcons_types = Constr.hcons - -(**********************************************************************) -(** HERE BEGINS THE INTERESTING STUFF *) -(**********************************************************************) - -(**********************************************************************) -(* Non primitive term destructors *) -(**********************************************************************) - -(* Destructor operations : partial functions - Raise [DestKO] if the const has not the expected form *) - -exception DestKO - -(* Destructs a de Bruijn index *) -let destRel c = match kind_of_term c with - | Rel n -> n - | _ -> raise DestKO - -(* Destructs an existential variable *) -let destMeta c = match kind_of_term c with - | Meta n -> n - | _ -> raise DestKO - -let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false - -(* Destructs a variable *) -let destVar c = match kind_of_term c with - | Var id -> id - | _ -> raise DestKO - -(* Destructs a type *) -let isSort c = match kind_of_term c with - | Sort _ -> true - | _ -> false - -let destSort c = match kind_of_term c with - | Sort s -> s - | _ -> raise DestKO - -let rec isprop c = match kind_of_term c with - | Sort (Prop _) -> true - | Cast (c,_,_) -> isprop c - | _ -> false - -let rec is_Prop c = match kind_of_term c with - | Sort (Prop Null) -> true - | Cast (c,_,_) -> is_Prop c - | _ -> false - -let rec is_Set c = match kind_of_term c with - | Sort (Prop Pos) -> true - | Cast (c,_,_) -> is_Set c - | _ -> false - -let rec is_Type c = match kind_of_term c with - | Sort (Type _) -> true - | Cast (c,_,_) -> is_Type c - | _ -> false - -let is_small = Sorts.is_small - -let iskind c = isprop c || is_Type c - -(* Tests if an evar *) -let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false - -let isEvar_or_Meta c = match kind_of_term c with - | Evar _ | Meta _ -> true - | _ -> false - -(* Destructs a casted term *) -let destCast c = match kind_of_term c with - | Cast (t1,k,t2) -> (t1,k,t2) - | _ -> raise DestKO - -let isCast c = match kind_of_term c with Cast _ -> true | _ -> false - - -(* Tests if a de Bruijn index *) -let isRel c = match kind_of_term c with Rel _ -> true | _ -> false -let isRelN n c = - match kind_of_term c with Rel n' -> Int.equal n n' | _ -> 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.equal id id' | _ -> false - -(* Tests if an inductive *) -let isInd c = match kind_of_term c with Ind _ -> true | _ -> false - -(* Destructs the product (x:t1)t2 *) -let destProd c = match kind_of_term c with - | Prod (x,t1,t2) -> (x,t1,t2) - | _ -> raise DestKO - -let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false - -(* Destructs the abstraction [x:t1]t2 *) -let destLambda c = match kind_of_term c with - | Lambda (x,t1,t2) -> (x,t1,t2) - | _ -> raise DestKO - -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) - | _ -> raise DestKO - -let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false - -(* Destructs an application *) -let destApp c = match kind_of_term c with - | App (f,a) -> (f, a) - | _ -> raise DestKO - -let destApplication = destApp - -let isApp c = match kind_of_term c with App _ -> true | _ -> false - -(* Destructs a constant *) -let destConst c = match kind_of_term c with - | Const kn -> kn - | _ -> raise DestKO - -let isConst c = match kind_of_term c with Const _ -> true | _ -> false - -(* Destructs an existential variable *) -let destEvar c = match kind_of_term c with - | Evar (kn, a as r) -> r - | _ -> raise DestKO - -(* Destructs a (co)inductive type named kn *) -let destInd c = match kind_of_term c with - | Ind (kn, a as r) -> r - | _ -> raise DestKO - -(* Destructs a constructor *) -let destConstruct c = match kind_of_term c with - | Construct (kn, a as r) -> r - | _ -> raise DestKO - -let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false - -(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) -let destCase c = match kind_of_term c with - | Case (ci,p,c,v) -> (ci,p,c,v) - | _ -> raise DestKO - -let isCase c = match kind_of_term c with Case _ -> true | _ -> false - -let isProj c = match kind_of_term c with Proj _ -> true | _ -> false - -let destProj c = match kind_of_term c with - | Proj (p, c) -> (p, c) - | _ -> raise DestKO - -let destFix c = match kind_of_term c with - | Fix fix -> fix - | _ -> raise DestKO - -let isFix c = match kind_of_term c with Fix _ -> true | _ -> false - -let destCoFix c = match kind_of_term c with - | CoFix cofix -> cofix - | _ -> raise DestKO - -let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false - -(******************************************************************) -(* Flattening and unflattening of embedded applications and casts *) -(******************************************************************) - -let decompose_app c = - match kind_of_term c with - | App (f,cl) -> (f, Array.to_list cl) - | _ -> (c,[]) - -let decompose_appvect c = - match kind_of_term c with - | App (f,cl) -> (f, cl) - | _ -> (c,[||]) +type sorts = Sorts.t = + | Prop | Set + | Type of Univ.Universe.t (** Type *) +[@@ocaml.deprecated "Alias for Sorts.t"] (****************************************************************************) (* Functions for dealing with constr terms *) @@ -433,7 +116,7 @@ let rec to_lambda n prod = if Int.equal n 0 then prod else - match kind_of_term prod with + match kind prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c | _ -> user_err ~hdr:"to_lambda" (mt ()) @@ -442,7 +125,7 @@ let rec to_prod n lam = if Int.equal n 0 then lam else - match kind_of_term lam with + match kind lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c | _ -> user_err ~hdr:"to_prod" (mt ()) @@ -454,7 +137,7 @@ let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) let lambda_applist c l = let rec app subst c l = - match kind_of_term c, l with + match kind c, l with | Lambda(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c | _ -> anomaly (Pp.str "Not enough lambda's.") in @@ -466,10 +149,11 @@ let lambda_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments.") - else match kind_of_term t, l with + else anomaly (Pp.str "Too many arguments.") + else match kind t, l with | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _, [] -> anomaly (Pp.str "Not enough arguments.") | _ -> anomaly (Pp.str "Not enough lambda/let's.") in app n [] c l @@ -478,7 +162,7 @@ let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist c l = let rec app subst c l = - match kind_of_term c, l with + match kind c, l with | Prod(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c | _ -> anomaly (Pp.str "Not enough prod's.") in @@ -491,10 +175,11 @@ let prod_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t - else anomaly (Pp.str "Not enough arguments.") - else match kind_of_term t, l with + else anomaly (Pp.str "Too many arguments.") + else match kind t, l with | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _, [] -> anomaly (Pp.str "Not enough arguments.") | _ -> anomaly (Pp.str "Not enough prod/let's.") in app n [] c l @@ -507,7 +192,7 @@ let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v) (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod = - let rec prodec_rec l c = match kind_of_term c with + let rec prodec_rec l c = match kind c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c @@ -517,7 +202,7 @@ let decompose_prod = (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = - let rec lamdec_rec l c = match kind_of_term c with + let rec lamdec_rec l c = match kind c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c @@ -530,7 +215,7 @@ let decompose_prod_n n = if n < 0 then user_err (str "decompose_prod_n: integer parameter must be positive"); let rec prodec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with + else match kind c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | _ -> user_err (str "decompose_prod_n: not enough products") @@ -543,7 +228,7 @@ let decompose_lam_n n = if n < 0 then user_err (str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with + else match kind c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | _ -> user_err (str "decompose_lam_n: not enough abstractions") @@ -555,7 +240,7 @@ let decompose_lam_n n = let decompose_prod_assum = let open Context.Rel.Declaration in let rec prodec_rec l c = - match kind_of_term c with + match kind c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec l c @@ -568,7 +253,7 @@ let decompose_prod_assum = let decompose_lam_assum = let rec lamdec_rec l c = let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> lamdec_rec l c @@ -587,7 +272,7 @@ let decompose_prod_n_assum n = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c @@ -608,7 +293,7 @@ let decompose_lam_n_assum n = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c | Cast (c,_,_) -> lamdec_rec l n c @@ -624,7 +309,7 @@ let decompose_lam_n_decls n = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c @@ -651,12 +336,12 @@ let strip_lam_n n t = snd (decompose_lam_n n t) Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = Context.Rel.t * sorts +type arity = Constr.rel_context * Sorts.t let destArity = let open Context.Rel.Declaration in let rec prodec_rec l c = - match kind_of_term c with + match kind c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c @@ -668,7 +353,7 @@ let destArity = let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign let rec isArity c = - match kind_of_term c with + match kind c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) | Cast (c,_,_) -> isArity c @@ -679,13 +364,13 @@ let rec isArity c = (* Experimental, used in Presburger contrib *) type ('constr, 'types) kind_of_type = - | SortType of sorts + | SortType of Sorts.t | CastType of 'types * 'types | ProdType of Name.t * 'types * 'types | LetInType of Name.t * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array -let kind_of_type t = match kind_of_term t with +let kind_of_type t = match kind t with | Sort s -> SortType s | Cast (c,_,t) -> CastType (c, t) | Prod (na,t,c) -> ProdType (na, t, c) diff --git a/kernel/term.mli b/kernel/term.mli index d5aaf6ad06..181d714ed7 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -1,202 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names - -(** {5 Redeclaration of types from module Constr and Sorts} - - This reexports constructors of inductive types defined in module [Constr], - for compatibility purposes. Refer to this module for further info. - -*) - -type contents = Sorts.contents = Pos | Null - -type sorts = Sorts.t = - | Prop of contents (** Prop and Set *) - | Type of Univ.universe (** Type *) - -type sorts_family = Sorts.family = InProp | InSet | InType - -type 'a puniverses = 'a Univ.puniverses - -(** Simply type aliases *) -type pconstant = constant puniverses -type pinductive = inductive puniverses -type pconstructor = constructor puniverses - -type constr = Constr.constr -(** Alias types, for compatibility. *) - -type types = Constr.types -(** Same as [constr], for documentation purposes. *) - -type existential_key = Constr.existential_key - -type existential = Constr.existential - -type metavariable = Constr.metavariable - -type case_style = Constr.case_style = - LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle - -type case_printing = Constr.case_printing = - { ind_tags : bool list; cstr_tags : bool list array; style : case_style } - -type case_info = Constr.case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; - ci_cstr_nargs : int array; - ci_pp_info : case_printing - } - -type cast_kind = Constr.cast_kind = - VMcast | NATIVEcast | DEFAULTcast | REVERTcast - -type rec_declaration = Constr.rec_declaration -type fixpoint = Constr.fixpoint -type cofixpoint = Constr.cofixpoint -type 'constr pexistential = 'constr Constr.pexistential -type ('constr, 'types) prec_declaration = - ('constr, 'types) Constr.prec_declaration -type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint -type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint - -type ('constr, 'types, 'sort, 'univs) kind_of_term = - ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = - | Rel of int - | Var of Id.t - | Meta of metavariable - | Evar of 'constr pexistential - | Sort of 'sort - | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array - | Const of (constant * 'univs) - | Ind of (inductive * 'univs) - | Construct of (constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr - -type values = Constr.values - -(** {5 Simple term case analysis. } *) - -val isRel : constr -> bool -val isRelN : int -> constr -> bool -val isVar : constr -> bool -val isVarId : Id.t -> constr -> bool -val isInd : constr -> bool -val isEvar : constr -> bool -val isMeta : constr -> bool -val isEvar_or_Meta : constr -> bool -val isSort : constr -> bool -val isCast : constr -> bool -val isApp : constr -> bool -val isLambda : constr -> bool -val isLetIn : constr -> bool -val isProd : constr -> bool -val isConst : constr -> bool -val isConstruct : constr -> bool -val isFix : constr -> bool -val isCoFix : constr -> bool -val isCase : constr -> bool -val isProj : constr -> bool - -val is_Prop : constr -> bool -val is_Set : constr -> bool -val isprop : constr -> bool -val is_Type : constr -> bool -val iskind : constr -> bool -val is_small : sorts -> bool - - -(** {5 Term destructors } *) -(** Destructor operations are partial functions and - @raise DestKO if the term has not the expected form. *) - -exception DestKO - -(** Destructs a de Bruijn index *) -val destRel : constr -> int - -(** Destructs an existential variable *) -val destMeta : constr -> metavariable - -(** Destructs a variable *) -val destVar : constr -> Id.t - -(** 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 *) -val destCast : constr -> constr * cast_kind * constr - -(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) -val destProd : types -> Name.t * types * types - -(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) -val destLambda : constr -> Name.t * types * constr - -(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) -val destLetIn : constr -> Name.t * constr * types * constr - -(** Destructs an application *) -val destApp : constr -> constr * constr array - -(** Obsolete synonym of destApp *) -val destApplication : constr -> constr * constr array - -(** Decompose any term as an applicative term; the list of args can be empty *) -val decompose_app : constr -> constr * constr list - -(** Same as [decompose_app], but returns an array. *) -val decompose_appvect : constr -> constr * constr array - -(** Destructs a constant *) -val destConst : constr -> constant puniverses - -(** Destructs an existential variable *) -val destEvar : constr -> existential - -(** Destructs a (co)inductive type *) -val destInd : constr -> inductive puniverses - -(** Destructs a constructor *) -val destConstruct : constr -> constructor puniverses - -(** 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 a projection *) -val destProj : constr -> projection * constr - -(** 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 - +open Constr (** {5 Derived constructors} *) @@ -212,14 +25,14 @@ val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr val mkNamedProd : Id.t -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) -val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types -val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types -val mkNamedProd_or_LetIn : Context.Named.Declaration.t -> types -> types -val mkNamedProd_wo_LetIn : Context.Named.Declaration.t -> types -> types +val mkProd_or_LetIn : Constr.rel_declaration -> types -> types +val mkProd_wo_LetIn : Constr.rel_declaration -> types -> types +val mkNamedProd_or_LetIn : Constr.named_declaration -> types -> types +val mkNamedProd_wo_LetIn : Constr.named_declaration -> types -> types (** Constructs either [[x:t]c] or [[x=b:t]c] *) -val mkLambda_or_LetIn : Context.Rel.Declaration.t -> constr -> constr -val mkNamedLambda_or_LetIn : Context.Named.Declaration.t -> constr -> constr +val mkLambda_or_LetIn : Constr.rel_declaration -> constr -> constr +val mkNamedLambda_or_LetIn : Constr.named_declaration -> constr -> constr (** {5 Other term constructors. } *) @@ -261,8 +74,8 @@ val to_lambda : int -> constr -> constr where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr -val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr -val it_mkProd_or_LetIn : types -> Context.Rel.t -> types +val it_mkLambda_or_LetIn : constr -> Constr.rel_context -> constr +val it_mkProd_or_LetIn : types -> Constr.rel_context -> types (** In [lambda_applist c args], [c] is supposed to have the form [λΓ.c] with [Γ] without let-in; it returns [c] with the variables @@ -271,7 +84,7 @@ val lambda_applist : constr -> constr list -> constr val lambda_appvect : constr -> constr array -> constr (** In [lambda_applist_assum n c args], [c] is supposed to have the - form [λΓ.c] with [Γ] of length [m] and possibly with let-ins; it + form [λΓ.c] with [Γ] of length [n] and possibly with let-ins; it returns [c] with the assumptions of [Γ] instantiated by [args] and the local definitions of [Γ] expanded. *) val lambda_applist_assum : int -> constr -> constr list -> constr @@ -280,15 +93,15 @@ val lambda_appvect_assum : int -> constr -> constr array -> constr (** pseudo-reduction rule *) (** [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 prod_appvect : types -> constr array -> types +val prod_applist : types -> constr list -> types (** In [prod_appvect_assum n c args], [c] is supposed to have the - form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it + form [∀Γ.c] with [Γ] of length [n] and possibly with let-ins; it returns [c] with the assumptions of [Γ] instantiated by [args] and the local definitions of [Γ] expanded. *) -val prod_appvect_assum : int -> constr -> constr array -> constr -val prod_applist_assum : int -> constr -> constr list -> constr +val prod_appvect_assum : int -> types -> constr array -> types +val prod_applist_assum : int -> types -> constr list -> types (** {5 Other term destructors. } *) @@ -313,29 +126,29 @@ val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr (** 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 -> Context.Rel.t * types +val decompose_prod_assum : types -> Constr.rel_context * types (** Idem with lambda's and let's *) -val decompose_lam_assum : constr -> Context.Rel.t * constr +val decompose_lam_assum : constr -> Constr.rel_context * constr (** Idem but extract the first [n] premisses, counting let-ins. *) -val decompose_prod_n_assum : int -> types -> Context.Rel.t * types +val decompose_prod_n_assum : int -> types -> Constr.rel_context * types (** Idem for lambdas, _not_ counting let-ins *) -val decompose_lam_n_assum : int -> constr -> Context.Rel.t * constr +val decompose_lam_n_assum : int -> constr -> Constr.rel_context * constr (** Idem, counting let-ins *) -val decompose_lam_n_decls : int -> constr -> Context.Rel.t * constr +val decompose_lam_n_decls : int -> constr -> Constr.rel_context * constr (** Return the premisses/parameters of a type/term (let-in included) *) -val prod_assum : types -> Context.Rel.t -val lam_assum : constr -> Context.Rel.t +val prod_assum : types -> Constr.rel_context +val lam_assum : constr -> Constr.rel_context (** Return the first n-th premisses/parameters of a type (let included and counted) *) -val prod_n_assum : int -> types -> Context.Rel.t +val prod_n_assum : int -> types -> Constr.rel_context (** Return the first n-th premisses/parameters of a term (let included but not counted) *) -val lam_n_assum : int -> constr -> Context.Rel.t +val lam_n_assum : int -> constr -> Constr.rel_context (** Remove the premisses/parameters of a type/term *) val strip_prod : types -> types @@ -354,7 +167,7 @@ val strip_lam_assum : constr -> constr Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = Context.Rel.t * sorts +type arity = Constr.rel_context * Sorts.t (** Build an "arity" from its canonical form *) val mkArity : arity -> types @@ -368,7 +181,7 @@ val isArity : types -> bool (** {5 Kind of type} *) type ('constr, 'types) kind_of_type = - | SortType of sorts + | SortType of Sorts.t | CastType of 'types * 'types | ProdType of Name.t * 'types * 'types | LetInType of Name.t * 'constr * 'types * 'types @@ -376,117 +189,11 @@ type ('constr, 'types) kind_of_type = val kind_of_type : types -> (constr, types) kind_of_type -(** {5 Redeclaration of stuff from module [Sorts]} *) - -val set_sort : sorts -(** Alias for Sorts.set *) - -val prop_sort : sorts -(** Alias for Sorts.prop *) - -val type1_sort : sorts -(** Alias for Sorts.type1 *) - -val sorts_ord : sorts -> sorts -> int -(** Alias for Sorts.compare *) - -val is_prop_sort : sorts -> bool -(** Alias for Sorts.is_prop *) - -val family_of_sort : sorts -> sorts_family -(** Alias for Sorts.family *) - -(** {5 Redeclaration of stuff from module [Constr]} - - See module [Constr] for further info. *) - -(** {6 Term constructors. } *) - -val mkRel : int -> constr -val mkVar : Id.t -> constr -val mkMeta : metavariable -> constr -val mkEvar : existential -> constr -val mkSort : sorts -> types -val mkProp : types -val mkSet : types -val mkType : Univ.universe -> types -val mkCast : constr * cast_kind * constr -> constr -val mkProd : Name.t * types * types -> types -val mkLambda : Name.t * types * constr -> constr -val mkLetIn : Name.t * constr * types * constr -> constr -val mkApp : constr * constr array -> constr -val mkConst : constant -> constr -val mkProj : projection * constr -> constr -val mkInd : inductive -> constr -val mkConstruct : constructor -> constr -val mkConstU : constant puniverses -> constr -val mkIndU : inductive puniverses -> constr -val mkConstructU : constructor puniverses -> constr -val mkConstructUi : (pinductive * int) -> constr -val mkCase : case_info * constr * constr * constr array -> constr -val mkFix : fixpoint -> constr -val mkCoFix : cofixpoint -> constr - -(** {6 Aliases} *) - -val eq_constr : constr -> constr -> bool -(** Alias for [Constr.equal] *) - -(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, - application grouping and the universe constraints in [u]. *) -val eq_constr_univs : constr UGraph.check_function - -(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo - alpha, casts, application grouping and the universe constraints in [u]. *) -val leq_constr_univs : constr UGraph.check_function - -(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, - application grouping and ignoring universe instances. *) -val eq_constr_nounivs : constr -> constr -> bool - -val kind_of_term : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -(** Alias for [Constr.kind] *) - -val compare : constr -> constr -> int -(** Alias for [Constr.compare] *) - -val constr_ord : constr -> constr -> int -(** Alias for [Term.compare] *) - -val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a -(** Alias for [Constr.fold] *) - -val map_constr : (constr -> constr) -> constr -> constr -(** Alias for [Constr.map] *) - -val map_constr_with_binders : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr -(** Alias for [Constr.map_with_binders] *) - -val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses -val univ_of_sort : sorts -> Univ.universe -val sort_of_univ : Univ.universe -> sorts - -val iter_constr : (constr -> unit) -> constr -> unit -(** Alias for [Constr.iter] *) - -val iter_constr_with_binders : - ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit -(** Alias for [Constr.iter_with_binders] *) - -val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool -(** Alias for [Constr.compare_head] *) - -val hash_constr : constr -> int -(** Alias for [Constr.hash] *) - -(*********************************************************************) - -val hcons_sorts : sorts -> sorts -(** Alias for [Constr.hashcons_sorts] *) - -val hcons_constr : constr -> constr -(** Alias for [Constr.hashcons] *) +(* Deprecated *) +type sorts_family = Sorts.family = InProp | InSet | InType +[@@ocaml.deprecated "Alias for Sorts.family"] -val hcons_types : types -> types -(** Alias for [Constr.hashcons] *) +type sorts = Sorts.t = + | Prop | Set + | Type of Univ.Universe.t (** Type *) +[@@ocaml.deprecated "Alias for Sorts.t"] diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 283febed24..1f7ee145a2 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of @@ -15,13 +17,12 @@ open CErrors open Util open Names -open Term +open Constr open Declarations open Environ open Entries open Typeops -module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (* Insertion of constants and parameters in environment. *) @@ -77,6 +78,10 @@ end type side_effects = SideEffects.t +type _ trust = +| Pure : unit trust +| SideEffects : structure_body -> side_effects trust + let uniq_seff_rev = SideEffects.repr let uniq_seff l = List.rev (SideEffects.repr l) @@ -122,17 +127,15 @@ let inline_side_effects env body ctx side_eff = | _ -> assert false in match cb.const_universes with - | Monomorphic_const cnstctx -> + | Monomorphic_const univs -> (** Abstract over the term at the top of the proof *) - let ty = Typeops.type_of_constant_type env cb.const_type in + let ty = cb.const_type in let subst = Cmap_env.add c (Inr var) subst in - let univs = Univ.ContextSet.of_context cnstctx in let ctx = Univ.ContextSet.union ctx univs in (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) | Polymorphic_const auctx -> (** Inline the term to emulate universe polymorphism *) - let data = (Univ.AUContext.instance auctx, b) in - let subst = Cmap_env.add c (Inl data) subst in + let subst = Cmap_env.add c (Inl b) subst in (subst, var, ctx, args) in let (subst, len, ctx, args) = List.fold_left fold (Cmap_env.empty, 1, ctx, []) side_eff in @@ -142,7 +145,7 @@ let inline_side_effects env body ctx side_eff = let data = try Some (Cmap_env.find c subst) with Not_found -> None in begin match data with | None -> t - | Some (Inl (inst, b)) -> + | Some (Inl b) -> (** [b] is closed but may refer to other constants *) subst_const i k (Vars.subst_instance_constr u b) | Some (Inr n) -> @@ -152,7 +155,7 @@ let inline_side_effects env body ctx side_eff = (** Lift free rel variables *) if n <= k then t else mkRel (n + len - i - 1) - | _ -> map_constr_with_binders ((+) 1) (fun k t -> subst_const i k t) k t + | _ -> Constr.map_with_binders ((+) 1) (fun k t -> subst_const i k t) k t in let map_args i (na, b, ty, opaque) = (** Both the type and the body may mention other constants *) @@ -176,36 +179,36 @@ let rec is_nth_suffix n l suf = | _ :: l -> is_nth_suffix (pred n) l suf (* Given the list of signatures of side effects, checks if they match. - * I.e. if they are ordered descendants of the current revstruct *) + * I.e. if they are ordered descendants of the current revstruct. + Returns the number of effects that can be trusted. *) let check_signatures curmb sl = - let is_direct_ancestor (sl, curmb) (mb, how_many) = - match curmb with - | None -> None, None - | Some curmb -> + let is_direct_ancestor accu (mb, how_many) = + match accu with + | None -> None + | Some (n, curmb) -> try let mb = CEphemeron.get mb in - match sl with - | None -> sl, None - | Some n -> - if is_nth_suffix how_many mb curmb - then Some (n + how_many), Some mb - else None, None - with CEphemeron.InvalidKey -> None, None in - let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in - sl + if is_nth_suffix how_many mb curmb + then Some (n + how_many, mb) + else None + with CEphemeron.InvalidKey -> None in + let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in + match sl with + | None -> 0 + | Some (n, _) -> n let skip_trusted_seff sl b e = let rec aux sl b e acc = let open Context.Rel.Declaration in - match sl, kind_of_term b with - | (None|Some 0), _ -> b, e, acc - | Some sl, LetIn (n,c,ty,bo) -> - aux (Some (sl-1)) bo + if Int.equal sl 0 then b, e, acc + else match kind b with + | LetIn (n,c,ty,bo) -> + aux (sl - 1) bo (Environ.push_rel (LocalDef (n,c,ty)) e) (`Let(n,c,ty)::acc) - | Some sl, App(hd,arg) -> - begin match kind_of_term hd with + | App(hd,arg) -> + begin match kind hd with | Lambda (n,ty,bo) -> - aux (Some (sl-1)) bo + aux (sl - 1) bo (Environ.push_rel (LocalAssum (n,ty)) e) (`Cut(n,ty,arg)::acc) | _ -> assert false end @@ -222,29 +225,35 @@ let rec unzip ctx j = unzip ctx { j with uj_val = mkApp (mkLambda (n,ty,j.uj_val),arg) } let feedback_completion_typecheck = - let open Feedback in Option.iter (fun state_id -> - feedback ~id:state_id Feedback.Complete) + Feedback.feedback ~id:state_id Feedback.Complete) -let abstract_constant_universes abstract uctx = - if not abstract then +let abstract_constant_universes = function + | Monomorphic_const_entry uctx -> Univ.empty_level_subst, Monomorphic_const uctx - else + | Polymorphic_const_entry uctx -> let sbst, auctx = Univ.abstract_universes uctx in + let sbst = Univ.make_instance_subst sbst in sbst, Polymorphic_const auctx -let infer_declaration ~trust env kn dcl = +let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = match dcl with - | ParameterEntry (ctx,poly,(t,uctx),nl) -> - let env = push_context ~strict:(not poly) uctx env in - let j = infer env t in - let abstract = poly && not (Option.is_empty kn) in - let usubst, univs = - abstract_constant_universes abstract uctx + | ParameterEntry (ctx,(t,uctx),nl) -> + let env = match uctx with + | Monomorphic_const_entry uctx -> push_context_set ~strict:true uctx env + | Polymorphic_const_entry uctx -> push_context ~strict:false uctx env in + let j = infer env t in + let usubst, univs = abstract_constant_universes uctx in let c = Typeops.assumption_of_judgment env j in - let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in - Undef nl, RegularArity t, None, univs, false, ctx + let t = Constr.hcons (Vars.subst_univs_level_constr usubst c) in + { + Cooking.cook_body = Undef nl; + cook_type = t; + cook_universes = univs; + cook_inline = false; + cook_context = ctx; + } (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, so we delay the typing and hash consing of its body. @@ -252,95 +261,92 @@ let infer_declaration ~trust env kn dcl = delay even in the polymorphic case. *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; - const_entry_polymorphic = false} as c) -> - let env = push_context ~strict:true c.const_entry_universes env in + const_entry_universes = Monomorphic_const_entry univs } as c) -> + let env = push_context_set ~strict:true univs env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = - Future.chain ~pure:true body (fun ((body,uctx),side_eff) -> - let body, uctx, signatures = - inline_side_effects env body uctx side_eff in - let valid_signatures = check_signatures trust signatures in - let env = push_context_set uctx env in - let j = + Future.chain body (fun ((body,uctx),side_eff) -> + let j, uctx = match trust with + | Pure -> + let env = push_context_set uctx env in + let j = infer env body in + let _ = judge_of_cast env j DEFAULTcast tyj in + j, uctx + | SideEffects mb -> + let (body, uctx, signatures) = inline_side_effects env body uctx side_eff in + let valid_signatures = check_signatures mb signatures in + let env = push_context_set uctx env in let body,env,ectx = skip_trusted_seff valid_signatures body env in let j = infer env body in - unzip ectx j in - let subst = Univ.LMap.empty in - let _ = judge_of_cast env j DEFAULTcast tyj in - assert (eq_constr typ tyj.utj_val); - let c = hcons_constr j.uj_val in - let _typ = RegularArity (Vars.subst_univs_level_constr subst typ) in + let j = unzip ectx j in + let _ = judge_of_cast env j DEFAULTcast tyj in + j, uctx + in + let c = Constr.hcons j.uj_val in feedback_completion_typecheck feedback_id; c, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in - def, RegularArity typ, None, - (Monomorphic_const c.const_entry_universes), - c.const_entry_inline_code, c.const_entry_secctx + { + Cooking.cook_body = def; + cook_type = typ; + cook_universes = Monomorphic_const univs; + cook_inline = c.const_entry_inline_code; + cook_context = c.const_entry_secctx; + } (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in - let univsctx = Univ.ContextSet.of_context c.const_entry_universes in - let body, ctx, _ = inline_side_effects env body - (Univ.ContextSet.union univsctx ctx) side_eff in - let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in - let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in - let usubst, univs = - abstract_constant_universes abstract (Univ.ContextSet.to_context ctx) - in + let body, ctx, _ = match trust with + | Pure -> body, ctx, [] + | SideEffects _ -> inline_side_effects env body ctx side_eff + in + let env, usubst, univs = match c.const_entry_universes with + | Monomorphic_const_entry univs -> + let ctx = Univ.ContextSet.union univs ctx in + let env = push_context_set ~strict:true ctx env in + env, Univ.empty_level_subst, Monomorphic_const ctx + | Polymorphic_const_entry uctx -> + (** Ensure not to generate internal constraints in polymorphic mode. + The only way for this to happen would be that either the body + contained deferred universes, or that it contains monomorphic + side-effects. The first property is ruled out by upper layers, + and the second one is ensured by the fact we currently + unconditionally export side-effects from polymorphic definitions, + i.e. [trust] is always [Pure]. *) + let () = assert (Univ.ContextSet.is_empty ctx) in + let env = push_context ~strict:false uctx env in + let sbst, auctx = Univ.abstract_universes uctx in + let sbst = Univ.make_instance_subst sbst in + env, sbst, Polymorphic_const auctx + in let j = infer env body in let typ = match typ with | None -> - if not c.const_entry_polymorphic then (* Old-style polymorphism *) - make_polymorphic_if_constant_for_ind env j - else RegularArity (Vars.subst_univs_level_constr usubst j.uj_type) + Vars.subst_univs_level_constr usubst j.uj_type | Some t -> let tj = infer_type env t in let _ = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - RegularArity (Vars.subst_univs_level_constr usubst t) + Vars.subst_univs_level_constr usubst t in - let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in + let def = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in let def = if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty))) else Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; - def, typ, None, univs, c.const_entry_inline_code, c.const_entry_secctx - - | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} -> - let mib, _ = Inductive.lookup_mind_specif env (ind,0) in - let kn, pb = - match mib.mind_record with - | Some (Some (id, kns, pbs)) -> - if i < Array.length pbs then - kns.(i), pbs.(i) - else assert false - | _ -> assert false - in - let univs = - match mib.mind_universes with - | Monomorphic_ind ctx -> Monomorphic_const ctx - | Polymorphic_ind auctx -> Polymorphic_const auctx - | Cumulative_ind acumi -> - Polymorphic_const (Univ.ACumulativityInfo.univ_context acumi) - in - let term, typ = pb.proj_eta in - Def (Mod_subst.from_val (hcons_constr term)), RegularArity typ, Some pb, - univs, false, None - -let global_vars_set_constant_type env = function - | RegularArity t -> global_vars_set env t - | TemplateArity (ctx,_) -> - Context.Rel.fold_outside - (RelDecl.fold_constr - (fun t c -> Id.Set.union (global_vars_set env t) c)) - ctx ~init:Id.Set.empty - -let record_aux env s_ty s_bo suggested_expr = + { + Cooking.cook_body = def; + cook_type = typ; + cook_universes = univs; + cook_inline = c.const_entry_inline_code; + cook_context = c.const_entry_secctx; + } + +let record_aux env s_ty s_bo = let in_ty = keep_hyps env s_ty in let v = String.concat " " @@ -349,20 +355,19 @@ let record_aux env s_ty s_bo suggested_expr = if List.exists (NamedDecl.get_id %> Id.equal id) in_ty then None else Some (Id.to_string id)) (keep_hyps env s_bo)) in - Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) + Aux_file.record_in_aux "context_used" v -let suggest_proof_using = ref (fun _ _ _ _ _ -> "") -let set_suggest_proof_using f = suggest_proof_using := f - -let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = +let build_constant_declaration kn env result = + let open Cooking in + let typ = result.cook_type in let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then - let l = Id.Set.elements (Idset.diff inferred_set declared_set) in + let l = Id.Set.elements (Id.Set.diff inferred_set declared_set) in let n = List.length l in - let declared_vars = Pp.pr_sequence Id.print (Idset.elements declared_set) in - let inferred_vars = Pp.pr_sequence Id.print (Idset.elements inferred_set) in + let declared_vars = Pp.pr_sequence Id.print (Id.Set.elements declared_set) in + let inferred_vars = Pp.pr_sequence Id.print (Id.Set.elements inferred_set) in let missing_vars = Pp.pr_sequence Id.print (List.rev l) in user_err Pp.(prlist str ["The following section "; (String.plural n "variable"); " "; @@ -373,7 +378,7 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = str "Proof using " ++ declared_vars ++ fnl () ++ str "to" ++ fnl () ++ str "Proof using " ++ inferred_vars) in - let sort evn l = + let sort l = List.filter (fun decl -> let id = NamedDecl.get_id decl in List.exists (NamedDecl.get_id %> Names.Id.equal id) l) @@ -381,13 +386,14 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map NamedDecl.get_id (named_context env) in - match ctx with + let def = result.cook_body in + match result.cook_context with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = match def with - | Undef _ -> Idset.empty + | Undef _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = @@ -395,82 +401,57 @@ let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = (Opaqueproof.force_proof (opaque_tables env) lc) in (* we force so that cst are added to the env immediately after *) ignore(Opaqueproof.force_constraints (opaque_tables env) lc); - let expr = - !suggest_proof_using (Constant.to_string kn) - env vars ids_typ context_ids in - if !Flags.compilation_mode = Flags.BuildVo then - record_aux env ids_typ vars expr; + if !Flags.record_aux_file then record_aux env ids_typ vars; vars in - keep_hyps env (Idset.union ids_typ ids_def), def + keep_hyps env (Id.Set.union ids_typ ids_def), def | None -> - if !Flags.compilation_mode = Flags.BuildVo then - record_aux env Id.Set.empty Id.Set.empty ""; + if !Flags.record_aux_file then + record_aux env Id.Set.empty Id.Set.empty; [], def (* Empty section context: no need to check *) | Some declared -> (* We use the declared set and chain a check of correctness *) - sort env declared, + sort declared, match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in - let inferred = keep_hyps env (Idset.union ids_typ ids_def) in + let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in - let inferred = keep_hyps env (Idset.union ids_typ ids_def) in + let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in check declared inferred) lc) in + let univs = result.cook_universes in let tps = - let res = - match proj with - | None -> compile_constant_body env univs def - | Some pb -> - (* The compilation of primitive projections is a bit tricky, because - they refer to themselves (the body of p looks like fun c => - Proj(p,c)). We break the cycle by building an ad-hoc compilation - environment. A cleaner solution would be that kernel projections are - simply Proj(i,c) with i an int and c a constr, but we would have to - get rid of the compatibility layer. *) - let cb = - { const_hyps = hyps; - const_body = def; - const_type = typ; - const_proj = proj; - const_body_code = None; - const_universes = univs; - const_inline_code = inline_code; - const_typing_flags = Environ.typing_flags env; - } - in - let env = add_constant kn cb env in - compile_constant_body env univs def - in Option.map Cemitcodes.from_val res + let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in + Option.map Cemitcodes.from_val res in { const_hyps = hyps; const_body = def; const_type = typ; - const_proj = proj; const_body_code = tps; const_universes = univs; - const_inline_code = inline_code; + const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } (*s Global and local constant declaration. *) let translate_constant mb env kn ce = build_constant_declaration kn env - (infer_declaration ~trust:mb env (Some kn) ce) + (infer_declaration ~trust:mb env ce) let constant_entry_of_side_effect cb u = - let poly, univs = + let univs = match cb.const_universes with - | Monomorphic_const ctx -> false, ctx + | Monomorphic_const uctx -> + Monomorphic_const_entry uctx | Polymorphic_const auctx -> - true, Univ.instantiate_univ_context auctx + Polymorphic_const_entry (Univ.AUContext.repr auctx) in let pt = match cb.const_body, u with @@ -478,12 +459,10 @@ let constant_entry_of_side_effect cb u = | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty | _ -> assert false in DefinitionEntry { - const_entry_body = Future.from_val (pt, empty_seff); + const_entry_body = Future.from_val (pt, ()); const_entry_secctx = None; const_entry_feedback = None; - const_entry_type = - (match cb.const_type with RegularArity t -> Some t | _ -> None); - const_entry_polymorphic = poly; + const_entry_type = Some cb.const_type; const_entry_universes = univs; const_entry_opaque = Declareops.is_opaque cb; const_entry_inline_code = cb.const_inline_code } @@ -502,17 +481,14 @@ type side_effect_role = | Schema of inductive * string type exported_side_effect = - constant * constant_body * side_effects constant_entry * side_effect_role + Constant.t * constant_body * side_effect_role -let export_side_effects mb env ce = - match ce with - | ParameterEntry _ | ProjectionEntry _ -> [], ce - | DefinitionEntry c -> +let export_side_effects mb env c = let { const_entry_body = body } = c in let _, eff = Future.force body in - let ce = DefinitionEntry { c with - const_entry_body = Future.chain ~pure:true body - (fun (b_ctx, _) -> b_ctx, empty_seff) } in + let ce = { c with + const_entry_body = Future.chain body + (fun (b_ctx, _) -> b_ctx, ()) } in let not_exists (c,_,_,_) = try ignore(Environ.lookup_constant c env); false with Not_found -> true in @@ -532,7 +508,7 @@ let export_side_effects mb env ce = let env = Environ.add_constant kn cb env in match cb.const_universes with | Monomorphic_const ctx -> - Environ.push_context ~strict:true ctx env + Environ.push_context_set ~strict:true ctx env | Polymorphic_const _ -> env end | kn, cb, `Opaque(_, ctx), _ -> @@ -540,29 +516,30 @@ let export_side_effects mb env ce = let env = Environ.add_constant kn cb env in match cb.const_universes with | Monomorphic_const cstctx -> - let env = Environ.push_context ~strict:true cstctx env in + let env = Environ.push_context_set ~strict:true cstctx env in Environ.push_context_set ~strict:true ctx env | Polymorphic_const _ -> env end in let rec translate_seff sl seff acc env = - match sl, seff with - | _, [] -> List.rev acc, ce - | (None | Some 0), cbs :: rest -> + match seff with + | [] -> List.rev acc, ce + | cbs :: rest -> + if Int.equal sl 0 then let env, cbs = List.fold_left (fun (env,cbs) (kn, ocb, u, r) -> let ce = constant_entry_of_side_effect ocb u in - let cb = translate_constant mb env kn ce in - (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,ce,r) :: cbs)) + let cb = translate_constant Pure env kn ce in + (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,r) :: cbs)) (env,[]) cbs in - translate_seff sl rest (cbs @ acc) env - | Some sl, cbs :: rest -> + translate_seff 0 rest (cbs @ acc) env + else let cbs_len = List.length cbs in let cbs = List.map turn_direct cbs in let env = List.fold_left push_seff env cbs in let ecbs = List.map (fun (kn,cb,u,r) -> - kn, cb, constant_entry_of_side_effect cb u, r) cbs in - translate_seff (Some (sl-cbs_len)) rest (ecbs @ acc) env + kn, cb, r) cbs in + translate_seff (sl - cbs_len) rest (ecbs @ acc) env in translate_seff trusted seff [] env ;; @@ -577,37 +554,58 @@ let translate_recipe env kn r = be useless. It is detected by the dirpath of the constant being empty. *) let (_, dir, _) = Constant.repr3 kn in let hcons = DirPath.is_empty dir in - build_constant_declaration kn env (Cooking.cook_constant ~hcons env r) - -let translate_local_def mb env id centry = - let def,typ,proj,univs,inline_code,ctx = - infer_declaration ~trust:mb env None (DefinitionEntry centry) in - let typ = type_of_constant_type env typ in - if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin - match def with + build_constant_declaration kn env (Cooking.cook_constant ~hcons r) + +let translate_local_def env id centry = + let open Cooking in + let body = Future.from_val ((centry.secdef_body, Univ.ContextSet.empty), ()) in + let centry = { + const_entry_body = body; + const_entry_secctx = centry.secdef_secctx; + const_entry_feedback = centry.secdef_feedback; + const_entry_type = centry.secdef_type; + const_entry_universes = Monomorphic_const_entry Univ.ContextSet.empty; + const_entry_opaque = false; + const_entry_inline_code = false; + } in + let decl = infer_declaration ~trust:Pure env (DefinitionEntry centry) in + let typ = decl.cook_type in + if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin + match decl.cook_body with | Undef _ -> () | Def _ -> () | OpaqueDef lc -> - let context_ids = List.map NamedDecl.get_id (named_context env) in let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Opaqueproof.force_proof (opaque_tables env) lc) in - let expr = - !suggest_proof_using (Id.to_string id) - env ids_def ids_typ context_ids in - record_aux env ids_typ ids_def expr + record_aux env ids_typ ids_def end; - def, typ, univs + let () = match decl.cook_universes with + | Monomorphic_const ctx -> assert (Univ.ContextSet.is_empty ctx) + | Polymorphic_const _ -> assert false + in + let c = match decl.cook_body with + | Def c -> Mod_subst.force_constr c + | OpaqueDef o -> + let p = Opaqueproof.force_proof (Environ.opaque_tables env) o in + let cst = Opaqueproof.force_constraints (Environ.opaque_tables env) o in + (** Let definitions are ensured to have no extra constraints coming from + the body by virtue of the typing of [Entries.section_def_entry]. *) + let () = assert (Univ.ContextSet.is_empty cst) in + p + | Undef _ -> assert false + in + c, typ (* Insertion of inductive types. *) let translate_mind env kn mie = Indtypes.check_inductive env kn mie let inline_entry_side_effects env ce = { ce with - const_entry_body = Future.chain ~pure:true + const_entry_body = Future.chain ce.const_entry_body (fun ((body, ctx), side_eff) -> let body, ctx',_ = inline_side_effects env body ctx side_eff in - (body, ctx'), empty_seff); + (body, ctx'), ()); } let inline_side_effects env body side_eff = diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 77d126074f..6a0ff072f5 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -1,21 +1,27 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Environ open Declarations open Entries type side_effects -val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry -> - constant_def * types * constant_universes +type _ trust = +| Pure : unit trust +| SideEffects : structure_body -> side_effects trust + +val translate_local_def : env -> Id.t -> section_def_entry -> + constr * types val translate_local_assum : env -> types -> types @@ -26,7 +32,7 @@ val inline_side_effects : env -> constr -> side_effects -> constr redexes. *) val inline_entry_side_effects : - env -> side_effects definition_entry -> side_effects definition_entry + env -> side_effects definition_entry -> unit definition_entry (** Same as {!inline_side_effects} but applied to entries. Only modifies the {!Entries.const_entry_body} field. It is meant to get a term out of a not yet type checked proof. *) @@ -43,7 +49,7 @@ val uniq_seff : side_effects -> side_effect list val equal_eff : side_effect -> side_effect -> bool val translate_constant : - structure_body -> env -> constant -> side_effects constant_entry -> + 'a trust -> env -> Constant.t -> 'a constant_entry -> constant_body type side_effect_role = @@ -51,31 +57,25 @@ type side_effect_role = | Schema of inductive * string type exported_side_effect = - constant * constant_body * side_effects constant_entry * side_effect_role + Constant.t * constant_body * side_effect_role (* Given a constant entry containing side effects it exports them (either * by re-checking them or trusting them). Returns the constant bodies to * be pushed in the safe_env by safe typing. The main constant entry * needs to be translated as usual after this step. *) val export_side_effects : - structure_body -> env -> side_effects constant_entry -> - exported_side_effect list * side_effects constant_entry - -val constant_entry_of_side_effect : - constant_body -> seff_env -> side_effects constant_entry + structure_body -> env -> side_effects definition_entry -> + exported_side_effect list * unit definition_entry val translate_mind : - env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body + env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body -val translate_recipe : env -> constant -> Cooking.recipe -> constant_body +val translate_recipe : env -> Constant.t -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : trust:structure_body -> env -> constant option -> - side_effects constant_entry -> Cooking.result +val infer_declaration : trust:'a trust -> env -> + 'a constant_entry -> Cooking.result val build_constant_declaration : - constant -> env -> Cooking.result -> constant_body - -val set_suggest_proof_using : - (string -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> string) -> unit + Constant.t -> env -> Cooking.result -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index bbaf569d39..1c323e3ea2 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Environ open Reduction @@ -44,9 +46,9 @@ type ('constr, 'types) ptype_error = | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of identifier * 'constr - | ElimArity of pinductive * sorts_family list * 'constr * ('constr, 'types) punsafe_judgment - * (sorts_family * sorts_family * arity_error) option + | ReferenceVariables of Id.t * 'constr + | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -59,7 +61,7 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.constraints + | UnsatisfiedConstraints of Univ.Constraint.t type type_error = (constr, types) ptype_error @@ -115,6 +117,7 @@ let error_ill_typed_rec_body env i lna vdefj vargs = raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs))) let error_elim_explain kp ki = + let open Sorts in match kp,ki with | (InType | InSet), InProp -> NonInformativeToInformative | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 1b2ccf8f82..20bf300ac3 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -1,13 +1,15 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Term +open Constr open Environ (** Type errors. {% \label{%}typeerrors{% }%} *) @@ -45,9 +47,9 @@ type ('constr, 'types) ptype_error = | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of identifier * 'constr - | ElimArity of pinductive * sorts_family list * 'constr * ('constr, 'types) punsafe_judgment - * (sorts_family * sorts_family * arity_error) option + | ReferenceVariables of Id.t * 'constr + | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -60,7 +62,7 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.constraints + | UnsatisfiedConstraints of Univ.Constraint.t type type_error = (constr, types) ptype_error @@ -74,11 +76,11 @@ val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a -val error_reference_variables : env -> identifier -> constr -> 'a +val error_reference_variables : env -> Id.t -> constr -> 'a val error_elim_arity : - env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> - (sorts_family * sorts_family * arity_error) option -> 'a + env -> pinductive -> Sorts.family list -> constr -> unsafe_judgment -> + (Sorts.family * Sorts.family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -103,6 +105,6 @@ val error_ill_formed_rec_body : val error_ill_typed_rec_body : env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a -val error_elim_explain : sorts_family -> sorts_family -> arity_error +val error_elim_explain : Sorts.family -> Sorts.family -> arity_error -val error_unsatisfied_constraints : env -> Univ.constraints -> 'a +val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index b814deb6eb..7f36f3813f 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -1,16 +1,19 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open CErrors open Util open Names open Univ -open Term +open Sorts +open Constr open Vars open Declarations open Environ @@ -38,7 +41,7 @@ let check_constraints cst env = (* This should be a type (a priori without intention to be an assumption) *) let check_type env c t = - match kind_of_term(whd_all env t) with + match kind(whd_all env t) with | Sort s -> s | _ -> error_not_type env (make_judge c t) @@ -57,7 +60,7 @@ let check_assumption env t ty = (* Prop and Set *) -let type1 = mkSort type1_sort +let type1 = mkSort Sorts.type1 (* Type of Type(i). *) @@ -65,6 +68,10 @@ let type_of_type u = let uu = Universe.super u in mkType uu +let type_of_sort = function + | Prop | Set -> type1 + | Type u -> type_of_type u + (*s Type of a de Bruijn index. *) let type_of_relative env n = @@ -111,36 +118,17 @@ let check_hyps_inclusion env f c sign = (* Type of constants *) -let type_of_constant_type_knowing_parameters env t paramtyps = - match t with - | RegularArity t -> t - | TemplateArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_knowing_parameters env (kn,u as cst) args = +let type_of_constant env (kn,u as cst) = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in let ty, cu = constant_type env cst in - let ty = type_of_constant_type_knowing_parameters env ty args in let () = check_constraints cu env in ty -let type_of_constant_knowing_parameters_in env (kn,u as cst) args = +let type_of_constant_in env (kn,u as cst) = let cb = lookup_constant kn env in let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in - let ty = constant_type_in env cst in - type_of_constant_type_knowing_parameters env ty args - -let type_of_constant env cst = - type_of_constant_knowing_parameters env cst [||] - -let type_of_constant_in env cst = - type_of_constant_knowing_parameters_in env cst [||] - -let type_of_constant_type env t = - type_of_constant_type_knowing_parameters env t [||] + constant_type_in env cst (* Type of a lambda-abstraction. *) @@ -167,7 +155,7 @@ let type_of_apply env func funt argsv argstv = let rec apply_rec i typ = if Int.equal i len then typ else - (match kind_of_term (whd_all env typ) with + (match kind (whd_all env typ) with | Prod (_,c1,c2) -> let arg = argsv.(i) and argt = argstv.(i) in (try @@ -190,11 +178,11 @@ let type_of_apply env func funt argsv argstv = let sort_of_product env domsort rangsort = match (domsort, rangsort) with (* Product rule (s,Prop,Prop) *) - | (_, Prop Null) -> rangsort + | (_, Prop) -> rangsort (* Product rule (Prop/Set,Set,Set) *) - | (Prop _, Prop Pos) -> rangsort + | ((Prop | Set), Set) -> rangsort (* Product rule (Type,Set,?) *) - | (Type u1, Prop Pos) -> + | (Type u1, Set) -> if is_impredicative_set env then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort @@ -202,9 +190,9 @@ let sort_of_product env domsort rangsort = (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (Universe.sup Universe.type0 u1) (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) + | (Set, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Null, Type _) -> rangsort + | (Prop, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (Universe.sup u1 u2) @@ -233,7 +221,7 @@ let check_cast env c ct k expected_type = try match k with | VMcast -> - vm_conv CUMUL env ct expected_type + Vconv.vm_conv CUMUL env ct expected_type | DEFAULTcast -> default_conv ~l2r:false CUMUL env ct expected_type | REVERTcast -> @@ -308,14 +296,14 @@ let type_of_case env ci p pt c ct lf lft = rslty let type_of_projection env p c ct = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - assert(eq_mind pb.proj_ind (fst ind)); - let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in - substl (c :: List.rev args) ty + assert(eq_ind (Projection.inductive p) ind); + let ty = Vars.subst_instance_constr u pty in + substl (c :: CList.rev args) ty (* Fixpoints. *) @@ -340,13 +328,9 @@ let check_fixpoint env lna lar vdef vdeft = arbitraires et non plus des variables *) let rec execute env cstr = let open Context.Rel.Declaration in - match kind_of_term cstr with + match kind cstr with (* Atomic terms *) - | Sort (Prop c) -> - type1 - - | Sort (Type u) -> - type_of_type u + | Sort s -> type_of_sort s | Rel n -> type_of_relative env n @@ -365,13 +349,10 @@ let rec execute env cstr = | App (f,args) -> let argst = execute_array env args in let ft = - match kind_of_term f with + match kind f with | Ind ind when Environ.template_polymorphic_pind ind env -> let args = Array.map (fun t -> lazy t) argst in type_of_inductive_knowing_parameters env ind args - | Const cst when Environ.template_polymorphic_pconstant cst env -> - let args = Array.map (fun t -> lazy t) argst in - type_of_constant_knowing_parameters env cst args | _ -> (* No template polymorphism *) execute env f @@ -456,8 +437,8 @@ let infer env constr = let infer = if Flags.profile then - let infer_key = Profile.declare_profile "Fast_infer" in - Profile.profile2 infer_key (fun b c -> infer b c) + let infer_key = CProfile.declare_profile "Fast_infer" in + CProfile.profile2 infer_key (fun b c -> infer b c) else (fun b c -> infer b c) let assumption_of_judgment env {uj_val=c; uj_type=t} = @@ -500,17 +481,11 @@ let judge_of_prop = make_judge mkProp type1 let judge_of_set = make_judge mkSet type1 let judge_of_type u = make_judge (mkType u) (type_of_type u) -let judge_of_prop_contents = function - | Null -> judge_of_prop - | Pos -> judge_of_set - let judge_of_relative env k = make_judge (mkRel k) (type_of_relative env k) let judge_of_variable env x = make_judge (mkVar x) (type_of_variable env x) let judge_of_constant env cst = make_judge (mkConstU cst) (type_of_constant env cst) -let judge_of_constant_knowing_parameters env cst args = - make_judge (mkConstU cst) (type_of_constant_knowing_parameters env cst args) let judge_of_projection env p cj = make_judge (mkProj (p,cj.uj_val)) (type_of_projection env p cj.uj_val cj.uj_type) @@ -549,44 +524,3 @@ let judge_of_case env ci pj cj lfj = let lf, lft = dest_judgev lfj in make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft) - -let type_of_projection_constant env (p,u) = - let cst = Projection.constant p in - let cb = lookup_constant cst env in - match cb.const_proj with - | Some pb -> - if Declareops.constant_is_polymorphic cb then - Vars.subst_instance_constr u pb.proj_type - else pb.proj_type - | None -> raise (Invalid_argument "type_of_projection: not a projection") - -(* Instantiation of terms on real arguments. *) - -(* Make a type polymorphic if an arity *) - -let extract_level env p = - let _,c = dest_prod_assum env p in - match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None - -let extract_context_levels env l = - let fold l = function - | RelDecl.LocalAssum (_,p) -> extract_level env p :: l - | RelDecl.LocalDef _ -> l - in - List.fold_left fold [] l - -let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = - let params, ccl = dest_prod_assum env t in - match kind_of_term ccl with - | Sort (Type u) -> - let ind, l = decompose_app (whd_all env c) in - if isInd ind && List.is_empty l then - let mis = lookup_mind_specif env (fst (destInd ind)) in - let nparams = Inductive.inductive_params mis in - let paramsl = CList.lastn nparams params in - let param_ccls = extract_context_levels env paramsl in - let s = { template_param_levels = param_ccls; template_level = u} in - TemplateArity (params,s) - else RegularArity t - | _ -> - RegularArity t diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 24521070e2..57acdfe4b5 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -1,17 +1,18 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names +open Constr open Univ -open Term open Environ open Entries -open Declarations (** {6 Typing functions (not yet tagged as safe) } @@ -27,7 +28,7 @@ val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : - env -> (Id.t * local_entry) list -> (env * Context.Rel.t) + env -> (Id.t * local_entry) list -> (env * Constr.rel_context) (** {6 Basic operations of the typing machine. } *) @@ -38,27 +39,27 @@ val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment (** {6 Type of sorts. } *) +val type1 : types +val type_of_sort : Sorts.t -> types val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment -val judge_of_prop_contents : contents -> unsafe_judgment -val judge_of_type : universe -> unsafe_judgment +val judge_of_type : Universe.t -> unsafe_judgment (** {6 Type of a bound variable. } *) +val type_of_relative : env -> int -> types val judge_of_relative : env -> int -> unsafe_judgment (** {6 Type of variables } *) +val type_of_variable : env -> variable -> types val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) val judge_of_constant : env -> pconstant -> unsafe_judgment -val judge_of_constant_knowing_parameters : - env -> pconstant -> types Lazy.t array -> unsafe_judgment - (** {6 type of an applied projection } *) -val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment +val judge_of_projection : env -> Projection.t -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : @@ -70,9 +71,9 @@ val judge_of_abstraction : env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment -val sort_of_product : env -> sorts -> sorts -> sorts - (** {6 Type of a product. } *) +val sort_of_product : env -> Sorts.t -> Sorts.t -> Sorts.t +val type_of_product : env -> Name.t -> Sorts.t -> Sorts.t -> types val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment @@ -98,21 +99,7 @@ val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment -val type_of_constant_type : env -> constant_type -> types - -val type_of_projection_constant : env -> Names.projection puniverses -> types - val type_of_constant_in : env -> pconstant -> types -val type_of_constant_type_knowing_parameters : - env -> constant_type -> types Lazy.t array -> types - -val type_of_constant_knowing_parameters_in : - env -> pconstant -> types Lazy.t array -> types - -(** Make a type polymorphic if an arity *) -val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> - constant_type - (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Context.Named.t -> unit +val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Constr.named_context -> unit diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 487257a776..bc624ba56d 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Pp @@ -19,7 +21,7 @@ open Univ (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) -let error_inconsistency o u v (p:explanation option) = +let error_inconsistency o u v p = raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) (* Universes are stratified by a partial ordering $\le$. @@ -501,7 +503,7 @@ let insert_edge strict ucan vcan g = let () = cleanup_universes g in raise e -let add_universe vlev strict g = +let add_universe_gen vlev g = try let _arcv = UMap.find vlev g.entries in raise AlreadyDeclared @@ -518,8 +520,14 @@ let add_universe vlev strict g = } in let entries = UMap.add vlev (Canonical v) g.entries in - let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in - insert_edge strict (get_set_arc g) v g + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v + +let add_universe vlev strict g = + let g, v = add_universe_gen vlev g in + insert_edge strict (get_set_arc g) v g + +let add_universe_unconstrained vlev g = + fst (add_universe_gen vlev g) exception Found_explanation of explanation @@ -555,8 +563,7 @@ let get_explanation strict u v g = else match traverse strict u with Some exp -> exp | None -> assert false let get_explanation strict u v g = - if !Flags.univ_print then Some (get_explanation strict u v g) - else None + Some (lazy (get_explanation strict u v g)) (* To compare two nodes, we simply do a forward search. We implement two improvements: @@ -695,6 +702,9 @@ let enforce_univ_lt u v g = error_inconsistency Lt u v (get_explanation false v u g) let empty_universes = + { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + +let initial_universes = let set_arc = Canonical { univ = Level.set; ltle = LMap.empty; @@ -717,9 +727,6 @@ let empty_universes = let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in enforce_univ_lt Level.prop Level.set empty -(* Prop = Set is forbidden here. *) -let initial_universes = empty_universes - let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries let enforce_constraint cst g = @@ -740,6 +747,45 @@ let check_constraint g (l,d,r) = let check_constraints c g = Constraint.for_all (check_constraint g) c +let leq_expr (u,m) (v,n) = + let d = match m - n with + | 1 -> Lt + | diff -> assert (diff <= 0); Le + in + (u,d,v) + +let enforce_leq_alg u v g = + let enforce_one (u,v) = function + | Inr _ as orig -> orig + | Inl (cstrs,g) as orig -> + if check_smaller_expr g u v then orig + else + (let c = leq_expr u v in + match enforce_constraint c g with + | g -> Inl (Constraint.add c cstrs,g) + | exception (UniverseInconsistency _ as e) -> Inr e) + in + (* max(us) <= max(vs) <-> forall u in us, exists v in vs, u <= v *) + let c = Universe.map (fun u -> Universe.map (fun v -> (u,v)) v) u in + let c = List.cartesians enforce_one (Inl (Constraint.empty,g)) c in + (* We pick a best constraint: smallest number of constraints, not an error if possible. *) + let order x y = match x, y with + | Inr _, Inr _ -> 0 + | Inl _, Inr _ -> -1 + | Inr _, Inl _ -> 1 + | Inl (c,_), Inl (c',_) -> + Int.compare (Constraint.cardinal c) (Constraint.cardinal c') + in + match List.min order c with + | Inl x -> x + | Inr e -> raise e + +(* sanity check wrapper *) +let enforce_leq_alg u v g = + let _,g as cg = enforce_leq_alg u v g in + assert (check_leq g u v); + cg + (* Normalization *) (** [normalize_universes g] returns a graph where all edges point @@ -766,18 +812,54 @@ let normalize_universes g = g.entries g let constraints_of_universes g = + let module UF = Unionfind.Make (LSet) (LMap) in + let uf = UF.create () in let constraints_of u v acc = match v with | Canonical {univ=u; ltle} -> UMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> Constraint.add (u,Eq,v) acc + | Equiv v -> UF.union u v uf; acc in - UMap.fold constraints_of g.entries Constraint.empty - -let constraints_of_universes g = - constraints_of_universes (normalize_universes g) + let csts = UMap.fold constraints_of g.entries Constraint.empty in + csts, UF.partition uf + +(* domain g.entries = kept + removed *) +let constraints_for ~kept g = + (* rmap: partial map from canonical universes to kept universes *) + let rmap, csts = LSet.fold (fun u (rmap,csts) -> + let arcu = repr g u in + if LSet.mem arcu.univ kept then + LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts + else + match LMap.find arcu.univ rmap with + | v -> rmap, enforce_eq_level u v csts + | exception Not_found -> LMap.add arcu.univ u rmap, csts) + kept (LMap.empty,Constraint.empty) + in + let rec add_from u csts todo = match todo with + | [] -> csts + | (v,strict)::todo -> + let v = repr g v in + (match LMap.find v.univ rmap with + | v -> + let d = if strict then Lt else Le in + let csts = Constraint.add (u,d,v) csts in + add_from u csts todo + | exception Not_found -> + (* v is not equal to any kept universe *) + let todo = LMap.fold (fun v' strict' todo -> + (v',strict || strict') :: todo) + v.ltle todo + in + add_from u csts todo) + in + LSet.fold (fun u csts -> + let arc = repr g u in + LMap.fold (fun v strict csts -> add_from u csts [v,strict]) + arc.ltle csts) + kept csts (** [sort_universes g] builds a totally ordered universe graph. The output graph should imply the input graph (and the implication @@ -830,6 +912,18 @@ let sort_universes g = in normalize_universes g +(** Subtyping of polymorphic contexts *) + +let check_subtype univs ctxT ctx = + if AUContext.size ctxT == AUContext.size ctx then + let (inst, cst) = UContext.dest (AUContext.repr ctx) in + let cstT = UContext.constraints (AUContext.repr ctxT) in + let push accu v = add_universe v false accu in + let univs = Array.fold_left push univs (Instance.to_array inst) in + let univs = merge_constraints cstT univs in + check_constraints cst univs + else false + (** Instances *) let check_eq_instances g t1 t2 = @@ -878,23 +972,24 @@ let dump_universes output g = let merge_constraints = if Flags.profile then - let key = Profile.declare_profile "merge_constraints" in - Profile.profile2 key merge_constraints + let key = CProfile.declare_profile "merge_constraints" in + CProfile.profile2 key merge_constraints else merge_constraints let check_constraints = if Flags.profile then - let key = Profile.declare_profile "check_constraints" in - Profile.profile2 key check_constraints + let key = CProfile.declare_profile "check_constraints" in + CProfile.profile2 key check_constraints else check_constraints let check_eq = if Flags.profile then - let check_eq_key = Profile.declare_profile "check_eq" in - Profile.profile3 check_eq_key check_eq + let check_eq_key = CProfile.declare_profile "check_eq" in + CProfile.profile3 check_eq_key check_eq else check_eq let check_leq = if Flags.profile then - let check_leq_key = Profile.declare_profile "check_leq" in - Profile.profile3 check_leq_key check_leq + let check_leq_key = CProfile.declare_profile "check_leq" in + CProfile.profile3 check_leq_key check_leq else check_leq + diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 935a3cab4a..8c2d877b0b 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -1,40 +1,34 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Univ (** {6 Graphs of universes. } *) - type t - type universes = t +[@@ocaml.deprecated "Use UGraph.t"] -type 'a check_function = universes -> 'a -> 'a -> bool -val check_leq : universe check_function -val check_eq : universe check_function -val check_eq_level : universe_level check_function +type 'a check_function = t -> 'a -> 'a -> bool -(** The empty graph of universes *) -val empty_universes : universes +val check_leq : Universe.t check_function +val check_eq : Universe.t check_function +val check_eq_level : Level.t check_function (** The initial graph of universes: Prop < Set *) -val initial_universes : universes - -val is_initial_universes : universes -> bool - -val sort_universes : universes -> universes - -(** Adds a universe to the graph, ensuring it is >= or > Set. - @raises AlreadyDeclared if the level is already declared in the graph. *) +val initial_universes : t -exception AlreadyDeclared +(** Check if we are in the initial case *) +val is_initial_universes : t -> bool -val add_universe : universe_level -> bool -> universes -> universes +(** Check equality of instances w.r.t. a universe graph *) +val check_eq_instances : Instance.t check_function (** {6 ... } *) (** Merge of constraints in a universes graph. @@ -42,26 +36,53 @@ val add_universe : universe_level -> bool -> universes -> universes universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) -val enforce_constraint : univ_constraint -> universes -> universes -val merge_constraints : constraints -> universes -> universes +val enforce_constraint : univ_constraint -> t -> t +val merge_constraints : Constraint.t -> t -> t -val constraints_of_universes : universes -> constraints +val check_constraint : t -> univ_constraint -> bool +val check_constraints : Constraint.t -> t -> bool -val check_constraint : universes -> univ_constraint -> bool -val check_constraints : constraints -> universes -> bool +(** Picks an arbitrary set of constraints sufficient to ensure [u <= v]. *) +val enforce_leq_alg : Universe.t -> Universe.t -> t -> Constraint.t * t -val check_eq_instances : Instance.t check_function -(** Check equality of instances w.r.t. a universe graph *) +(** Adds a universe to the graph, ensuring it is >= or > Set. + @raise AlreadyDeclared if the level is already declared in the graph. *) + +exception AlreadyDeclared + +val add_universe : Level.t -> bool -> t -> t + +(** Add a universe without (Prop,Set) <= u *) +val add_universe_unconstrained : Level.t -> t -> t (** {6 Pretty-printing of universes. } *) -val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds +val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t + +(** The empty graph of universes *) +val empty_universes : t + +val sort_universes : t -> t + +(** [constraints_of_universes g] returns [csts] and [partition] where + [csts] are the non-Eq constraints and [partition] is the partition + of the universes into equivalence classes. *) +val constraints_of_universes : t -> Constraint.t * LSet.t list + +(** [constraints_for ~kept g] returns the constraints about the + universes [kept] in [g] up to transitivity. + + eg if [g] is [a <= b <= c] then [constraints_for ~kept:{a, c} g] is [a <= c]. *) +val constraints_for : kept:LSet.t -> t -> Constraint.t + +val check_subtype : AUContext.t check_function +(** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of + [ctx1]. *) (** {6 Dumping to a file } *) val dump_universes : - (constraint_type -> string -> string -> unit) -> - universes -> unit + (constraint_type -> string -> string -> unit) -> t -> unit (** {6 Debugging} *) -val check_universes_invariants : universes -> unit +val check_universes_invariants : t -> unit diff --git a/kernel/univ.ml b/kernel/univ.ml index 1c887e2a99..311477daca 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) @@ -31,133 +33,6 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module type Hashconsed = -sig - type t - val hash : t -> int - val eq : t -> t -> bool - val hcons : t -> t -end - -module HashedList (M : Hashconsed) : -sig - type t = private Nil | Cons of M.t * int * t - val nil : t - val cons : M.t -> t -> t -end = -struct - type t = Nil | Cons of M.t * int * t - module Self = - struct - type _t = t - type t = _t - type u = (M.t -> M.t) - let hash = function Nil -> 0 | Cons (_, h, _) -> h - let eq l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 - | _ -> false - let hashcons hc = function - | Nil -> Nil - | Cons (x, h, l) -> Cons (hc x, h, l) - end - module Hcons = Hashcons.Make(Self) - let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons - (** No recursive call: the interface guarantees that all HLists from this - program are already hashconsed. If we get some external HList, we can - still reconstruct it by traversing it entirely. *) - let nil = Nil - let cons x l = - let h = M.hash x in - let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in - let h = Hashset.Combine.combine h hl in - hcons (Cons (x, h, l)) -end - -module HList = struct - - module type S = sig - type elt - type t = private Nil | Cons of elt * int * t - val hash : t -> int - val nil : t - val cons : elt -> t -> t - val tip : elt -> t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val map : (elt -> elt) -> t -> t - val smartmap : (elt -> elt) -> t -> t - val exists : (elt -> bool) -> t -> bool - val for_all : (elt -> bool) -> t -> bool - val for_all2 : (elt -> elt -> bool) -> t -> t -> bool - val mem : elt -> t -> bool - val remove : elt -> t -> t - val to_list : t -> elt list - val compare : (elt -> elt -> int) -> t -> t -> int - end - - module Make (H : Hashconsed) : S with type elt = H.t = - struct - type elt = H.t - include HashedList(H) - - let hash = function Nil -> 0 | Cons (_, h, _) -> h - - let tip e = cons e nil - - let rec fold f l accu = match l with - | Nil -> accu - | Cons (x, _, l) -> fold f l (f x accu) - - let rec map f = function - | Nil -> nil - | Cons (x, _, l) -> cons (f x) (map f l) - - let smartmap = map - (** Apriori hashconsing ensures that the map is equal to its argument *) - - let rec exists f = function - | Nil -> false - | Cons (x, _, l) -> f x || exists f l - - let rec for_all f = function - | Nil -> true - | Cons (x, _, l) -> f x && for_all f l - - let rec for_all2 f l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 - | _ -> false - - let rec to_list = function - | Nil -> [] - | Cons (x, _, l) -> x :: to_list l - - let rec remove x = function - | Nil -> nil - | Cons (y, _, l) -> - if H.eq x y then l - else cons y (remove x l) - - let rec mem x = function - | Nil -> false - | Cons (y, _, l) -> H.eq x y || mem x l - - let rec compare cmp l1 l2 = match l1, l2 with - | Nil, Nil -> 0 - | Cons (x1, h1, l1), Cons (x2, h2, l2) -> - let c = Int.compare h1 h2 in - if c == 0 then - let c = cmp x1 x2 in - if c == 0 then - compare cmp l1 l2 - else c - else c - | Cons _, Nil -> 1 - | Nil, Cons _ -> -1 - - end -end - module RawLevel = struct open Names @@ -248,8 +123,7 @@ module Level = struct (** Hashcons on levels + their hash *) module Self = struct - type _t = t - type t = _t + type nonrec t = t type u = unit let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash @@ -320,6 +194,10 @@ module Level = struct let make m n = make (Level (n, Names.DirPath.hcons m)) + let name u = + match data u with + | Level (n, d) -> Some (d, n) + | _ -> None end (** Level maps *) @@ -390,12 +268,11 @@ struct module Expr = struct type t = Level.t * int - type _t = t - + (* Hashing of expressions *) module ExprHash = struct - type t = _t + type t = Level.t * int type u = Level.t -> Level.t let hashcons hdir (b,n as x) = let b' = hdir b in @@ -409,25 +286,12 @@ struct end - module HExpr = - struct + module H = Hashcons.Make(ExprHash) - module H = Hashcons.Make(ExprHash) + let hcons = + Hashcons.simple_hcons H.generate H.hcons Level.hcons - type t = ExprHash.t - - let hcons = - Hashcons.simple_hcons H.generate H.hcons Level.hcons - let hash = ExprHash.hash - let eq x y = x == y || - (let (u,n) = x and (v,n') = y in - Int.equal n n' && Level.equal u v) - - end - - let hcons = HExpr.hcons - - let make l = hcons (l, 0) + let make l = (l, 0) let compare u v = if u == v then 0 @@ -436,8 +300,8 @@ struct if Int.equal n n' then Level.compare x x' else n - n' - let prop = make Level.prop - let set = make Level.set + let prop = hcons (Level.prop, 0) + let set = hcons (Level.set, 0) let type1 = hcons (Level.set, 1) let is_small = function @@ -448,6 +312,8 @@ struct (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) + let hash = ExprHash.hash + let leq (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' @@ -457,13 +323,13 @@ struct let successor (u,n) = if Level.is_prop u then type1 - else hcons (u, n + 1) + else (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then - hcons (Level.set,n+k) - else hcons (u,n+k) + (Level.set,n+k) + else (u,n+k) type super_result = SuperSame of bool @@ -477,19 +343,16 @@ struct returning [SuperSame] if they refer to the same level at potentially different increments or [SuperDiff] if they are different. The booleans indicate if the left expression is "smaller" than the right one in both cases. *) - let super (u,n as x) (v,n' as y) = + let super (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then SuperSame (n < n') else - match x, y with - | (l,0), (l',0) -> - let open RawLevel in - (match Level.data l, Level.data l' with - | Prop, Prop -> SuperSame false - | Prop, _ -> SuperSame true - | _, Prop -> SuperSame false - | _, _ -> SuperDiff cmp) - | _, _ -> SuperDiff cmp + let open RawLevel in + match Level.data u, n, Level.data v, n' with + | Prop, _, Prop, _ -> SuperSame (n < n') + | Prop, 0, _, _ -> SuperSame true + | _, _, Prop, 0 -> SuperSame false + | _, _, _, _ -> SuperDiff cmp let to_string (v, n) = if Int.equal n 0 then Level.to_string v @@ -515,71 +378,63 @@ struct let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then - hcons (Level.set, n) - else hcons (v', n) + (Level.set, n) + else (v', n) end - - let compare_expr = Expr.compare - module Huniv = HList.Make(Expr.HExpr) - type t = Huniv.t - open Huniv - - let equal x y = x == y || - (Huniv.hash x == Huniv.hash y && - Huniv.for_all2 Expr.equal x y) + type t = Expr.t list - let hash = Huniv.hash + let tip l = [l] + let cons x l = x :: l - let compare x y = - if x == y then 0 - else - let hx = Huniv.hash x and hy = Huniv.hash y in - let c = Int.compare hx hy in - if c == 0 then - Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y - else c + let rec hash = function + | [] -> 0 + | e :: l -> Hashset.Combine.combinesmall (Expr.ExprHash.hash e) (hash l) + + let equal x y = x == y || List.equal Expr.equal x y + + let compare x y = if x == y then 0 else List.compare Expr.compare x y + + module Huniv = Hashcons.Hlist(Expr) - let rec hcons = function - | Nil -> Huniv.nil - | Cons (x, _, l) -> Huniv.cons x (hcons l) + let hcons = Hashcons.recursive_hcons Huniv.generate Huniv.hcons Expr.hcons - let make l = Huniv.tip (Expr.make l) - let tip x = Huniv.tip x + let make l = tip (Expr.make l) + let tip x = tip x let pr l = match l with - | Cons (u, _, Nil) -> Expr.pr u + | [u] -> Expr.pr u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ + (prlist_with_sep pr_comma Expr.pr l) ++ str ")" let pr_with f l = match l with - | Cons (u, _, Nil) -> Expr.pr_with f u + | [u] -> Expr.pr_with f u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++ + (prlist_with_sep pr_comma (Expr.pr_with f) l) ++ str ")" let is_level l = match l with - | Cons (l, _, Nil) -> Expr.is_level l + | [l] -> Expr.is_level l | _ -> false let rec is_levels l = match l with - | Cons (l, _, r) -> Expr.is_level l && is_levels r - | Nil -> true + | l :: r -> Expr.is_level l && is_levels r + | [] -> true let level l = match l with - | Cons (l, _, Nil) -> Expr.level l + | [l] -> Expr.level l | _ -> None let levels l = - fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty + List.fold_left (fun acc x -> LSet.add (Expr.get_level x) acc) LSet.empty l let is_small u = match u with - | Cons (l, _, Nil) -> Expr.is_small l + | [l] -> Expr.is_small l | _ -> false (* The lower predicative level of the hierarchy that contains (impredicative) @@ -601,16 +456,16 @@ struct let super l = if is_small l then type1 else - Huniv.map (fun x -> Expr.successor x) l + List.Smart.map (fun x -> Expr.successor x) l let addn n l = - Huniv.map (fun x -> Expr.addn n x) l + List.Smart.map (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with - | Nil, _ -> l2 - | _, Nil -> l1 - | Cons (h1, _, t1), Cons (h2, _, t2) -> + | [], _ -> l2 + | _, [] -> l1 + | h1 :: t1, h2 :: t2 -> let open Expr in (match super h1 h2 with | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 @@ -623,7 +478,7 @@ struct let sort u = let rec aux a l = match l with - | Cons (b, _, l') -> + | b :: l' -> let open Expr in (match super a b with | SuperSame false -> aux a l' @@ -631,22 +486,23 @@ struct | SuperDiff c -> if c <= 0 then cons a l else cons b (aux a l')) - | Nil -> cons a l + | [] -> cons a l in - fold (fun a acc -> aux a acc) u nil - + List.fold_right (fun a acc -> aux a acc) u [] + (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y - let empty = nil + let empty = [] - let exists = Huniv.exists + let exists = List.exists - let for_all = Huniv.for_all + let for_all = List.for_all - let smartmap = Huniv.smartmap + let smart_map = List.Smart.map + let map = List.map end type universe = Universe.t @@ -685,11 +541,11 @@ let constraint_type_ord c1 c2 = match c1, c2 with (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) -type univ_inconsistency = constraint_type * universe * universe * explanation option +type univ_inconsistency = constraint_type * universe * universe * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency -let error_inconsistency o u v (p:explanation option) = +let error_inconsistency o u v p = raise (UniverseInconsistency (o,make u,make v,p)) (* Constraints and sets of constraints. *) @@ -810,7 +666,7 @@ let constraint_add_leq v u c = else (* j >= 1 *) (* m = n + k, u <= v+k *) if Level.equal x y then c (* u <= u+k, trivial *) else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) - else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints.") + else Constraint.add (x,Le,y) c (* u <= v implies u <= v+k *) let check_univ_leq_one u v = Universe.exists (Expr.leq u) v @@ -818,13 +674,7 @@ let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - let open Universe.Huniv in - let rec aux acc v = - match v with - | Cons (v, _, l) -> - aux (fold (fun u -> constraint_add_leq u v) u c) l - | Nil -> acc - in aux c v + List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v let enforce_leq u v c = if check_univ_leq u v then c @@ -833,21 +683,16 @@ let enforce_leq u v c = let enforce_leq_level u v c = if Level.equal u v then c else Constraint.add (u,Le,v) c -let enforce_univ_constraint (u,d,v) = - match d with - | Eq -> enforce_eq u v - | Le -> enforce_leq u v - | Lt -> enforce_leq (super u) v - (* Miscellaneous functions to remove or test local univ assumed to occur in a universe *) -let univ_level_mem u v = Huniv.mem (Expr.make u) v +let univ_level_mem u v = + List.exists (fun (l, n) -> Int.equal n 0 && Level.equal u l) v let univ_level_rem u v min = match Universe.level v with | Some u' -> if Level.equal u u' then min else v - | None -> Huniv.remove (Universe.Expr.make u) v + | None -> List.filter (fun (l, n) -> not (Int.equal n 0 && Level.equal u l)) v (* Is u mentionned in v (or equals to v) ? *) @@ -864,15 +709,55 @@ type universe_level_subst = universe_level universe_map (** A full substitution might involve algebraic universes *) type universe_subst = universe universe_map -let level_subst_of f = - fun l -> - try let u = f l in - match Universe.level u with - | None -> l - | Some l -> l - with Not_found -> l - -module Instance : sig +module Variance = +struct + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contravariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + type t = Irrelevant | Covariant | Invariant + + let sup x y = + match x, y with + | Irrelevant, s | s, Irrelevant -> s + | Invariant, _ | _, Invariant -> Invariant + | Covariant, Covariant -> Covariant + + let check_subtype x y = match x, y with + | (Irrelevant | Covariant | Invariant), Irrelevant -> true + | Irrelevant, Covariant -> false + | (Covariant | Invariant), Covariant -> true + | (Irrelevant | Covariant), Invariant -> false + | Invariant, Invariant -> true + + let pr = function + | Irrelevant -> str "*" + | Covariant -> str "+" + | Invariant -> str "=" + + let leq_constraint csts variance u u' = + match variance with + | Irrelevant -> csts + | Covariant -> enforce_leq_level u u' csts + | Invariant -> enforce_eq_level u u' csts + + let eq_constraint csts variance u u' = + match variance with + | Irrelevant -> csts + | Covariant | Invariant -> enforce_eq_level u u' csts + + let leq_constraints variance u u' csts = + let len = Array.length u in + assert (len = Array.length u' && len = Array.length variance); + Array.fold_left3 leq_constraint csts variance u u' + + let eq_constraints variance u u' csts = + let len = Array.length u in + assert (len = Array.length u' && len = Array.length variance); + Array.fold_left3 eq_constraint csts variance u u' +end + +module Instance : sig type t = Level.t array val empty : t @@ -892,7 +777,7 @@ module Instance : sig val subst_fn : universe_level_subst_fn -> t -> t - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr : (Level.t -> Pp.t) -> ?variance:Variance.t array -> t -> Pp.t val levels : t -> LSet.t end = struct @@ -902,8 +787,7 @@ struct module HInstancestruct = struct - type _t = t - type t = _t + type nonrec t = t type u = Level.t -> Level.t let hashcons huniv a = @@ -964,13 +848,17 @@ struct let length a = Array.length a let subst_fn fn t = - let t' = CArray.smartmap fn t in + let t' = CArray.Smart.map fn t in if t' == t then t else of_array t' let levels x = LSet.of_array x - let pr = - prvect_with_sep spc + let pr prl ?variance = + let ppu i u = + let v = Option.map (fun v -> v.(i)) variance in + pr_opt_no_spc Variance.pr v ++ prl u + in + prvecti_with_sep spc ppu let equal t u = t == u || @@ -988,6 +876,34 @@ let enforce_eq_instances x y = (Pp.str " instances of different lengths.")); CArray.fold_right2 enforce_eq_level ax ay +let enforce_eq_variance_instances = Variance.eq_constraints +let enforce_leq_variance_instances = Variance.leq_constraints + +let subst_instance_level s l = + match l.Level.data with + | Level.Var n -> s.(n) + | _ -> l + +let subst_instance_instance s i = + Array.Smart.map (fun l -> subst_instance_level s l) i + +let subst_instance_universe s u = + let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in + let u' = Universe.smart_map f u in + if u == u' then u + else Universe.sort u' + +let subst_instance_constraint s (u,d,v as c) = + let u' = subst_instance_level s u in + let v' = subst_instance_level s v in + if u' == u && v' == v then c + else (u',d,v') + +let subst_instance_constraints s csts = + Constraint.fold + (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) + csts Constraint.empty + type universe_instance = Instance.t type 'a puniverses = 'a * Instance.t @@ -1009,9 +925,9 @@ struct let empty = (Instance.empty, Constraint.empty) let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst - let pr prl (univs, cst as ctx) = + let pr prl ?variance (univs, cst as ctx) = if is_empty ctx then mt() else - h 0 (Instance.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) + h 0 (Instance.pr prl ?variance univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) @@ -1031,71 +947,58 @@ end type universe_context = UContext.t let hcons_universe_context = UContext.hcons -module AUContext = UContext +module AUContext = +struct + include UContext + + let repr (inst, cst) = + (Array.mapi (fun i l -> Level.var i) inst, cst) + + let instantiate inst (u, cst) = + assert (Array.length u = Array.length inst); + subst_instance_constraints inst cst + +end type abstract_universe_context = AUContext.t let hcons_abstract_universe_context = AUContext.hcons -(** Universe info for cumulative inductive types: - A context of universe levels - with universe constraints, representing local universe variables - and constraints, together with a context of universe levels with - universe constraints, representing conditions for subtyping used - for inductive types. +(** Universe info for cumulative inductive types: A context of + universe levels with universe constraints, representing local + universe variables and constraints, together with an array of + Variance.t. - This data structure maintains the invariant that the context for - subtyping constraints is exactly twice as big as the context for - universe constraints. *) + This data structure maintains the invariant that the variance + array has the same length as the universe instance. *) module CumulativityInfo = struct - type t = universe_context * universe_context + type t = universe_context * Variance.t array let make x = - if (Instance.length (UContext.instance (snd x))) = - (Instance.length (UContext.instance (fst x))) * 2 then x + if (Instance.length (UContext.instance (fst x))) = + (Array.length (snd x)) then x else anomaly (Pp.str "Invalid subtyping information encountered!") - let empty = (UContext.empty, UContext.empty) - let is_empty (univcst, subtypcst) = UContext.is_empty univcst && UContext.is_empty subtypcst - - let halve_context ctx = - let len = Array.length (Instance.to_array ctx) in - let halflen = len / 2 in - (Instance.of_array (Array.sub (Instance.to_array ctx) 0 halflen), - Instance.of_array (Array.sub (Instance.to_array ctx) halflen halflen)) - - let pr prl (univcst, subtypcst) = - if UContext.is_empty univcst then mt() else - let (ctx, ctx') = halve_context (UContext.instance subtypcst) in - (UContext.pr prl univcst) ++ fnl () ++ fnl () ++ - h 0 (str "~@{" ++ Instance.pr prl ctx ++ str "} <= ~@{" ++ Instance.pr prl ctx' ++ str "} iff ") - ++ fnl () ++ h 0 (v 0 (Constraint.pr prl (UContext.constraints subtypcst))) + let empty = (UContext.empty, [||]) + let is_empty (univs, variance) = UContext.is_empty univs && Array.is_empty variance - let hcons (univcst, subtypcst) = - (UContext.hcons univcst, UContext.hcons subtypcst) + let pr prl (univs, variance) = + UContext.pr prl ~variance univs - let univ_context (univcst, subtypcst) = univcst - let subtyp_context (univcst, subtypcst) = subtypcst + let hcons (univs, variance) = (* should variance be hconsed? *) + (UContext.hcons univs, variance) - let create_trivial_subtyping ctx ctx' = - CArray.fold_left_i - (fun i cst l -> Constraint.add (l, Eq, Array.get ctx' i) cst) - Constraint.empty (Instance.to_array ctx) + let univ_context (univs, subtypcst) = univs + let variance (univs, variance) = variance (** This function takes a universe context representing constraints - of an inductive and a Instance.t of fresh universe names for the - subtyping (with the same length as the context in the given - universe context) and produces a UInfoInd.t that with the - trivial subtyping relation. *) - let from_universe_context univcst freshunivs = - let inst = (UContext.instance univcst) in - assert (Instance.length freshunivs = Instance.length inst); - (univcst, UContext.make (Instance.append inst freshunivs, - create_trivial_subtyping inst freshunivs)) - - let subtyping_susbst (univcst, subtypcst) = - let (ctx, ctx') = (halve_context (UContext.instance subtypcst))in - Array.fold_left2 (fun subst l1 l2 -> LMap.add l1 l2 subst) LMap.empty ctx ctx' + of an inductive and produces a CumulativityInfo.t with the + trivial subtyping relation. *) + let from_universe_context univs = + (univs, Array.init (UContext.size univs) (fun _ -> Variance.Invariant)) + + let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts + let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts end @@ -1166,6 +1069,7 @@ struct let constraints (univs, cst) = cst let levels (univs, cst) = univs + let size (univs,_) = LSet.cardinal univs end type universe_context_set = ContextSet.t @@ -1191,7 +1095,7 @@ let subst_univs_level_level subst l = let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in - let u' = Universe.smartmap f u in + let u' = Universe.smart_map f u in if u == u' then u else Universe.sort u' @@ -1224,7 +1128,7 @@ let subst_univs_expr_opt fn (l,n) = let subst_univs_universe fn ul = let subst, nosubst = - Universe.Huniv.fold (fun u (subst,nosubst) -> + List.fold_right (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) @@ -1235,60 +1139,9 @@ let subst_univs_universe fn ul = let substs = List.fold_left Universe.merge_univs Universe.empty subst in - List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst -let subst_univs_level fn l = - try Some (fn l) - with Not_found -> None - -let subst_univs_constraint fn (u,d,v as c) cstrs = - let u' = subst_univs_level fn u in - let v' = subst_univs_level fn v in - match u', v' with - | None, None -> Constraint.add c cstrs - | Some u, None -> enforce_univ_constraint (u,d,make v) cstrs - | None, Some v -> enforce_univ_constraint (make u,d,v) cstrs - | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs - -let subst_univs_constraints subst csts = - Constraint.fold - (fun c cstrs -> subst_univs_constraint subst c cstrs) - csts Constraint.empty - -let subst_instance_level s l = - match l.Level.data with - | Level.Var n -> s.(n) - | _ -> l - -let subst_instance_instance s i = - Array.smartmap (fun l -> subst_instance_level s l) i - -let subst_instance_universe s u = - let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smartmap f u in - if u == u' then u - else Universe.sort u' - -let subst_instance_constraint s (u,d,v as c) = - let u' = subst_instance_level s u in - let v' = subst_instance_level s v in - if u' == u && v' == v then c - else (u',d,v') - -let subst_instance_constraints s csts = - Constraint.fold - (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) - csts Constraint.empty - -(** Substitute instance inst for ctx in csts *) -let instantiate_univ_context (ctx, csts) = - (ctx, subst_instance_constraints ctx csts) - -(** Substitute instance inst for ctx in universe constraints and subtyping constraints *) -let instantiate_cumulativity_info (univcst, subtpcst) = - (instantiate_univ_context univcst, instantiate_univ_context subtpcst) - let make_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> @@ -1311,12 +1164,25 @@ let abstract_universes ctx = (UContext.constraints ctx) in let ctx = UContext.make (instance, cstrs) in - subst, ctx - -let abstract_cumulativity_info (univcst, substcst) = - let instance, univcst = abstract_universes univcst in - let _, substcst = abstract_universes substcst in - (instance, (univcst, substcst)) + instance, ctx + +let abstract_cumulativity_info (univs, variance) = + let subst, univs = abstract_universes univs in + subst, (univs, variance) + +let rec compact_univ s vars i u = + match u with + | [] -> (s, List.rev vars) + | (lvl, _) :: u -> + match Level.var_index lvl with + | Some k when not (LMap.mem lvl s) -> + let lvl' = Level.var i in + compact_univ (LMap.add lvl lvl' s) (k :: vars) (i+1) u + | _ -> compact_univ s vars i u + +let compact_univ u = + let (s, s') = compact_univ LMap.empty [] 0 u in + (subst_univs_level_universe s u, s') (** Pretty-printing *) @@ -1364,13 +1230,16 @@ let explain_universe_inconsistency prl (o,u,v,p) = | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" in let reason = match p with - | None | Some [] -> mt() + | None -> mt() | Some p -> - str " because" ++ spc() ++ pr_uni v ++ + let p = Lazy.force p in + if p = [] then mt () + else + str " because" ++ spc() ++ pr_uni v ++ prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) - p ++ + p ++ (if Universe.equal (snd (List.last p)) u then mt() else - (spc() ++ str "= " ++ pr_uni u)) + (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ pr_rel o ++ spc() ++ pr_uni v ++ reason @@ -1378,19 +1247,3 @@ let explain_universe_inconsistency prl (o,u,v,p) = let compare_levels = Level.compare let eq_levels = Level.equal let equal_universes = Universe.equal - - -let subst_instance_constraints = - if Flags.profile then - let key = Profile.declare_profile "subst_instance_constraints" in - Profile.profile2 key subst_instance_constraints - else subst_instance_constraints - -let subst_instance_context = - let subst_instance_context_body inst (inner_inst, inner_constr) = - (inner_inst, subst_instance_constraints inst inner_constr) - in - if Flags.profile then - let key = Profile.declare_profile "subst_instance_constraints" in - Profile.profile2 key subst_instance_context_body - else subst_instance_context_body diff --git a/kernel/univ.mli b/kernel/univ.mli index d7ee3eceec..b68bbdf359 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -1,13 +1,14 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) (** Universes. *) - module Level : sig type t @@ -20,11 +21,11 @@ sig val is_small : t -> bool (** Is the universe set or prop? *) - + val is_prop : t -> bool val is_set : t -> bool (** Is it specifically Prop or Set *) - + val compare : t -> t -> int (** Comparison function *) @@ -37,7 +38,7 @@ sig (** Create a new universe level from a unique identifier and an associated module path. *) - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t (** Pretty-printing *) val to_string : t -> string @@ -46,21 +47,24 @@ sig val var : int -> t val var_index : t -> int option + + val name : t -> (Names.DirPath.t * int) option end type universe_level = Level.t -(** Alias name. *) +[@@ocaml.deprecated "Use Level.t"] (** Sets of universe levels *) -module LSet : -sig - include CSig.SetS with type elt = universe_level - - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds +module LSet : +sig + include CSig.SetS with type elt = Level.t + + val pr : (Level.t -> Pp.t) -> t -> Pp.t (** Pretty-printing *) end type universe_set = LSet.t +[@@ocaml.deprecated "Use LSet.t"] module Universe : sig @@ -86,10 +90,10 @@ sig val make : Level.t -> t (** Create a universe representing the given level. *) - val pr : t -> Pp.std_ppcmds + val pr : t -> Pp.t (** Pretty-printing *) - val pr_with : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr_with : (Level.t -> Pp.t) -> t -> Pp.t val is_level : t -> bool (** Test if the universe is a level or an algebraic universe. *) @@ -106,83 +110,87 @@ sig val super : t -> t (** The universe strictly above *) - + val sup : t -> t -> t (** The l.u.b. of 2 universes *) - val type0m : t + val type0m : t (** image of Prop in the universes hierarchy *) - - val type0 : t + + val type0 : t (** image of Set in the universes hierarchy *) - - val type1 : t + + val type1 : t (** the universe of the type of Prop/Set *) val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool + + val map : (Level.t * int -> 'a) -> t -> 'a list + end type universe = Universe.t +[@@ocaml.deprecated "Use Universe.t"] (** Alias name. *) -val pr_uni : universe -> Pp.std_ppcmds - -(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... +val pr_uni : Universe.t -> Pp.t + +(** 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 -val type0_univ : universe -val type1_univ : universe +val type0m_univ : Universe.t +val type0_univ : Universe.t +val type1_univ : Universe.t -val is_type0_univ : universe -> bool -val is_type0m_univ : universe -> bool -val is_univ_variable : universe -> bool -val is_small_univ : universe -> bool +val is_type0_univ : Universe.t -> bool +val is_type0m_univ : Universe.t -> bool +val is_univ_variable : Universe.t -> bool +val is_small_univ : Universe.t -> bool -val sup : universe -> universe -> universe -val super : universe -> universe +val sup : Universe.t -> Universe.t -> Universe.t +val super : Universe.t -> Universe.t -val universe_level : universe -> universe_level option +val universe_level : Universe.t -> Level.t option (** [univ_level_mem l u] Is l is mentionned in u ? *) -val univ_level_mem : universe_level -> universe -> bool +val univ_level_mem : Level.t -> Universe.t -> bool (** [univ_level_rem u v min] removes [u] from [v], resulting in [min] if [v] was exactly [u]. *) -val univ_level_rem : universe_level -> universe -> universe -> universe +val univ_level_rem : Level.t -> Universe.t -> Universe.t -> Universe.t (** {6 Constraints. } *) type constraint_type = Lt | Le | Eq -type univ_constraint = universe_level * constraint_type * universe_level +type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig include Set.S with type elt = univ_constraint end type constraints = Constraint.t +[@@ocaml.deprecated "Use Constraint.t"] -val empty_constraint : constraints -val union_constraint : constraints -> constraints -> constraints -val eq_constraint : constraints -> constraints -> bool +val empty_constraint : Constraint.t +val union_constraint : Constraint.t -> Constraint.t -> Constraint.t +val eq_constraint : Constraint.t -> Constraint.t -> bool -(** A value with universe constraints. *) -type 'a constrained = 'a * constraints +(** A value with universe Constraint.t. *) +type 'a constrained = 'a * Constraint.t (** Constrained *) -val constraints_of : 'a constrained -> constraints +val constraints_of : 'a constrained -> Constraint.t -(** Enforcing constraints. *) +(** Enforcing Constraint.t. *) +type 'a constraint_function = 'a -> 'a -> Constraint.t -> Constraint.t -type 'a constraint_function = 'a -> 'a -> constraints -> constraints - -val enforce_eq : universe constraint_function -val enforce_leq : universe constraint_function -val enforce_eq_level : universe_level constraint_function -val enforce_leq_level : universe_level constraint_function +val enforce_eq : Universe.t constraint_function +val enforce_leq : Universe.t constraint_function +val enforce_eq_level : Level.t constraint_function +val enforce_leq_level : Level.t constraint_function (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed @@ -194,19 +202,19 @@ val enforce_leq_level : universe_level constraint_function universes in the path are canonical. Note that each step does not necessarily correspond to an actual constraint, but reflect how the system stores the graph and may result from combination of several - constraints... + Constraint.t... *) -type explanation = (constraint_type * universe) list -type univ_inconsistency = constraint_type * universe * universe * explanation option +type explanation = (constraint_type * Universe.t) list +type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) -module LMap : +module LMap : sig - include CMap.ExtS with type key = universe_level and module Set := LSet + include CMap.ExtS with type key = Level.t and module Set := LSet val union : 'a t -> 'a t -> 'a t (** [union x y] favors the bindings in the first map. *) @@ -218,7 +226,7 @@ sig (** [subst_union x y] favors the bindings of the first map that are [Some], otherwise takes y's bindings. *) - val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds + val pr : ('a -> Pp.t) -> 'a t -> Pp.t (** Pretty-printing *) end @@ -226,18 +234,33 @@ type 'a universe_map = 'a LMap.t (** {6 Substitution} *) -type universe_subst_fn = universe_level -> universe -type universe_level_subst_fn = universe_level -> universe_level +type universe_subst_fn = Level.t -> Universe.t +type universe_level_subst_fn = Level.t -> Level.t (** A full substitution, might involve algebraic universes *) -type universe_subst = universe universe_map -type universe_level_subst = universe_level universe_map +type universe_subst = Universe.t universe_map +type universe_level_subst = Level.t universe_map -val level_subst_of : universe_subst_fn -> universe_level_subst_fn +module Variance : +sig + (** A universe position in the instance given to a cumulative + inductive can be the following. Note there is no Contravariant + case because [forall x : A, B <= forall x : A', B'] requires [A = + A'] as opposed to [A' <= A]. *) + type t = Irrelevant | Covariant | Invariant + + (** [check_subtype x y] holds if variance [y] is also an instance of [x] *) + val check_subtype : t -> t -> bool + + val sup : t -> t -> t + + val pr : t -> Pp.t + +end (** {6 Universe instances} *) -module Instance : +module Instance : sig type t (** A universe instance represents a vector of argument universes @@ -270,7 +293,7 @@ sig val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) - val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds + val pr : (Level.t -> Pp.t) -> ?variance:Variance.t array -> t -> Pp.t (** Pretty-printing, no comments *) val levels : t -> LSet.t @@ -279,115 +302,130 @@ sig end type universe_instance = Instance.t +[@@ocaml.deprecated "Use Instance.t"] + +val enforce_eq_instances : Instance.t constraint_function -val enforce_eq_instances : universe_instance constraint_function +val enforce_eq_variance_instances : Variance.t array -> Instance.t constraint_function +val enforce_leq_variance_instances : Variance.t array -> Instance.t constraint_function -type 'a puniverses = 'a * universe_instance +type 'a puniverses = 'a * Instance.t val out_punivs : 'a puniverses -> 'a val in_punivs : 'a -> 'a puniverses val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool -(** A vector of universe levels with universe constraints, - representiong local universe variables and associated constraints *) +(** A vector of universe levels with universe Constraint.t, + representiong local universe variables and associated Constraint.t *) module UContext : -sig +sig type t val make : Instance.t constrained -> t val empty : t val is_empty : t -> bool - + val instance : t -> Instance.t - val constraints : t -> constraints + val constraints : t -> Constraint.t - val dest : t -> Instance.t * constraints + val dest : t -> Instance.t * Constraint.t (** Keeps the order of the instances *) val union : t -> t -> t - (* the number of universes in the context *) + (** the number of universes in the context *) val size : t -> int end type universe_context = UContext.t +[@@ocaml.deprecated "Use UContext.t"] module AUContext : -sig +sig type t + val repr : t -> UContext.t + (** [repr ctx] is [(Var(0), ... Var(n-1) |= cstr] where [n] is the length of + the context and [cstr] the abstracted Constraint.t. *) + val empty : t + val is_empty : t -> bool + (** Don't use. *) val instance : t -> Instance.t - + val size : t -> int (** Keeps the order of the instances *) val union : t -> t -> t + val instantiate : Instance.t -> t -> Constraint.t + (** Generate the set of instantiated Constraint.t **) + end type abstract_universe_context = AUContext.t +[@@ocaml.deprecated "Use AUContext.t"] -(** Universe info for inductive types: A context of universe levels - with universe constraints, representing local universe variables - and constraints, together with a context of universe levels with - universe constraints, representing conditions for subtyping used - for inductive types. +(** Universe info for cumulative inductive types: A context of + universe levels with universe constraints, representing local + universe variables and constraints, together with an array of + Variance.t. - This data structure maintains the invariant that the context for - subtyping constraints is exactly twice as big as the context for - universe constraints. *) + This data structure maintains the invariant that the variance + array has the same length as the universe instance. *) module CumulativityInfo : sig type t - val make : universe_context * universe_context -> t + val make : UContext.t * Variance.t array -> t val empty : t val is_empty : t -> bool - val univ_context : t -> universe_context - val subtyp_context : t -> universe_context + val univ_context : t -> UContext.t + val variance : t -> Variance.t array (** This function takes a universe context representing constraints - of an inductive and a Instance.t of fresh universe names for the - subtyping (with the same length as the context in the given - universe context) and produces a UInfoInd.t that with the - trivial subtyping relation. *) - val from_universe_context : universe_context -> universe_instance -> t - - val subtyping_susbst : t -> universe_level_subst + of an inductive and produces a CumulativityInfo.t with the + trivial subtyping relation. *) + val from_universe_context : UContext.t -> t + val leq_constraints : t -> Instance.t constraint_function + val eq_constraints : t -> Instance.t constraint_function end type cumulativity_info = CumulativityInfo.t +[@@ocaml.deprecated "Use CumulativityInfo.t"] module ACumulativityInfo : sig type t - val univ_context : t -> abstract_universe_context - val subtyp_context : t -> abstract_universe_context + val univ_context : t -> AUContext.t + val variance : t -> Variance.t array + val leq_constraints : t -> Instance.t constraint_function + val eq_constraints : t -> Instance.t constraint_function end type abstract_cumulativity_info = ACumulativityInfo.t +[@@ocaml.deprecated "Use ACumulativityInfo.t"] (** Universe contexts (as sets) *) module ContextSet : -sig - type t = universe_set constrained +sig + type t = LSet.t constrained val empty : t val is_empty : t -> bool - val singleton : universe_level -> t + val singleton : Level.t -> t val of_instance : Instance.t -> t - val of_set : universe_set -> t + val of_set : LSet.t -> t val equal : t -> t -> bool val union : t -> t -> t @@ -397,38 +435,43 @@ sig much smaller than the right one. *) val diff : t -> t -> t - val add_universe : universe_level -> t -> t - val add_constraints : constraints -> t -> t + val add_universe : Level.t -> t -> t + val add_constraints : Constraint.t -> t -> t val add_instance : Instance.t -> t -> t (** Arbitrary choice of linear order of the variables *) - val to_context : t -> universe_context - val of_context : universe_context -> t + val sort_levels : Level.t array -> Level.t array + val to_context : t -> UContext.t + val of_context : UContext.t -> t - val constraints : t -> constraints - val levels : t -> universe_set + val constraints : t -> Constraint.t + val levels : t -> LSet.t + + (** the number of universes in the context *) + val size : t -> int end -(** A set of universes with universe constraints. - We linearize the set to a list after typechecking. +(** A set of universes with universe Constraint.t. + We linearize the set to a list after typechecking. Beware, representation could change. *) type universe_context_set = ContextSet.t +[@@ocaml.deprecated "Use ContextSet.t"] (** A value in a universe context (resp. context set). *) -type 'a in_universe_context = 'a * universe_context -type 'a in_universe_context_set = 'a * universe_context_set +type 'a in_universe_context = 'a * UContext.t +type 'a in_universe_context_set = 'a * ContextSet.t val empty_level_subst : universe_level_subst val is_empty_level_subst : universe_level_subst -> bool (** Substitution of universes. *) -val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level -val subst_univs_level_universe : universe_level_subst -> universe -> universe -val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints +val subst_univs_level_level : universe_level_subst -> Level.t -> Level.t +val subst_univs_level_universe : universe_level_subst -> Universe.t -> Universe.t +val subst_univs_level_constraints : universe_level_subst -> Constraint.t -> Constraint.t val subst_univs_level_abstract_universe_context : - universe_level_subst -> abstract_universe_context -> abstract_universe_context -val subst_univs_level_instance : universe_level_subst -> universe_instance -> universe_instance + universe_level_subst -> AUContext.t -> AUContext.t +val subst_univs_level_instance : universe_level_subst -> Instance.t -> Instance.t (** Level to universe substitutions. *) @@ -436,63 +479,73 @@ val empty_subst : universe_subst val is_empty_subst : universe_subst -> bool val make_subst : universe_subst -> universe_subst_fn -val subst_univs_universe : universe_subst_fn -> universe -> universe -val subst_univs_constraints : universe_subst_fn -> constraints -> constraints +val subst_univs_universe : universe_subst_fn -> Universe.t -> Universe.t +(** Only user in the kernel is template polymorphism. Ideally we get rid of + this code if it goes away. *) (** Substitution of instances *) -val subst_instance_instance : universe_instance -> universe_instance -> universe_instance -val subst_instance_universe : universe_instance -> universe -> universe -val subst_instance_context : universe_instance -> abstract_universe_context -> universe_context +val subst_instance_instance : Instance.t -> Instance.t -> Instance.t +val subst_instance_universe : Instance.t -> Universe.t -> Universe.t -val make_instance_subst : universe_instance -> universe_level_subst -val make_inverse_instance_subst : universe_instance -> universe_level_subst +val make_instance_subst : Instance.t -> universe_level_subst +(** Creates [u(0) ↦ 0; ...; u(n-1) ↦ n - 1] out of [u(0); ...; u(n - 1)] *) -val abstract_universes : universe_context -> universe_level_subst * abstract_universe_context +val make_inverse_instance_subst : Instance.t -> universe_level_subst -val abstract_cumulativity_info : cumulativity_info -> universe_level_subst * abstract_cumulativity_info +val abstract_universes : UContext.t -> Instance.t * AUContext.t +val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativityInfo.t +(** TODO: move universe abstraction out of the kernel *) -val make_abstract_instance : abstract_universe_context -> universe_instance +val make_abstract_instance : AUContext.t -> Instance.t -(** Get the instantiated graph. *) -val instantiate_univ_context : abstract_universe_context -> universe_context - -(** Get the instantiated graphs for both universe constraints and subtyping constraints. *) -val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info +(** [compact_univ u] remaps local variables in [u] such that their indices become + consecutive. It returns the new universe and the mapping. + Example: compact_univ [(Var 0, i); (Prop, 0); (Var 2; j))] = + [(Var 0,i); (Prop, 0); (Var 1; j)], [0; 2] +*) +val compact_univ : Universe.t -> Universe.t * int list (** {6 Pretty-printing of universes. } *) -val pr_constraint_type : constraint_type -> Pp.std_ppcmds -val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds -val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds -val pr_cumulativity_info : (Level.t -> Pp.std_ppcmds) -> cumulativity_info -> Pp.std_ppcmds -val pr_abstract_universe_context : (Level.t -> Pp.std_ppcmds) -> abstract_universe_context -> Pp.std_ppcmds -val pr_abstract_cumulativity_info : (Level.t -> Pp.std_ppcmds) -> abstract_cumulativity_info -> Pp.std_ppcmds -val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> universe_context_set -> Pp.std_ppcmds -val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> - univ_inconsistency -> Pp.std_ppcmds - -val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds -val pr_universe_subst : universe_subst -> Pp.std_ppcmds +val pr_constraint_type : constraint_type -> Pp.t +val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t +val pr_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> + UContext.t -> Pp.t +val pr_cumulativity_info : (Level.t -> Pp.t) -> CumulativityInfo.t -> Pp.t +val pr_abstract_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> + AUContext.t -> Pp.t +val pr_abstract_cumulativity_info : (Level.t -> Pp.t) -> ACumulativityInfo.t -> Pp.t +val pr_universe_context_set : (Level.t -> Pp.t) -> ContextSet.t -> Pp.t +val explain_universe_inconsistency : (Level.t -> Pp.t) -> + univ_inconsistency -> Pp.t + +val pr_universe_level_subst : universe_level_subst -> Pp.t +val pr_universe_subst : universe_subst -> Pp.t (** {6 Hash-consing } *) -val hcons_univ : universe -> universe -val hcons_constraints : constraints -> constraints -val hcons_universe_set : universe_set -> universe_set -val hcons_universe_context : universe_context -> universe_context -val hcons_abstract_universe_context : abstract_universe_context -> abstract_universe_context -val hcons_universe_context_set : universe_context_set -> universe_context_set -val hcons_cumulativity_info : cumulativity_info -> cumulativity_info -val hcons_abstract_cumulativity_info : abstract_cumulativity_info -> abstract_cumulativity_info +val hcons_univ : Universe.t -> Universe.t +val hcons_constraints : Constraint.t -> Constraint.t +val hcons_universe_set : LSet.t -> LSet.t +val hcons_universe_context : UContext.t -> UContext.t +val hcons_abstract_universe_context : AUContext.t -> AUContext.t +val hcons_universe_context_set : ContextSet.t -> ContextSet.t +val hcons_cumulativity_info : CumulativityInfo.t -> CumulativityInfo.t +val hcons_abstract_cumulativity_info : ACumulativityInfo.t -> ACumulativityInfo.t (******) (* deprecated: use qualified names instead *) -val compare_levels : universe_level -> universe_level -> int -val eq_levels : universe_level -> universe_level -> bool +val compare_levels : Level.t -> Level.t -> int +[@@ocaml.deprecated "Use Level.compare"] + +val eq_levels : Level.t -> Level.t -> bool +[@@ocaml.deprecated "Use Level.equal"] (** deprecated: Equality of formal universe expressions. *) -val equal_universes : universe -> universe -> bool +val equal_universes : Universe.t -> Universe.t -> bool +[@@ocaml.deprecated "Use Universe.equal"] -(** Universes of constraints *) -val universes_of_constraints : constraints -> universe_set +(** Universes of Constraint.t *) +val universes_of_constraints : Constraint.t -> LSet.t +[@@ocaml.deprecated "Use Constraint.universes_of"] diff --git a/kernel/vars.ml b/kernel/vars.ml index d0dad02ece..0f588a6302 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names @@ -133,8 +135,8 @@ let substn_many lamv n c = substrec n c (* -let substkey = Profile.declare_profile "substn_many";; -let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;; +let substkey = CProfile.declare_profile "substn_many";; +let substn_many lamv n c = CProfile.profile3 substkey substn_many lamv n c;; *) let make_subst = function @@ -235,49 +237,6 @@ let subst_vars subst c = substn_vars 1 subst c (** Universe substitutions *) open Constr -let subst_univs_fn_puniverses fn = - let f = Univ.Instance.subst_fn fn in - fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') - -let subst_univs_fn_constr f c = - let changed = ref false in - let fu = Univ.subst_univs_universe f in - let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in - let rec aux t = - match kind t with - | Sort (Sorts.Type u) -> - let u' = fu u in - if u' == u then t else - (changed := true; mkSort (Sorts.sort_of_univ u')) - | Const (c, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkConstU (c, u')) - | Ind (i, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkIndU (i, u')) - | Construct (c, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkConstructU (c, u')) - | _ -> map aux t - in - let c' = aux c in - if !changed then c' else c - -let subst_univs_constr subst c = - if Univ.is_empty_subst subst then c - else - let f = Univ.make_subst subst in - subst_univs_fn_constr f c - -let subst_univs_constr = - if Flags.profile then - let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" in - Profile.profile2 subst_univs_constr_key subst_univs_constr - else subst_univs_constr - let subst_univs_level_constr subst c = if Univ.is_empty_level_subst subst then c else @@ -347,12 +306,9 @@ let subst_instance_constr subst c = in aux c -(* let substkey = Profile.declare_profile "subst_instance_constr";; *) -(* let subst_instance_constr inst c = Profile.profile2 substkey subst_instance_constr inst c;; *) +(* let substkey = CProfile.declare_profile "subst_instance_constr";; *) +(* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else Context.Rel.map (fun x -> subst_instance_constr s x) ctx - -type id_key = constant tableKey -let eq_id_key x y = Names.eq_table_key Constant.equal x y diff --git a/kernel/vars.mli b/kernel/vars.mli index 59dc09a75d..fdddbdb342 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names @@ -68,10 +70,10 @@ type substl = constr list as if usable in [applist] while the substitution is represented the other way round, i.e. ending with either [u₁] or [c₁], as if usable for [substl]. *) -val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl +val subst_of_rel_context_instance : Constr.rel_context -> constr list -> substl (** For compatibility: returns the substitution reversed *) -val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list +val adjust_subst_to_rel_context : Constr.rel_context -> constr list -> constr list (** Take an index in an instance of a context and returns its index wrt to the full context (e.g. 2 in [x:A;y:=b;z:C] is 3, i.e. a reference to z) *) @@ -95,13 +97,13 @@ val subst1 : constr -> constr -> constr accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *) -val substnl_decl : substl -> int -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t +val substnl_decl : substl -> int -> Constr.rel_declaration -> Constr.rel_declaration (** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *) -val substl_decl : substl -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t +val substl_decl : substl -> Constr.rel_declaration -> Constr.rel_declaration (** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *) -val subst1_decl : constr -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t +val subst1_decl : constr -> Constr.rel_declaration -> Constr.rel_declaration (** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by [cj] in [t]. *) @@ -129,20 +131,11 @@ val subst_var : Id.t -> constr -> constr open Univ -val subst_univs_fn_constr : universe_subst_fn -> constr -> constr -val subst_univs_fn_puniverses : universe_level_subst_fn -> - 'a puniverses -> 'a puniverses - -val subst_univs_constr : universe_subst -> constr -> constr - (** Level substitutions for polymorphism. *) val subst_univs_level_constr : universe_level_subst -> constr -> constr -val subst_univs_level_context : Univ.universe_level_subst -> Context.Rel.t -> Context.Rel.t +val subst_univs_level_context : Univ.universe_level_subst -> Constr.rel_context -> Constr.rel_context (** Instance substitution for polymorphism. *) -val subst_instance_constr : universe_instance -> constr -> constr -val subst_instance_context : universe_instance -> Context.Rel.t -> Context.Rel.t - -type id_key = constant tableKey -val eq_id_key : id_key -> id_key -> bool +val subst_instance_constr : Instance.t -> constr -> constr +val subst_instance_context : Instance.t -> Constr.rel_context -> Constr.rel_context diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 0e452621c8..d19bea5199 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -3,11 +3,9 @@ open Names open Environ open Reduction open Vm +open Vmvalues open Csymtable -let val_of_constr env c = - val_of_constr (pre_env env) c - (* Test la structure des piles *) let compare_zipper z1 z2 = @@ -43,7 +41,6 @@ let rec conv_val env pb k v1 v2 cu = and conv_whd env pb k whd1 whd2 cu = (* Pp.(msg_debug (str "conv_whd(" ++ pr_whd whd1 ++ str ", " ++ pr_whd whd2 ++ str ")")) ; *) match whd1, whd2 with - | Vsort s1, Vsort s2 -> sort_cmp_universes env pb s1 s2 cu | Vuniv_level _ , _ | _ , Vuniv_level _ -> (** Both of these are invalid since universes are handled via @@ -80,7 +77,7 @@ and conv_whd env pb k whd1 whd2 cu = (* on the fly eta expansion *) conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu - | Vsort _, _ | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ + | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible @@ -93,7 +90,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = let mib = Environ.lookup_mind mi env in let ulen = match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind ctx -> Univ.UContext.size ctx + | Declarations.Monomorphic_ind ctx -> Univ.ContextSet.size ctx | Declarations.Polymorphic_ind auctx -> Univ.AUContext.size auctx | Declarations.Cumulative_ind cumi -> Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) @@ -115,11 +112,12 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = conv_stack env k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> - if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then + if Vmvalues.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible - | Atype _ , _ | _, Atype _ -> assert false - | Aind _, _ | Aid _, _ -> raise NotConvertible + | Asort s1, Asort s2 -> + sort_cmp_universes env pb s1 s2 cu + | Asort _ , _ | Aind _, _ | Aid _, _ -> raise NotConvertible and conv_stack env k stk1 stk2 cu = match stk1, stk2 with @@ -141,7 +139,7 @@ and conv_stack env k stk1 stk2 cu = conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> - if Constant.equal p1 p2 then conv_stack env k stk1 stk2 cu + if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ | Zproj _ :: _, _ -> raise NotConvertible @@ -184,8 +182,18 @@ and conv_arguments env ?from:(from=0) k args1 args2 cu = !rcu else raise NotConvertible +let warn_bytecode_compiler_failed = + let open Pp in + CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler" + (fun () -> strbrk "Bytecode compiler failed, " ++ + strbrk "falling back to standard conversion") + let vm_conv_gen cv_pb env univs t1 t2 = - try + if not Coq_config.bytecode_compiler then + Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) + full_transparent_state env univs t1 t2 + else + try let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) @@ -203,5 +211,3 @@ let vm_conv cv_pb env t1 t2 = if not b then let univs = (univs, checked_universes) in let _ = vm_conv_gen cv_pb env univs t1 t2 in () - -let _ = Reduction.set_vm_conv vm_conv diff --git a/kernel/vconv.mli b/kernel/vconv.mli index f4e680c690..1a31848989 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -1,13 +1,14 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term -open Environ +open Constr open Reduction (********************************************************************** @@ -17,6 +18,3 @@ val vm_conv : conv_pb -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function - -(** Precompute a VM value from a constr *) -val val_of_constr : env -> constr -> values diff --git a/kernel/vm.ml b/kernel/vm.ml index 6b7a86d6f9..d7eedc226c 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -1,51 +1,20 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names -open Term open Cbytecodes +open Vmvalues external set_drawinstr : unit -> unit = "coq_set_drawinstr" -(******************************************) -(* Utility Functions about Obj ************) -(******************************************) - -external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" -external offset : Obj.t -> int = "coq_offset" - -(*******************************************) -(* Initalization of the abstract machine ***) -(*******************************************) - -external init_vm : unit -> unit = "init_coq_vm" - -let _ = init_vm () - -(*******************************************) -(* Machine code *** ************************) -(*******************************************) - -type tcode -let tcode_of_obj v = ((Obj.obj v):tcode) -let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) - -external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" -external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" -external int_tcode : tcode -> int -> int = "coq_int_tcode" - -external accumulate : unit -> tcode = "accumulate_code" -let accumulate = accumulate () - -external is_accumulate : tcode -> bool = "coq_is_accumulate_code" - let popstop_tbl = ref (Array.init 30 mkPopStopCode) let popstop_code i = @@ -61,107 +30,6 @@ let popstop_code i = let stop = popstop_code 0 -(******************************************************) -(* Abstract data types and utility functions **********) -(******************************************************) - -(* Values of the abstract machine *) -let val_of_obj v = ((Obj.obj v):values) -let crazy_val = (val_of_obj (Obj.repr 0)) - -(* Abstract data *) -type vprod -type vfun -type vfix -type vcofix -type vblock -type arguments - -type vm_env -type vstack = values array - -type vswitch = { - sw_type_code : tcode; - sw_code : tcode; - sw_annot : annot_switch; - sw_stk : vstack; - sw_env : vm_env - } - -(* Representation of values *) -(* + Products : *) -(* - vprod = 0_[ dom | codom] *) -(* dom : values, codom : vfun *) -(* *) -(* + Functions have two representations : *) -(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) -(* C:tcode, fvi : values *) -(* Remark : a function and its environment is the same value. *) -(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) -(* *) -(* + Fixpoints : *) -(* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) -(* One single block to represent all of the fixpoints, each fixpoint *) -(* is the pointer to the field holding the pointer to its code, and *) -(* the infix tag is used to know where the block starts. *) -(* - Partial application follows the scheme of partially applied *) -(* functions. Note: only fixpoints not having been applied to its *) -(* recursive argument are coded this way. When the rec. arg. is *) -(* applied, either it's a constructor and the fix reduces, or it's *) -(* and the fix is coded as an accumulator. *) -(* *) -(* + Cofixpoints : see cbytegen.ml *) -(* *) -(* + vblock's encode (non constant) constructors as in Ocaml, but *) -(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) -(* accumulators. *) -(* *) -(* + vm_env is the type of the machine environments (i.e. a function or *) -(* a fixpoint) *) -(* *) -(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) -(* - representation of [accu] : tag_[....] *) -(* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) -(* -- 10_[accu|proj name] : a projection blocked by an accu *) -(* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) -(* -- 12_[accu|vswitch] : a match blocked by an accu *) -(* -- 13_[fcofix] : a cofix function *) -(* -- 14_[fcofix|val] : a cofix function, val represent the value *) -(* of the function applied to arg1 ... argn *) -(* The [arguments] type, which is abstracted as an array, represents : *) -(* tag[ _ | _ |v1|... | vn] *) -(* Generally the first field is a code pointer. *) - -(* Do not edit this type without editing C code, especially "coq_values.h" *) - -type atom = - | Aid of Vars.id_key - | Aind of inductive - | Atype of Univ.universe - -(* Zippers *) - -type zipper = - | Zapp of arguments - | Zfix of vfix*arguments (* Possibly empty *) - | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) - -type stack = zipper list - -type to_up = values - -type whd = - | Vsort of sorts - | Vprod of vprod - | Vfun of vfun - | Vfix of vfix * arguments option - | Vcofix of vcofix * to_up * arguments option - | Vconstr_const of int - | Vconstr_block of vblock - | Vatom_stk of atom * stack - | Vuniv_level of Univ.universe_level - (************************************************) (* Abstract machine *****************************) (************************************************) @@ -174,392 +42,77 @@ external push_vstack : vstack -> int -> unit = "coq_push_vstack" (* interpreteur *) -external interprete : tcode -> values -> vm_env -> int -> values = - "coq_interprete_ml" - +external coq_interprete : tcode -> values -> atom array -> vm_global -> vm_env -> int -> values = + "coq_interprete_byte" "coq_interprete_ml" +let interprete code v env k = + coq_interprete code v (get_atom_rel ()) (Csymtable.get_global_data ()) env k (* Functions over arguments *) -let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 -let arg args i = - if 0 <= i && i < (nargs args) then - val_of_obj (Obj.field (Obj.repr args) (i+2)) - else invalid_arg - ("Vm.arg size = "^(string_of_int (nargs args))^ - " acces "^(string_of_int i)) (* Apply a value to arguments contained in [vargs] *) let apply_arguments vf vargs = let n = nargs vargs in - if Int.equal n 0 then vf + if Int.equal n 0 then fun_val vf else begin push_ra stop; push_arguments vargs; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + interprete (fun_code vf) (fun_val vf) (fun_env vf) (n - 1) end (* Apply value [vf] to an array of argument values [varray] *) let apply_varray vf varray = let n = Array.length varray in - if Int.equal n 0 then vf + if Int.equal n 0 then fun_val vf else begin push_ra stop; (* The fun code of [vf] will make sure we have enough stack, so we put 0 here. *) push_vstack varray 0; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + interprete (fun_code vf) (fun_val vf) (fun_env vf) (n - 1) end -(*************************************************) -(* Destructors ***********************************) -(*************************************************) - -let uni_lvl_val (v : values) : Univ.universe_level = - let whd = Obj.magic v in - match whd with - | Vuniv_level lvl -> lvl - | _ -> - let pr = - let open Pp in - match whd with - | Vsort _ -> str "Vsort" - | Vprod _ -> str "Vprod" - | Vfun _ -> str "Vfun" - | Vfix _ -> str "Vfix" - | Vcofix _ -> str "Vcofix" - | Vconstr_const i -> str "Vconstr_const" - | Vconstr_block b -> str "Vconstr_block" - | Vatom_stk (a,stk) -> str "Vatom_stk" - | _ -> assert false - in - CErrors.anomaly - Pp.( strbrk "Parsing virtual machine value expected universe level, got " - ++ pr ++ str ".") - -let rec whd_accu a stk = - let stk = - if Int.equal (Obj.size a) 2 then stk - else Zapp (Obj.obj a) :: stk in - let at = Obj.field a 1 in - match Obj.tag at with - | i when Int.equal i type_atom_tag -> - begin match stk with - | [Zapp args] -> - let u = ref (Obj.obj (Obj.field at 0)) in - for i = 0 to nargs args - 1 do - u := Univ.Universe.sup !u (Univ.Universe.make (uni_lvl_val (arg args i))) - done; - Vsort (Type !u) - | _ -> assert false - end - | i when i <= max_atom_tag -> - Vatom_stk(Obj.magic at, stk) - | i when Int.equal i proj_tag -> - let zproj = Zproj (Obj.obj (Obj.field at 0)) in - whd_accu (Obj.field at 1) (zproj :: stk) - | i when Int.equal i fix_app_tag -> - let fa = Obj.field at 1 in - let zfix = - Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in - whd_accu (Obj.field at 0) (zfix :: stk) - | i when Int.equal i switch_tag -> - let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in - whd_accu (Obj.field at 0) (zswitch :: stk) - | i when Int.equal i cofix_tag -> - let vcfx = Obj.obj (Obj.field at 0) in - let to_up = Obj.obj a in - begin match stk with - | [] -> Vcofix(vcfx, to_up, None) - | [Zapp args] -> Vcofix(vcfx, to_up, Some args) - | _ -> assert false - end - | i when Int.equal i cofix_evaluated_tag -> - let vcofix = Obj.obj (Obj.field at 0) in - let res = Obj.obj a in - begin match stk with - | [] -> Vcofix(vcofix, res, None) - | [Zapp args] -> Vcofix(vcofix, res, Some args) - | _ -> assert false - end - | tg -> - CErrors.anomaly - Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") - -external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" - -let whd_val : values -> whd = - fun v -> - let o = Obj.repr v in - if Obj.is_int o then Vconstr_const (Obj.obj o) - else - let tag = Obj.tag o in - if tag = accu_tag then - ( - if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *) - else - if is_accumulate (fun_code o) then whd_accu o [] - else Vprod(Obj.obj o)) - else - if tag = Obj.closure_tag || tag = Obj.infix_tag then - (match kind_of_closure o with - | 0 -> Vfun(Obj.obj o) - | 1 -> Vfix(Obj.obj o, None) - | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) - | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) - | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) - else - Vconstr_block(Obj.obj o) - -(**********************************************) -(* Constructors *******************************) -(**********************************************) - -let obj_of_atom : atom -> Obj.t = - fun a -> - let res = Obj.new_block accu_tag 2 in - Obj.set_field res 0 (Obj.repr accumulate); - Obj.set_field res 1 (Obj.repr a); - res - -(* obj_of_str_const : structured_constant -> Obj.t *) -let rec obj_of_str_const str = - match str with - | Const_sorts s -> Obj.repr (Vsort s) - | Const_ind ind -> obj_of_atom (Aind ind) - | Const_proj p -> Obj.repr p - | Const_b0 tag -> Obj.repr tag - | Const_bn(tag, args) -> - let len = Array.length args in - let res = Obj.new_block tag len in - for i = 0 to len - 1 do - Obj.set_field res i (obj_of_str_const args.(i)) - done; - res - | Const_univ_level l -> Obj.repr (Vuniv_level l) - | Const_type u -> obj_of_atom (Atype u) - -let val_of_obj o = ((Obj.obj o) : values) - -let val_of_str_const str = val_of_obj (obj_of_str_const str) - -let val_of_atom a = val_of_obj (obj_of_atom a) - -let atom_of_proj kn v = - let r = Obj.new_block proj_tag 2 in - Obj.set_field r 0 (Obj.repr kn); - Obj.set_field r 1 (Obj.repr v); - ((Obj.obj r) : atom) - -let val_of_proj kn v = - val_of_atom (atom_of_proj kn v) - -module IdKeyHash = -struct - type t = constant tableKey - let equal = Names.eq_table_key Constant.equal - open Hashset.Combine - let hash = function - | ConstKey c -> combinesmall 1 (Constant.hash c) - | VarKey id -> combinesmall 2 (Id.hash id) - | RelKey i -> combinesmall 3 (Int.hash i) -end - -module KeyTable = Hashtbl.Make(IdKeyHash) - -let idkey_tbl = KeyTable.create 31 - -let val_of_idkey key = - try KeyTable.find idkey_tbl key - with Not_found -> - let v = val_of_atom (Aid key) in - KeyTable.add idkey_tbl key v; - v - -let val_of_rel k = val_of_idkey (RelKey k) - -let val_of_named id = val_of_idkey (VarKey id) - -let val_of_constant c = val_of_idkey (ConstKey c) - -external val_of_annot_switch : annot_switch -> values = "%identity" - let mkrel_vstack k arity = let max = k + arity - 1 in Array.init arity (fun i -> val_of_rel (max - i)) - -(*************************************************) -(** Operations manipulating data types ***********) -(*************************************************) - -(* Functions over products *) - -let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) -let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) - -(* Functions over vfun *) - -external closure_arity : vfun -> int = "coq_closure_arity" - -let body_of_vfun k vf = +let reduce_fun k vf = let vargs = mkrel_vstack k 1 in - apply_varray (Obj.magic vf) vargs + apply_varray vf vargs let decompose_vfun2 k vf1 vf2 = let arity = min (closure_arity vf1) (closure_arity vf2) in assert (0 < arity && arity < Sys.max_array_length); let vargs = mkrel_vstack k arity in - let v1 = apply_varray (Obj.magic vf1) vargs in - let v2 = apply_varray (Obj.magic vf2) vargs in + let v1 = apply_varray vf1 vargs in + let v2 = apply_varray vf2 vargs in arity, v1, v2 -(* Functions over fixpoint *) - -let first o = (offset_closure o (offset o)) -let last o = (Obj.field o (Obj.size o - 1)) - -let current_fix vf = - (offset (Obj.repr vf) / 2) - -let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) - -let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 - -let rec_args vf = - let fb = first (Obj.repr vf) in - let size = Obj.size (last fb) in - Array.init size (unsafe_rec_arg fb) - -exception FALSE - -let check_fix f1 f2 = - let i1, i2 = current_fix f1, current_fix f2 in - (* Checking starting point *) - if i1 = i2 then - let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in - let n = Obj.size (last fb1) in - (* Checking number of definitions *) - if n = Obj.size (last fb2) then - (* Checking recursive arguments *) - try - for i = 0 to n - 1 do - if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i - then raise FALSE - done; - true - with FALSE -> false - else false - else false - (* Functions over vfix *) -external atom_rel : unit -> atom array = "get_coq_atom_tbl" -external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" - -let relaccu_tbl = - let atom_rel = atom_rel() in - let len = Array.length atom_rel in - for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; - ref (Array.init len mkAccuCode) - -let relaccu_code i = - let len = Array.length !relaccu_tbl in - if i < len then !relaccu_tbl.(i) - else - begin - realloc_atom_rel i; - let atom_rel = atom_rel () in - let nl = Array.length atom_rel in - for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; - relaccu_tbl := - Array.init nl - (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); - !relaccu_tbl.(i) - end let reduce_fix k vf = - let fb = first (Obj.repr vf) in + let fb = first_fix vf in (* computing types *) - let fc_typ = ((Obj.obj (last fb)) : tcode array) in + let fc_typ = fix_types fb in let ndef = Array.length fc_typ in - let et = offset_closure fb (2*(ndef - 1)) in + let et = offset_closure_fix fb (2*(ndef - 1)) in let ftyp = Array.map - (fun c -> interprete c crazy_val (Obj.magic et) 0) fc_typ in + (fun c -> interprete c crazy_val et 0) fc_typ in (* Construction of the environment of fix bodies *) - let e = Obj.dup fb in - for i = 0 to ndef - 1 do - Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) - done; - let fix_body i = - let jump_grabrec c = offset_tcode c 2 in - let c = jump_grabrec (unsafe_fb_code fb i) in - let res = Obj.new_block Obj.closure_tag 2 in - Obj.set_field res 0 (Obj.repr c); - Obj.set_field res 1 (offset_closure e (2*i)); - ((Obj.obj res) : vfun) in - (Array.init ndef fix_body, ftyp) - -(* Functions over vcofix *) - -let get_fcofix vcf i = - match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with - | Vcofix(vcfi, _, _) -> vcfi - | _ -> assert false - -let current_cofix vcf = - let ndef = Obj.size (last (Obj.repr vcf)) in - let rec find_cofix pos = - if pos < ndef then - if get_fcofix vcf pos == vcf then pos - else find_cofix (pos+1) - else raise Not_found in - try find_cofix 0 - with Not_found -> assert false - -let check_cofix vcf1 vcf2 = - (current_cofix vcf1 = current_cofix vcf2) && - (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2))) + (mk_fix_body k ndef fb, ftyp) let reduce_cofix k vcf = - let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in + let fc_typ = cofix_types vcf in let ndef = Array.length fc_typ in let ftyp = (* Evaluate types *) - Array.map (fun c -> interprete c crazy_val (Obj.magic vcf) 0) fc_typ in + Array.map (fun c -> interprete c crazy_val (cofix_env vcf) 0) fc_typ in (* Construction of the environment of cofix bodies *) - let e = Obj.dup (Obj.repr vcf) in - for i = 0 to ndef - 1 do - Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) - done; - - let cofix_body i = - let vcfi = get_fcofix vcf i in - let c = Obj.field (Obj.repr vcfi) 0 in - Obj.set_field e 0 c; - let atom = Obj.new_block cofix_tag 1 in - let self = Obj.new_block accu_tag 2 in - Obj.set_field self 0 (Obj.repr accumulate); - Obj.set_field self 1 (Obj.repr atom); - apply_varray (Obj.obj e) [|Obj.obj self|] in - (Array.init ndef cofix_body, ftyp) - - -(* Functions over vblock *) - -let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) -let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) -let bfield b i = - if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i) - else invalid_arg "Vm.bfield" - - -(* Functions over vswitch *) - -let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl - -let case_info sw = sw.sw_annot.ci + (mk_cofix_body apply_varray k ndef vcf, ftyp) let type_of_switch sw = (* The fun code of types will make sure we have enough stack, so we put 0 @@ -567,20 +120,6 @@ let type_of_switch sw = push_vstack sw.sw_stk 0; interprete sw.sw_type_code crazy_val sw.sw_env 0 -let branch_arg k (tag,arity) = - if Int.equal arity 0 then ((Obj.magic tag):values) - else - let b, ofs = - if tag < last_variant_tag then Obj.new_block tag arity, 0 - else - let b = Obj.new_block last_variant_tag (arity+1) in - Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); - b,1 in - for i = ofs to ofs + arity - 1 do - Obj.set_field b i (Obj.repr (val_of_rel (k+i))) - done; - val_of_obj b - let apply_switch sw arg = let tc = sw.sw_annot.tailcall in if tc then @@ -602,8 +141,8 @@ let branch_of_switch k sw = (* t = a stk --> t v *) let rec apply_stack a stk v = match stk with - | [] -> apply_varray a [|v|] - | Zapp args :: stk -> apply_stack (apply_arguments a args) stk v + | [] -> apply_varray (fun_of_val a) [|v|] + | Zapp args :: stk -> apply_stack (apply_arguments (fun_of_val a) args) stk v | Zproj kn :: stk -> apply_stack (val_of_proj kn a) stk v | Zfix(f,args) :: stk -> let a,stk = @@ -614,7 +153,7 @@ let rec apply_stack a stk v = push_val a; push_arguments args; let a = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fix_code f) (fix_val f) (fix_env f) (nargs args+ nargs args') in a, stk | _ -> @@ -622,7 +161,7 @@ let rec apply_stack a stk v = push_val a; push_arguments args; let a = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fix_code f) (fix_val f) (fix_env f) (nargs args) in a, stk in apply_stack a stk v @@ -632,51 +171,22 @@ let rec apply_stack a stk v = let apply_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 + | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false + | Vfun f -> reduce_fun k f | Vfix(f, None) -> push_ra stop; push_val v; - interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0 + interprete (fix_code f) (fix_val f) (fix_env 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) + interprete (fix_code f) (fix_val f) (fix_env 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 + interprete (cofix_upd_code to_up) (cofix_upd_val to_up) (cofix_upd_env to_up) 0 | Vatom_stk(a,stk) -> - apply_stack (val_of_atom a) stk v + apply_stack (val_of_atom a) stk v | Vuniv_level lvl -> assert false -let rec pr_atom a = - Pp.(match a with - | Aid c -> str "Aid(" ++ (match c with - | ConstKey c -> Names.pr_con c - | RelKey i -> str "#" ++ int i - | _ -> str "...") ++ str ")" - | Aind (mi,i) -> str "Aind(" ++ Names.pr_mind mi ++ str "#" ++ int i ++ str ")" - | Atype _ -> str "Atype(") -and pr_whd w = - Pp.(match w with - | Vsort _ -> str "Vsort" - | Vprod _ -> str "Vprod" - | Vfun _ -> str "Vfun" - | Vfix _ -> str "Vfix" - | Vcofix _ -> str "Vcofix" - | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" - | Vconstr_block b -> str "Vconstr_block" - | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" - | Vuniv_level _ -> assert false) -and pr_stack stk = - Pp.(match stk with - | [] -> str "[]" - | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) -and pr_zipper z = - Pp.(match z with - | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" - | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" - | Zswitch s -> str "Zswitch(...)" - | Zproj c -> str "Zproj(" ++ Names.pr_con c ++ str ")") diff --git a/kernel/vm.mli b/kernel/vm.mli index 6e9579aa46..50ebc90626 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -1,115 +1,35 @@ -open Names -open Term -open Cbytecodes +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Vmvalues (** Debug printing *) val set_drawinstr : unit -> unit -(** Machine code *) - -type tcode - -(** Values *) - -type vprod -type vfun -type vfix -type vcofix -type vblock -type vswitch -type arguments - -type atom = - | Aid of Vars.id_key - | Aind of inductive - | Atype of Univ.universe - -(** Zippers *) - -type zipper = - | Zapp of arguments - | Zfix of vfix * arguments (** might be empty *) - | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) - -type stack = zipper list - -type to_up - -type whd = - | Vsort of sorts - | Vprod of vprod - | Vfun of vfun - | Vfix of vfix * arguments option - | Vcofix of vcofix * to_up * arguments option - | Vconstr_const of int - | Vconstr_block of vblock - | Vatom_stk of atom * stack - | Vuniv_level of Univ.universe_level - -(** For debugging purposes only *) - -val pr_atom : atom -> Pp.std_ppcmds -val pr_whd : whd -> Pp.std_ppcmds -val pr_stack : stack -> Pp.std_ppcmds - -(** Constructors *) - -val val_of_str_const : structured_constant -> values -val val_of_rel : int -> values -val val_of_named : Id.t -> values -val val_of_constant : constant -> values - -external val_of_annot_switch : annot_switch -> values = "%identity" - -(** Destructors *) - -val whd_val : values -> whd -val uni_lvl_val : values -> Univ.universe_level - -(** Arguments *) - -val nargs : arguments -> int -val arg : arguments -> int -> values - -(** Product *) - -val dom : vprod -> values -val codom : vprod -> vfun - -(** Function *) - -val body_of_vfun : int -> vfun -> values -val decompose_vfun2 : int -> vfun -> vfun -> int * values * values - -(** 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 *) -(** CoFix *) - -val current_cofix : vcofix -> int -val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array (** bodies , types *) -(** Block *) +val type_of_switch : vswitch -> values -val btag : vblock -> int -val bsize : vblock -> int -val bfield : vblock -> int -> values +val branch_of_switch : int -> vswitch -> (int * values) array -(** Switch *) +val reduce_fun : int -> vfun -> values -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 +(** [decompose_vfun2 k f1 f2] takes two functions [f1] and [f2] at current + DeBruijn level [k], with [n] lambdas in common, returns [n] and the reduced + bodies under those lambdas. *) +val decompose_vfun2 : int -> vfun -> vfun -> int * values * values (** Apply a value *) diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml new file mode 100644 index 0000000000..d6d9312938 --- /dev/null +++ b/kernel/vmvalues.ml @@ -0,0 +1,556 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Names +open Sorts +open Cbytecodes +open Univ + +(*******************************************) +(* Initalization of the abstract machine ***) +(* Necessary for [relaccu_tbl] *) +(*******************************************) + +external init_vm : unit -> unit = "init_coq_vm" + +let _ = init_vm () + +(******************************************************) +(* Abstract data types and utility functions **********) +(******************************************************) + +(* Values of the abstract machine *) +type values +let val_of_obj v = ((Obj.obj v):values) +let crazy_val = (val_of_obj (Obj.repr 0)) + +(* Abstract data *) +type vprod +type vfun +type vfix +type vcofix +type vblock +type arguments + +let fun_val v = (Obj.magic v : values) +let fix_val v = (Obj.magic v : values) +let cofix_upd_val v = (Obj.magic v : values) + +type vm_env +type vm_global +let fun_env v = (Obj.magic v : vm_env) +let fix_env v = (Obj.magic v : vm_env) +let cofix_env v = (Obj.magic v : vm_env) +let cofix_upd_env v = (Obj.magic v : vm_env) +type vstack = values array + +let fun_of_val v = (Obj.magic v : vfun) + +let vm_global (v : values array) = (Obj.magic v : vm_global) + +(*******************************************) +(* Machine code *** ************************) +(*******************************************) + +type tcode +(** A block whose first field is a C-allocated VM bytecode, encoded as char*. + This is compatible with the representation of the Coq VM closures. *) + +type tcode_array + +external mkAccuCode : int -> tcode = "coq_makeaccu" +external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" + +let fun_code v = (Obj.magic v : tcode) +let fix_code = fun_code +let cofix_upd_code = fun_code + + +type vswitch = { + sw_type_code : tcode; + sw_code : tcode; + sw_annot : annot_switch; + sw_stk : vstack; + sw_env : vm_env + } + +(* Representation of values *) +(* + Products : *) +(* - vprod = 0_[ dom | codom] *) +(* dom : values, codom : vfun *) +(* *) +(* + Functions have two representations : *) +(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) +(* C:tcode, fvi : values *) +(* Remark : a function and its environment is the same value. *) +(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) +(* *) +(* + Fixpoints : *) +(* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) +(* One single block to represent all of the fixpoints, each fixpoint *) +(* is the pointer to the field holding the pointer to its code, and *) +(* the infix tag is used to know where the block starts. *) +(* - Partial application follows the scheme of partially applied *) +(* functions. Note: only fixpoints not having been applied to its *) +(* recursive argument are coded this way. When the rec. arg. is *) +(* applied, either it's a constructor and the fix reduces, or it's *) +(* and the fix is coded as an accumulator. *) +(* *) +(* + Cofixpoints : see cbytegen.ml *) +(* *) +(* + vblock's encode (non constant) constructors as in Ocaml, but *) +(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) +(* accumulators. *) +(* *) +(* + vm_env is the type of the machine environments (i.e. a function or *) +(* a fixpoint) *) +(* *) +(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) +(* - representation of [accu] : tag_[....] *) +(* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) +(* -- 10_[accu|proj name] : a projection blocked by an accu *) +(* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) +(* -- 12_[accu|vswitch] : a match blocked by an accu *) +(* -- 13_[fcofix] : a cofix function *) +(* -- 14_[fcofix|val] : a cofix function, val represent the value *) +(* of the function applied to arg1 ... argn *) +(* The [arguments] type, which is abstracted as an array, represents : *) +(* tag[ _ | _ |v1|... | vn] *) +(* Generally the first field is a code pointer. *) + +(* Do not edit this type without editing C code, especially "coq_values.h" *) + +type id_key = +| ConstKey of Constant.t +| VarKey of Id.t +| RelKey of Int.t +| EvarKey of Evar.t + +let eq_id_key k1 k2 = match k1, k2 with +| ConstKey c1, ConstKey c2 -> Constant.equal c1 c2 +| VarKey id1, VarKey id2 -> Id.equal id1 id2 +| RelKey n1, RelKey n2 -> Int.equal n1 n2 +| EvarKey evk1, EvarKey evk2 -> Evar.equal evk1 evk2 +| _ -> false + +type atom = + | Aid of id_key + | Aind of inductive + | Asort of Sorts.t + +(* Zippers *) + +type zipper = + | Zapp of arguments + | Zfix of vfix*arguments (* Possibly empty *) + | Zswitch of vswitch + | Zproj of Projection.Repr.t (* name of the projection *) + +type stack = zipper list + +type to_update = values + +type whd = + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix * arguments option + | Vcofix of vcofix * to_update * arguments option + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack + | Vuniv_level of Univ.Level.t + +(* Functions over arguments *) +let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 +let arg args i = + if 0 <= i && i < (nargs args) then + val_of_obj (Obj.field (Obj.repr args) (i+2)) + else invalid_arg + ("Vm.arg size = "^(string_of_int (nargs args))^ + " acces "^(string_of_int i)) + +(*************************************************) +(* Destructors ***********************************) +(*************************************************) + +let uni_lvl_val (v : values) : Univ.Level.t = + let whd = Obj.magic v in + match whd with + | Vuniv_level lvl -> lvl + | _ -> + let pr = + let open Pp in + match whd with + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk" + | _ -> assert false + in + CErrors.anomaly + Pp.( strbrk "Parsing virtual machine value expected universe level, got " + ++ pr ++ str ".") + +let rec whd_accu a stk = + let stk = + if Int.equal (Obj.size a) 2 then stk + else Zapp (Obj.obj a) :: stk in + let at = Obj.field a 1 in + match Obj.tag at with + | i when Int.equal i type_atom_tag -> + begin match stk with + | [] -> Vatom_stk(Obj.magic at, stk) + | [Zapp args] -> + let args = Array.init (nargs args) (arg args) in + let s = Obj.obj (Obj.field at 0) in + begin match s with + | Type u -> + let inst = Instance.of_array (Array.map uni_lvl_val args) in + let u = Univ.subst_instance_universe inst u in + Vatom_stk (Asort (Type u), []) + | _ -> assert false + end + | _ -> assert false + end + | i when i <= max_atom_tag -> + Vatom_stk(Obj.magic at, stk) + | i when Int.equal i proj_tag -> + let zproj = Zproj (Obj.obj (Obj.field at 0)) in + whd_accu (Obj.field at 1) (zproj :: stk) + | i when Int.equal i fix_app_tag -> + let fa = Obj.field at 1 in + let zfix = + Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in + whd_accu (Obj.field at 0) (zfix :: stk) + | i when Int.equal i switch_tag -> + let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in + whd_accu (Obj.field at 0) (zswitch :: stk) + | i when Int.equal i cofix_tag -> + let vcfx = Obj.obj (Obj.field at 0) in + let to_up = Obj.obj a in + begin match stk with + | [] -> Vcofix(vcfx, to_up, None) + | [Zapp args] -> Vcofix(vcfx, to_up, Some args) + | _ -> assert false + end + | i when Int.equal i cofix_evaluated_tag -> + let vcofix = Obj.obj (Obj.field at 0) in + let res = Obj.obj a in + begin match stk with + | [] -> Vcofix(vcofix, res, None) + | [Zapp args] -> Vcofix(vcofix, res, Some args) + | _ -> assert false + end + | tg -> + CErrors.anomaly + Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") + +external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" +external is_accumulate : tcode -> bool = "coq_is_accumulate_code" +external int_tcode : tcode -> int -> int = "coq_int_tcode" +external accumulate : unit -> tcode = "accumulate_code" +external set_bytecode_field : Obj.t -> int -> tcode -> unit = "coq_set_bytecode_field" +let accumulate = accumulate () + +let whd_val : values -> whd = + fun v -> + let o = Obj.repr v in + if Obj.is_int o then Vconstr_const (Obj.obj o) + else + let tag = Obj.tag o in + if tag = accu_tag then + if is_accumulate (fun_code o) then whd_accu o [] + else Vprod(Obj.obj o) + else + if tag = Obj.closure_tag || tag = Obj.infix_tag then + (match kind_of_closure o with + | 0 -> Vfun(Obj.obj o) + | 1 -> Vfix(Obj.obj o, None) + | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) + | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) + | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + else + Vconstr_block(Obj.obj o) + +(**********************************************) +(* Constructors *******************************) +(**********************************************) + +let obj_of_atom : atom -> Obj.t = + fun a -> + let res = Obj.new_block accu_tag 2 in + set_bytecode_field res 0 accumulate; + Obj.set_field res 1 (Obj.repr a); + res + +(* obj_of_str_const : structured_constant -> Obj.t *) +let rec obj_of_str_const str = + match str with + | Const_sort s -> obj_of_atom (Asort s) + | Const_ind ind -> obj_of_atom (Aind ind) + | Const_b0 tag -> Obj.repr tag + | Const_bn(tag, args) -> + let len = Array.length args in + let res = Obj.new_block tag len in + for i = 0 to len - 1 do + Obj.set_field res i (obj_of_str_const args.(i)) + done; + res + | Const_univ_level l -> Obj.repr (Vuniv_level l) + +let val_of_obj o = ((Obj.obj o) : values) + +let val_of_str_const str = val_of_obj (obj_of_str_const str) + +let val_of_atom a = val_of_obj (obj_of_atom a) + +let atom_of_proj kn v = + let r = Obj.new_block proj_tag 2 in + Obj.set_field r 0 (Obj.repr kn); + Obj.set_field r 1 (Obj.repr v); + ((Obj.obj r) : atom) + +let val_of_proj kn v = + val_of_atom (atom_of_proj kn v) + +module IdKeyHash = +struct + type t = id_key + let equal = eq_id_key + open Hashset.Combine + let hash = function + | ConstKey c -> combinesmall 1 (Constant.hash c) + | VarKey id -> combinesmall 2 (Id.hash id) + | RelKey i -> combinesmall 3 (Int.hash i) + | EvarKey evk -> combinesmall 4 (Evar.hash evk) +end + +module KeyTable = Hashtbl.Make(IdKeyHash) + +let idkey_tbl = KeyTable.create 31 + +let val_of_idkey key = + try KeyTable.find idkey_tbl key + with Not_found -> + let v = val_of_atom (Aid key) in + KeyTable.add idkey_tbl key v; + v + +let val_of_rel k = val_of_idkey (RelKey k) + +let val_of_named id = val_of_idkey (VarKey id) + +let val_of_constant c = val_of_idkey (ConstKey c) + +let val_of_evar evk = val_of_idkey (EvarKey evk) + +external val_of_annot_switch : annot_switch -> values = "%identity" +external val_of_proj_name : Projection.Repr.t -> values = "%identity" + +(*************************************************) +(** Operations manipulating data types ***********) +(*************************************************) + +(* Functions over products *) + +let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) +let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) + +(* Functions over vfun *) + +external closure_arity : vfun -> int = "coq_closure_arity" + +(* Functions over fixpoint *) + +external offset : Obj.t -> int = "coq_offset" +external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" +external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" +external tcode_array : tcode_array -> tcode array = "coq_tcode_array" + +let first o = (offset_closure o (offset o)) +let first_fix (v:vfix) = (Obj.magic (first (Obj.repr v)) : vfix) + +let last o = (Obj.field o (Obj.size o - 1)) +let fix_types (v:vfix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array) +let cofix_types (v:vcofix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array) + +let current_fix vf = - (offset (Obj.repr vf) / 2) + +let unsafe_fb_code fb i = + let off = (2 * i) * (Sys.word_size / 8) in + Obj.obj (Obj.add_offset (Obj.repr fb) (Int32.of_int off)) + +let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 + +let rec_args vf = + let fb = first (Obj.repr vf) in + let size = Obj.size (last fb) in + Array.init size (unsafe_rec_arg fb) + +exception FALSE + +let check_fix f1 f2 = + let i1, i2 = current_fix f1, current_fix f2 in + (* Checking starting point *) + if i1 = i2 then + let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in + let n = Obj.size (last fb1) in + (* Checking number of definitions *) + if n = Obj.size (last fb2) then + (* Checking recursive arguments *) + try + for i = 0 to n - 1 do + if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i + then raise FALSE + done; + true + with FALSE -> false + else false + else false + +let atom_rel : atom array ref = + let init i = Aid (RelKey i) in + ref (Array.init 40 init) + +let get_atom_rel () = !atom_rel + +let realloc_atom_rel n = + let n = min (2 * n + 0x100) Sys.max_array_length in + let init i = Aid (RelKey i) in + let ans = Array.init n init in + atom_rel := ans + +let relaccu_tbl = + let len = Array.length !atom_rel in + ref (Array.init len mkAccuCode) + +let relaccu_code i = + let len = Array.length !relaccu_tbl in + if i < len then !relaccu_tbl.(i) + else + begin + realloc_atom_rel i; + let nl = Array.length !atom_rel in + relaccu_tbl := + Array.init nl + (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); + !relaccu_tbl.(i) + end + +let mk_fix_body k ndef fb = + let e = Obj.dup (Obj.repr fb) in + for i = 0 to ndef - 1 do + set_bytecode_field e (2 * i) (relaccu_code (k + i)) + done; + let fix_body i = + let c = offset_tcode (unsafe_fb_code fb i) 2 in + let res = Obj.new_block Obj.closure_tag 2 in + set_bytecode_field res 0 c; + Obj.set_field res 1 (offset_closure e (2*i)); + ((Obj.obj res) : vfun) in + Array.init ndef fix_body + +(* Functions over vcofix *) + +let get_fcofix vcf i = + match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with + | Vcofix(vcfi, _, _) -> vcfi + | _ -> assert false + +let current_cofix vcf = + let ndef = Obj.size (last (Obj.repr vcf)) in + let rec find_cofix pos = + if pos < ndef then + if get_fcofix vcf pos == vcf then pos + else find_cofix (pos+1) + else raise Not_found in + try find_cofix 0 + with Not_found -> assert false + +let check_cofix vcf1 vcf2 = + (current_cofix vcf1 = current_cofix vcf2) && + (Obj.size (last (Obj.repr vcf1)) = Obj.size (last (Obj.repr vcf2))) + +let mk_cofix_body apply_varray k ndef vcf = + let e = Obj.dup (Obj.repr vcf) in + for i = 0 to ndef - 1 do + Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) + done; + + let cofix_body i = + let vcfi = get_fcofix vcf i in + let c = Obj.field (Obj.repr vcfi) 0 in + Obj.set_field e 0 c; + let atom = Obj.new_block cofix_tag 1 in + let self = Obj.new_block accu_tag 2 in + set_bytecode_field self 0 accumulate; + Obj.set_field self 1 (Obj.repr atom); + apply_varray (Obj.obj e) [|Obj.obj self|] in + Array.init ndef cofix_body + +(* Functions over vblock *) + +let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) +let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) +let bfield b i = + if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i) + else invalid_arg "Vm.bfield" + + +(* Functions over vswitch *) + +let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl + +let branch_arg k (tag,arity) = + if Int.equal arity 0 then ((Obj.magic tag):values) + else + let b, ofs = + if tag < last_variant_tag then Obj.new_block tag arity, 0 + else + let b = Obj.new_block last_variant_tag (arity+1) in + Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); + b,1 in + for i = ofs to ofs + arity - 1 do + Obj.set_field b i (Obj.repr (val_of_rel (k+i))) + done; + val_of_obj b + +(* Printing *) + +let rec pr_atom a = + Pp.(match a with + | Aid c -> str "Aid(" ++ (match c with + | ConstKey c -> Constant.print c + | RelKey i -> str "#" ++ int i + | _ -> str "...") ++ str ")" + | Aind (mi,i) -> str "Aind(" ++ MutInd.print mi ++ str "#" ++ int i ++ str ")" + | Asort _ -> str "Asort(") +and pr_whd w = + Pp.(match w with + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" + | Vuniv_level _ -> assert false) +and pr_stack stk = + Pp.(match stk with + | [] -> str "[]" + | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) +and pr_zipper z = + Pp.(match z with + | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" + | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" + | Zswitch s -> str "Zswitch(...)" + | Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")") diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli new file mode 100644 index 0000000000..6eedcf1d37 --- /dev/null +++ b/kernel/vmvalues.mli @@ -0,0 +1,161 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Cbytecodes + +(** Values *) + +type values +type vm_env +type vm_global +type vprod +type vfun +type vfix +type vcofix +type vblock +type arguments +type vstack = values array +type to_update + +val fun_val : vfun -> values +val fix_val : vfix -> values +val cofix_upd_val : to_update -> values + +val fun_env : vfun -> vm_env +val fix_env : vfix -> vm_env +val cofix_env : vcofix -> vm_env +val cofix_upd_env : to_update -> vm_env + +val vm_global : values array -> vm_global + +(** Cast a value known to be a function, unsafe in general *) +val fun_of_val : values -> vfun + +val crazy_val : values + +(** Machine code *) + +type tcode + +type vswitch = { + sw_type_code : tcode; + sw_code : tcode; + sw_annot : annot_switch; + sw_stk : vstack; + sw_env : vm_env + } + +external mkAccuCode : int -> tcode = "coq_makeaccu" + +val fun_code : vfun -> tcode +val fix_code : vfix -> tcode +val cofix_upd_code : to_update -> tcode + +type id_key = +| ConstKey of Constant.t +| VarKey of Id.t +| RelKey of Int.t +| EvarKey of Evar.t + +val eq_id_key : id_key -> id_key -> bool + +type atom = + | Aid of id_key + | Aind of inductive + | Asort of Sorts.t + +val get_atom_rel : unit -> atom array +(** Global table of rels *) + +(** Zippers *) + +type zipper = + | Zapp of arguments + | Zfix of vfix * arguments (** might be empty *) + | Zswitch of vswitch + | Zproj of Projection.Repr.t (* name of the projection *) + +type stack = zipper list + +type whd = + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix * arguments option + | Vcofix of vcofix * to_update * arguments option + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack + | Vuniv_level of Univ.Level.t + +(** For debugging purposes only *) + +val pr_atom : atom -> Pp.t +val pr_whd : whd -> Pp.t +val pr_stack : stack -> Pp.t + +(** Constructors *) + +val val_of_str_const : structured_constant -> values +val val_of_rel : int -> values +val val_of_named : Id.t -> values +val val_of_constant : Constant.t -> values +val val_of_evar : Evar.t -> values +val val_of_proj : Projection.Repr.t -> values -> values +val val_of_atom : atom -> values + +external val_of_annot_switch : annot_switch -> values = "%identity" +external val_of_proj_name : Projection.Repr.t -> values = "%identity" + +(** Destructors *) + +val whd_val : values -> whd +val uni_lvl_val : values -> Univ.Level.t + +(** Arguments *) + +val nargs : arguments -> int +val arg : arguments -> int -> values + +(** Product *) + +val dom : vprod -> values +val codom : vprod -> vfun + +(** Fun *) +external closure_arity : vfun -> int = "coq_closure_arity" + +(** Fix *) + +val current_fix : vfix -> int +val check_fix : vfix -> vfix -> bool +val rec_args : vfix -> int array +val first_fix : vfix -> vfix +val fix_types : vfix -> tcode array +val cofix_types : vcofix -> tcode array +external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" +val mk_fix_body : int -> int -> vfix -> vfun array + +(** CoFix *) + +val current_cofix : vcofix -> int +val check_cofix : vcofix -> vcofix -> bool +val mk_cofix_body : (vfun -> vstack -> values) -> int -> int -> vcofix -> values array + +(** Block *) + +val btag : vblock -> int +val bsize : vblock -> int +val bfield : vblock -> int -> values + +(** Switch *) + +val check_switch : vswitch -> vswitch -> bool +val branch_arg : int -> Cbytecodes.tag * int -> values |