From 3ef7797ef6fc605dfafb32523261fe1b023aeecb Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Fri, 28 Apr 2006 14:59:16 +0000 Subject: Imported Upstream version 8.0pl3+8.1alpha --- kernel/byterun/coq_fix_code.c | 166 +++++++ kernel/byterun/coq_fix_code.h | 34 ++ kernel/byterun/coq_gc.h | 48 +++ kernel/byterun/coq_instruct.h | 39 ++ kernel/byterun/coq_interp.c | 974 ++++++++++++++++++++++++++++++++++++++++++ kernel/byterun/coq_interp.h | 23 + kernel/byterun/coq_memory.c | 273 ++++++++++++ kernel/byterun/coq_memory.h | 70 +++ kernel/byterun/coq_values.c | 69 +++ kernel/byterun/coq_values.h | 28 ++ kernel/cbytecodes.ml | 120 ++++++ kernel/cbytecodes.mli | 61 +++ kernel/cbytegen.ml | 490 +++++++++++++++++++++ kernel/cbytegen.mli | 17 + kernel/cemitcodes.ml | 303 +++++++++++++ kernel/cemitcodes.mli | 40 ++ kernel/closure.ml | 95 ++-- kernel/closure.mli | 18 +- kernel/conv_oracle.ml | 17 +- kernel/conv_oracle.mli | 6 +- kernel/cooking.ml | 228 ++++------ kernel/cooking.mli | 21 +- kernel/csymtable.ml | 179 ++++++++ kernel/csymtable.mli | 8 + kernel/declarations.ml | 193 ++++++--- kernel/declarations.mli | 140 ++++-- kernel/entries.ml | 15 +- kernel/entries.mli | 16 +- kernel/environ.ml | 223 ++++++---- kernel/environ.mli | 70 ++- kernel/esubst.ml | 2 +- kernel/esubst.mli | 2 +- kernel/indtypes.ml | 268 +++++++----- kernel/indtypes.mli | 8 +- kernel/inductive.ml | 197 +++++++-- kernel/inductive.mli | 30 +- kernel/make-opcodes | 2 + kernel/mod_subst.ml | 260 +++++++++++ kernel/mod_subst.mli | 80 ++++ kernel/mod_typing.ml | 67 ++- kernel/mod_typing.mli | 4 +- kernel/modops.ml | 77 +++- kernel/modops.mli | 8 +- kernel/names.ml | 133 +++--- kernel/names.mli | 75 ++-- kernel/pre_env.ml | 146 +++++++ kernel/pre_env.mli | 86 ++++ kernel/reduction.ml | 41 +- kernel/reduction.mli | 19 +- kernel/safe_typing.ml | 17 +- kernel/safe_typing.mli | 7 +- kernel/sign.ml | 31 +- kernel/sign.mli | 5 +- kernel/subtyping.ml | 135 +++--- kernel/subtyping.mli | 2 +- kernel/term.ml | 190 ++++---- kernel/term.mli | 36 +- kernel/term_typing.ml | 41 +- kernel/term_typing.mli | 8 +- kernel/type_errors.ml | 6 +- kernel/type_errors.mli | 4 +- kernel/typeops.ml | 158 ++++--- kernel/typeops.mli | 8 +- kernel/univ.ml | 406 +++++++++++------- kernel/univ.mli | 20 +- kernel/vconv.ml | 555 ++++++++++++++++++++++++ kernel/vconv.mli | 46 ++ kernel/vm.ml | 601 ++++++++++++++++++++++++++ kernel/vm.mli | 109 +++++ 69 files changed, 6643 insertions(+), 1231 deletions(-) create mode 100644 kernel/byterun/coq_fix_code.c create mode 100644 kernel/byterun/coq_fix_code.h create mode 100644 kernel/byterun/coq_gc.h create mode 100644 kernel/byterun/coq_instruct.h create mode 100644 kernel/byterun/coq_interp.c create mode 100644 kernel/byterun/coq_interp.h create mode 100644 kernel/byterun/coq_memory.c create mode 100644 kernel/byterun/coq_memory.h create mode 100644 kernel/byterun/coq_values.c create mode 100644 kernel/byterun/coq_values.h create mode 100644 kernel/cbytecodes.ml create mode 100644 kernel/cbytecodes.mli create mode 100644 kernel/cbytegen.ml create mode 100644 kernel/cbytegen.mli create mode 100644 kernel/cemitcodes.ml create mode 100644 kernel/cemitcodes.mli create mode 100644 kernel/csymtable.ml create mode 100644 kernel/csymtable.mli create mode 100644 kernel/make-opcodes create mode 100644 kernel/mod_subst.ml create mode 100644 kernel/mod_subst.mli create mode 100644 kernel/pre_env.ml create mode 100644 kernel/pre_env.mli create mode 100644 kernel/vconv.ml create mode 100644 kernel/vconv.mli create mode 100644 kernel/vm.ml create mode 100644 kernel/vm.mli (limited to 'kernel') diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c new file mode 100644 index 00000000..4616580d --- /dev/null +++ b/kernel/byterun/coq_fix_code.c @@ -0,0 +1,166 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#include +#include +#include "config.h" +#include "misc.h" +#include "mlvalues.h" +#include "fail.h" +#include "memory.h" +#include "coq_instruct.h" +#include "coq_fix_code.h" + +#ifdef THREADED_CODE +char ** coq_instr_table; +char * coq_instr_base; +int arity[STOP+1]; + +void init_arity () { + /* instruction with zero operand */ + arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= + arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= + arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]=arity[PUSHACC6]= + arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]=arity[ENVACC4]= + arity[PUSHENVACC1]=arity[PUSHENVACC2]=arity[PUSHENVACC3]=arity[PUSHENVACC4]= + arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[RESTART]=arity[OFFSETCLOSUREM2]= + arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]= + arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]= + arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= + arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= + arity[ACCUMULATE]=arity[STOP]=arity[FORCE]=arity[MAKEPROD]= 0; + /* instruction with one operand */ + arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= + arity[PUSH_RETADDR]= + arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]=arity[APPTERM3]=arity[RETURN]= + arity[GRAB]=arity[COGRAB]= + arity[OFFSETCLOSURE]=arity[PUSHOFFSETCLOSURE]= + arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= + arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEACCU]= + arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=arity[PUSHFIELD]= + arity[ACCUMULATECOND]= 1; + /* instruction with two operands */ + arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=2; + /* instruction with four operands */ + arity[MAKESWITCHBLOCK]=4; + /* instruction with arbitrary operands */ + arity[CLOSUREREC]=arity[SWITCH]=0; +} + +#endif /* THREADED_CODE */ + + +void * coq_stat_alloc (asize_t sz) +{ + void * result = malloc (sz); + if (result == NULL) raise_out_of_memory (); + return result; +} + +value coq_makeaccu (value i) { + code_t q; + code_t res = coq_stat_alloc(8); + q = res; + *q++ = VALINSTR(MAKEACCU); + *q = (opcode_t)Int_val(i); + return (value)res; +} + +value coq_accucond (value i) { + code_t q; + code_t res = coq_stat_alloc(8); + q = res; + *q++ = VALINSTR(ACCUMULATECOND); + *q = (opcode_t)Int_val(i); + return (value)res; +} + +value coq_pushpop (value i) { + code_t res; + int n; + n = Int_val(i); + if (n == 0) { + res = coq_stat_alloc(4); + *res = VALINSTR(STOP); + return (value)res; + } + else { + code_t q; + res = coq_stat_alloc(12); + q = res; + *q++ = VALINSTR(POP); + *q++ = (opcode_t)n; + *q = VALINSTR(STOP); + return (value)res; + } +} + +value coq_is_accumulate_code(value code){ + code_t q; + int res; + q = (code_t)code; + res = Is_instruction(q,ACCUMULATECOND) || Is_instruction(q,ACCUMULATE); + return Val_bool(res); +} + +#ifdef ARCH_BIG_ENDIAN +#define Reverse_32(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[3]; \ + _q[1] = _p[2]; \ + _q[3] = _a; \ + _q[2] = _b; \ +} +#define COPY32(dst,src) Reverse_32(dst,src) +#else +#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; + len /= sizeof(opcode_t); + for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { + opcode_t instr; + COPY32(&instr,p); + p++; + if (instr < 0 || instr > STOP){ + instr = STOP; + }; + *q++ = VALINSTR(instr); + if (instr == SWITCH) { + uint32 i, sizes, const_size, block_size; + COPY32(q,p); p++; + sizes=*q++; + const_size = sizes & 0xFFFF; + block_size = sizes >> 16; + sizes = const_size + block_size; + for(i=0; i +#include "coq_gc.h" +#include "coq_instruct.h" +#include "coq_fix_code.h" +#include "coq_memory.h" +#include "coq_values.h" + + +/* Registers for the abstract machine: + pc the code pointer + sp the stack pointer (grows downward) + accu the accumulator + env heap-allocated environment + trapsp pointer to the current trap frame + extra_args number of extra arguments provided by the caller + +sp is a local copy of the global variable extern_sp. */ + + + +/* Instruction decoding */ + + +#ifdef THREADED_CODE +# define Instruct(name) coq_lbl_##name: +# if defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +# define coq_Jumptbl_base ((char *) &&coq_lbl_ACC0) +# else +# define coq_Jumptbl_base ((char *) 0) +# define coq_jumptbl_base ((char *) 0) +# endif +# ifdef DEBUG +# define Next goto next_instr +# else +# ifdef __ia64__ +# define Next goto *(void *)(coq_jumptbl_base + *((uint32 *) pc)++) +# else +# define Next goto *(void *)(coq_jumptbl_base + *pc++) +# endif +# endif +#else +# define Instruct(name) case name: +# define Next break +#endif + +/* #define _COQ_DEBUG_ */ + +#ifdef _COQ_DEBUG_ +# define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s) +# define print_int(i) /*if (drawinstr)*/ printf("%d\n",i) +# else +# define print_instr(s) +# define print_int(i) +#endif + +/* GC interface */ +#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } +#define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } + + +/* Register optimization. + Some compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, Xavier Leroy have hand-assigned hardware registers for + several architectures. +*/ + +#if defined(__GNUC__) && !defined(DEBUG) +#ifdef __mips__ +#define PC_REG asm("$16") +#define SP_REG asm("$17") +#define ACCU_REG asm("$18") +#endif +#ifdef __sparc__ +#define PC_REG asm("%l0") +#define SP_REG asm("%l1") +#define ACCU_REG asm("%l2") +#endif +#ifdef __alpha__ +#ifdef __CRAY__ +#define PC_REG asm("r9") +#define SP_REG asm("r10") +#define ACCU_REG asm("r11") +#define JUMPTBL_BASE_REG asm("r12") +#else +#define PC_REG asm("$9") +#define SP_REG asm("$10") +#define ACCU_REG asm("$11") +#define JUMPTBL_BASE_REG asm("$12") +#endif +#endif +#ifdef __i386__ +#define PC_REG asm("%esi") +#define SP_REG asm("%edi") +#define ACCU_REG +#endif +#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#define PC_REG asm("26") +#define SP_REG asm("27") +#define ACCU_REG asm("28") +#endif +#ifdef __hppa__ +#define PC_REG asm("%r18") +#define SP_REG asm("%r17") +#define ACCU_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define PC_REG asm("a5") +#define SP_REG asm("a4") +#define ACCU_REG asm("d7") +#endif +#ifdef __arm__ +#define PC_REG asm("r9") +#define SP_REG asm("r8") +#define ACCU_REG asm("r7") +#endif +#ifdef __ia64__ +#define PC_REG asm("36") +#define SP_REG asm("37") +#define ACCU_REG asm("38") +#define JUMPTBL_BASE_REG asm("39") +#endif +#endif + +/* The interpreter itself */ + +value coq_interprete +(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args) +{ + /*Declaration des variables */ +#ifdef PC_REG + register code_t pc PC_REG; + register value * sp SP_REG; + register value accu ACCU_REG; +#else + register code_t pc; + register value * sp; + register value accu; +#endif +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) +#ifdef JUMPTBL_BASE_REG + register char * coq_jumptbl_base JUMPTBL_BASE_REG; +#else + register char * coq_jumptbl_base; +#endif +#endif +#ifdef THREADED_CODE + static void * coq_jumptable[] = { +# include "coq_jumptbl.h" + }; +#else + opcode_t curr_instr; +#endif + print_instr("Enter Interpreter"); + if (coq_pc == NULL) { /* Interpreter is initializing */ + print_instr("Interpreter is initializing"); +#ifdef THREADED_CODE + coq_instr_table = (char **) coq_jumptable; + coq_instr_base = coq_Jumptbl_base; +#endif + return Val_unit; + } +#if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) + coq_jumptbl_base = coq_Jumptbl_base; +#endif + + /* Initialisation */ + sp = coq_sp; + pc = coq_pc; + accu = coq_accu; +#ifdef THREADED_CODE + goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */ +#else + while(1) { + curr_instr = *pc++; + switch(curr_instr) { +#endif +/* Basic stack operations */ + + Instruct(ACC0){ + print_instr("ACC0"); + accu = sp[0]; Next; + } + Instruct(ACC1){ + print_instr("ACC1"); + accu = sp[1]; Next; + } + Instruct(ACC2){ + print_instr("ACC2"); + accu = sp[2]; Next; + } + Instruct(ACC3){ + print_instr("ACC3"); + accu = sp[3]; Next; + } + Instruct(ACC4){ + print_instr("ACC4"); + accu = sp[4]; Next; + } + Instruct(ACC5){ + print_instr("ACC5"); + accu = sp[5]; Next; + } + Instruct(ACC6){ + print_instr("ACC6"); + accu = sp[6]; Next; + } + Instruct(ACC7){ + print_instr("ACC7"); + accu = sp[7]; Next; + } + Instruct(PUSH){ + print_instr("PUSH"); + *--sp = accu; Next; + } + Instruct(PUSHACC0) { + print_instr("PUSHACC0"); + *--sp = accu; Next; + } + Instruct(PUSHACC1){ + print_instr("PUSHACC1"); + *--sp = accu; accu = sp[1]; Next; + } + Instruct(PUSHACC2){ + print_instr("PUSHACC2"); + *--sp = accu; accu = sp[2]; Next; + } + Instruct(PUSHACC3){ + print_instr("PUSHACC3"); + *--sp = accu; accu = sp[3]; Next; + } + Instruct(PUSHACC4){ + print_instr("PUSHACC4"); + *--sp = accu; accu = sp[4]; Next; + } + Instruct(PUSHACC5){ + print_instr("PUSHACC5"); + *--sp = accu; accu = sp[5]; Next; + } + Instruct(PUSHACC6){ + print_instr("PUSHACC5"); + *--sp = accu; accu = sp[6]; Next; + } + Instruct(PUSHACC7){ + print_instr("PUSHACC7"); + *--sp = accu; accu = sp[7]; Next; + } + Instruct(PUSHACC){ + print_instr("PUSHACC"); + *--sp = accu; + } + /* Fallthrough */ + + Instruct(ACC){ + print_instr("ACC"); + accu = sp[*pc++]; + Next; + } + + Instruct(POP){ + print_instr("POP"); + sp += *pc++; + Next; + } + /* Access in heap-allocated environment */ + + Instruct(ENVACC1){ + print_instr("ENVACC1"); + accu = Field(coq_env, 1); Next; + } + Instruct(ENVACC2){ + print_instr("ENVACC2"); + accu = Field(coq_env, 2); Next; + } + Instruct(ENVACC3){ + print_instr("ENVACC3"); + accu = Field(coq_env, 3); Next; + } + Instruct(ENVACC4){ + print_instr("ENVACC4"); + accu = Field(coq_env, 4); Next; + } + Instruct(PUSHENVACC1){ + print_instr("PUSHENVACC1"); + *--sp = accu; accu = Field(coq_env, 1); Next; + } + Instruct(PUSHENVACC2){ + print_instr("PUSHENVACC2"); + *--sp = accu; accu = Field(coq_env, 2); Next; + } + Instruct(PUSHENVACC3){ + print_instr("PUSHENVACC3"); + *--sp = accu; accu = Field(coq_env, 3); Next; + } + Instruct(PUSHENVACC4){ + print_instr("PUSHENVACC4"); + *--sp = accu; accu = Field(coq_env, 4); Next; + } + Instruct(PUSHENVACC){ + print_instr("PUSHENVACC"); + *--sp = accu; + } + /* Fallthrough */ + Instruct(ENVACC){ + print_instr("ENVACC"); + accu = Field(coq_env, *pc++); + Next; + } + /* Function application */ + + Instruct(PUSH_RETADDR) { + print_instr("PUSH_RETADDR"); + sp -= 3; + sp[0] = (value) (pc + *pc); + sp[1] = coq_env; + sp[2] = Val_long(coq_extra_args); + coq_extra_args = 0; + pc++; + Next; + } + Instruct(APPLY) { + print_instr("APPLY"); + coq_extra_args = *pc - 1; + pc = Code_val(accu); + coq_env = accu; + goto check_stacks; + } + Instruct(APPLY1) { + value arg1 = sp[0]; + print_instr("APPLY1"); + sp -= 3; + sp[0] = arg1; + sp[1] = (value)pc; + sp[2] = coq_env; + sp[3] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 0; + goto check_stacks; + } + Instruct(APPLY2) { + value arg1 = sp[0]; + value arg2 = sp[1]; + print_instr("APPLY2"); + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = (value)pc; + sp[3] = coq_env; + sp[4] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 1; + goto check_stacks; + } + Instruct(APPLY3) { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + print_instr("APPLY3"); + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = (value)pc; + sp[4] = coq_env; + sp[5] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 2; + goto check_stacks; + } + + Instruct(APPTERM) { + int nargs = *pc++; + int slotsize = *pc; + value * newsp; + int i; + print_instr("APPTERM"); + /* Slide the nargs bottom words of the current frame to the top + of the frame, and discard the remainder of the frame */ + newsp = sp + slotsize - nargs; + for (i = nargs - 1; i >= 0; i--) newsp[i] = sp[i]; + sp = newsp; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += nargs - 1; + goto check_stacks; + } + Instruct(APPTERM1) { + value arg1 = sp[0]; + print_instr("APPTERM1"); + sp = sp + *pc - 1; + sp[0] = arg1; + pc = Code_val(accu); + coq_env = accu; + goto check_stacks; + } + Instruct(APPTERM2) { + value arg1 = sp[0]; + value arg2 = sp[1]; + print_instr("APPTERM2"); + sp = sp + *pc - 2; + sp[0] = arg1; + sp[1] = arg2; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += 1; + goto check_stacks; + } + Instruct(APPTERM3) { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + print_instr("APPTERM3"); + sp = sp + *pc - 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + pc = Code_val(accu); + coq_env = accu; + coq_extra_args += 2; + goto check_stacks; + } + + Instruct(RETURN) { + print_instr("RETURN"); + sp += *pc++; + if (coq_extra_args > 0) { + coq_extra_args--; + pc = Code_val(accu); + coq_env = accu; + } else { + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(RESTART) { + int num_args = Wosize_val(coq_env) - 2; + int i; + print_instr("RESTART"); + sp -= num_args; + for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); + coq_env = Field(coq_env, 1); + coq_extra_args += num_args; + Next; + } + + Instruct(GRAB) { + int required = *pc++; + print_instr("GRAB"); + /* printf("GRAB %d\n",required); */ + if (coq_extra_args >= required) { + coq_extra_args -= required; + } else { + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + + Instruct(COGRAB){ + int required = *pc++; + print_instr("COGRAB"); + if(forcable == Val_true) { + print_instr("true"); + /* L'instruction précédante est FORCE */ + if (coq_extra_args > 0) coq_extra_args--; + pc++; + forcable = Val_false; + } else { /* L'instruction précédante est APPLY */ + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + Next; + } + Instruct(GRABREC) { + int rec_pos = *pc++; /* commence a zero */ + print_instr("GRABREC"); + if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { + pc++;/* On saute le Restart */ + } else { + if (coq_extra_args < rec_pos) { + mlsize_t num_args, i; + num_args = 1 + coq_extra_args; /* arg1 + extra args */ + Alloc_small(accu, num_args + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc - 3; + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } else { + /* L'argument recursif est un accumulateur */ + mlsize_t num_args, i; + /* Construction du PF partiellement appliqué */ + Alloc_small(accu, rec_pos + 2, Closure_tag); + Field(accu, 1) = coq_env; + for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; + Code_val(accu) = pc; + sp += rec_pos; + *--sp = accu; + /* Construction de l'atom */ + Alloc_small(accu, 2, ATOM_FIX_TAG); + Field(accu,1) = sp[0]; + Field(accu,0) = sp[1]; + sp++; sp[0] = accu; + /* Construction de l'accumulateur */ + num_args = coq_extra_args - rec_pos; + Alloc_small(accu, 2+num_args, Accu_tag); + Code_val(accu) = accumulate; + Field(accu,1) = sp[0]; sp++; + for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; + sp += num_args; + pc = (code_t)(sp[0]); + coq_env = sp[1]; + coq_extra_args = Long_val(sp[2]); + sp += 3; + } + } + Next; + } + + Instruct(CLOSURE) { + int nvars = *pc++; + int i; + print_instr("CLOSURE"); + print_int(nvars); + if (nvars > 0) *--sp = accu; + Alloc_small(accu, 1 + nvars, Closure_tag); + Code_val(accu) = pc + *pc; + pc++; + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + sp += nvars; + Next; + } + + Instruct(CLOSUREREC) { + int nfuncs = *pc++; + int nvars = *pc++; + int start = *pc++; + int i; + value * p; + print_instr("CLOSUREREC"); + if (nvars > 0) *--sp = accu; + /* construction du vecteur de type */ + Alloc_small(accu, nfuncs, 0); + for(i = 0; i < nfuncs; i++) { + Field(accu,i) = (value)(pc+pc[i]); + } + pc += nfuncs; + *--sp=accu; + Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); + Field(accu, nfuncs * 2 + nvars - 1) = *sp++; + /* On remplie la partie pour les variables libres */ + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++) { + *p++ = *sp++; + } + p = &Field(accu, 0); + *p = (value) (pc + pc[0]); + p++; + for (i = 1; i < nfuncs; i++) { + *p = Make_header(i * 2, Infix_tag, Caml_white); + p++; /* color irrelevant. */ + *p = (value) (pc + pc[i]); + p++; + } + pc += nfuncs; + accu = accu + 2 * start * sizeof(value); + Next; + } + + Instruct(PUSHOFFSETCLOSURE) { + print_instr("PUSHOFFSETCLOSURE"); + *--sp = accu; + } /* fallthrough */ + Instruct(OFFSETCLOSURE) { + print_instr("OFFSETCLOSURE"); + accu = coq_env + *pc++ * sizeof(value); Next; + } + Instruct(PUSHOFFSETCLOSUREM2) { + print_instr("PUSHOFFSETCLOSUREM2"); + *--sp = accu; + } /* fallthrough */ + Instruct(OFFSETCLOSUREM2) { + print_instr("OFFSETCLOSUREM2"); + accu = coq_env - 2 * sizeof(value); Next; + } + Instruct(PUSHOFFSETCLOSURE0) { + print_instr("PUSHOFFSETCLOSURE0"); + *--sp = accu; + }/* fallthrough */ + Instruct(OFFSETCLOSURE0) { + print_instr("OFFSETCLOSURE0"); + accu = coq_env; Next; + } + Instruct(PUSHOFFSETCLOSURE2){ + print_instr("PUSHOFFSETCLOSURE2"); + *--sp = accu; /* fallthrough */ + } + Instruct(OFFSETCLOSURE2) { + print_instr("OFFSETCLOSURE2"); + accu = coq_env + 2 * sizeof(value); Next; + } + +/* Access to global variables */ + + Instruct(PUSHGETGLOBAL) { + print_instr("PUSHGETGLOBAL"); + *--sp = accu; + } + /* Fallthrough */ + Instruct(GETGLOBAL){ + print_instr("GETGLOBAL"); + accu = Field(coq_global_data, *pc); + pc++; + Next; + } + +/* Allocation of blocks */ + + Instruct(MAKEBLOCK) { + mlsize_t wosize = *pc++; + tag_t tag = *pc++; + mlsize_t i; + value block; + print_instr("MAKEBLOCK"); + Alloc_small(block, wosize, tag); + Field(block, 0) = accu; + for (i = 1; i < wosize; i++) Field(block, i) = *sp++; + accu = block; + Next; + } + Instruct(MAKEBLOCK1) { + + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK1"); + Alloc_small(block, 1, tag); + Field(block, 0) = accu; + accu = block; + Next; + } + Instruct(MAKEBLOCK2) { + + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK2"); + Alloc_small(block, 2, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + sp += 1; + accu = block; + Next; + } + Instruct(MAKEBLOCK3) { + tag_t tag = *pc++; + value block; + print_instr("MAKEBLOCK3"); + Alloc_small(block, 3, tag); + Field(block, 0) = accu; + Field(block, 1) = sp[0]; + Field(block, 2) = sp[1]; + sp += 2; + accu = block; + Next; + } + + +/* Access to components of blocks */ + + +/* Branches and conditional branches */ + Instruct(FORCE) { + print_instr("FORCE"); + if (Is_block(accu) && Tag_val(accu) == Closure_tag) { + forcable = Val_true; + /* On pousse l'addresse de retour et l'argument */ + sp -= 3; + sp[0] = (value) (pc - 1); + sp[1] = coq_env; + sp[2] = Val_long(coq_extra_args); + /* On evalue le cofix */ + coq_extra_args = 0; + pc = Code_val(accu); + coq_env = accu; + goto check_stacks; + } else { + if (Is_block(accu)) print_int(Tag_val(accu)); + else print_instr("Not a block"); + } + Next; + } + + + Instruct(SWITCH) { + uint32 sizes = *pc++; + print_instr("SWITCH"); + print_int(sizes); + if (Is_block(accu)) { + long index = Tag_val(accu); + print_instr("block"); + print_int(index); + pc += pc[(sizes & 0xFFFF) + index]; + } else { + long index = Long_val(accu); + print_instr("constant"); + print_int(index); + pc += pc[index]; + } + Next; + } + Instruct(PUSHFIELD){ + int i; + int size = *pc++; + print_instr("PUSHFIELD"); + sp -= size; + for(i=0;i +#include +#include "coq_gc.h" +#include "coq_instruct.h" +#include "coq_fix_code.h" +#include "coq_memory.h" + +/* stack */ + +value * coq_stack_low; +value * coq_stack_high; +value * coq_stack_threshold; +asize_t coq_max_stack_size = Coq_max_stack_size; +/* global_data */ + + +value coq_global_data; +value coq_global_boxed; +int coq_all_transp; +value coq_atom_tbl; + +int drawinstr; +/* interp state */ + +long coq_saved_sp_offset; +value * coq_sp; +value forcable; +/* Some predefined pointer code */ +code_t accumulate; + +/* functions over global environment */ + +void coq_stat_free (void * blk) +{ + free (blk); +} + +value coq_static_alloc(value size) /* ML */ +{ + return (value) coq_stat_alloc((asize_t) Long_val(size)); +} + +value coq_static_free(value blk) /* ML */ +{ + coq_stat_free((void *) blk); + return Val_unit; +} + +value accumulate_code(value unit) /* ML */ +{ + return (value) accumulate; +} + +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_global_boxed, &coq_global_boxed); + (*action)(coq_atom_tbl, &coq_atom_tbl); + /* Scan the stack */ + for (i = coq_sp; i < coq_stack_high; i++) { + (*action) (*i, i); + }; + /* Hook */ + if (coq_prev_scan_roots_hook != NULL) (*coq_prev_scan_roots_hook)(action); + + +} + +void init_coq_stack() +{ + coq_stack_low = (value *) coq_stat_alloc(Coq_stack_size); + coq_stack_high = coq_stack_low + Coq_stack_size / sizeof (value); + coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); + 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_global_boxed(long requested_size) +{ + int i; + coq_global_boxed = alloc_shr(requested_size, 0); + for (i = 0; i < requested_size; i++) + Field (coq_global_boxed, i) = Val_true; +} + +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); +} + +static int coq_vm_initialized = 0; + +value init_coq_vm(value unit) /* ML */ +{ + int i; + if (coq_vm_initialized == 1) { + fprintf(stderr,"already open \n");fflush(stderr);} + else { + drawinstr=0; +#ifdef THREADED_CODE + init_arity(); +#endif /* THREADED_CODE */ + /* Allocate the table of global and the stack */ + init_coq_stack(); + init_coq_global_data(Coq_global_data_Size); + init_coq_global_boxed(40); + init_coq_atom_tbl(40); + /* Initialing the interpreter */ + coq_all_transp = 0; + forcable = Val_false; + init_coq_interpreter(); + + /* Some predefined pointer code */ + accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t)); + *accumulate = VALINSTR(ACCUMULATE); + + /* Initialize GC */ + if (coq_prev_scan_roots_hook == NULL) + coq_prev_scan_roots_hook = scan_roots_hook; + scan_roots_hook = coq_scan_roots; + coq_vm_initialized = 1; + } + return Val_unit;; +} + +void realloc_coq_stack(asize_t required_space) +{ + asize_t size; + value * new_low, * new_high, * new_sp; + value * p; + size = coq_stack_high - coq_stack_low; + do { + size *= 2; + } while (size < coq_stack_high - coq_sp + required_space); + new_low = (value *) coq_stat_alloc(size * sizeof(value)); + new_high = new_low + size; + +#define shift(ptr) \ + ((char *) new_high - ((char *) coq_stack_high - (char *) (ptr))) + + new_sp = (value *) shift(coq_sp); + memmove((char *) new_sp, + (char *) coq_sp, + (coq_stack_high - coq_sp) * sizeof(value)); + coq_stat_free(coq_stack_low); + coq_stack_low = new_low; + coq_stack_high = new_high; + coq_stack_threshold = coq_stack_low + Coq_stack_threshold / sizeof(value); + coq_sp = new_sp; +#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 get_coq_global_boxed(value unit) /* ML */ +{ + return coq_global_boxed; +} + +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_global_boxed(value size) /* ML */ +{ + mlsize_t requested_size, actual_size, i; + value new_global_boxed; + requested_size = Long_val(size); + actual_size = Wosize_val(coq_global_boxed); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + new_global_boxed = alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++) + initialize(&Field(new_global_boxed, i), Field(coq_global_boxed, i)); + for (i = actual_size; i < requested_size; i++) + Field (new_global_boxed, i) = Val_long (0); + coq_global_boxed = new_global_boxed; + } + 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_transp_value(value transp) +{ + coq_all_transp = (transp == Val_true); + return Val_unit; +} + +value get_coq_transp_value(value unit) +{ + return Val_bool(coq_all_transp); +} + +value coq_set_drawinstr(value unit) +{ + drawinstr = 1; + return Val_unit; +} + +value coq_set_forcable (value unit) +{ + forcable = Val_true; + return Val_unit; +} diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h new file mode 100644 index 00000000..7c96e684 --- /dev/null +++ b/kernel/byterun/coq_memory.h @@ -0,0 +1,70 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#ifndef _COQ_MEMORY_ +#define _COQ_MEMORY_ + +#include "config.h" +#include "fail.h" +#include "misc.h" +#include "memory.h" +#include "mlvalues.h" + + +#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 +#define BOXED 1 + +/* stack */ + +extern value * coq_stack_low; +extern value * coq_stack_high; +extern value * coq_stack_threshold; + +/* global_data */ + +extern value coq_global_data; +extern value coq_global_boxed; +extern int coq_all_transp; +extern value coq_atom_tbl; + +extern int drawinstr; +/* interp state */ + +extern value * coq_sp; +extern value forcable; +/* Some predefined pointer code */ +extern code_t accumulate; + +/* functions over global environment */ + +value coq_static_alloc(value size); /* ML */ +value coq_static_free(value string); /* ML */ + +value init_coq_vm(value unit); /* ML */ +value re_init_coq_vm(value unit); /* ML */ + +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_global_boxed(value unit); +value realloc_coq_global_boxed(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_ */ + + +value coq_set_drawinstr(value unit); diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c new file mode 100644 index 00000000..baf3ab09 --- /dev/null +++ b/kernel/byterun/coq_values.c @@ -0,0 +1,69 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#include +#include "coq_fix_code.h" +#include "coq_instruct.h" +#include "coq_memory.h" +#include "coq_values.h" +#include "memory.h" +/* KIND OF VALUES */ + +#define Setup_for_gc +#define Restore_after_gc + +value coq_kind_of_closure(value v) { + opcode_t * c; + int res; + int is_app = 0; + c = Code_val(v); + if (Is_instruction(c, GRAB)) return Val_int(0); + if (Is_instruction(c, RESTART)) {is_app = 1; c++;} + if (Is_instruction(c, GRABREC)) return Val_int(1+is_app); + if (Is_instruction(c, COGRAB)) return Val_int(3+is_app); + if (Is_instruction(c, MAKEACCU)) return Val_int(5); + return Val_int(0); +} + + +/* DESTRUCT ACCU */ + +value coq_closure_arity(value clos) { + opcode_t * c = Code_val(clos); + if (Is_instruction(c,RESTART)) { + c++; + if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos)); + else { + if (Wosize_val(clos) != 2) failwith("Coq Values : coq_closure_arity"); + return Val_int(1); + } + } + if (Is_instruction(c,GRAB)) return Val_int(1 + c[1]); + return Val_int(1); +} + +/* Fonction sur les fix */ + +value coq_offset(value v) { + if (Tag_val(v) == Closure_tag) return Val_int(0); + else return Val_long(-Wsize_bsize(Infix_offset_val(v))); +} + +value coq_offset_closure(value v, value offset){ + return (value)&Field(v, Int_val(offset)); +} + +value coq_offset_tcode(value code,value offset){ + return((value)((code_t)code + Int_val(offset))); +} + +value coq_int_tcode(value code, value offset) { + return Val_int(*((code_t) code + Int_val(offset))); +} diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h new file mode 100644 index 00000000..a186d62a --- /dev/null +++ b/kernel/byterun/coq_values.h @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* Coq Compiler */ +/* */ +/* Benjamin Gregoire, projets Logical and Cristal */ +/* INRIA Rocquencourt */ +/* */ +/* */ +/***********************************************************************/ + +#ifndef _COQ_VALUES_ +#define _COQ_VALUES_ + +#include "alloc.h" +#include "mlvalues.h" + +#define ATOM_FIX_TAG 3 +#define ATOM_SWITCH_TAG 4 + +#define Accu_tag 0 +#define Default_tag 0 + +/* Les blocs accumulate */ +#define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) + +#endif /* _COQ_VALUES_ */ + + diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml new file mode 100644 index 00000000..49955474 --- /dev/null +++ b/kernel/cbytecodes.ml @@ -0,0 +1,120 @@ +open Names +open Term + +type tag = int + +type structured_constant = + | Const_sorts of sorts + | Const_ind of inductive + | Const_b0 of tag + | Const_bn of tag * structured_constant array + +type reloc_table = (tag * int) array + +type annot_switch = + {ci : case_info; rtbl : reloc_table; tailcall : bool} + +module Label = + struct + type t = int + let no = -1 + let counter = ref no + let create () = incr counter; !counter + let reset_label_counter () = counter := no + end + + +type instruction = + | Klabel of Label.t + | Kacc of int + | Kenvacc of int + | Koffsetclosure of int + | Kpush + | Kpop of int + | Kpush_retaddr of Label.t + | Kapply of int (* number of arguments *) + | Kappterm of int * int (* number of arguments, slot size *) + | Kreturn of int (* slot size *) + | Kjump + | Krestart + | Kgrab of int (* number of arguments *) + | Kgrabrec of int (* rec arg *) + | Kcograb of int (* number of arguments *) + | Kclosure of Label.t * int (* label, number of free variables *) + | Kclosurerec of int * int * Label.t array * Label.t array + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal of constant + | Kconst of structured_constant + | Kmakeblock of int * tag (* size, tag *) + | Kmakeprod + | Kmakeswitchblock of Label.t * Label.t * annot_switch * int + | Kforce + | Kswitch of Label.t array * Label.t array (* consts,blocks *) + | Kpushfield of int + | Kstop + | Ksequence of bytecodes * bytecodes + +and bytecodes = instruction list + +type fv_elem = FVnamed of identifier | FVrel of int + +type fv = fv_elem array + + +(* --- Pretty print *) +open Format +let rec instruction ppf = function + | Klabel lbl -> fprintf ppf "L%i:" lbl + | Kacc n -> fprintf ppf "\tacc %i" n + | Kenvacc n -> fprintf ppf "\tenvacc %i" n + | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n + | Kpush -> fprintf ppf "\tpush" + | Kpop n -> fprintf ppf "\tpop %i" n + | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl + | Kapply n -> fprintf ppf "\tapply %i" n + | Kappterm(n, m) -> + fprintf ppf "\tappterm %i, %i" n m + | Kreturn n -> fprintf ppf "\treturn %i" n + | Kjump -> fprintf ppf "\tjump" + | Krestart -> fprintf ppf "\trestart" + | Kgrab n -> fprintf ppf "\tgrab %i" n + | Kgrabrec n -> fprintf ppf "\tgrabrec %i" n + | Kcograb n -> fprintf ppf "\tcograb %i" n + | Kclosure(lbl, n) -> + fprintf ppf "\tclosure L%i, %i" lbl n + | Kclosurerec(fv,init,lblt,lblb) -> + fprintf ppf "\tclosurerec"; + fprintf ppf "%i , %i, " fv init; + print_string "types = "; + Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt; + print_string " bodies = "; + Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal id -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id) + | Kconst cst -> + fprintf ppf "\tconst" + | Kmakeblock(n, m) -> + fprintf ppf "\tmakeblock %i, %i" n m + | Kmakeprod -> fprintf ppf "\tmakeprod" + | Kmakeswitchblock(lblt,lbls,_,sz) -> + fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz + | Kforce -> fprintf ppf "\tforce" + | Kswitch(lblc,lblb) -> + fprintf ppf "\tswitch"; + Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc; + Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; + | Kpushfield n -> + fprintf ppf "\tpushfield %i" n + | Kstop -> fprintf ppf "\tstop" + | Ksequence (c1,c2) -> + fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 + +and instruction_list ppf = function + [] -> () + | Klabel lbl :: il -> + fprintf ppf "L%i:%a" lbl instruction_list il + | instr :: il -> + fprintf ppf "%a@ %a" instruction instr instruction_list il + +let draw_instr c = + fprintf std_formatter "@[%a@]" instruction_list c diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli new file mode 100644 index 00000000..a996f750 --- /dev/null +++ b/kernel/cbytecodes.mli @@ -0,0 +1,61 @@ +open Names +open Term + +type tag = int + +type structured_constant = + | Const_sorts of sorts + | Const_ind of inductive + | Const_b0 of tag + | Const_bn of tag * structured_constant array + +type reloc_table = (tag * int) array + +type annot_switch = + {ci : case_info; rtbl : reloc_table; tailcall : bool} + +module Label : + sig + type t = int + val no : t + val create : unit -> t + val reset_label_counter : unit -> unit + end + +type instruction = + | Klabel of Label.t + | Kacc of int + | Kenvacc of int + | Koffsetclosure of int + | Kpush + | Kpop of int + | Kpush_retaddr of Label.t + | Kapply of int (* number of arguments *) + | Kappterm of int * int (* number of arguments, slot size *) + | Kreturn of int (* slot size *) + | Kjump + | Krestart + | Kgrab of int (* number of arguments *) + | Kgrabrec of int (* rec arg *) + | Kcograb of int (* number of arguments *) + | Kclosure of Label.t * int (* label, number of free variables *) + | Kclosurerec of int * int * Label.t array * Label.t array + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal of constant + | Kconst of structured_constant + | Kmakeblock of int * tag (* size, tag *) + | Kmakeprod + | Kmakeswitchblock of Label.t * Label.t * annot_switch * int + | Kforce + | Kswitch of Label.t array * Label.t array (* consts,blocks *) + | Kpushfield of int + | Kstop + | Ksequence of bytecodes * bytecodes + +and bytecodes = instruction list + +type fv_elem = FVnamed of identifier | FVrel of int + +type fv = fv_elem array + +val draw_instr : bytecodes -> unit diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml new file mode 100644 index 00000000..041e0795 --- /dev/null +++ b/kernel/cbytegen.ml @@ -0,0 +1,490 @@ +open Util +open Names +open Cbytecodes +open Cemitcodes +open Term +open Declarations +open Pre_env + +(*i Compilation des variables + calcul des variables libres *) + +(* Representation des environnements machines : *) +(*[t0|C0| ... |tc|Cc| ... |t(nbr-1)|C(nbr-1)| fv1 | fv1 | .... | fvn] *) +(* ^<----------offset---------> *) + + +type fv = fv_elem list + +type vm_env = {size : int; fv_rev : fv} + (* size = n; fv_rev = [fvn; ... ;fv1] *) + +type t = { + nb_stack : int; (* nbre de variables sur la pile *) + in_stack : int list; (* position dans la pile *) + nb_rec : int; (* nbre de fonctions mutuellement recursives = + nbr *) + pos_rec : int; (* position de la fonction courante = c *) + offset : int; + in_env : vm_env ref + } + +let empty_fv = {size= 0; fv_rev = []} + +let fv r = !(r.in_env) + +(* [add_param n] rend la liste [sz+1;sz+2;...;sz+n] *) +let rec add_param n sz l = + if n = 0 then l else add_param (n - 1) sz (n+sz::l) + +(* [push_param ] ajoute les parametres de fonction dans la pile *) +let push_param n sz r = + { r with + nb_stack = r.nb_stack + n; + in_stack = add_param n sz r.in_stack } + +(* [push_local e sz] ajoute une nouvelle variable dans la pile a la position *) +let push_local sz r = + { r with + nb_stack = r.nb_stack + 1; + in_stack = (sz + 1) :: r.in_stack } + +(* Table de relocation initiale *) +let empty () = + { nb_stack = 0; in_stack = []; + nb_rec = 0;pos_rec = 0; + offset = 0; in_env = ref empty_fv } + +let init_fun arity = + { nb_stack = arity; in_stack = add_param arity 0 []; + nb_rec = 0; pos_rec = 0; + offset = 1; in_env = ref empty_fv } + +let init_type ndef rfv = + { nb_stack = 0; in_stack = []; + nb_rec = 0; pos_rec = 0; + offset = 2*(ndef-1)+1; in_env = rfv } + +let init_fix ndef pos_rec arity rfv = + { nb_stack = arity; in_stack = add_param arity 0 []; + nb_rec = ndef; pos_rec = pos_rec; + offset = 2 * (ndef - pos_rec - 1)+1; in_env = rfv} + +let find_at el l = + let rec aux n = function + | [] -> raise Not_found + | hd :: tl -> if hd = el then n else aux (n+1) tl + in aux 1 l + +let pos_named id r = + let env = !(r.in_env) in + let cid = FVnamed id in + try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev)) + with Not_found -> + let pos = env.size in + r.in_env := { size = pos+1; fv_rev = cid:: env.fv_rev}; + Kenvacc (r.offset + pos) + +let pos_rel i r sz = + if i <= r.nb_stack then + Kacc(sz - (List.nth r.in_stack (i-1))) + else if i <= r.nb_stack + r.nb_rec + then Koffsetclosure (2 * (r.nb_rec + r.nb_stack - r.pos_rec - i)) + else + let db = FVrel(i - r.nb_stack - r.nb_rec) in + let env = !(r.in_env) in + try Kenvacc(r.offset + env.size - (find_at db env.fv_rev)) + with Not_found -> + let pos = env.size in + r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; + Kenvacc(r.offset + pos) + + +(*i Examination of the continuation *) + +(* Discard all instructions up to the next label. + This function is to be applied to the continuation before adding a + non-terminating instruction (branch, raise, return, appterm) + in front of it. *) + +let rec discard_dead_code cont = cont +(*function + [] -> [] + | (Klabel _ | Krestart ) :: _ as cont -> cont + | _ :: cont -> discard_dead_code cont +*) + +(* Return a label to the beginning of the given continuation. + If the sequence starts with a branch, use the target of that branch + as the label, thus avoiding a jump to a jump. *) + +let label_code = function + | Klabel lbl :: _ as cont -> (lbl, cont) + | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont) + +(* Return a branch to the continuation. That is, an instruction that, + when executed, branches to the continuation or performs what the + continuation performs. We avoid generating branches to returns. *) + +let make_branch cont = + match cont with + | (Kreturn _ as return) :: cont' -> return, cont' + | Klabel lbl as b :: _ -> b, cont + | _ -> let b = Klabel(Label.create()) in b,b::cont + +(* Check if we're in tailcall position *) + +let rec is_tailcall = function + | Kreturn k :: _ -> Some k + | Klabel _ :: c -> is_tailcall c + | _ -> None + +(* Extention of the continuation ****) + +(* Add a Kpop n instruction in front of a continuation *) +let rec add_pop n = function + | Kpop m :: cont -> add_pop (n+m) cont + | Kreturn m:: cont -> Kreturn (n+m) ::cont + | cont -> if n = 0 then cont else Kpop n :: cont + +let add_grab arity lbl cont = + if arity = 1 then Klabel lbl :: cont + else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont + + +(* Environnement global *****) + +let global_env = ref empty_env + +let set_global_env env = global_env := env + + +(* Code des fermetures ****) +let fun_code = ref [] + +let init_fun_code () = fun_code := [] + +(* Compilation des constructeurs et des inductifs *) + +(* Inv : nparam + arity > 0 *) +let code_construct tag nparams arity cont = + let f_cont = + add_pop nparams + (if arity = 0 then + [Kconst (Const_b0 tag); Kreturn 0] + else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]) + in + let lbl = Label.create() in + fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; + Kclosure(lbl,0) :: cont + +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 *) + +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) -> + let oib = lookup_mind kn !global_env in + let oip = oib.mind_packets.(j) in + let num,arity = oip.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + if nparams + arity = Array.length args then + if arity = 0 then Bstrconst(Const_b0 num) + 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(num, sc_args)) + with Not_found -> + Bmakeblock(num,b_args) + else + let b_args = Array.map str_const args in + Bconstruct_app(num, nparams, arity, b_args) + | _ -> Bconstr c + end + | Ind ind -> Bstrconst (Const_ind ind) + | Construct ((kn,j),i) -> + let oib = lookup_mind kn !global_env in + let oip = oib.mind_packets.(j) in + let num,arity = oip.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + if nparams + arity = 0 then Bstrconst(Const_b0 num) + else Bconstruct_app(num,nparams,arity,[||]) + | _ -> Bconstr c + +(* compilation des applications *) +let comp_args comp_expr reloc 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 + for i = 1 to nargs_m_1 do + c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) + done; + !c + +let comp_app comp_fun comp_arg reloc f args sz cont = + let nargs = Array.length args in + match is_tailcall cont with + | Some k -> + comp_args comp_arg reloc args sz + (Kpush :: + comp_fun reloc 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))) + 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)))) + +(* Compilation des variables libres *) + +let compile_fv_elem reloc fv sz cont = + match fv with + | FVrel i -> pos_rel i reloc sz :: cont + | FVnamed id -> pos_named id reloc :: cont + +(* compilation des constantes *) + +let rec get_allias env kn = + let tps = (lookup_constant kn env).const_body_code in + match Cemitcodes.force tps with + | BCallias kn' -> get_allias env kn' + | _ -> kn + +(* compilation des expressions *) + +let rec compile_constr reloc c sz cont = + match kind_of_term c with + | Meta _ -> raise (Invalid_argument "Cbytegen.gen_lam : Meta") + | Evar _ -> raise (Invalid_argument "Cbytegen.gen_lam : Evar") + + | 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 -> Kgetglobal (get_allias !global_env kn) :: cont + + | Sort _ | Ind _ | Construct _ -> + compile_str_cst reloc (str_const c) sz cont + + | 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 = init_fun arity in + let lbl_fun = Label.create() in + let cont_fun = + 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 + | _ -> 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 + let rfv = ref empty_fv in + let lbl_types = Array.create ndef Label.no in + let lbl_bodies = Array.create ndef Label.no in + (* Compilation des types *) + let rtype = init_type ndef rfv in + for i = 0 to ndef - 1 do + let lbl,fcode = + label_code + (compile_constr rtype type_bodies.(i) 0 [Kstop]) in + lbl_types.(i) <- lbl; + fun_code := [Ksequence(fcode,!fun_code)] + done; + (* Compilation des corps *) + for i = 0 to ndef - 1 do + let params,body = decompose_lam rec_bodies.(i) in + let arity = List.length params in + let rbody = init_fix ndef i arity rfv in + let cont1 = + compile_constr rbody body arity [Kreturn arity] in + let lbl = Label.create () in + lbl_bodies.(i) <- lbl; + let fcode = + if arity = 1 then + Klabel lbl :: Kgrabrec 0 :: Krestart :: cont1 + else + Krestart :: Klabel lbl :: Kgrabrec rec_args.(i) :: + Krestart :: Kgrab (arity - 1) :: cont1 + in + fun_code := [Ksequence(fcode,!fun_code)] + done; + let fv = !rfv in + compile_fv reloc 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 + let rfv = ref empty_fv in + let lbl_types = Array.create ndef Label.no in + let lbl_bodies = Array.create ndef Label.no in + (* Compilation des types *) + let rtype = init_type ndef rfv in + for i = 0 to ndef - 1 do + let lbl,fcode = + label_code + (compile_constr rtype type_bodies.(i) 0 [Kstop]) in + lbl_types.(i) <- lbl; + fun_code := [Ksequence(fcode,!fun_code)] + done; + (* Compilation des corps *) + for i = 0 to ndef - 1 do + let params,body = decompose_lam rec_bodies.(i) in + let arity = List.length params in + let rbody = init_fix ndef i arity rfv in + let lbl = Label.create () in + + let cont1 = + compile_constr rbody body arity [Kreturn(arity)] in + let cont2 = + if arity <= 1 then cont1 else Kgrab (arity - 1) :: cont1 in + let cont3 = + Krestart :: Klabel lbl :: Kcograb arity :: Krestart :: cont2 in + fun_code := [Ksequence(cont3,!fun_code)]; + lbl_bodies.(i) <- lbl + done; + let fv = !rfv in + compile_fv reloc fv.fv_rev sz + (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) + + | Case(ci,t,a,branchs) -> + let ind = ci.ci_ind in + let mib = lookup_mind (fst ind) !global_env in + let oib = mib.mind_packets.(snd ind) in + let tbl = oib.mind_reloc_tbl in + let lbl_consts = Array.create oib.mind_nb_constant Label.no in + let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in + let branch1,cont = make_branch cont in + (* Compilation du type *) + let lbl_typ,fcode = + label_code (compile_constr reloc t sz [Kpop sz; Kstop]) + in fun_code := [Ksequence(fcode,!fun_code)]; + (* Compilation des branches *) + let lbl_sw = Label.create () in + let sz_b,branch,is_tailcall = + match branch1 with + | Kreturn k -> assert (k = sz); sz, branch1, true + | _ -> sz+3, Kjump, false + in + let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in + (* Compilation de la branche accumulate *) + let lbl_accu, code_accu = + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) + in + lbl_blocks.(0) <- lbl_accu; + let c = ref code_accu in + (* Compilation des branches constructeurs *) + for i = 0 to Array.length tbl - 1 do + let tag, arity = tbl.(i) in + if 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 lbl_b,code_b = + label_code( + if nargs = arity then + Kpushfield arity :: + 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 + Kpushfield arity :: + compile_constr reloc branchs.(i) (sz_b+arity) + (Kappterm(arity,sz_appterm) :: !c)) + in + lbl_blocks.(tag) <- lbl_b; + c := code_b + done; + c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; + let code_sw = + match branch1 with + | Klabel lbl -> Kpush_retaddr lbl :: !c + | _ -> !c + in + let cont_a = if mib.mind_finite then code_sw else Kforce :: code_sw in + compile_constr reloc a sz cont_a + +and compile_fv reloc l sz cont = + match l with + | [] -> cont + | [fvn] -> compile_fv_elem reloc fvn sz cont + | fvn :: tl -> + compile_fv_elem reloc fvn sz + (Kpush :: compile_fv reloc tl (sz + 1) cont) + +and compile_str_cst reloc sc sz cont = + match sc with + | Bconstr c -> compile_constr reloc c sz cont + | Bstrconst sc -> Kconst sc :: cont + | Bmakeblock(tag,args) -> + let nargs = Array.length args in + comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont) + | Bconstruct_app(tag,nparams,arity,args) -> + if 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 + +let compile env c = + set_global_env env; + init_fun_code (); + Label.reset_label_counter (); + let reloc = empty () in + let init_code = compile_constr reloc c 0 [Kstop] in + let fv = List.rev (!(reloc.in_env).fv_rev) in + init_code,!fun_code, Array.of_list fv + +let compile_constant_body env body opaque boxed = + if opaque then BCconstant + else match body with + | None -> BCconstant + | Some sb -> + let body = Declarations.force sb in + if boxed then + let res = compile env body in + let to_patch = to_memory res in + BCdefined(true, to_patch) + else + match kind_of_term body with + | Const kn' -> BCallias (get_allias env kn') + | _ -> + let res = compile env body in + let to_patch = to_memory res in + BCdefined (false, to_patch) + diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli new file mode 100644 index 00000000..f761e4f6 --- /dev/null +++ b/kernel/cbytegen.mli @@ -0,0 +1,17 @@ +open Names +open Cbytecodes +open Cemitcodes +open Term +open Declarations +open Pre_env + + + +val compile : env -> constr -> bytecodes * bytecodes * fv + (* init, fun, fv *) + +val compile_constant_body : + env -> constr_substituted option -> bool -> bool -> body_code + (* opaque *) (* boxed *) + + diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml new file mode 100644 index 00000000..cccb1844 --- /dev/null +++ b/kernel/cemitcodes.ml @@ -0,0 +1,303 @@ +open Names +open Term +open Cbytecodes +open Copcodes +open Mod_subst + +(* Relocation information *) +type reloc_info = + | Reloc_annot of annot_switch + | Reloc_const of structured_constant + | Reloc_getglobal of constant + +type patch = reloc_info * int + +let patch_int buff pos n = + String.unsafe_set buff pos (Char.unsafe_chr n); + String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); + String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); + String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) + + +(* Buffering of bytecode *) + +let out_buffer = ref(String.create 1024) +and out_position = ref 0 + +let out_word b1 b2 b3 b4 = + let p = !out_position in + if p >= String.length !out_buffer then begin + let len = String.length !out_buffer in + let new_buffer = String.create (2 * len) in + String.blit !out_buffer 0 new_buffer 0 len; + out_buffer := new_buffer + end; + String.unsafe_set !out_buffer p (Char.unsafe_chr b1); + String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); + String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); + String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); + out_position := p + 4 + +let out opcode = + out_word opcode 0 0 0 + +let out_int n = + out_word 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 + while needed >= !new_size do new_size := 2 * !new_size done; + let new_table = Array.create !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 + !out_buffer.[pos] <- Char.unsafe_chr displ; + !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); + !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); + !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) + +let define_label lbl = + if lbl >= Array.length !label_table then extend_label_table lbl; + match (!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 + +let out_label_with_orig orig lbl = + if lbl >= Array.length !label_table then extend_label_table lbl; + match (!label_table).(lbl) with + Label_defined def -> + out_int((def - orig) asr 2) + | Label_undefined patchlist -> + if patchlist = [] then + (!label_table).(lbl) <- + Label_undefined((!out_position, orig) :: patchlist); + out_int 0 + +let out_label l = out_label_with_orig !out_position l + +(* Relocation information *) + +let reloc_info = ref ([] : (reloc_info * int) list) + +let enter info = + reloc_info := (info, !out_position) :: !reloc_info + +let slot_for_const c = + enter (Reloc_const c); + out_int 0 + +and slot_for_annot a = + enter (Reloc_annot a); + out_int 0 + +and slot_for_getglobal id = + enter (Reloc_getglobal id); + out_int 0 + + +(* Emission of one instruction *) + + +let emit_instr = function + | Klabel lbl -> define_label lbl + | Kacc n -> + if n < 8 then out(opACC0 + n) else (out opACC; out_int n) + | Kenvacc n -> + if n >= 1 && n <= 4 + then out(opENVACC1 + n - 1) + else (out opENVACC; out_int n) + | Koffsetclosure ofs -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out (opOFFSETCLOSURE0 + ofs / 2) + else (out opOFFSETCLOSURE; out_int ofs) + | Kpush -> + out opPUSH + | Kpop n -> + out opPOP; out_int n + | Kpush_retaddr lbl -> + out opPUSH_RETADDR; out_label lbl + | Kapply n -> + if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) + | Kappterm(n, sz) -> + if n < 4 then (out(opAPPTERM1 + n - 1); out_int sz) + else (out opAPPTERM; out_int n; out_int sz) + | Kreturn n -> + out opRETURN; out_int n + | Kjump -> + out opRETURN; out_int 0 + | Krestart -> + out opRESTART + | Kgrab n -> + out opGRAB; out_int n + | Kgrabrec(rec_arg) -> + out opGRABREC; out_int rec_arg + | Kcograb n -> + out opCOGRAB; out_int n + | Kclosure(lbl, n) -> + out opCLOSURE; out_int n; out_label 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 + | Kgetglobal q -> + out opGETGLOBAL; slot_for_getglobal q + | Kconst((Const_b0 i)) -> + if i >= 0 && i <= 3 + then out (opCONST0 + i) + else (out opCONSTINT; out_int i) + | Kconst c -> + out opGETGLOBAL; slot_for_const c + | Kmakeblock(n, t) -> + if n = 0 then raise (Invalid_argument "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) + | Kmakeprod -> + out opMAKEPROD + | Kmakeswitchblock(typlbl,swlbl,annot,sz) -> + out opMAKESWITCHBLOCK; + out_label typlbl; out_label swlbl; + slot_for_annot annot;out_int sz + | Kforce -> + out opFORCE + | Kswitch (tbl_const, tbl_block) -> + out opSWITCH; + out_int (Array.length tbl_const + (Array.length tbl_block lsl 16)); + let org = !out_position in + Array.iter (out_label_with_orig org) tbl_const; + Array.iter (out_label_with_orig org) tbl_block + | Kpushfield n -> + out opPUSHFIELD;out_int n + | Kstop -> + out opSTOP + | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") + +(* Emission of a list of instructions. Include some peephole optimization. *) + +let rec emit = function + | [] -> () + (* Peephole optimizations *) + | Kpush :: Kacc n :: c -> + if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); + emit c + | Kpush :: Kenvacc n :: c -> + if n >= 1 && n <= 4 + then out(opPUSHENVACC1 + n - 1) + else (out opPUSHENVACC; out_int n); + emit c + | Kpush :: Koffsetclosure ofs :: c -> + if ofs = -2 || ofs = 0 || ofs = 2 + then out(opPUSHOFFSETCLOSURE0 + ofs / 2) + else (out opPUSHOFFSETCLOSURE; out_int ofs); + emit c + | Kpush :: Kgetglobal id :: c -> + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c + | Kpush :: Kconst (Const_b0 i) :: c -> + if i >= 0 && i <= 3 + then out (opPUSHCONST0 + i) + else (out opPUSHCONSTINT; out_int i); + emit c + | Kpush :: Kconst const :: c -> + out opPUSHGETGLOBAL; slot_for_const const; + emit c + | Kpop n :: Kjump :: c -> + out opRETURN; out_int n; emit c + | Ksequence(c1,c2)::c -> + emit c1; emit c2;emit c + (* Default case *) + | instr :: c -> + emit_instr instr; emit c + +(* Initialization *) + +let init () = + out_position := 0; + label_table := Array.create 16 (Label_undefined []); + reloc_info := [] + +type emitcodes = string + +let length = String.length + +type to_patch = emitcodes * (patch list) * fv + +(* Substitution *) +let rec subst_strcst s sc = + match sc with + | Const_sorts _ | Const_b0 _ -> 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_kn s kn, i)) + +let subst_patch s (ri,pos) = + match ri with + | Reloc_annot a -> + let (kn,i) = a.ci.ci_ind in + let ci = {a.ci with ci_ind = (subst_kn 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 (fst (subst_con s kn)), pos) + +let subst_to_patch s (code,pl,fv) = + code,List.rev_map (subst_patch s) pl,fv + +type body_code = + | BCdefined of bool * to_patch + | BCallias of constant + | BCconstant + +let subst_body_code s = function + | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp) + | BCallias kn -> BCallias (fst (subst_con s kn)) + | BCconstant -> BCconstant + +type to_patch_substituted = body_code substituted + +let from_val = from_val + +let force = force subst_body_code + +let subst_to_patch_subst = subst_substituted + +let is_boxed tps = + match force tps with + | BCdefined(b,_) -> b + | _ -> false + +let to_memory (init_code, fun_code, fv) = + init(); + emit init_code; + emit fun_code; + let code = String.create !out_position in + String.unsafe_blit !out_buffer 0 code 0 !out_position; + let reloc = List.rev !reloc_info in + Array.iter (fun lbl -> + (match lbl with + Label_defined _ -> assert true + | Label_undefined patchlist -> + assert (patchlist = []))) !label_table; + (code, reloc, fv) + + + + + diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli new file mode 100644 index 00000000..ca6da65e --- /dev/null +++ b/kernel/cemitcodes.mli @@ -0,0 +1,40 @@ +open Names +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 + +type emitcodes + +val length : emitcodes -> int + +val patch_int : emitcodes -> (*pos*)int -> int -> unit + +type to_patch = emitcodes * (patch list) * fv + +val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch + +type body_code = + | BCdefined of bool*to_patch + | BCallias of constant + | BCconstant + + +type to_patch_substituted + +val from_val : body_code -> to_patch_substituted + +val force : to_patch_substituted -> body_code + +val is_boxed : to_patch_substituted -> bool + +val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted + +val to_memory : bytecodes * bytecodes * fv -> to_patch + (* init code, fun code, fv *) diff --git a/kernel/closure.ml b/kernel/closure.ml index 1a635ccf..8e16a922 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: closure.ml,v 1.54.2.1 2004/07/16 19:30:23 herbelin Exp $ *) +(* $Id: closure.ml 7639 2005-12-02 10:01:15Z gregoire $ *) open Util open Pp @@ -16,7 +16,6 @@ open Declarations open Environ open Esubst - let stats = ref false let share = ref true @@ -52,10 +51,8 @@ let with_stats c = end else Lazy.force c -type transparent_state = Idpred.t * KNpred.t - -let all_opaque = (Idpred.empty, KNpred.empty) -let all_transparent = (Idpred.full, KNpred.full) +let all_opaque = (Idpred.empty, Cpred.empty) +let all_transparent = (Idpred.full, Cpred.full) module type RedFlagsSig = sig type reds @@ -110,7 +107,7 @@ module RedFlags = (struct | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> let (l1,l2) = red.r_const in - { red with r_const = l1, KNpred.add kn l2 } + { red with r_const = l1, Cpred.add kn l2 } | IOTA -> { red with r_iota = true } | ZETA -> { red with r_zeta = true } | VAR id -> @@ -122,7 +119,7 @@ module RedFlags = (struct | DELTA -> { red with r_delta = false } | CONST kn -> let (l1,l2) = red.r_const in - { red with r_const = l1, KNpred.remove kn l2 } + { red with r_const = l1, Cpred.remove kn l2 } | IOTA -> { red with r_iota = false } | ZETA -> { red with r_zeta = false } | VAR id -> @@ -138,7 +135,7 @@ module RedFlags = (struct | BETA -> incr_cnt red.r_beta beta | CONST kn -> let (_,l) = red.r_const in - let c = KNpred.mem kn l in + let c = Cpred.mem kn l in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let (l,_) = red.r_const in @@ -152,7 +149,7 @@ module RedFlags = (struct let red_get_const red = let p1,p2 = red.r_const in let (b1,l1) = Idpred.elements p1 in - let (b2,l2) = KNpred.elements p2 in + let (b2,l2) = Cpred.elements p2 in if b1=b2 then let l1' = List.map (fun x -> EvalVarRef x) l1 in let l2' = List.map (fun x -> EvalConstRef x) l2 in @@ -326,11 +323,7 @@ fin obsol * instantiations (cbv or lazy) are. *) -type table_key = - | ConstKey of constant - | VarKey of identifier - | FarRelKey of int - (* FarRel: index in the rel_context part of _initial_ environment *) +type table_key = id_key type 'a infos = { i_flags : reds; @@ -349,7 +342,7 @@ let ref_value_cache info ref = try let body = match ref with - | FarRelKey n -> + | RelKey n -> let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) | VarKey id -> List.assoc id info.i_vars | ConstKey cst -> constant_value info.i_env cst @@ -364,22 +357,22 @@ let ref_value_cache info ref = let defined_vars flags env = (* if red_local_const (snd flags) then*) - fold_named_context - (fun env (id,b,t) e -> + Sign.fold_named_context + (fun (id,b,_) e -> match b with | None -> e | Some body -> (id, body)::e) - env ~init:[] + (named_context env) ~init:[] (* else []*) let defined_rels flags env = (* if red_local_const (snd flags) then*) - fold_rel_context - (fun env (id,b,t) (i,subs) -> + Sign.fold_rel_context + (fun (id,b,t) (i,subs) -> match b with | None -> (i+1, subs) | Some body -> (i+1, (i,body) :: subs)) - env ~init:(0,[]) + (rel_context env) ~init:(0,[]) (* else (0,[])*) @@ -519,7 +512,7 @@ type fconstr = { and fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) - | FCast of fconstr * fconstr + | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor @@ -539,6 +532,8 @@ let fterm_of v = v.term let set_norm v = v.norm <- Norm let is_val v = v.norm = Norm +let mk_atom c = {norm=Norm;term=FAtom c} + (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) let update v1 (no,t) = @@ -553,7 +548,7 @@ let update v1 (no,t) = when the lift is 0. *) let rec lft_fconstr n ft = match ft.term with - | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FAtom _) -> ft + | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)) -> ft | FRel i -> {norm=Norm;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} @@ -573,7 +568,7 @@ let clos_rel e i = | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Norm; term= FRel k} | Inr(k,Some p) -> - lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)} + lift_fconstr (k-p) {norm=Norm;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = @@ -608,10 +603,10 @@ let rec compact_constr (lg, subs as s) c k = | Evar(ev,v) -> let (v',s) = compact_vect s v k in if v==v' then c,s else mkEvar(ev,v'),s - | Cast(a,b) -> + | Cast(a,ck,b) -> let (a',s) = compact_constr s a k in let (b',s) = compact_constr s b k in - if a==a' && b==b' then c,s else mkCast(a',b'), s + if a==a' && b==b' then c,s else mkCast(a', ck, b'), s | App(f,v) -> let (f',s) = compact_constr s f k in let (v',s) = compact_vect s v k in @@ -664,7 +659,7 @@ let optimise_closure env c = (env',c') let mk_lambda env t = -(* let (env,t) = optimise_closure env t in*) + let (env,t) = optimise_closure env t in let (rvars,t') = decompose_lam t in FLambda(List.length rvars, List.rev rvars, t', env) @@ -698,9 +693,9 @@ let mk_clos_deep clos_fun env t = match kind_of_term t with | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> mk_clos env t - | Cast (a,b) -> + | Cast (a,k,b) -> { norm = Red; - term = FCast (clos_fun env a, clos_fun env b)} + term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, Array.map (clos_fun env) v) } @@ -730,15 +725,11 @@ let mk_clos2 = mk_clos_deep mk_clos let rec to_constr constr_fun lfts v = match v.term with | FRel i -> mkRel (reloc_rel i lfts) - | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts) + | FFlex (RelKey p) -> mkRel (reloc_rel p lfts) | FFlex (VarKey x) -> mkVar x - | FAtom c -> - (match kind_of_term c with - | Sort s -> mkSort s - | Meta m -> mkMeta m - | _ -> assert false) - | FCast (a,b) -> - mkCast (constr_fun lfts a, constr_fun lfts b) + | FAtom c -> exliftn lfts c + | FCast (a,k,b) -> + mkCast (constr_fun lfts a, k, constr_fun lfts b) | FFlex (ConstKey op) -> mkConst op | FInd op -> mkInd op | FConstruct op -> mkConstruct op @@ -808,23 +799,23 @@ let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) -let rec zip zfun m stk = +let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> let args = Array.of_list args in - zip zfun {norm=neutr m.norm; term=FApp(m, Array.map zfun args)} s + zip {norm=neutr m.norm; term=FApp(m, args)} s | Zcase(ci,p,br)::s -> - let t = FCases(ci, zfun p, m, Array.map zfun br) in - zip zfun {norm=neutr m.norm; term=t} s + let t = FCases(ci, p, m, br) in + zip {norm=neutr m.norm; term=t} s | Zfix(fx,par)::s -> - zip zfun fx (par @ append_stack_list ([m], s)) + zip fx (par @ append_stack_list ([m], s)) | Zshift(n)::s -> - zip zfun (lift_fconstr n m) s + zip (lift_fconstr n m) s | Zupdate(rf)::s -> - zip zfun (update rf (m.norm,m.term)) s + zip (update rf (m.norm,m.term)) s -let fapp_stack (m,stk) = zip (fun x -> x) m stk +let fapp_stack (m,stk) = zip m stk (*********************************************************************) @@ -849,7 +840,7 @@ let strip_update_shift_app head stk = let rec strip_rec rstk h depth = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s - | (Zapp args :: s) as stk -> + | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) {norm=h.norm;term=FApp(h,Array.of_list args)} depth s | Zupdate(m)::s -> @@ -892,7 +883,7 @@ let get_arg h stk = let rec get_args n tys f e stk = match stk with Zupdate r :: s -> - let hd = update r (Cstr,FLambda(n,tys,f,e)) in + let _hd = update r (Cstr,FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s @@ -985,7 +976,7 @@ let rec knh m stk = (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) - | FCast(t,_) -> knh t stk + | FCast(t,_,_) -> knh t stk (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> @@ -999,7 +990,7 @@ and knht e t stk = | Case(ci,p,t,br) -> knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) | Fix _ -> knh (mk_clos2 e t) stk - | Cast(a,b) -> knht e a stk + | Cast(a,_,_) -> knht e a stk | Rel n -> knh (clos_rel e n) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> @@ -1023,8 +1014,8 @@ let rec knr info m stk = (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FFlex(FarRelKey k) when red_set info.i_flags fDELTA -> - (match ref_value_cache info (FarRelKey k) with + | FFlex(RelKey k) when red_set info.i_flags fDELTA -> + (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct(ind,c) when red_set info.i_flags fIOTA -> diff --git a/kernel/closure.mli b/kernel/closure.mli index e58b91eb..706a089e 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: closure.mli,v 1.42.2.1 2004/07/16 19:30:24 herbelin Exp $ i*) +(*i $Id: closure.mli 7639 2005-12-02 10:01:15Z gregoire $ i*) (*i*) open Pp @@ -27,7 +27,7 @@ val with_stats: 'a Lazy.t -> 'a Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) -type transparent_state = Idpred.t * KNpred.t + val all_opaque : transparent_state val all_transparent : transparent_state @@ -82,13 +82,8 @@ val betadeltaiotanolet : reds val unfold_red : evaluable_global_reference -> reds -(************************************************************************) - -type table_key = - | ConstKey of constant - | VarKey of identifier - | FarRelKey of int - (* FarRel: index in the [rel_context] part of {\em initial} environment *) +(***********************************************************************) +type table_key = id_key type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option @@ -120,6 +115,7 @@ val stack_args_size : 'a stack -> int val app_stack : constr * constr stack -> constr val stack_tail : int -> 'a stack -> 'a stack val stack_nth : 'a stack -> int -> 'a +val zip_term : ('a -> constr) -> constr -> 'a stack -> constr (************************************************************************) (*s Lazy reduction. *) @@ -134,7 +130,7 @@ type fconstr type fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) - | FCast of fconstr * fconstr + | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor @@ -159,6 +155,8 @@ val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr +(* mk_atom: prevents a term from being evaluated *) +val mk_atom : constr -> fconstr (* Global and local constant cache *) type clos_infos diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index dba373ce..4c692308 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -6,18 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: conv_oracle.ml,v 1.2.8.2 2004/07/16 19:30:24 herbelin Exp $ *) +(* $Id: conv_oracle.ml 6303 2004-11-16 12:37:40Z sacerdot $ *) open Names -open Closure (* Opaque constants *) -let cst_transp = ref KNpred.full +let cst_transp = ref Cpred.full -let set_opaque_const kn = cst_transp := KNpred.remove kn !cst_transp -let set_transparent_const kn = cst_transp := KNpred.add kn !cst_transp +let set_opaque_const kn = cst_transp := Cpred.remove kn !cst_transp +let set_transparent_const kn = cst_transp := Cpred.add kn !cst_transp -let is_opaque_cst kn = not (KNpred.mem kn !cst_transp) +let is_opaque_cst kn = not (Cpred.mem kn !cst_transp) (* Opaque variables *) let var_transp = ref Idpred.full @@ -31,13 +30,13 @@ let is_opaque_var kn = not (Idpred.mem kn !var_transp) let is_opaque = function | ConstKey cst -> is_opaque_cst cst | VarKey id -> is_opaque_var id - | FarRelKey _ -> false + | RelKey _ -> false (* Unfold the first only if it is not opaque and the second is opaque *) let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1) (* summary operations *) - -let init() = (cst_transp := KNpred.full; var_transp := Idpred.full) +type transparent_state = Idpred.t * Cpred.t +let init() = (cst_transp := Cpred.full; var_transp := Idpred.full) let freeze () = (!var_transp, !cst_transp) let unfreeze (vo,co) = (cst_transp := co; var_transp := vo) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 8d0c12bb..966edd1d 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -6,16 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: conv_oracle.mli,v 1.3.8.3 2005/01/21 17:14:10 herbelin Exp $ i*) +(*i $Id: conv_oracle.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) open Names -open Closure + (* Order on section paths for unfolding. 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 : table_key -> table_key -> bool +val oracle_order : 'a tableKey -> 'a tableKey -> bool (* Changing the oracle *) val set_opaque_const : constant -> unit diff --git a/kernel/cooking.ml b/kernel/cooking.ml index d69efe3a..a6aa2a8e 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cooking.ml,v 1.17.8.1 2004/07/16 19:30:24 herbelin Exp $ i*) +(*i $Id: cooking.ml 6748 2005-02-18 22:17:50Z herbelin $ i*) open Pp open Util @@ -19,154 +19,110 @@ open Reduction (*s Cooking the constants. *) -type 'a modification = - | NOT_OCCUR - | DO_ABSTRACT of 'a * constr array - | DO_REPLACE of constant_body +type work_list = identifier array Cmap.t * identifier array KNmap.t -type work_list = - (constant * constant modification) list - * (inductive * inductive modification) list - * (constructor * constructor modification) list +let dirpath_prefix p = match repr_dirpath p with + | [] -> anomaly "dirpath_prefix: empty dirpath" + | _::l -> make_dirpath l -type recipe = { - d_from : constant_body; - d_abstract : identifier list; - d_modlist : work_list } +let pop_kn kn = + let (mp,dir,l) = Names.repr_kn kn in + Names.make_kn mp (dirpath_prefix dir) l + +let pop_con con = + let (mp,dir,l) = Names.repr_con con in + Names.make_con mp (dirpath_prefix dir) l + +type my_global_reference = + | ConstRef of constant + | IndRef of inductive + | ConstructRef of constructor + +let cache = (Hashtbl.create 13 : (my_global_reference, constr) Hashtbl.t) + +let clear_cooking_sharing () = Hashtbl.clear cache + +let share r (cstl,knl) = + try Hashtbl.find cache r + with Not_found -> + let f,l = + match r with + | IndRef (kn,i) -> + mkInd (pop_kn kn,i), KNmap.find kn knl + | ConstructRef ((kn,i),j) -> + mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl + | ConstRef cst -> + mkConst (pop_con cst), Cmap.find cst cstl in + let c = mkApp (f, Array.map mkVar l) in + Hashtbl.add cache r c; + (* has raised Not_found if not in work_list *) + c -let failure () = - anomalylabstrm "generic__modify_opers" - (str"An oper which was never supposed to appear has just appeared" ++ - spc () ++ str"Either this is in system code, and you need to" ++ spc () ++ - str"report this error," ++ spc () ++ - str"Or you are using a user-written tactic which calls" ++ spc () ++ - str"generic__modify_opers, in which case the user-written code" ++ - spc () ++ str"is broken - this function is an internal system" ++ - spc () ++ str"for internal system use only") - -let modify_opers replfun (constl,indl,cstrl) = +let update_case_info ci modlist = + try + let ind, n = + match kind_of_term (share (IndRef ci.ci_ind) modlist) with + | App (f,l) -> (destInd f, Array.length l) + | Ind ind -> ind, 0 + | _ -> assert false in + { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } + with Not_found -> + ci + +let empty_modlist = (Cmap.empty, KNmap.empty) + +let expmod_constr modlist c = let rec substrec c = - let c' = map_constr substrec c in - match kind_of_term c' with + match kind_of_term c with | Case (ci,p,t,br) -> + map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) + + | Ind ind -> (try - match List.assoc ci.ci_ind indl with - | DO_ABSTRACT (ind,abs_vars) -> - let n' = Array.length abs_vars + ci.ci_npar in - let ci' = { ci with - ci_ind = ind; - ci_npar = n' } in - mkCase (ci',p,t,br) - | _ -> raise Not_found - with - | Not_found -> c') - - | Ind spi -> - (try - (match List.assoc spi indl with - | NOT_OCCUR -> failure () - | DO_ABSTRACT (oper',abs_vars) -> - mkApp (mkInd oper', abs_vars) - | DO_REPLACE _ -> assert false) + share (IndRef ind) modlist with - | Not_found -> c') - - | Construct spi -> + | Not_found -> map_constr substrec c) + + | Construct cstr -> (try - (match List.assoc spi cstrl with - | NOT_OCCUR -> failure () - | DO_ABSTRACT (oper',abs_vars) -> - mkApp (mkConstruct oper', abs_vars) - | DO_REPLACE _ -> assert false) + share (ConstructRef cstr) modlist with - | Not_found -> c') - - | Const kn -> + | Not_found -> map_constr substrec c) + + | Const cst -> (try - (match List.assoc kn constl with - | NOT_OCCUR -> failure () - | DO_ABSTRACT (oper',abs_vars) -> - mkApp (mkConst oper', abs_vars) - | DO_REPLACE cb -> substrec (replfun (kn,cb))) + share (ConstRef cst) modlist with - | Not_found -> c') - - | _ -> c' - in - if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec + | Not_found -> map_constr substrec c) + + | _ -> map_constr substrec c -let expmod_constr modlist c = - let simpfun = - if modlist = ([],[],[]) then fun x -> x else nf_betaiota in - let expfun (kn,cb) = - if cb.const_opaque then - errorlabstrm "expmod_constr" - (str"Cannot unfold the value of " ++ - str(string_of_kn kn) ++ spc () ++ - str"You cannot declare local lemmas as being opaque" ++ spc () ++ - str"and then require that theorems which use them" ++ spc () ++ - str"be transparent"); - match cb.const_body with - | Some body -> Declarations.force body - | None -> assert false - in - let c' = modify_opers expfun modlist c in - match kind_of_term c' with - | Cast (value,typ) -> mkCast (simpfun value,simpfun typ) - | _ -> simpfun c' - -let expmod_type modlist c = - type_app (expmod_constr modlist) c - -let abstract_constant ids_to_abs hyps (body,typ) = - let abstract_once_typ ((hyps,typ) as sofar) id = - match hyps with - | (hyp,c,t as decl)::rest when hyp = id -> - let typ' = mkNamedProd_wo_LetIn decl typ in - (rest, typ') - | _ -> - sofar - in - let abstract_once_body ((hyps,body) as sofar) id = - match hyps with - | (hyp,c,t as decl)::rest when hyp = id -> - let body' = mkNamedLambda_or_LetIn decl body in - (rest, body') - | _ -> - sofar - in - let (_,typ') = - List.fold_left abstract_once_typ (hyps,typ) ids_to_abs - in - let body' = match body with - None -> None - | Some l_body -> - Some (Declarations.from_val - (let body = Declarations.force l_body in - let (_,body') = - List.fold_left abstract_once_body (hyps,body) ids_to_abs - in - body')) in - (body',typ') + if modlist = empty_modlist then c + else under_outer_cast nf_betaiota (substrec c) + +let abstract_constant_type = + List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) + +let abstract_constant_body = + List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c) + +type recipe = { + d_from : constant_body; + d_abstract : named_context; + d_modlist : work_list } + +let on_body f = + option_app (fun c -> Declarations.from_val (f (Declarations.force c))) let cook_constant env r = let cb = r.d_from in - let typ = expmod_type r.d_modlist cb.const_type in - let body = - option_app - (fun lconstr -> - Declarations.from_val - (expmod_constr r.d_modlist (Declarations.force lconstr))) - cb.const_body - in - let hyps = - Sign.fold_named_context - (fun d ctxt -> - Sign.add_named_decl - (map_named_declaration (expmod_constr r.d_modlist) d) - ctxt) - cb.const_hyps - ~init:empty_named_context in - let body,typ = abstract_constant r.d_abstract hyps (body,typ) in - (body, typ, cb.const_constraints, cb.const_opaque) + let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in + let body = + on_body (fun c -> + abstract_constant_body (expmod_constr r.d_modlist c) hyps) + cb.const_body in + let typ = + abstract_constant_type (expmod_constr r.d_modlist cb.const_type) hyps in + let boxed = Cemitcodes.is_boxed cb.const_body_code in + (body, typ, cb.const_constraints, cb.const_opaque, boxed) diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 54526e99..7b51ac0c 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cooking.mli,v 1.9.8.1 2004/07/16 19:30:24 herbelin Exp $ i*) +(*i $Id: cooking.mli 6748 2005-02-18 22:17:50Z herbelin $ i*) open Names open Term @@ -16,27 +16,22 @@ open Univ (*s Cooking the constants. *) -type 'a modification = - | NOT_OCCUR - | DO_ABSTRACT of 'a * constr array - | DO_REPLACE of constant_body - -type work_list = - (constant * constant modification) list - * (inductive * inductive modification) list - * (constructor * constructor modification) list +type work_list = identifier array Cmap.t * identifier array KNmap.t type recipe = { d_from : constant_body; - d_abstract : identifier list; + d_abstract : Sign.named_context; d_modlist : work_list } val cook_constant : - env -> recipe -> constr_substituted option * constr * constraints * bool + env -> recipe -> + constr_substituted option * constr * constraints * bool * bool (*s Utility functions used in module [Discharge]. *) val expmod_constr : work_list -> constr -> constr -val expmod_type : work_list -> types -> types + +val clear_cooking_sharing : unit -> unit + diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml new file mode 100644 index 00000000..fc2d0925 --- /dev/null +++ b/kernel/csymtable.ml @@ -0,0 +1,179 @@ +open Names +open Term +open Vm +open Cemitcodes +open Cbytecodes +open Declarations +open Pre_env +open Cbytegen + + +external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" +external free_tcode : tcode -> unit = "coq_static_free" +external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" + +(*******************) +(* Linkage du code *) +(*******************) + +(* Table des globaux *) + +(* [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" + +(* [realloc_global_data n] augmente de n la taille de [global_data] *) +external realloc_global_data : int -> unit = "realloc_coq_global_data" + +let check_global_data n = + if n >= Array.length (global_data()) then realloc_global_data n + +let num_global = ref 0 + +let set_global v = + let n = !num_global in + check_global_data n; + (global_data()).(n) <- v; + incr num_global; + n + +(* [global_transp],[global_boxed] contiennent les valeurs des + definitions gelees. Les deux versions sont maintenues en //. + [global_transp] contient la version transparente. + [global_boxed] contient la version gelees. *) + +external global_boxed : unit -> bool array = "get_coq_global_boxed" + +(* [realloc_global_data n] augmente de n la taille de [global_data] *) +external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed" + +let check_global_boxed n = + if n >= Array.length (global_boxed()) then realloc_global_boxed n + +let num_boxed = ref 0 + +let boxed_tbl = Hashtbl.create 53 + +let cst_opaque = ref Cpred.full + +let is_opaque kn = Cpred.mem kn !cst_opaque + +let set_global_boxed kn v = + let n = !num_boxed in + check_global_boxed n; + (global_boxed()).(n) <- (is_opaque kn); + Hashtbl.add boxed_tbl kn n ; + incr num_boxed; + set_global (val_of_constant_def n kn v) + +(* table pour les structured_constant et les annotations des switchs *) + +let str_cst_tbl = Hashtbl.create 31 + (* (structured_constant * int) Hashtbl.t*) + +let annot_tbl = Hashtbl.create 31 + (* (annot_switch * int) Hashtbl.t *) + +(*************************************************************) +(*** Mise a jour des valeurs des variables et des constantes *) +(*************************************************************) + +exception NotEvaluated + +let key rk = + match !rk with + | Some k -> k + | _ -> raise NotEvaluated + +(************************) +(* traduction des patch *) + +(* slot_for_*, calcul la valeur de l'objet, la place + dans la table global, rend sa position dans la table *) + +let slot_for_str_cst key = + try Hashtbl.find str_cst_tbl key + with Not_found -> + let n = set_global (val_of_str_const key) in + Hashtbl.add str_cst_tbl key n; + n + +let slot_for_annot key = + try Hashtbl.find annot_tbl key + with Not_found -> + let n = set_global (Obj.magic key) in + Hashtbl.add annot_tbl key n; + n + +let rec slot_for_getglobal env kn = + let (cb,rk) = lookup_constant_key kn env in + try key rk + with NotEvaluated -> + let pos = + match Cemitcodes.force cb.const_body_code with + | BCdefined(boxed,(code,pl,fv)) -> + let v = eval_to_patch env (code,pl,fv) in + if boxed then set_global_boxed kn v + else set_global v + | BCallias kn' -> slot_for_getglobal env kn' + | BCconstant -> set_global (val_of_constant kn) in + rk := Some pos; + pos + +and slot_for_fv env fv= + match fv with + | FVnamed id -> + let nv = lookup_named_val id env in + begin + match !nv with + | VKvalue v -> v + | VKaxiom id -> + let v = val_of_named id in + nv := VKvalue v; v + | VKdef c -> + let v = val_of_constr (env_of_named id env) c in + nv := VKvalue v; v + end + | FVrel i -> + let rv = lookup_rel_val i env in + begin + match !rv with + | VKvalue v -> v + | VKaxiom k -> + let v = val_of_rel k in + rv := VKvalue v; v + | VKdef c -> + let v = val_of_constr (env_of_rel i env) c in + rv := VKvalue v; v + end + +and eval_to_patch env (buff,pl,fv) = + let patch = function + | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a) + | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc) + | Reloc_getglobal kn, pos -> + patch_int buff pos (slot_for_getglobal env kn) + in + List.iter patch pl; + 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 + +and val_of_constr env c = + let (_,fun_code,_ as ccfv) = + try compile env c + with e -> print_string "can not compile \n";Format.print_flush();raise e in + eval_to_patch env (to_memory ccfv) + +let set_transparent_const kn = + cst_opaque := Cpred.remove kn !cst_opaque; + List.iter (fun n -> (global_boxed()).(n) <- false) + (Hashtbl.find_all boxed_tbl kn) + +let set_opaque_const kn = + cst_opaque := Cpred.add kn !cst_opaque; + List.iter (fun n -> (global_boxed()).(n) <- true) + (Hashtbl.find_all boxed_tbl kn) + + diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli new file mode 100644 index 00000000..2640a4df --- /dev/null +++ b/kernel/csymtable.mli @@ -0,0 +1,8 @@ +open Names +open Term +open Pre_env + +val val_of_constr : env -> constr -> values + +val set_opaque_const : constant -> unit +val set_transparent_const : constant -> unit diff --git a/kernel/declarations.ml b/kernel/declarations.ml index ac2c52cc..33d9959c 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declarations.ml,v 1.31.2.2 2005/11/29 21:40:51 letouzey Exp $ i*) +(*i $Id: declarations.ml 8653 2006-03-22 09:41:17Z herbelin $ i*) (*i*) open Util @@ -14,40 +14,33 @@ open Names open Univ open Term open Sign +open Mod_subst (*i*) (* This module defines the types of global declarations. This includes global constants/axioms and mutual inductive definitions *) -(*s Constants (internal representation) (Definition/Axiom) *) +type engagement = ImpredicativeSet + -type subst_internal = - | Constr of constr - | LazyConstr of substitution * constr +(*s Constants (internal representation) (Definition/Axiom) *) -type constr_substituted = subst_internal ref +type constr_substituted = constr substituted -let from_val c = ref (Constr c) +let from_val = from_val -let force cs = match !cs with - Constr c -> c - | LazyConstr (subst,c) -> - let c' = subst_mps subst c in - cs := Constr c'; - c' +let force = force subst_mps -let subst_constr_subst subst cs = match !cs with - Constr c -> ref (LazyConstr (subst,c)) - | LazyConstr (subst',c) -> - let subst'' = join subst' subst in - ref (LazyConstr (subst'',c)) +let subst_constr_subst = subst_substituted type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constr_substituted option; - const_type : types; - const_constraints : constraints; - const_opaque : bool } + const_hyps : section_context; (* New: younger hyp at top *) + const_body : constr_substituted option; + const_type : types; + const_body_code : Cemitcodes.to_patch_substituted; + (* const_type_code : Cemitcodes.to_patch; *) + const_constraints : constraints; + const_opaque : bool } (*s Inductive types (internal representation with redundant information). *) @@ -82,72 +75,140 @@ let recarg_length p j = let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p -(* [mind_typename] is the name of the inductive; [mind_arity] is - the arity generalized over global parameters; [mind_lc] is the list - of types of constructors generalized over global parameters and - relative to the global context enriched with the arities of the - inductives *) +(**********************************************************************) +(* Representation of mutual inductive types in the kernel *) +(* + Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 + ... + with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn +*) type one_inductive_body = { - mind_typename : identifier; - mind_nparams : int; - mind_params_ctxt : rel_context; - mind_nrealargs : int; - mind_nf_arity : types; - mind_user_arity : types; - mind_sort : sorts; - mind_kelim : sorts_family list; - mind_consnames : identifier array; - mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) - mind_user_lc : types array; - mind_recargs : wf_paths; - } + +(* Primitive datas *) + + (* Name of the type: [Ii] *) + mind_typename : identifier; + + (* Arity of [Ii] with parameters: [forall params, Ui] *) + mind_user_arity : types; + + (* Names of the constructors: [cij] *) + mind_consnames : identifier array; + + (* Types of the constructors with parameters: [forall params, Tij], + where the Ik are replaced by de Bruijn index in the context + I1:forall params, U1 .. In:forall params, Un *) + mind_user_lc : types array; + +(* Derived datas *) + + (* Head normalized arity so that the conclusion is a sort *) + mind_nf_arity : types; + + (* Number of expected real arguments of the type (no let, no params) *) + mind_nrealargs : int; + + (* Conclusion of the arity *) + mind_sort : sorts; + + (* List of allowed elimination sorts *) + mind_kelim : sorts_family list; + + (* Head normalized constructor types so that their conclusion is atomic *) + mind_nf_lc : types array; + + (* Length of the signature of the constructors (with let, w/o params) *) + mind_consnrealdecls : int array; + + (* Signature of recursive arguments in the constructors *) + mind_recargs : wf_paths; + +(* Datas for bytecode compilation *) + + (* number of constant constructor *) + mind_nb_constant : int; + + (* number of no constant constructor *) + mind_nb_args : int; + + mind_reloc_tbl : Cbytecodes.reloc_table; + } type mutual_inductive_body = { - mind_record : bool; - mind_finite : bool; - mind_ntypes : int; - mind_hyps : section_context; - mind_packets : one_inductive_body array; - mind_constraints : constraints; - mind_equiv : kernel_name option - } + + (* The component of the mutual inductive block *) + mind_packets : one_inductive_body array; + + (* Whether the inductive type has been declared as a record *) + mind_record : bool; + + (* Whether the type is inductive or coinductive *) + mind_finite : bool; + + (* Number of types in the block *) + mind_ntypes : int; + + (* Section hypotheses on which the block depends *) + mind_hyps : section_context; + + (* Number of expected parameters *) + mind_nparams : int; + + (* Number of recursively uniform (i.e. ordinary) parameters *) + mind_nparams_rec : int; + + (* The context of parameters (includes let-in declaration) *) + mind_params_ctxt : rel_context; + + (* Universes constraints enforced by the inductive declaration *) + mind_constraints : constraints; + + (* Source of the inductive block when aliased in a module *) + mind_equiv : kernel_name option + } (* TODO: should be changed to non-coping after Term.subst_mps *) -let subst_const_body sub cb = - { const_body = option_app (subst_constr_subst sub) cb.const_body; - const_type = type_app (Term.subst_mps sub) cb.const_type; +let subst_const_body sub cb = { const_hyps = (assert (cb.const_hyps=[]); []); + const_body = option_app (subst_constr_subst sub) cb.const_body; + const_type = type_app (subst_mps sub) cb.const_type; + const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; + (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) const_constraints = cb.const_constraints; - const_opaque = cb.const_opaque} - + const_opaque = cb.const_opaque } + let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; + mind_consnrealdecls = mbp.mind_consnrealdecls; mind_typename = mbp.mind_typename; mind_nf_lc = - array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_nf_lc; - mind_nf_arity = type_app (Term.subst_mps sub) mbp.mind_nf_arity; + array_smartmap (type_app (subst_mps sub)) mbp.mind_nf_lc; + mind_nf_arity = type_app (subst_mps sub) mbp.mind_nf_arity; mind_user_lc = - array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_user_lc; - mind_user_arity = type_app (Term.subst_mps sub) mbp.mind_user_arity; + array_smartmap (type_app (subst_mps sub)) mbp.mind_user_lc; + mind_user_arity = type_app (subst_mps sub) mbp.mind_user_arity; mind_sort = mbp.mind_sort; mind_nrealargs = mbp.mind_nrealargs; mind_kelim = mbp.mind_kelim; - mind_nparams = mbp.mind_nparams; - mind_params_ctxt = - map_rel_context (Term.subst_mps sub) mbp.mind_params_ctxt; - mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); -} + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_nb_constant = mbp.mind_nb_constant; + mind_nb_args = mbp.mind_nb_args; + mind_reloc_tbl = mbp.mind_reloc_tbl } + let subst_mind sub mib = { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (assert (mib.mind_hyps=[]); []) ; + mind_nparams = mib.mind_nparams; + mind_nparams_rec = mib.mind_nparams_rec; + mind_params_ctxt = + map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints ; - mind_equiv = option_app (subst_kn sub) mib.mind_equiv; -} + mind_equiv = option_app (subst_kn sub) mib.mind_equiv } (*s Modules: signature component specifications, module types, and @@ -171,7 +232,6 @@ and module_specification_body = msb_equiv : module_path option; msb_constraints : constraints } - type structure_elem_body = | SEBconst of constant_body | SEBmind of mutual_inductive_body @@ -193,3 +253,4 @@ and module_body = mod_type : module_type_body; mod_equiv : module_path option; mod_constraints : constraints } + diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 6cff3936..7ad953e5 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -6,20 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declarations.mli,v 1.33.2.3 2005/11/29 21:40:51 letouzey Exp $ i*) +(*i $Id: declarations.mli 8653 2006-03-22 09:41:17Z herbelin $ i*) (*i*) open Names open Univ open Term +open Cemitcodes open Sign +open Mod_subst (*i*) (* This module defines the internal representation of global declarations. This includes global constants/axioms, mutual inductive definitions, modules and module types *) -(*s Constants (Definition/Axiom) *) +type engagement = ImpredicativeSet + +(**********************************************************************) +(*s Representation of constants (Definition/Axiom) *) type constr_substituted @@ -27,16 +32,18 @@ val from_val : constr -> constr_substituted val force : constr_substituted -> constr type constant_body = { - const_hyps : section_context; (* New: younger hyp at top *) - const_body : constr_substituted option; - const_type : types; - const_constraints : constraints; - const_opaque : bool } + const_hyps : section_context; (* New: younger hyp at top *) + const_body : constr_substituted option; + const_type : types; + const_body_code : to_patch_substituted; + (*i const_type_code : to_patch;i*) + const_constraints : constraints; + const_opaque : bool } val subst_const_body : substitution -> constant_body -> constant_body -(*s Inductive types (internal representation with redundant - information). *) +(**********************************************************************) +(*s Representation of mutual inductive types in the kernel *) type recarg = | Norec @@ -55,41 +62,102 @@ val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths -(* [mind_typename] is the name of the inductive; [mind_arity] is - the arity generalized over global parameters; [mind_lc] is the list - of types of constructors generalized over global parameters and - relative to the global context enriched with the arities of the - inductives *) +(* +\begin{verbatim} + Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1 + ... + with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn +\end{verbatim} +*) type one_inductive_body = { - mind_typename : identifier; - mind_nparams : int; - mind_params_ctxt : rel_context; - mind_nrealargs : int; - mind_nf_arity : types; - mind_user_arity : types; - mind_sort : sorts; - mind_kelim : sorts_family list; - mind_consnames : identifier array; - mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) - mind_user_lc : types array; - mind_recargs : wf_paths; - } + +(* Primitive datas *) + + (* Name of the type: [Ii] *) + mind_typename : identifier; + + (* Arity of [Ii] with parameters: [forall params, Ui] *) + mind_user_arity : types; + + (* Names of the constructors: [cij] *) + mind_consnames : identifier array; + + (* Types of the constructors with parameters: [forall params, Tij], + where the Ik are replaced by de Bruijn index in the context + I1:forall params, U1 .. In:forall params, Un *) + mind_user_lc : types array; + +(* Derived datas *) + + (* Head normalized arity so that the conclusion is a sort *) + mind_nf_arity : types; + + (* Number of expected real arguments of the type (no let, no params) *) + mind_nrealargs : int; + + (* Conclusion of the arity *) + mind_sort : sorts; + + (* List of allowed elimination sorts *) + mind_kelim : sorts_family list; + + (* Head normalized constructor types so that their conclusion is atomic *) + mind_nf_lc : types array; + + (* Length of the signature of the constructors (with let, w/o params) *) + mind_consnrealdecls : int array; + + (* Signature of recursive arguments in the constructors *) + mind_recargs : wf_paths; + +(* Datas for bytecode compilation *) + + (* number of constant constructor *) + mind_nb_constant : int; + + (* number of no constant constructor *) + mind_nb_args : int; + + mind_reloc_tbl : Cbytecodes.reloc_table; + } type mutual_inductive_body = { - mind_record : bool; - mind_finite : bool; - mind_ntypes : int; - mind_hyps : section_context; - mind_packets : one_inductive_body array; - mind_constraints : constraints; - mind_equiv : kernel_name option; - } + (* The component of the mutual inductive block *) + mind_packets : one_inductive_body array; -val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body + (* Whether the inductive type has been declared as a record *) + mind_record : bool; + + (* Whether the type is inductive or coinductive *) + mind_finite : bool; + + (* Number of types in the block *) + mind_ntypes : int; + (* Section hypotheses on which the block depends *) + mind_hyps : section_context; + + (* Number of expected parameters *) + mind_nparams : int; + + (* Number of recursively uniform (i.e. ordinary) parameters *) + mind_nparams_rec : int; + + (* The context of parameters (includes let-in declaration) *) + mind_params_ctxt : rel_context; + + (* Universes constraints enforced by the inductive declaration *) + mind_constraints : constraints; + + (* Source of the inductive block when aliased in a module *) + mind_equiv : kernel_name option + } + +val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body +(**********************************************************************) (*s Modules: signature component specifications, module types, and module declarations *) diff --git a/kernel/entries.ml b/kernel/entries.ml index a3d3d336..56b198c3 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: entries.ml,v 1.3.8.2 2005/11/29 21:40:51 letouzey Exp $ i*) +(*i $Id: entries.ml 8647 2006-03-18 15:33:09Z herbelin $ i*) (*i*) open Names @@ -32,9 +32,9 @@ type local_entry = (* Assume the following definition in concrete syntax: \begin{verbatim} -Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1 +Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1 ... -with Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. +with Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. \end{verbatim} then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]]; [mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]]; @@ -42,7 +42,6 @@ then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]]; *) type one_inductive_entry = { - mind_entry_params : (identifier * local_entry) list; mind_entry_typename : identifier; mind_entry_arity : constr; mind_entry_consnames : identifier list; @@ -51,6 +50,7 @@ type one_inductive_entry = { type mutual_inductive_entry = { mind_entry_record : bool; mind_entry_finite : bool; + mind_entry_params : (identifier * local_entry) list; mind_entry_inds : one_inductive_entry list } @@ -59,7 +59,8 @@ type mutual_inductive_entry = { type definition_entry = { const_entry_body : constr; const_entry_type : types option; - const_entry_opaque : bool } + const_entry_opaque : bool; + const_entry_boxed : bool} type parameter_entry = types @@ -84,8 +85,8 @@ and module_type_entry = and module_signature_entry = (label * specification_entry) list and with_declaration = - With_Module of identifier * module_path - | With_Definition of identifier * constr + With_Module of identifier list * module_path + | With_Definition of identifier list * constr and module_expr = MEident of module_path diff --git a/kernel/entries.mli b/kernel/entries.mli index e9bc420e..b9a95d44 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: entries.mli,v 1.3.8.2 2005/11/29 21:40:51 letouzey Exp $ i*) +(*i $Id: entries.mli 8647 2006-03-18 15:33:09Z herbelin $ i*) (*i*) open Names @@ -32,9 +32,9 @@ type local_entry = (* Assume the following definition in concrete syntax: \begin{verbatim} -Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1 +Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1 ... -with Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. +with Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. \end{verbatim} then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]]; [mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]]; @@ -42,7 +42,6 @@ then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]]; *) type one_inductive_entry = { - mind_entry_params : (identifier * local_entry) list; mind_entry_typename : identifier; mind_entry_arity : constr; mind_entry_consnames : identifier list; @@ -51,15 +50,16 @@ type one_inductive_entry = { type mutual_inductive_entry = { mind_entry_record : bool; mind_entry_finite : bool; + mind_entry_params : (identifier * local_entry) list; mind_entry_inds : one_inductive_entry list } - (*s Constants (Definition/Axiom) *) type definition_entry = { const_entry_body : constr; const_entry_type : types option; - const_entry_opaque : bool } + const_entry_opaque : bool; + const_entry_boxed : bool } type parameter_entry = types @@ -84,8 +84,8 @@ and module_type_entry = and module_signature_entry = (label * specification_entry) list and with_declaration = - With_Module of identifier * module_path - | With_Definition of identifier * constr + With_Module of identifier list * module_path + | With_Definition of identifier list * constr and module_expr = MEident of module_path diff --git a/kernel/environ.ml b/kernel/environ.ml index ec3c903d..77d77118 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: environ.ml,v 1.89.2.1 2004/07/16 19:30:25 herbelin Exp $ *) +(* $Id: environ.ml 7830 2006-01-10 22:45:28Z herbelin $ *) open Util open Names @@ -14,49 +14,25 @@ open Sign open Univ open Term open Declarations +open Pre_env +open Csymtable (* The type of environments. *) -type checksum = int +type named_context_val = Pre_env.named_context_val -type compilation_unit_name = dir_path * checksum +type env = Pre_env.env -type global = Constant | Inductive +let pre_env env = env -type engagement = ImpredicativeSet +let empty_named_context_val = empty_named_context_val -type globals = { - env_constants : constant_body KNmap.t; - env_inductives : mutual_inductive_body KNmap.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body KNmap.t } - -type stratification = { - env_universes : universes; - env_engagement : engagement option -} - -type env = { - env_globals : globals; - env_named_context : named_context; - env_rel_context : rel_context; - env_stratification : stratification } - -let empty_env = { - env_globals = { - env_constants = KNmap.empty; - env_inductives = KNmap.empty; - env_modules = MPmap.empty; - env_modtypes = KNmap.empty }; - env_named_context = empty_named_context; - env_rel_context = empty_rel_context; - env_stratification = { - env_universes = initial_universes; - env_engagement = None } } +let empty_env = empty_env let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context +let named_context_val env = env.env_named_context,env.env_named_vals let rel_context env = env.env_rel_context let empty_context env = @@ -75,68 +51,109 @@ let evaluable_rel n env = with Not_found -> false -let push_rel d env = - { env with - env_rel_context = add_rel_decl d env.env_rel_context } +let nb_rel env = env.env_nb_rel + +let push_rel = push_rel let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x + let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, type_app (lift i) t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt - + let reset_rel_context env = { env with - env_rel_context = empty_rel_context } + env_rel_context = empty_rel_context; + env_rel_val = []; + env_nb_rel = 0 } let fold_rel_context f env ~init = - snd (Sign.fold_rel_context - (fun d (env,e) -> (push_rel d env, f env d e)) - (rel_context env) ~init:(reset_rel_context env,init)) - + let rec fold_right env = + match env.env_rel_context with + | [] -> init + | 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 (* Named context *) -let lookup_named id env = - Sign.lookup_named id env.env_named_context -(* A local const is evaluable if it is defined and not opaque *) -let evaluable_named id env = - try - match lookup_named id env with - (_,Some _,_) -> true - | _ -> false - with Not_found -> - false +let named_context_of_val = fst -let push_named d env = - { env with - env_named_context = Sign.add_named_decl d env.env_named_context } +(* [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 f (ctxt,ctxtv) = + let ctxt = + List.map (fun (id,body,typ) -> (id, option_app f body, f typ)) ctxt in + (ctxt,ctxtv) -let reset_context env = - { env with - env_named_context = empty_named_context; - env_rel_context = empty_rel_context } +let empty_named_context = empty_named_context -let reset_with_named_context ctxt env = - { env with - env_named_context = ctxt; - env_rel_context = empty_rel_context } +let push_named = 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 id env = Sign.lookup_named id env.env_named_context +let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt + +let eq_named_context_val c1 c2 = + c1 == c2 || named_context_of_val c1 = named_context_of_val c2 + +(* A local const is evaluable if it is defined *) + +let named_type id env = + let (_,_,t) = lookup_named id env in t +let named_body id env = + let (_,b,_) = lookup_named id env in b + +let evaluable_named id env = + try + match named_body id env with + |Some _ -> true + | _ -> false + with Not_found -> false + +let reset_with_named_context (ctxt,ctxtv) env = + { env with + env_named_context = ctxt; + env_named_vals = ctxtv; + env_rel_context = empty_rel_context; + env_rel_val = []; + env_nb_rel = 0 } + +let reset_context = reset_with_named_context empty_named_context_val + let fold_named_context f env ~init = - snd (Sign.fold_named_context - (fun d (env,e) -> (push_named d env, f env d e)) - (named_context env) ~init:(reset_context env,init)) + let rec fold_right env = + match env.env_named_context with + | [] -> init + | d::ctxt -> + let env = + reset_with_named_context (ctxt,List.tl env.env_named_vals) env in + f env d (fold_right env) + in fold_right env let fold_named_context_reverse f ~init env = - Sign.fold_named_context_reverse f ~init:init (named_context env) - + Sign.fold_named_context_reverse f ~init:init (named_context env) + (* Global constants *) -let lookup_constant kn env = - KNmap.find kn env.env_globals.env_constants -let add_constant kn cb env = - let new_constants = KNmap.add kn cb env.env_globals.env_constants in +let lookup_constant = lookup_constant + +let add_constant kn cs env = + let new_constants = + Cmap.add kn (cs,ref None) env.env_globals.env_constants in let new_globals = { env.env_globals with env_constants = new_constants } in @@ -168,8 +185,7 @@ let evaluable_constant cst env = with Not_found | NotEvaluableConst _ -> false (* Mutual Inductives *) -let lookup_mind kn env = - KNmap.find kn env.env_globals.env_inductives +let lookup_mind = lookup_mind let add_mind kn mib env = let new_inds = KNmap.add kn mib env.env_globals.env_inductives in @@ -253,7 +269,6 @@ let keep_hyps env needed = (named_context env) ~init:empty_named_context - (* Modules *) let add_modtype ln mtb env = @@ -293,3 +308,61 @@ type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } +(*s Compilation of global declaration *) + +let compile_constant_body = Cbytegen.compile_constant_body + +(*s Special functions for the refiner (logic.ml) *) + +let clear_hyps ids check (ctxt,vals) = + let ctxt,vals,rmv = + List.fold_right2 (fun (id,_,_ as d) v (ctxt,vals,rmv) -> + if List.mem id ids then (ctxt,vals,id::rmv) + else begin + check rmv d; + (d::ctxt,v::vals,rmv) + end) ctxt vals ([],[],[]) + in ((ctxt,vals),rmv) + +exception Hyp_not_found + +let rec apply_to_hyp (ctxt,vals) id f = + let rec aux rtail ctxt vals = + match ctxt, vals with + | (idc,c,ct as d)::ctxt, v::vals -> + if idc = id then + (f ctxt d rtail)::ctxt, v::vals + else + let ctxt',vals' = aux (d::rtail) ctxt vals in + d::ctxt', v::vals' + | [],[] -> raise Hyp_not_found + | _, _ -> assert false + in aux [] ctxt vals + +let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g = + let rec aux ctxt vals = + match ctxt,vals with + | (idc,c,ct as d)::ctxt, v::vals -> + if idc = id then + let sign = ctxt,vals in + push_named_context_val (f d sign) sign + else + let (ctxt,vals as sign) = aux ctxt vals in + push_named_context_val (g d sign) sign + | [],[] -> raise Hyp_not_found + | _,_ -> assert false + in aux ctxt vals + +let insert_after_hyp (ctxt,vals) id d check = + let rec aux ctxt vals = + match ctxt, vals with + | (idc,c,ct)::ctxt', v::vals' -> + if idc = id then begin + check ctxt; + push_named_context_val d (ctxt,vals) + end else + let ctxt,vals = aux ctxt vals in + d::ctxt, v::vals + | [],[] -> raise Hyp_not_found + | _, _ -> assert false + in aux ctxt vals diff --git a/kernel/environ.mli b/kernel/environ.mli index a2a66cb7..701159da 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: environ.mli,v 1.66.2.2 2005/01/21 16:41:49 herbelin Exp $ i*) +(*i $Id: environ.mli 7640 2005-12-05 10:16:24Z gregoire $ i*) (*i*) open Names @@ -22,21 +22,30 @@ open Sign (* Environments have the following components: - a context for de Bruijn variables + - a context for de Bruijn variables vm values - a context for section variables and goal assumptions + - a context for section variables and goal assumptions vm values - a context for global constants and axioms - a context for inductive definitions - a set of universe constraints - a flag telling if Set is, can be, or cannot be set impredicative *) + + + type env +val pre_env : env -> Pre_env.env + +type named_context_val +val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> Univ.universes val rel_context : env -> rel_context val named_context : env -> named_context +val named_context_val : env -> named_context_val -type engagement = ImpredicativeSet val engagement : env -> engagement option @@ -45,6 +54,7 @@ val empty_context : env -> bool (************************************************************************) (*s Context of de Bruijn variables ([rel_context]) *) +val nb_rel : env -> int val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : rec_declaration -> env -> env @@ -60,14 +70,35 @@ val fold_rel_context : (************************************************************************) (* Context of variables (section variables and goal assumptions) *) + +val named_context_of_val : named_context_val -> named_context +val val_of_named_context : named_context -> named_context_val +val empty_named_context_val : named_context_val + + +(* [map_named_val f ctxt] apply [f] to the body and the type of + each declarations. + *** /!\ *** [f t] should be convertible with t *) +val map_named_val : + (constr -> constr) -> named_context_val -> named_context_val + val push_named : named_declaration -> env -> env +val push_named_context_val : + 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 identifier is not found *) -val lookup_named : variable -> env -> named_declaration -val evaluable_named : variable -> env -> bool +val lookup_named : variable -> env -> named_declaration +val lookup_named_val : variable -> named_context_val -> named_declaration +val evaluable_named : variable -> env -> bool +val named_type : variable -> env -> types +val named_body : variable -> env -> constr option + (*s Recurrence on [named_context]: older declarations processed first *) + val fold_named_context : (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a @@ -78,7 +109,7 @@ val fold_named_context_reverse : (* This forgets named and rel contexts *) val reset_context : env -> env (* This forgets rel context and sets a new named context *) -val reset_with_named_context : named_context -> env -> env +val reset_with_named_context : named_context_val -> env -> env (************************************************************************) (*s Global constants *) @@ -87,6 +118,7 @@ val add_constant : constant -> constant_body -> env -> env (* Looks up in the context of global constant names *) (* raises [Not_found] if the required path is not found *) + val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool @@ -153,7 +185,35 @@ type unsafe_type_judgment = { utj_type : sorts } +(*s Compilation of global declaration *) + +val compile_constant_body : + env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code + (* opaque *) (* boxed *) + +(*s Functions for proofs/logic.ml *) +val clear_hyps : + variable list -> (variable list -> named_declaration -> unit) -> + named_context_val -> named_context_val * variable list + +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 -> + (named_context -> named_declaration -> named_context -> named_declaration) -> + named_context_val +(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into + [tail::(id,_,_)::head] and + return [(g tail)::(f (id,_,_))::head]. *) +val apply_to_hyp_and_dependent_on : named_context_val -> variable -> + (named_declaration -> named_context_val -> named_declaration) -> + (named_declaration -> named_context_val -> named_declaration) -> + named_context_val +val insert_after_hyp : named_context_val -> variable -> + named_declaration -> + (named_context -> unit) -> named_context_val diff --git a/kernel/esubst.ml b/kernel/esubst.ml index 38db01fc..0a3f4578 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: esubst.ml,v 1.4.2.1 2004/07/16 19:30:25 herbelin Exp $ *) +(* $Id: esubst.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Util diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 2fe981f7..39fbbede 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: esubst.mli,v 1.3.2.2 2005/01/21 17:14:10 herbelin Exp $ i*) +(*i $Id: esubst.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) (*s Compact representation of explicit relocations. \\ [ELSHFT(l,n)] == lift of [n], then apply [lift l]. diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 0b1d49f5..a3fc0db4 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: indtypes.ml,v 1.59.2.4 2005/12/30 15:58:59 barras Exp $ *) +(* $Id: indtypes.ml 8653 2006-03-22 09:41:17Z herbelin $ *) open Util open Names @@ -26,14 +26,14 @@ let weaker_noccur_between env x nvars t = if noccur_between x nvars t then Some t else let t' = whd_betadeltaiota env t in - if noccur_between x nvars t then Some t' + if noccur_between x nvars t' then Some t' else None (************************************************************************) (* Various well-formedness check for inductive declarations *) +(* Errors related to inductive constructions *) type inductive_error = - (* These are errors related to inductive constructions in this module *) | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr @@ -43,10 +43,6 @@ type inductive_error = | SameNamesOverlap of identifier list | NotAnArity of identifier | BadEntry - (* These are errors related to recursors building in Indrec *) - | NotAllowedCaseAnalysis of bool * sorts * inductive - | BadInduction of bool * identifier * sorts - | NotMutualInScheme exception InductiveError of inductive_error @@ -141,7 +137,7 @@ let rec infos_and_sort env t = let logic = not (is_info_type env varj) in let small = Term.is_small varj.utj_type in (logic,small) :: (infos_and_sort env1 c2) - | Cast (c,_) -> infos_and_sort env c + | Cast (c,_,_) -> infos_and_sort env c | _ -> [] let small_unit constrsinfos = @@ -175,19 +171,19 @@ let type_one_constructor env_ar_par params arsort c = (infos, full_cstr_type, cst2) -let infer_constructor_packet env_ar params arsort vc = +let infer_constructor_packet env_ar params arsort lc = let env_ar_par = push_rel_context params env_ar in let (constrsinfos,jlc,cst) = List.fold_right (fun c (infosl,l,cst) -> - let (infos,ct,cst') = + let (infos,ct,cst') = type_one_constructor env_ar_par params arsort c in (infos::infosl,ct::l, Constraint.union cst cst')) - vc + lc ([],[],Constraint.empty) in - let vc' = Array.of_list jlc in + let lc' = Array.of_list jlc in let issmall,isunit = small_unit constrsinfos in - (issmall,isunit,vc', cst) + (issmall,isunit,lc',cst) (* Type-check an inductive definition. Does not check positivity conditions. *) @@ -196,16 +192,15 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; mind_check_arities env mie; - (* We first type params and arity of each inductive definition *) + (* Params are typed-checked here *) + let params = mie.mind_entry_params in + let env_params, params, cstp = infer_local_decls env params in + (* We first type arity of each inductive definition *) (* This allows to build the environment of arities and to share *) (* the set of constraints *) let cst, arities, rev_params_arity_list = List.fold_left (fun (cst,arities,l) ind -> - (* Params are typed-checked here *) - let params = ind.mind_entry_params in - let env_params, params, cst1 = - infer_local_decls env params in (* Arities (without params) are typed-checked here *) let arity, cst2 = infer_type env_params ind.mind_entry_arity in @@ -215,10 +210,10 @@ let typecheck_inductive env mie = upper universe will be generated *) let id = ind.mind_entry_typename in let full_arity = it_mkProd_or_LetIn arity.utj_val params in - Constraint.union cst (Constraint.union cst1 cst2), + Constraint.union cst cst2, Sign.add_rel_decl (Name id, None, full_arity) arities, (params, id, full_arity, arity.utj_val)::l) - (Constraint.empty,empty_rel_context,[]) + (cstp,empty_rel_context,[]) mie.mind_entry_inds in let env_arities = push_rel_context arities env in @@ -234,13 +229,13 @@ let typecheck_inductive env mie = let (issmall,isunit,lc',cst') = infer_constructor_packet env_arities params arsort lc in let consnames = ind.mind_entry_consnames in - let ind' = (params,id,full_arity,consnames,issmall,isunit,lc') + let ind' = (id,full_arity,consnames,issmall,isunit,lc') in (ind'::inds, Constraint.union cst cst')) mie.mind_entry_inds params_arity_list ([],cst) in - (env_arities, Array.of_list inds, cst) + (env_arities, params, Array.of_list inds, cst) (************************************************************************) (************************************************************************) @@ -276,13 +271,18 @@ let explain_ind_err ntyp env0 nbpar c err = raise (InductiveError (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar)))) +let failwith_non_pos n ntypes c = + for k = n to n + ntypes - 1 do + if not (noccurn k c) then raise (IllFormedInd (LocalNonPos (k-n+1))) + done + let failwith_non_pos_vect n ntypes v = - for i = 0 to Array.length v - 1 do - for k = n to n + ntypes - 1 do - if not (noccurn k v.(i)) then raise (IllFormedInd (LocalNonPos (k-n+1))) - done - done; - anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur in v" + Array.iter (failwith_non_pos n ntypes) v; + anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur" + +let failwith_non_pos_list n ntypes l = + List.iter (failwith_non_pos n ntypes) l; + anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur" (* Check the inductive type is called with the expected parameters *) let check_correct_par (env,n,ntypes,_) hyps l largs = @@ -303,6 +303,26 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = if not (array_for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' +(* Computes the maximum number of recursive parameters : + the first parameters which are constant in recursive arguments + n is the current depth, nmr is the maximum number of possible + recursive parameters *) + +let compute_rec_par (env,n,_,_) hyps nmr largs = +if nmr = 0 then 0 else +(* start from 0, hyps will be in reverse order *) + let (lpar,_) = list_chop nmr largs in + let rec find k index = + function + ([],_) -> nmr + | (_,[]) -> assert false (* |hyps|>=nmr *) + | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps) + | (p::lp,_::hyps) -> + ( match kind_of_term (whd_betadeltaiota env p) with + | Rel w when w = index -> find (k+1) (index-1) (lp,hyps) + | _ -> k) + in find 0 (n-1) (lpar,List.rev hyps) + (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc env ntyps npars lc = @@ -326,9 +346,10 @@ let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let auxntyp = 1 in + let specif = lookup_mind_specif env mi in let env' = push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env mi) lpar) env in + hnf_prod_applist env (type_of_inductive specif) lpar) env in let ra_env' = (Imbr mi,Rtree.mk_param 0) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -336,46 +357,50 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let newidx = n + auxntyp in (env', newidx, ntypes, ra_env') +let array_min nmr a = if nmr = 0 then 0 else + Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a + (* The recursive function that checks positivity and builds the list of recursive arguments *) let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc = - let nparams = rel_context_length hyps in + let lparams = rel_context_length hyps in + let nmr = rel_context_nhyps hyps in (* check the inductive types occur positively in [c] *) - let rec check_pos (env, n, ntypes, ra_env as ienv) c = + let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with | Prod (na,b,d) -> assert (largs = []); (match weaker_noccur_between env n ntypes b with - None -> raise (IllFormedInd (LocalNonPos n)); + None -> failwith_non_pos_list n ntypes [b] | Some b -> - check_pos (ienv_push_var ienv (na, b, mk_norec)) d) + check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> - let (ra,rarg) = - try List.nth ra_env (k-1) - with Failure _ | Invalid_argument _ -> (Norec,mk_norec) in - (match ra with - Mrec _ -> check_correct_par ienv hyps (k-n+1) largs - | _ -> - if not (List.for_all (noccur_between n ntypes) largs) - then raise (IllFormedInd (LocalNonPos n))); - rarg + (try let (ra,rarg) = List.nth ra_env (k-1) in + let nmr1 = + (match ra with + Mrec _ -> compute_rec_par ienv hyps nmr largs + | _ -> nmr) + in + if not (List.for_all (noccur_between n ntypes) largs) + then failwith_non_pos_list n ntypes largs + else (nmr1,rarg) + with Failure _ | Invalid_argument _ -> (nmr,mk_norec)) | Ind ind_kn -> (* If the inductive type being defined appears in a parameter, then we have an imbricated type *) - if List.for_all (noccur_between n ntypes) largs then mk_norec - else check_positive_imbr ienv (ind_kn, largs) + if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) + else check_positive_imbr ienv nmr (ind_kn, largs) | err -> if noccur_between n ntypes x && List.for_all (noccur_between n ntypes) largs - then mk_norec - else raise (IllFormedInd (LocalNonPos n)) + then (nmr,mk_norec) + else failwith_non_pos_list n ntypes (x::largs) - (* accesses to the environment are not factorised, but does it worth - it? *) - and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) = + (* accesses to the environment are not factorised, but is it worth? *) + and check_positive_imbr (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = let (mib,mip) = lookup_mind_specif env mi in - let auxnpar = mip.mind_nparams in + let auxnpar = mib.mind_nparams_rec in let (lpar,auxlargs) = try list_chop auxnpar largs with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in @@ -393,31 +418,34 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc = let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in - let irecargs = + let irecargs_nmr = (* fails if the inductive type occurs non positively *) (* when substituted *) Array.map (function c -> let c' = hnf_prod_applist env' c lpar' in - check_constructors ienv' false c') + check_constructors ienv' false nmr c') auxlcvect + in + let irecargs = Array.map snd irecargs_nmr + and nmr' = array_min nmr irecargs_nmr in - (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0) + (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of the ith type *) - and check_constructors ienv check_head c = - let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = + 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_betadeltaiota env c) in match kind_of_term x with | Prod (na,b,d) -> assert (largs = []); - let recarg = check_pos ienv b in + let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in - check_constr_rec ienv' (recarg::lrec) d + check_constr_rec ienv' nmr' (recarg::lrec) d | hd -> if check_head then @@ -428,32 +456,39 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc = else if not (List.for_all (noccur_between n ntypes) largs) then raise (IllFormedInd (LocalNonPos n)); - List.rev lrec - in check_constr_rec ienv [] c + (nmr,List.rev lrec) + in check_constr_rec ienv nmr [] c in - mk_paths (Mrec i) - (Array.map + let irecargs_nmr = + Array.map (fun c -> - let c = body_of_type c in - let sign, rawc = mind_extract_params nparams c in - let env' = push_rel_context sign env in + let _,rawc = mind_extract_params lparams c in try - check_constructors ienv true rawc + check_constructors ienv true nmr rawc with IllFormedInd err -> - explain_ind_err (ntypes-i) env nparams c err) - indlc) + explain_ind_err (ntypes-i) env lparams c err) + indlc + in + let irecargs = Array.map snd irecargs_nmr + and nmr' = array_min nmr irecargs_nmr + in (nmr', mk_paths (Mrec i) irecargs) -let check_positivity env_ar inds = +let check_positivity env_ar params inds = let ntypes = Array.length inds in let lra_ind = List.rev (list_tabulate (fun j -> (Mrec j, Rtree.mk_param j)) ntypes) in - let check_one i (params,_,_,_,_,_,lc) = - let nparams = rel_context_length params in + let lparams = rel_context_length params in + let nmr = rel_context_nhyps params in + let check_one i (_,_,_,_,_,lc) = let ra_env = - list_tabulate (fun _ -> (Norec,mk_norec)) nparams @ lra_ind in - let ienv = (env_ar, 1+nparams, ntypes, ra_env) in - check_positivity_one ienv params i lc in - Rtree.mk_rec (Array.mapi check_one inds) + list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in + let ienv = (env_ar, 1+lparams, ntypes, ra_env) in + check_positivity_one ienv params i lc + in + let irecargs_nmr = Array.mapi check_one inds in + let irecargs = Array.map snd irecargs_nmr + and nmr' = array_min nmr irecargs_nmr + in (nmr',Rtree.mk_rec irecargs) (************************************************************************) @@ -480,67 +515,77 @@ let allowed_sorts env issmall isunit = function if issmall then all_sorts else impredicative_sorts | Prop Null -> -(* Added InType which is derivable :when the type is unit and small *) -(* unit+small types have all elimination - In predicative system, the - other inductive definitions have only Prop elimination. - In impredicative system, large unit type have also Set elimination -*) if isunit then - if issmall then all_sorts - else if Environ.engagement env = None - then logical_sorts else impredicative_sorts +(* 29/1/02: added InType which is derivable when the type is unit and small *) + if isunit then all_sorts else logical_sorts -let build_inductive env env_ar record finite inds recargs cst = +let fold_inductive_blocks f = + Array.fold_left (fun acc (_,ar,_,_,_,lc) -> f (Array.fold_left f acc lc) ar) + +let used_section_variables env inds = + let ids = fold_inductive_blocks + (fun l c -> Idset.union (Environ.global_vars_set env c) l) + Idset.empty inds in + keep_hyps env ids + +let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = let ntypes = Array.length inds in (* Compute the set of used section variables *) - let ids = - Array.fold_left - (fun acc (_,_,ar,_,_,_,lc) -> - Idset.union (Environ.global_vars_set env (body_of_type ar)) - (Array.fold_left - (fun acc c -> - Idset.union (global_vars_set env (body_of_type c)) acc) - acc - lc)) - Idset.empty inds in - let hyps = keep_hyps env ids in + let hyps = used_section_variables env inds in + let nparamargs = rel_context_nhyps params in (* Check one inductive *) - let build_one_packet (params,id,ar,cnames,issmall,isunit,lc) recarg = + let build_one_packet (id,ar,cnames,issmall,isunit,lc) recarg = (* Arity in normal form *) - let nparamargs = rel_context_nhyps params in let (ar_sign,ar_sort) = dest_arity env ar in - let nf_ar = - if isArity (body_of_type ar) then ar - else it_mkProd_or_LetIn (mkSort ar_sort) ar_sign in + let nf_ar = if isArity ar then ar else mkArity (ar_sign,ar_sort) in (* Type of constructors in normal form *) let splayed_lc = Array.map (dest_prod_assum env_ar) lc in - let nf_lc = - array_map2 (fun (d,b) c -> it_mkProd_or_LetIn b d) splayed_lc lc in + let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let nf_lc = if nf_lc = lc then lc else nf_lc in + let consnrealargs = + Array.map (fun (d,_) -> rel_context_length d - rel_context_length params) + splayed_lc in (* Elimination sorts *) let isunit = isunit && ntypes = 1 && (not (is_recursive recargs.(0))) in let kelim = allowed_sorts env issmall isunit ar_sort in + let nconst, nblock = ref 0, ref 0 in + let transf num = + let arity = List.length (dest_subterms recarg).(num) in + if arity = 0 then + let p = (!nconst, 0) in + incr nconst; p + else + let p = (!nblock + 1, arity) in + incr nblock; p + (* les tag des constructeur constant commence a 0, + les tag des constructeur non constant a 1 (0 => accumulator) *) + in + let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; - mind_nparams = nparamargs; - mind_params_ctxt = params; mind_user_arity = ar; mind_nf_arity = nf_ar; mind_nrealargs = rel_context_nhyps ar_sign - nparamargs; mind_sort = ar_sort; mind_kelim = kelim; mind_consnames = Array.of_list cnames; + mind_consnrealdecls = consnrealargs; mind_user_lc = lc; mind_nf_lc = nf_lc; - mind_recargs = recarg; + mind_recargs = recarg; + mind_nb_constant = !nconst; + mind_nb_args = !nblock; + mind_reloc_tbl = rtbl; } in let packets = array_map2 build_one_packet inds recargs in (* Build the mutual inductive *) - { mind_record = record; + { mind_record = isrecord; mind_ntypes = ntypes; - mind_finite = finite; + mind_finite = isfinite; mind_hyps = hyps; + mind_nparams = nparamargs; + mind_nparams_rec = nmr; + mind_params_ctxt = params; mind_packets = packets; mind_constraints = cst; mind_equiv = None; @@ -551,10 +596,9 @@ let build_inductive env env_ar record finite inds recargs cst = let check_inductive env mie = (* First type-check the inductive definition *) - let (env_arities, inds, cst) = typecheck_inductive env mie in + let (env_ar, params, inds, cst) = typecheck_inductive env mie in (* Then check positivity conditions *) - let recargs = check_positivity env_arities inds in + let (nmr,recargs) = check_positivity env_ar params inds in (* Build the inductive packets *) - build_inductive env env_arities mie.mind_entry_record mie.mind_entry_finite - inds recargs cst - + build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite + inds nmr recargs cst diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index f5e6d047..67d11f56 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: indtypes.mli,v 1.23.8.1 2004/07/16 19:30:25 herbelin Exp $ i*) +(*i $Id: indtypes.mli 7660 2005-12-17 21:13:48Z herbelin $ i*) (*i*) open Names @@ -22,8 +22,8 @@ open Typeops (*s The different kinds of errors that may result of a malformed inductive definition. *) +(* Errors related to inductive constructions *) type inductive_error = - (* These are errors related to inductive constructions in this module *) | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * constr * constr @@ -33,10 +33,6 @@ type inductive_error = | SameNamesOverlap of identifier list | NotAnArity of identifier | BadEntry - (* These are errors related to recursors building in Indrec *) - | NotAllowedCaseAnalysis of bool * sorts * inductive - | BadInduction of bool * identifier * sorts - | NotMutualInScheme exception InductiveError of inductive_error diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 07e9b8ea..736f4da1 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inductive.ml,v 1.74.2.2 2004/07/16 19:30:25 herbelin Exp $ *) +(* $Id: inductive.ml 8673 2006-03-29 21:21:52Z herbelin $ *) open Util open Names @@ -18,6 +18,8 @@ open Environ open Reduction open Type_errors +type mind_specif = mutual_inductive_body * one_inductive_body + (* raise Not_found if not an inductive type *) let lookup_mind_specif env (kn,tyi) = let mib = Environ.lookup_mind kn env in @@ -57,13 +59,10 @@ let ind_subst mind mib = (* Instantiate inductives in constructor type *) let constructor_instantiate mind mib c = let s = ind_subst mind mib in - type_app (substl s) c + substl s c -(* Instantiate the parameters of the inductive type *) -(* TODO: verify the arg of LetIn correspond to the value in the - signature ? *) -let instantiate_params t args sign = - let fail () = +let instantiate_params full t args sign = + let fail () = anomaly "instantiate_params: type, ctxt and args mismatch" in let (rem_args, subs, ty) = Sign.fold_rel_context @@ -71,38 +70,134 @@ let instantiate_params t args sign = match (copt, largs, kind_of_term ty) with | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) - | _ -> fail()) + | (_,[],_) -> if full then fail() else ([], subs, ty) + | _ -> fail ()) sign ~init:(args,[],t) in if rem_args <> [] then fail(); - type_app (substl subs) ty + substl subs ty + +let instantiate_partial_params = instantiate_params false -let full_inductive_instantiate mip params t = - instantiate_params t params mip.mind_params_ctxt +let full_inductive_instantiate mib params t = + instantiate_params true t params mib.mind_params_ctxt -let full_constructor_instantiate (((mind,_),mib,mip),params) = +let full_constructor_instantiate (((mind,_),mib,_),params) = let inst_ind = constructor_instantiate mind mib in (fun t -> - instantiate_params (inst_ind t) params mip.mind_params_ctxt) + instantiate_params true (inst_ind t) params mib.mind_params_ctxt) (************************************************************************) (************************************************************************) (* Functions to build standard types related to inductive *) +(* For each inductive type of a block that is of level u_i, we have + the constraints that u_i >= v_i where v_i is the type level of the + types of the constructors of this inductive type. Each v_i depends + of some of the u_i and of an extra (maybe non variable) universe, + say w_i. Typically, for three inductive types, we could have + + u1,u2,u3,w1 <= u1 + u1 w2 <= u2 + u2,u3,w3 <= u3 + + From this system of inequations, we shall deduce + + w1,w2,w3 <= u1 + w1,w2 <= u2 + w1,w2,w3 <= u3 +*) + +let number_of_inductives mib = Array.length mib.mind_packets +let number_of_constructors mip = Array.length mip.mind_consnames + +(* +Computing the actual sort of an applied or partially applied inductive type: + +I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) +uniformargs : utyps +otherargs : otyps +I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj +s'_k = max(..s_kj..) +merge(..s'_k..) = ..s''_k.. +-------------------------------------------------------------------- +Gamma |- I_i uniformargs otherargs : phi(s''_i) + +where + +- if p=0, phi() = Prop +- if p=1, phi(s) = s +- if p<>1, phi(s) = sup(Set,s) + +Remark: Set (predicative) is encoded as Type(0) +*) + +let find_constraint levels level_bounds i nci = + if nci = 0 then mk_Prop + else + let level_bounds' = solve_constraints_system levels level_bounds in + let level = level_bounds'.(i) in + if nci = 1 & is_empty_universe level then mk_Prop + else if Univ.is_base level then mk_Set else Type level + +let find_inductive_level env (mib,mip) (_,i) levels level_bounds = + find_constraint levels level_bounds i (number_of_constructors mip) + +let set_inductive_level env s t = + let sign,s' = dest_prod_assum env t in + if family_of_sort s <> family_of_sort (destSort s') then + (* This induces reductions if user_arity <> nf_arity *) + mkArity (sign,s) + else + t + +let constructor_instances env (mib,mip) (_,i) args = + let nargs = Array.length args in + let args = Array.to_list args in + let uargs = + if nargs > mib.mind_nparams_rec then + fst (list_chop mib.mind_nparams_rec args) + else args in + let arities = + Array.map (fun mip -> destArity mip.mind_nf_arity) mib.mind_packets in + (* Compute the minimal type *) + let levels = Array.init + (number_of_inductives mib) (fun _ -> fresh_local_univ ()) in + let arities = list_tabulate (fun i -> + let ctx,s = arities.(i) in + let s = match s with Type _ -> Type (levels.(i)) | s -> s in + (Name mib.mind_packets.(i).mind_typename,None,mkArity (ctx,s))) + (number_of_inductives mib) in + (* Remark: all arities are closed hence no need for lift *) + let env_ar = push_rel_context (List.rev arities) env in + let uargs = List.map (lift (number_of_inductives mib)) uargs in + let lc = + Array.map (fun mip -> + Array.map (fun c -> + instantiate_partial_params c uargs mib.mind_params_ctxt) + mip.mind_nf_lc) + mib.mind_packets in + env_ar, lc, levels + +let is_small_inductive (mip,mib) = is_small (snd (destArity mib.mind_nf_arity)) + +let max_inductive_sort v = + let v = Array.map (function + | Type u -> u + | _ -> anomaly "Only type levels when computing the minimal sort of an inductive type") v in + Univ.sup_array v + (* Type of an inductive type *) -let type_of_inductive env i = - let (_,mip) = lookup_mind_specif env i in - mip.mind_user_arity +let type_of_inductive (_,mip) = mip.mind_user_arity (************************************************************************) (* Type of a constructor *) -let type_of_constructor env cstr = +let type_of_constructor cstr (mib,mip) = let ind = inductive_of_constructor cstr in - let (mib,mip) = lookup_mind_specif env ind in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in @@ -113,8 +208,8 @@ let arities_of_specif kn (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn mib) specif -let arities_of_constructors env ind = - arities_of_specif (fst ind) (lookup_mind_specif env ind) +let arities_of_constructors ind specif = + arities_of_specif (fst ind) specif @@ -149,23 +244,28 @@ let local_rels ctxt = rels (* Get type of inductive, with parameters instantiated *) -let get_arity mip params = +let get_arity mib mip params = let arity = mip.mind_nf_arity in - destArity (full_inductive_instantiate mip params arity) + destArity (full_inductive_instantiate mib params arity) -let build_dependent_inductive ind mip params = - let arsign,_ = get_arity mip params in +let rel_list n m = + let rec reln l p = + if p>m then l else reln (mkRel(n+p)::l) (p+1) + in + reln [] 1 + +let build_dependent_inductive ind mib mip params = let nrealargs = mip.mind_nrealargs in applist - (mkInd ind, (List.map (lift nrealargs) params)@(local_rels arsign)) + (mkInd ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs)) (* This exception is local *) exception LocalArity of (constr * constr * arity_error) option -let is_correct_arity env c pj ind mip params = +let is_correct_arity env c pj ind mib mip params = let kelim = mip.mind_kelim in - let arsign,s = get_arity mip params in + let arsign,s = get_arity mib mip params in let nodep_ar = it_mkProd_or_LetIn (mkSort s) arsign in let rec srec env pt t u = let pt' = whd_betadeltaiota env pt in @@ -181,7 +281,9 @@ let is_correct_arity env c pj ind mip params = let ksort = match kind_of_term k with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in - let dep_ind = build_dependent_inductive ind mip params in + + let dep_ind = build_dependent_inductive ind mib mip params + in let univ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in @@ -225,7 +327,7 @@ let build_branches_type ind mib mip params dep p = let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in - let (lparams,vargs) = list_chop mip.mind_nparams allargs in + let (lparams,vargs) = list_chop mib.mind_nparams allargs in let cargs = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in @@ -245,10 +347,10 @@ let build_case_type dep p c realargs = let type_case_branches env (ind,largs) pj c = let (mib,mip) = lookup_mind_specif env ind in - let nparams = mip.mind_nparams in + let nparams = mib.mind_nparams in let (params,realargs) = list_chop nparams largs in let p = pj.uj_val in - let (dep,univ) = is_correct_arity env c pj ind mip params in + let (dep,univ) = is_correct_arity env c pj ind mib mip params in let lc = build_branches_type ind mib mip params dep p in let ty = build_case_type dep p c realargs in (lc, ty, univ) @@ -257,11 +359,22 @@ let type_case_branches env (ind,largs) pj c = (************************************************************************) (* Checking the case annotation is relevent *) +let rec inductive_kn_equiv env kn1 kn2 = + match (lookup_mind kn1 env).mind_equiv with + | Some kn1' -> inductive_kn_equiv env kn2 kn1' + | None -> match (lookup_mind kn2 env).mind_equiv with + | Some kn2' -> inductive_kn_equiv env kn2' kn1 + | None -> false + +let inductive_equiv env (kn1,i1) (kn2,i2) = + i1=i2 & inductive_kn_equiv env kn1 kn2 + let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if (indsp <> ci.ci_ind) or - (mip.mind_nparams <> ci.ci_npar) + (mib.mind_nparams <> ci.ci_npar) or + (mip.mind_consnrealdecls <> ci.ci_cstr_nargs) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) @@ -416,7 +529,7 @@ let inductive_of_fix env recarg body = subterm_specif env c ind subterm_specif should test if [c] (building objects of inductive - type [ind], not necassarily the same as that of the recursive + type [ind], not necessarily the same as that of the recursive argument) is a subterm of the recursive argument of the fixpoint we are checking and fails with Not_found if not. In case it is, it should send its recursive specification (i.e. on which arguments we @@ -584,7 +697,6 @@ let check_one_fix renv recpos def = | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> List.for_all (check_rec_call renv) l && array_for_all (check_rec_call renv) typarray && - let nbfix = Array.length typarray in let decrArg = recindxs.(i) in let renv' = push_fix_renv renv recdef in if (List.length l < (decrArg+1)) then @@ -604,7 +716,7 @@ let check_one_fix renv recpos def = bodies in array_for_all (fun b -> b) ok_vect - | Const kn as c -> + | Const kn -> (try List.for_all (check_rec_call renv) l with (FixGuardError _ ) as e -> if evaluable_constant kn renv.env then @@ -614,7 +726,7 @@ let check_one_fix renv recpos def = (* The cases below simply check recursively the condition on the subterms *) - | Cast (a,b) -> + | Cast (a,_, b) -> List.for_all (check_rec_call renv) (a::b::l) | Lambda (x,a,b) -> @@ -668,8 +780,8 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = or bodynum >= nbfix then anomaly "Ill-formed fix term"; let fixenv = push_rec_types recdef env in - let raise_err i err = - error_ill_formed_rec_body fixenv err names i in + let raise_err env i err = + error_ill_formed_rec_body env err names i in (* Check the i-th definition with recarg k *) let find_ind i k def = if k < 0 then anomaly "negative recarg position"; @@ -684,18 +796,19 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = (* get the inductive type of the fixpoint *) let (mind, _) = try find_inductive env a - with Not_found -> raise_err i RecursionNotOnInductiveType in + with Not_found -> + raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) else check_occur env' (n+1) b else anomaly "check_one_fix: Bad occurrence of recursive call" - | _ -> raise_err i NotEnoughAbstractionInFixBody in + | _ -> raise_err env i NotEnoughAbstractionInFixBody in check_occur fixenv 1 def in (* Do it on every fixpoint *) let rv = array_map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) -let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = +let check_fix env ((nvect,_),(names,_,bodies as _recdef) as fix) = let (minds, rdef) = inductive_of_mutfix env fix in for i = 0 to Array.length bodies - 1 do let (fenv,body) = rdef.(i) in @@ -760,7 +873,7 @@ let check_one_cofix env nbfix def deftype = let lra =vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in - let realargs = list_skipn mip.mind_nparams args in + let realargs = list_skipn mib.mind_nparams args in let rec process_args_of_constr = function | (t::lr), (rar::lrar) -> if rar = mk_norec then diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 04345621..e60f909e 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: inductive.mli,v 1.57.8.2 2005/01/21 16:41:49 herbelin Exp $ i*) +(*i $Id: inductive.mli 8673 2006-03-29 21:21:52Z herbelin $ i*) (*i*) open Names @@ -28,24 +28,24 @@ val find_rectype : env -> types -> inductive * constr list val find_inductive : env -> types -> inductive * constr list val find_coinductive : env -> types -> inductive * constr list +type mind_specif = mutual_inductive_body * one_inductive_body + (*s Fetching information in the environment about an inductive type. Raises [Not_found] if the inductive type is not found. *) -val lookup_mind_specif : - env -> inductive -> mutual_inductive_body * one_inductive_body +val lookup_mind_specif : env -> inductive -> mind_specif (*s Functions to build standard types related to inductive *) -val type_of_inductive : env -> inductive -> types +val type_of_inductive : mind_specif -> types (* Return type as quoted by the user *) -val type_of_constructor : env -> constructor -> types +val type_of_constructor : constructor -> mind_specif -> types (* Return constructor types in normal form *) -val arities_of_constructors : env -> inductive -> types array +val arities_of_constructors : inductive -> mind_specif -> types array (* Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive -> - mutual_inductive_body * one_inductive_body -> types array +val arities_of_specif : mutual_inductive -> mind_specif -> types array (* [type_case_branches env (I,args) (p:A) c] computes useful types about the following Cases expression: @@ -69,3 +69,17 @@ val scrape_mind : env -> mutual_inductive -> mutual_inductive (*s Guard conditions for fix and cofix-points. *) val check_fix : env -> fixpoint -> unit val check_cofix : env -> cofixpoint -> unit + +(*s Support for sort-polymorphic inductive types *) + +val constructor_instances : env -> mind_specif -> inductive -> + constr array -> env * types array array * universe array + +val set_inductive_level : env -> sorts -> types -> types + +val find_inductive_level : env -> mind_specif -> inductive -> + universe array -> universe array -> sorts + +val is_small_inductive : mind_specif -> bool + +val max_inductive_sort : sorts array -> universe diff --git a/kernel/make-opcodes b/kernel/make-opcodes new file mode 100644 index 00000000..c8f573c6 --- /dev/null +++ b/kernel/make-opcodes @@ -0,0 +1,2 @@ +$1=="enum" {n=0; next; } + {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml new file mode 100644 index 00000000..6d2064bf --- /dev/null +++ b/kernel/mod_subst.ml @@ -0,0 +1,260 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* None + | Some resolve -> + try List.assoc kn resolve with Not_found -> assert false + +type substitution_domain = MSI of mod_self_id | MBI of mod_bound_id + +let string_of_subst_domain = function + MSI msid -> debug_string_of_msid msid + | MBI mbid -> debug_string_of_mbid mbid + +module Umap = Map.Make(struct + type t = substitution_domain + let compare = Pervasives.compare + end) + +type substitution = (module_path * resolver option) Umap.t + +let empty_subst = Umap.empty + +let add_msid msid mp = + Umap.add (MSI msid) (mp,None) +let add_mbid mbid mp resolve = + Umap.add (MBI mbid) (mp,resolve) + +let map_msid msid mp = add_msid msid mp empty_subst +let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst + +let list_contents sub = + let one_pair uid (mp,_) l = + (string_of_subst_domain uid, string_of_mp mp)::l + in + Umap.fold one_pair sub [] + +let debug_string_of_subst sub = + let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in + "{" ^ String.concat "; " l ^ "}" + +let debug_pr_subst sub = + let l = list_contents sub in + let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) + in + str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" + +let subst_mp0 sub mp = (* 's like subst *) + let rec aux mp = + match mp with + | MPself sid -> + let mp',resolve = Umap.find (MSI sid) sub in + mp',resolve + | MPbound bid -> + let mp',resolve = Umap.find (MBI bid) sub in + mp',resolve + | MPdot (mp1,l) -> + let mp1',resolve = aux mp1 in + MPdot (mp1',l),resolve + | _ -> raise Not_found + in + try Some (aux mp) with Not_found -> None + +let subst_mp sub mp = + match subst_mp0 sub mp with + None -> mp + | Some (mp',_) -> mp' + + +let subst_kn0 sub kn = + let mp,dir,l = repr_kn kn in + match subst_mp0 sub mp with + Some (mp',_) -> + Some (make_kn mp' dir l) + | None -> None + +let subst_kn sub kn = + match subst_kn0 sub kn with + None -> kn + | Some kn' -> kn' + +let subst_con sub con = + let mp,dir,l = repr_con con in + match subst_mp0 sub mp with + None -> con,mkConst con + | Some (mp',resolve) -> + let con' = make_con mp' dir l in + match apply_opt_resolver resolve con with + None -> con',mkConst con' + | Some t -> con',t + +(* Here the semantics is completely unclear. + What does "Hint Unfold t" means when "t" is a parameter? + Does the user mean "Unfold X.t" or does she mean "Unfold y" + where X.t is later on instantiated with y? I choose the first + interpretation (i.e. an evaluable reference is never expanded). *) +let subst_evaluable_reference subst = function + | EvalVarRef id -> EvalVarRef id + | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) + +(* +This should be rewritten to prevent duplication of constr's when not +necessary. +For now, it uses map_constr and is rather ineffective +*) + +let rec map_kn f f' c = + let func = map_kn f f' in + match kind_of_term c with + | Const kn -> f' kn + | Ind (kn,i) -> + (match f kn with + None -> c + | Some kn' -> + mkInd (kn',i)) + | Construct ((kn,i),j) -> + (match f kn with + None -> c + | Some kn' -> + mkConstruct ((kn',i),j)) + | Case (ci,p,c,l) -> + let ci' = + { ci with + ci_ind = + let (kn,i) = ci.ci_ind in + match f kn with None -> ci.ci_ind | Some kn' -> kn',i } in + mkCase (ci', func p, func c, array_smartmap func l) + | _ -> map_constr func c + +let subst_mps sub = + map_kn (subst_kn0 sub) (fun con -> snd (subst_con sub con)) + +let rec replace_mp_in_mp mpfrom mpto mp = + match mp with + | _ when mp = mpfrom -> mpto + | MPdot (mp1,l) -> + let mp1' = replace_mp_in_mp mpfrom mpto mp1 in + if mp1==mp1' then mp + else MPdot (mp1',l) + | _ -> mp + +let replace_mp_in_con mpfrom mpto kn = + let mp,dir,l = repr_con kn in + let mp'' = replace_mp_in_mp mpfrom mpto mp in + if mp==mp'' then kn + else make_con mp'' dir l + +exception BothSubstitutionsAreIdentitySubstitutions +exception ChangeDomain of resolver + +let join (subst1 : substitution) (subst2 : substitution) = + let apply_subst (sub : substitution) key (mp,resolve) = + let mp',resolve' = + match subst_mp0 sub mp with + None -> mp, None + | Some (mp',resolve') -> mp',resolve' in + let resolve'' : resolver option = + try + let res = + match resolve with + Some res -> res + | None -> + match resolve' with + None -> raise BothSubstitutionsAreIdentitySubstitutions + | Some res -> raise (ChangeDomain res) + in + Some + (List.map + (fun (kn,topt) -> + kn, + match topt with + None -> + (match key with + MSI msid -> + let kn' = replace_mp_in_con (MPself msid) mp kn in + apply_opt_resolver resolve' kn' + | MBI mbid -> + let kn' = replace_mp_in_con (MPbound mbid) mp kn in + apply_opt_resolver resolve' kn') + | Some t -> Some (subst_mps sub t)) res) + with + BothSubstitutionsAreIdentitySubstitutions -> None + | ChangeDomain res -> + Some + ((List.map + (fun (kn,topt) -> + let key' = + match key with + MSI msid -> MPself msid + | MBI mbid -> MPbound mbid in + (* let's replace mp with key in kn *) + let kn' = replace_mp_in_con mp key' kn in + kn',topt)) res) + in + mp',resolve'' in + let subst = Umap.mapi (apply_subst subst2) subst1 in + Umap.fold Umap.add subst2 subst + +let rec occur_in_path uid path = + match uid,path with + | MSI sid,MPself sid' -> sid = sid' + | MBI bid,MPbound bid' -> bid = bid' + | _,MPdot (mp1,_) -> occur_in_path uid mp1 + | _ -> false + +let occur_uid uid sub = + let check_one uid' (mp,_) = + if uid = uid' || occur_in_path uid mp then raise Exit + in + try + Umap.iter check_one sub; + false + with Exit -> true + +let occur_msid uid = occur_uid (MSI uid) +let occur_mbid uid = occur_uid (MBI uid) + +type 'a lazy_subst = + | LSval of 'a + | LSlazy of substitution * 'a + +type 'a substituted = 'a lazy_subst ref + +let from_val a = ref (LSval a) + +let force fsubst r = + match !r with + | LSval a -> a + | LSlazy(s,a) -> + let a' = fsubst s a in + r := LSval a'; + a' + +let subst_substituted s r = + match !r with + | LSval a -> ref (LSlazy(s,a)) + | LSlazy(s',a) -> + let s'' = join s' s in + ref (LSlazy(s'',a)) diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli new file mode 100644 index 00000000..a7915a24 --- /dev/null +++ b/kernel/mod_subst.mli @@ -0,0 +1,80 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* resolver + +val empty_subst : substitution + +val add_msid : + mod_self_id -> module_path -> substitution -> substitution +val add_mbid : + mod_bound_id -> module_path -> resolver option -> substitution -> substitution + +val map_msid : + mod_self_id -> module_path -> substitution +val map_mbid : + mod_bound_id -> module_path -> resolver option -> substitution + +(* sequential composition: + [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] +*) +val join : substitution -> substitution -> substitution + +type 'a substituted +val from_val : 'a -> 'a substituted +val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a +val subst_substituted : substitution -> 'a substituted -> 'a substituted + +(*i debugging *) +val debug_string_of_subst : substitution -> string +val debug_pr_subst : substitution -> Pp.std_ppcmds +(*i*) + +(* [subst_mp sub mp] guarantees that whenever the result of the + substitution is structutally equal [mp], it is equal by pointers + as well [==] *) + +val subst_mp : + substitution -> module_path -> module_path + +val subst_kn : + substitution -> kernel_name -> kernel_name + +val subst_con : + substitution -> constant -> constant * constr + +(* Here the semantics is completely unclear. + What does "Hint Unfold t" means when "t" is a parameter? + Does the user mean "Unfold X.t" or does she mean "Unfold y" + where X.t is later on instantiated with y? I choose the first + interpretation (i.e. an evaluable reference is never expanded). *) +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_con : module_path -> module_path -> constant -> constant + +(* [subst_mps sub c] performs the substitution [sub] on all kernel + names appearing in [c] *) +val subst_mps : substitution -> constr -> constr + +(* [occur_*id id sub] returns true iff [id] occurs in [sub] + on either side *) + +val occur_msid : mod_self_id -> substitution -> bool +val occur_mbid : mod_bound_id -> substitution -> bool diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 5e8c7001..a8aff184 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_typing.ml,v 1.11.2.1 2004/07/16 19:30:26 herbelin Exp $ i*) +(*i $Id: mod_typing.ml 7639 2005-12-02 10:01:15Z gregoire $ i*) open Util open Names @@ -17,6 +17,7 @@ open Environ open Term_typing open Modops open Subtyping +open Mod_subst exception Not_path @@ -65,8 +66,9 @@ and merge_with env mtb with_decl = | MTBsig(msid,sig_b) -> msid,sig_b | _ -> error_signature_expected mtb in - let id = match with_decl with - | With_Definition (id,_) | With_Module (id,_) -> id + let id,idl = match with_decl with + | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl + | With_Definition ([],_) | With_Module ([],_) -> assert false in let l = label_of_id id in try @@ -74,7 +76,9 @@ and merge_with env mtb with_decl = let before = List.rev rev_before in let env' = Modops.add_signature (MPself msid) before env in let new_spec = match with_decl with - | With_Definition (id,c) -> + | With_Definition ([],_) + | With_Module ([],_) -> assert false + | With_Definition ([id],c) -> let cb = match spec with SPBconst cb -> cb | _ -> error_not_a_constant l @@ -88,21 +92,25 @@ and merge_with env mtb with_decl = let cst = Constraint.union (Constraint.union cb.const_constraints cst1) - cst2 - in + cst2 in + let body = Some (Declarations.from_val j.uj_val) in SPBconst {cb with - const_body = - Some (Declarations.from_val j.uj_val); - const_constraints = cst} + const_body = body; + const_body_code = Cemitcodes.from_val + (compile_constant_body env' body false false); + const_constraints = cst} | Some b -> let cst1 = Reduction.conv env' c (Declarations.force b) in let cst = Constraint.union cb.const_constraints cst1 in + let body = Some (Declarations.from_val c) in SPBconst {cb with - const_body = Some (Declarations.from_val c); - const_constraints = cst} + const_body = body; + const_body_code = Cemitcodes.from_val + (compile_constant_body env' body false false); + const_constraints = cst} end (* and what about msid's ????? Don't they clash ? *) - | With_Module (id, mp) -> + | With_Module ([id], mp) -> let old = match spec with SPBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) @@ -133,6 +141,29 @@ and merge_with env mtb with_decl = msb_constraints = Constraint.union old.msb_constraints cst } in SPBmodule msb + | With_Definition (_::_,_) + | With_Module (_::_,_) -> + let old = match spec with + SPBmodule msb -> msb + | _ -> error_not_a_module (string_of_label l) + in + begin + match old.msb_equiv with + None -> + let new_with_decl = match with_decl with + With_Definition (_,c) -> With_Definition (idl,c) + | With_Module (_,c) -> With_Module (idl,c) in + let modtype = + merge_with env' old.msb_modtype new_with_decl in + let msb = + {msb_modtype = modtype; + msb_equiv = None; + msb_constraints = old.msb_constraints } + in + SPBmodule msb + | Some mp -> + error_a_generative_module_expected l + end in MTBsig(msid, before@(l,new_spec)::after) with @@ -143,13 +174,14 @@ and translate_entry_list env msid is_definition sig_e = let mp = MPself msid in let do_entry env (l,e) = let kn = make_kn mp empty_dirpath l in + let con = make_con mp empty_dirpath l in match e with | SPEconst ce -> - let cb = translate_constant env ce in + let cb = translate_constant env con ce in begin match cb.const_hyps with | (_::_) -> error_local_context (Some l) | [] -> - add_constant kn cb env, (l, SEBconst cb), (l, SPBconst cb) + add_constant con cb env, (l, SEBconst cb), (l, SPBconst cb) end | SPEmind mie -> let mib = translate_mind env mie in @@ -253,8 +285,13 @@ and translate_mexpr env mexpr = match mexpr with | Not_path -> error_application_to_not_path mexpr (* place for nondep_supertype *) in + let resolve = Modops.resolver_of_environment farg_id farg_b mp env in MEBapply(feb,meb,cst), - subst_modtype (map_mbid farg_id mp) fbody_b + (* This is the place where the functor formal parameter is + substituted by the given argument to compute the type of the + functor application. *) + subst_modtype + (map_mbid farg_id mp (Some resolve)) fbody_b | MEstruct (msid,structure) -> let structure,signature = translate_entry_list env msid true structure in MEBstruct (msid,structure), diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index fdf39c56..706c617c 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_typing.mli,v 1.2.8.2 2005/01/21 17:14:10 herbelin Exp $ i*) +(*i $Id: mod_typing.mli 6621 2005-01-21 17:24:37Z herbelin $ i*) (*i*) open Declarations @@ -19,6 +19,8 @@ val translate_modtype : env -> module_type_entry -> module_type_body val translate_module : env -> module_entry -> module_body +val translate_mexpr : env -> module_expr -> module_expr_body * module_type_body + val add_modtype_constraints : env -> module_type_body -> env val add_module_constraints : env -> module_body -> env diff --git a/kernel/modops.ml b/kernel/modops.ml index 84845af5..3d041c6c 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.ml,v 1.12.2.1 2004/07/16 19:30:26 herbelin Exp $ i*) +(*i $Id: modops.ml 7639 2005-12-02 10:01:15Z gregoire $ i*) (*i*) open Util @@ -17,6 +17,7 @@ open Term open Declarations open Environ open Entries +open Mod_subst (*i*) let error_existing_label l = @@ -66,6 +67,11 @@ let error_not_a_constant l = let error_with_incorrect l = error ("Incorrect constraint for label \""^(string_of_label l)^"\"") +let error_a_generative_module_expected l = + error ("The module " ^ string_of_label l ^ " is not generative. Only " ^ + "component of generative modules can be changed using the \"with\" " ^ + "construct.") + let error_local_context lo = match lo with None -> @@ -123,6 +129,9 @@ let rec check_modpath_equiv env mp1 mp2 = let rec subst_modtype sub = function + (* This is the case in which I am substituting a whole module. + For instance "Module M(X). Module N := X. End M". When I apply + M to M' I must substitute M' for X in "Module N := X". *) | MTBident ln -> MTBident (subst_kn sub ln) | MTBfunsig (arg_id, arg_b, body_b) -> if occur_mbid arg_id sub then failwith "capture"; @@ -148,23 +157,77 @@ and subst_signature sub sign = and subst_module sub mb = let mtb' = subst_modtype sub mb.msb_modtype in + (* This is similar to the previous case. In this case we have + a module M in a signature that is knows to be equivalent to a module M' + (because the signature is "K with Module M := M'") and we are substituting + M' with some M''. *) let mpo' = option_smartmap (subst_mp sub) mb.msb_equiv in if mtb'==mb.msb_modtype && mpo'==mb.msb_equiv then mb else { msb_modtype=mtb'; msb_equiv=mpo'; msb_constraints=mb.msb_constraints} - let subst_signature_msid msid mp = subst_signature (map_msid msid mp) +let rec constants_of_specification env mp sign = + let aux res (l,elem) = + match elem with + | SPBconst cb -> ((make_con mp empty_dirpath l),cb)::res + | SPBmind _ -> res + | SPBmodule mb -> + (constants_of_modtype env (MPdot (mp,l)) + (module_body_of_spec mb).mod_type) @ res + | SPBmodtype mtb -> res (* ???? *) + in + List.fold_left aux [] sign + +and constants_of_modtype env mp modtype = + match scrape_modtype env modtype with + MTBident _ -> anomaly "scrape_modtype does not work!" + | MTBsig (msid,sign) -> + constants_of_specification env mp + (subst_signature_msid msid mp sign) + | MTBfunsig _ -> [] + +(* returns a resolver for kn that maps mbid to mp and then delta-expands + the obtained constants according to env *) +let resolver_of_environment mbid modtype mp env = + let constants = constants_of_modtype env (MPbound mbid) modtype in + let resolve = + List.map + (fun (con,expecteddef) -> + let con' = replace_mp_in_con (MPbound mbid) mp con in + let constr = + try + if expecteddef.Declarations.const_body <> None then + (* Do not expand constants that already have a body in the + expected type (i.e. only parameters/axioms in the module type + are expanded). In the few examples we have this seems to + be the more reasonable behaviour for the user. *) + None + else + let constant = lookup_constant con' env in + if constant.Declarations.const_opaque then + None + else + option_app Declarations.force + constant.Declarations.const_body + with Not_found -> error_no_such_label (con_label con') + in + con,constr + ) constants + in + Mod_subst.make_resolver resolve + (* we assume that the substitution of "mp" into "msid" is already done (or unnecessary) *) let rec add_signature mp sign env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in + let con = make_con mp empty_dirpath l in match elem with - | SPBconst cb -> Environ.add_constant kn cb env + | SPBconst cb -> Environ.add_constant con cb env | SPBmind mib -> Environ.add_mind kn mib env | SPBmodule mb -> add_module (MPdot (mp,l)) (module_body_of_spec mb) env @@ -180,7 +243,6 @@ and add_module mp mb env = | MTBident _ -> anomaly "scrape_modtype does not work!" | MTBsig (msid,sign) -> add_signature mp (subst_signature_msid msid mp sign) env - | MTBfunsig _ -> env @@ -189,11 +251,13 @@ let strengthen_const env mp l cb = | false, Some _ -> cb | true, Some _ | _, None -> - let const = mkConst (make_kn mp empty_dirpath l) in + let const = mkConst (make_con mp empty_dirpath l) in let const_subs = Some (Declarations.from_val const) in {cb with const_body = const_subs; - const_opaque = false + const_opaque = false; + const_body_code = Cemitcodes.from_val + (compile_constant_body env const_subs false false) } let strengthen_mind env mp l mib = match mib.mind_equiv with @@ -243,3 +307,4 @@ and strengthen_sig env msid sign mp = match sign with item::rest' let strengthen env mtb mp = strengthen_mtb env mp mtb + diff --git a/kernel/modops.mli b/kernel/modops.mli index cca2d315..371860f5 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.mli,v 1.7.6.2 2005/01/21 16:41:50 herbelin Exp $ i*) +(*i $Id: modops.mli 6616 2005-01-21 17:18:23Z herbelin $ i*) (*i*) open Util @@ -15,6 +15,7 @@ open Univ open Environ open Declarations open Entries +open Mod_subst (*i*) (* Various operations on modules and module types *) @@ -91,6 +92,11 @@ val error_not_a_constant : label -> 'a val error_with_incorrect : label -> 'a +val error_a_generative_module_expected : label -> 'a + val error_local_context : label option -> 'a val error_circular_with_module : identifier -> 'a + +val resolver_of_environment : + mod_bound_id -> module_type_body -> module_path -> env -> resolver diff --git a/kernel/names.ml b/kernel/names.ml index df3a012f..4c8cf7bb 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: names.ml,v 1.53.2.1 2004/07/16 19:30:26 herbelin Exp $ *) +(* $Id: names.ml 7834 2006-01-11 00:15:01Z herbelin $ *) open Pp open Util @@ -19,13 +19,7 @@ let id_ord = Pervasives.compare let id_of_string s = String.copy s -let map_ident id = - if Options.do_translate() then - match id with - "fix" -> "Fix" - | _ -> id - else id -let string_of_id id = String.copy (map_ident id) +let string_of_id id = String.copy id (* Hash-consing of identifier *) module Hident = Hashcons.Make( @@ -138,74 +132,6 @@ end module MPset = Set.Make(MPord) module MPmap = Map.Make(MPord) - -(* this is correct under the condition that bound and struct - identifiers can never be identical (i.e. get the same stamp)! *) - -type substitution = module_path Umap.t - -let empty_subst = Umap.empty - -let add_msid = Umap.add -let add_mbid = Umap.add - -let map_msid msid mp = add_msid msid mp empty_subst -let map_mbid mbid mp = add_msid mbid mp empty_subst - -let list_contents sub = - let one_pair uid mp l = - (string_of_uid uid, string_of_mp mp)::l - in - Umap.fold one_pair sub [] - -let debug_string_of_subst sub = - let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in - "{" ^ String.concat "; " l ^ "}" - -let debug_pr_subst sub = - let l = list_contents sub in - let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) - in - str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" - -let rec subst_mp sub mp = (* 's like subst *) - match mp with - | MPself sid -> - (try Umap.find sid sub with Not_found -> mp) - | MPbound bid -> - (try Umap.find bid sub with Not_found -> mp) - | MPdot (mp1,l) -> - let mp1' = subst_mp sub mp1 in - if mp1==mp1' then - mp - else - MPdot (mp1',l) - | _ -> mp - -let join subst1 subst2 = - let subst = Umap.map (subst_mp subst2) subst1 in - Umap.fold Umap.add subst2 subst - -let rec occur_in_path uid = function - | MPself sid -> sid = uid - | MPbound bid -> bid = uid - | MPdot (mp1,_) -> occur_in_path uid mp1 - | _ -> false - -let occur_uid uid sub = - let check_one uid' mp = - if uid = uid' || occur_in_path uid mp then raise Exit - in - try - Umap.iter check_one sub; - false - with Exit -> true - -let occur_msid = occur_uid -let occur_mbid = occur_uid - - - (* Kernel names *) type kernel_name = module_path * dir_path * label @@ -225,11 +151,6 @@ let string_of_kn (mp,dir,l) = let pr_kn kn = str (string_of_kn kn) -let subst_kn sub (mp,dir,l as kn) = - let mp' = subst_mp sub mp in - if mp==mp' then kn else (mp',dir,l) - - let kn_ord kn1 kn2 = let mp1,dir1,l1 = kn1 in let mp2,dir2,l2 = kn2 in @@ -252,7 +173,9 @@ end module KNmap = Map.Make(KNord) module KNpred = Predicate.Make(KNord) module KNset = Set.Make(KNord) - +module Cmap = KNmap +module Cpred = KNpred +module Cset = KNset let default_module_name = id_of_string "If you see this, it's a bug" @@ -267,11 +190,35 @@ type mutual_inductive = kernel_name type inductive = mutual_inductive * int type constructor = inductive * int +let constant_of_kn kn = kn +let make_con mp dir l = (mp,dir,l) +let repr_con con = con +let string_of_con = string_of_kn +let con_label = label +let pr_con = pr_kn +let con_modpath = modpath + let ith_mutual_inductive (kn,_) i = (kn,i) let ith_constructor_of_inductive ind i = (ind,i) let inductive_of_constructor (ind,i) = ind let index_of_constructor (ind,i) = i +module InductiveOrdered = struct + type t = inductive + let compare (spx,ix) (spy,iy) = + let c = ix - iy in if c = 0 then KNord.compare spx spy else c +end + +module Indmap = Map.Make(InductiveOrdered) + +module ConstructorOrdered = struct + type t = constructor + let compare (indx,ix) (indy,iy) = + let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c +end + +module Constrmap = Map.Make(ConstructorOrdered) + (* Better to have it here that in closure, since used in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier @@ -352,4 +299,24 @@ let hcons_names () = let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in - (hkn,hdir,hname,hident,hstring) + (hkn,hkn,hdir,hname,hident,hstring) + + +(*******) + +type transparent_state = Idpred.t * Cpred.t + +type 'a tableKey = + | ConstKey of constant + | VarKey of identifier + | RelKey of 'a + + +type inv_rel_key = int (* index in the [rel_context] part of environment + starting by the end, {\em inverse} + of de Bruijn indice *) + +type id_key = inv_rel_key tableKey + + + diff --git a/kernel/names.mli b/kernel/names.mli index 07c19841..5b0a7a30 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: names.mli,v 1.46.6.1 2004/07/16 19:30:26 herbelin Exp $ i*) +(*i $Id: names.mli 6736 2005-02-18 20:49:04Z herbelin $ i*) (*s Identifiers *) @@ -83,45 +83,6 @@ val string_of_mp : module_path -> string module MPset : Set.S with type elt = module_path module MPmap : Map.S with type key = module_path - -(*s Substitutions *) - -type substitution - -val empty_subst : substitution - -val add_msid : - mod_self_id -> module_path -> substitution -> substitution -val add_mbid : - mod_bound_id -> module_path -> substitution -> substitution - -val map_msid : mod_self_id -> module_path -> substitution -val map_mbid : mod_bound_id -> module_path -> substitution - -(* sequential composition: - [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] -*) -val join : substitution -> substitution -> substitution - -(*i debugging *) -val debug_string_of_subst : substitution -> string -val debug_pr_subst : substitution -> Pp.std_ppcmds -(*i*) - -(* [subst_mp sub mp] guarantees that whenever the result of the - substitution is structutally equal [mp], it is equal by pointers - as well [==] *) - -val subst_mp : - substitution -> module_path -> module_path - -(* [occur_*id id sub] returns true iff [id] occurs in [sub] - on either side *) - -val occur_msid : mod_self_id -> substitution -> bool -val occur_mbid : mod_bound_id -> substitution -> bool - - (* Name of the toplevel structure *) val initial_msid : mod_self_id val initial_path : module_path (* [= MPself initial_msid] *) @@ -142,7 +103,6 @@ val label : kernel_name -> label val string_of_kn : kernel_name -> string val pr_kn : kernel_name -> Pp.std_ppcmds -val subst_kn : substitution -> kernel_name -> kernel_name module KNset : Set.S with type elt = kernel_name @@ -153,13 +113,27 @@ module KNmap : Map.S with type key = kernel_name (*s Specific paths for declarations *) type variable = identifier -type constant = kernel_name +type constant type mutual_inductive = kernel_name (* Beware: first inductive has index 0 *) type inductive = mutual_inductive * int (* Beware: first constructor has index 1 *) type constructor = inductive * int +module Cmap : Map.S with type key = constant +module Cpred : Predicate.S with type elt = constant +module Cset : Set.S with type elt = constant +module Indmap : Map.S with type key = inductive +module Constrmap : Map.S with type key = constructor + +val constant_of_kn : kernel_name -> constant +val make_con : module_path -> dir_path -> label -> constant +val repr_con : constant -> module_path * dir_path * label +val string_of_con : constant -> string +val con_label : constant -> label +val con_modpath : constant -> module_path +val pr_con : constant -> Pp.std_ppcmds + val ith_mutual_inductive : inductive -> int -> inductive val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive @@ -172,5 +146,22 @@ type evaluable_global_reference = (* Hash-consing *) val hcons_names : unit -> + (constant -> constant) * (kernel_name -> kernel_name) * (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * (string -> string) + + +(******) + +type 'a tableKey = + | ConstKey of constant + | VarKey of identifier + | RelKey of 'a + +type transparent_state = Idpred.t * Cpred.t + +type inv_rel_key = int (* index in the [rel_context] part of environment + starting by the end, {\em inverse} + of de Bruijn indice *) + +type id_key = inv_rel_key tableKey diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml new file mode 100644 index 00000000..5a45c167 --- /dev/null +++ b/kernel/pre_env.ml @@ -0,0 +1,146 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* id = id') env.env_named_vals) + +(* Warning all the names should be different *) +let env_of_named id env = env + +(* Global constants *) + +let lookup_constant_key kn env = + Cmap.find kn env.env_globals.env_constants + +let lookup_constant kn env = + fst (Cmap.find kn env.env_globals.env_constants) + +(* Mutual Inductives *) +let lookup_mind kn env = + KNmap.find kn env.env_globals.env_inductives diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli new file mode 100644 index 00000000..be74decf --- /dev/null +++ b/kernel/pre_env.mli @@ -0,0 +1,86 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a -> 'a -> Univ.constraints +type conv_pb = CONV | CUMUL + +val sort_cmp : + conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints + val conv_sort : sorts conversion_function val conv_sort_leq : sorts conversion_function -val conv : types conversion_function +val conv_cmp : conv_pb -> constr conversion_function + +val conv : constr conversion_function val conv_leq : types conversion_function val conv_leq_vecti : types array conversion_function +(* option for conversion *) +val set_vm_conv : (conv_pb -> types conversion_function) -> unit +val vm_conv : conv_pb -> types conversion_function + +val set_default_conv : (conv_pb -> types conversion_function) -> unit +val default_conv : conv_pb -> types conversion_function +val default_conv_leq : types conversion_function + (************************************************************************) (* Builds an application node, reducing beta redexes it may produce. *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 0f8c0d54..34071182 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: safe_typing.ml,v 1.76.2.2 2005/11/23 14:46:08 barras Exp $ *) +(* $Id: safe_typing.ml 7602 2005-11-23 15:10:16Z barras $ *) open Util open Names @@ -132,15 +132,15 @@ let hcons_constant_body cb = let add_constant dir l decl senv = check_label l senv.labset; - let cb = match decl with - ConstantEntry ce -> translate_constant senv.env ce + let kn = make_con senv.modinfo.modpath dir l in + let cb = + match decl with + | ConstantEntry ce -> translate_constant senv.env kn ce | GlobalRecipe r -> - let cb = translate_recipe senv.env r in - if dir = empty_dirpath then hcons_constant_body cb else cb + let cb = translate_recipe senv.env kn r in + if dir = empty_dirpath then hcons_constant_body cb else cb in -(* let cb = if dir = empty_dirpath then hcons_constant_body cb else cb in*) let env' = Environ.add_constraints cb.const_constraints senv.env in - let kn = make_kn senv.modinfo.modpath dir l in let env'' = Environ.add_constant kn cb env' in kn, { old = senv.old; env = env''; @@ -417,7 +417,6 @@ let check_engagement env c = let set_engagement c senv = {senv with env = Environ.set_engagement c senv.env} - (* Libraries = Compiled modules *) type compiled_library = @@ -517,7 +516,7 @@ let import (dp,mb,depends,engmt) digest senv = loads = (mp,mb)::senv.loads } -(** Remove the body of opaque constants in modules *) +(* Remove the body of opaque constants in modules *) let rec lighten_module mb = { mb with diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index b973fcde..148a9d9d 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: safe_typing.mli,v 1.33.2.2 2005/11/23 14:46:08 barras Exp $ i*) +(*i $Id: safe_typing.mli 7639 2005-12-02 10:01:15Z gregoire $ i*) (*i*) open Names @@ -28,7 +28,6 @@ type safe_environment val env_of_safe_env : safe_environment -> Environ.env val empty_environment : safe_environment - val is_empty : safe_environment -> bool (* Adding and removing local declarations (Local or Variables) *) @@ -46,7 +45,7 @@ type global_declaration = val add_constant : dir_path -> label -> global_declaration -> safe_environment -> - kernel_name * safe_environment + constant * safe_environment (* Adding an inductive type *) val add_mind : @@ -68,7 +67,7 @@ val add_constraints : Univ.constraints -> safe_environment -> safe_environment (* Settin the strongly constructive or classical logical engagement *) -val set_engagement : Environ.engagement -> safe_environment -> safe_environment +val set_engagement : engagement -> safe_environment -> safe_environment (*s Interactive module functions *) diff --git a/kernel/sign.ml b/kernel/sign.ml index a4b2a2ea..7caf667f 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sign.ml,v 1.37.2.1 2004/07/16 19:30:26 herbelin Exp $ *) +(* $Id: sign.ml 7639 2005-12-02 10:01:15Z gregoire $ *) open Names open Util @@ -53,13 +53,11 @@ let empty_rel_context = [] let add_rel_decl d ctxt = d::ctxt -let lookup_rel n sign = - let rec lookrec = function - | (1, decl :: _) -> decl - | (n, _ :: sign) -> lookrec (n-1,sign) - | (_, []) -> raise Not_found - in - lookrec (n,sign) +let rec lookup_rel n sign = + match n, sign with + | 1, decl :: _ -> decl + | n, _ :: sign -> lookup_rel (n-1) sign + | _, [] -> raise Not_found let rel_context_length = List.length @@ -73,7 +71,7 @@ let rel_context_nhyps hyps = let fold_rel_context f l ~init:x = List.fold_right f l x let fold_rel_context_reverse f ~init:x l = List.fold_left f x l -let map_rel_context f l = +let map_context f l = let map_decl (n, body_o, typ as decl) = let body_o' = option_smartmap f body_o in let typ' = f typ in @@ -82,6 +80,9 @@ let map_rel_context f l = in list_smartmap map_decl l +let map_rel_context = map_context +let map_named_context = map_context + (* Push named declarations on top of a rel context *) (* Bizarre. Should be avoided. *) let push_named_to_rel_context hyps ctxt = @@ -121,7 +122,7 @@ let destArity = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c - | Cast (c,_) -> prodec_rec l c + | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly "destArity: not an arity" in @@ -133,7 +134,7 @@ let rec isArity c = match kind_of_term c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) - | Cast (c,_) -> isArity c + | Cast (c,_,_) -> isArity c | Sort _ -> true | _ -> false @@ -144,7 +145,7 @@ let decompose_prod_assum = match kind_of_term c with | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c - | Cast (c,_) -> prodec_rec l c + | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec empty_rel_context @@ -156,7 +157,7 @@ let decompose_lam_assum = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c - | Cast (c,_) -> lamdec_rec l c + | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec empty_rel_context @@ -171,7 +172,7 @@ let decompose_prod_n_assum n = else match kind_of_term c with | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c - | Cast (c,_) -> prodec_rec l n c + | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec empty_rel_context n @@ -186,7 +187,7 @@ let decompose_lam_n_assum n = else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c - | Cast (c,_) -> lamdec_rec l n c + | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec empty_rel_context n diff --git a/kernel/sign.mli b/kernel/sign.mli index 3f0549cc..4a90302b 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: sign.mli,v 1.40.2.1 2004/07/16 19:30:26 herbelin Exp $ i*) +(*i $Id: sign.mli 6737 2005-02-18 20:49:43Z herbelin $ i*) (*i*) open Names @@ -62,6 +62,9 @@ val fold_rel_context_reverse : (*s Map function of [rel_context] *) val map_rel_context : (constr -> constr) -> rel_context -> rel_context +(*s Map function of [named_context] *) +val map_named_context : (constr -> constr) -> named_context -> named_context + (*s Term constructors *) val it_mkLambda_or_LetIn : constr -> rel_context -> constr diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 835226fb..94251d90 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtyping.ml,v 1.11.2.2 2005/11/29 21:40:52 letouzey Exp $ i*) +(*i $Id: subtyping.ml 7639 2005-12-02 10:01:15Z gregoire $ i*) (*i*) open Util @@ -18,6 +18,8 @@ open Environ open Reduction open Inductive open Modops +open Mod_subst +open Entries (*i*) (* This local type is used to subtype a constant with a constructor or @@ -26,7 +28,6 @@ open Modops type namedobject = | Constant of constant_body - | Mind of mutual_inductive_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body | Module of module_specification_body @@ -40,31 +41,27 @@ let add_nameobjects_of_mib ln mib map = let ip = (ln,j) in let map = array_fold_right_i - (fun i id map -> Idmap.add id (IndConstr ((ip,i), mib)) map) - oib.mind_consnames - map + (fun i id map -> + Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) + oib.mind_consnames + map in - Idmap.add oib.mind_typename (IndType (ip, mib)) map + Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in array_fold_right_i add_nameobjects_of_one mib.mind_packets map + (* creates namedobject map for the whole signature *) -let make_label_map msid list = +let make_label_map mp list = let add_one (l,e) map = - let obj = - match e with - | SPBconst cb -> Constant cb - | SPBmind mib -> Mind mib - | SPBmodule mb -> Module mb - | SPBmodtype mtb -> Modtype mtb - in -(* let map = match obj with - | Mind mib -> - add_nameobjects_of_mib (make_ln (MPself msid) l) mib map - | _ -> map - in *) - Labmap.add l obj map + let add_map obj = Labmap.add l obj map in + match e with + | SPBconst cb -> add_map (Constant cb) + | SPBmind mib -> + add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map + | SPBmodule mb -> add_map (Module mb) + | SPBmodtype mtb -> add_map (Modtype mtb) in List.fold_right add_one list Labmap.empty @@ -81,8 +78,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = let check_conv cst f = check_conv_error error cst f in let mib1 = match info1 with - | Mind mib -> mib - (* | IndType (_,mib) -> mib we will enable this later*) + | IndType ((_,0), mib) -> mib | _ -> error () in let check_packet cst p1 p2 = @@ -118,8 +114,8 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = && Array.length mib2.mind_packets >= 1); (* TODO: we should allow renaming of parameters at least ! *) - check (fun mib -> mib.mind_packets.(0).mind_nparams); - check (fun mib -> mib.mind_packets.(0).mind_params_ctxt); + check (fun mib -> mib.mind_nparams); + check (fun mib -> mib.mind_params_ctxt); begin match mib2.mind_equiv with @@ -133,32 +129,19 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = if kn1 <> kn2 then error () end; (* we check that records and their field names are preserved. *) - (* To stay compatible, we don't fail but only issue a warning. *) - if mib1.mind_record <> mib2.mind_record then begin - let sid = string_of_id mib1.mind_packets.(0).mind_typename in - Pp.warning - (sid^": record is implemented as an inductive type or conversely.\n"^ - "Beware that extraction cannot handle this situation.\n") - end; + check (fun mib -> mib.mind_record); if mib1.mind_record then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) - | Cast(t,_) -> names_prod_letin t + | Cast(t,_,_) -> names_prod_letin t | _ -> [] in assert (Array.length mib1.mind_packets = 1); assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); - let fields1 = names_prod_letin mib1.mind_packets.(0).mind_user_lc.(0) - and fields2 = names_prod_letin mib2.mind_packets.(0).mind_user_lc.(0) in - if fields1 <> fields2 then - let sid = string_of_id mib1.mind_packets.(0).mind_typename in - Pp.warning - (sid^": record has different field names in its signature and "^ - "implemantation.\n"^ - "Beware that extraction cannot handle this situation.\n"); + check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); end; (* we first check simple things *) let cst = @@ -173,23 +156,43 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = let check_constant cst env msid1 l info1 cb2 spec2 = let error () = error_not_match l spec2 in let check_conv cst f = check_conv_error error cst f in - let cb1 = - match info1 with - | Constant cb -> cb - | _ -> error () - in - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; - (*Start by checking types*) - let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in - match cb2.const_body with - | None -> cst - | Some lc2 -> - let c2 = Declarations.force lc2 in - let c1 = match cb1.const_body with - | Some lc1 -> Declarations.force lc1 - | None -> mkConst (make_kn (MPself msid1) empty_dirpath l) - in - check_conv cst conv env c1 c2 + match info1 with + | Constant cb1 -> + assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; + (*Start by checking types*) + let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in + let con = make_con (MPself msid1) empty_dirpath l in + let cst = + match cb2.const_body with + | None -> cst + | Some lc2 -> + let c2 = Declarations.force lc2 in + let c1 = match cb1.const_body with + | Some lc1 -> Declarations.force lc1 + | None -> mkConst con + in + check_conv cst conv env c1 c2 + in + cst + | IndType ((kn,i),mind1) -> + Util.error ("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.") ; + assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; + if cb2.const_body <> None then error () ; + let arity1 = mind1.mind_packets.(i).mind_user_arity in + check_conv cst conv_leq env arity1 cb2.const_type + | IndConstr (((kn,i),j) as cstr,mind1) -> + Util.error ("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.") ; + assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ; + if cb2.const_body <> None then error () ; + let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in + check_conv cst conv env ty1 cb2.const_type + | _ -> error () let rec check_modules cst env msid1 l msb1 msb2 = let mp = (MPdot(MPself msid1,l)) in @@ -206,11 +209,11 @@ let rec check_modules cst env msid1 l msb1 msb2 = cst -and check_signatures cst env' (msid1,sig1) (msid2,sig2') = +and check_signatures cst env (msid1,sig1) (msid2,sig2') = let mp1 = MPself msid1 in - let env = add_signature mp1 sig1 env' in + let env = add_signature mp1 sig1 env in let sig2 = subst_signature_msid msid2 mp1 sig2' in - let map1 = make_label_map msid1 sig1 in + let map1 = make_label_map mp1 sig1 in let check_one_body cst (l,spec2) = let info1 = try @@ -241,10 +244,10 @@ and check_signatures cst env' (msid1,sig1) (msid2,sig2') = List.fold_left check_one_body cst sig2 and check_modtypes cst env mtb1 mtb2 equiv = - if mtb1==mtb2 then (); (* just in case :) *) + if mtb1==mtb2 then cst else (* just in case :) *) let mtb1' = scrape_modtype env mtb1 in let mtb2' = scrape_modtype env mtb2 in - if mtb1'==mtb2' then (); + if mtb1'==mtb2' then cst else match mtb1', mtb2' with | MTBsig (msid1,list1), MTBsig (msid2,list2) -> @@ -257,15 +260,17 @@ and check_modtypes cst env mtb1 mtb2 equiv = MTBfunsig (arg_id2,arg_t2,body_t2) -> let cst = check_modtypes cst env arg_t2 arg_t1 equiv in (* contravariant *) - let env' = + let env = add_module (MPbound arg_id2) (module_body_of_type arg_t2) env in let body_t1' = + (* since we are just checking well-typedness we do not need + to expand any constant. Hence the identity resolver. *) subst_modtype - (map_mbid arg_id1 (MPbound arg_id2)) + (map_mbid arg_id1 (MPbound arg_id2) None) body_t1 in - check_modtypes cst env' body_t1' body_t2 equiv + check_modtypes cst env body_t1' body_t2 equiv | MTBident _ , _ -> anomaly "Subtyping: scrape failed" | _ , MTBident _ -> anomaly "Subtyping: scrape failed" | _ , _ -> error_incompatible_modtypes mtb1 mtb2 diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index af09dafc..8bc25464 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtyping.mli,v 1.2.8.1 2004/07/16 19:30:26 herbelin Exp $ i*) +(*i $Id: subtyping.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*i*) open Univ diff --git a/kernel/term.ml b/kernel/term.ml index 30e73e4f..7060d000 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: term.ml,v 1.95.2.1 2004/07/16 19:30:26 herbelin Exp $ *) +(* $Id: term.ml 8049 2006-02-16 10:42:18Z coq $ *) -(* This module instanciates the structure of generic deBruijn terms to Coq *) +(* This module instantiates the structure of generic deBruijn terms to Coq *) open Util open Pp @@ -21,6 +21,8 @@ open Esubst type existential_key = int type metavariable = int +(* This defines the strategy to use for verifiying a Cast *) + (* This defines Cases annotations *) type pattern_source = DefaultPat of int | RegularPat type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle @@ -31,6 +33,7 @@ type case_printing = type case_info = { ci_ind : inductive; ci_npar : int; + ci_cstr_nargs : int array; (* number of real args of each constructor *) ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -56,6 +59,8 @@ let family_of_sort = function (* Constructions as implemented *) (********************************************************************) +type cast_kind = VMcast | DEFAULTcast + (* [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 @@ -74,7 +79,7 @@ type ('constr, 'types) kind_of_term = | Meta of metavariable | Evar of 'constr pexistential | Sort of sorts - | Cast of 'constr * 'types + | Cast of 'constr * cast_kind * 'types | Prod of name * 'types * 'types | Lambda of name * 'types * 'constr | LetIn of name * 'constr * 'types * 'constr @@ -89,14 +94,14 @@ type ('constr, 'types) kind_of_term = (* Experimental *) type ('constr, 'types) kind_of_type = | SortType of sorts - | CastType of 'types * 'types + | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array let kind_of_type = function | Sort s -> SortType s - | Cast (c,t) -> CastType (c, t) + | Cast (c,_,t) -> CastType (c, t) | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) @@ -123,7 +128,7 @@ let comp_term t1 t2 = | Meta m1, Meta m2 -> m1 == m2 | Var id1, Var id2 -> id1 == id2 | Sort s1, Sort s2 -> s1 == s2 - | Cast (c1,t1), Cast (c2,t2) -> c1 == c2 & t1 == t2 + | Cast (c1,_,t1), Cast (c2,_,t2) -> c1 == c2 & t1 == t2 | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> @@ -148,19 +153,19 @@ let comp_term t1 t2 = & array_for_all2 (==) bl1 bl2 | _ -> false -let hash_term (sh_rec,(sh_sort,sh_kn,sh_na,sh_id)) t = +let hash_term (sh_rec,(sh_sort,sh_con,sh_kn,sh_na,sh_id)) t = match t with | Rel _ -> t | Meta x -> Meta x | Var x -> Var (sh_id x) | Sort s -> Sort (sh_sort s) - | Cast (c,t) -> Cast (sh_rec c, sh_rec t) + | Cast (c, k, t) -> Cast (sh_rec c, k, (sh_rec t)) | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c) | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c) | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c) | App (c,l) -> App (sh_rec c, Array.map sh_rec l) | Evar (e,l) -> Evar (e, Array.map sh_rec l) - | Const c -> Const (sh_kn c) + | Const c -> Const (sh_con c) | Ind (kn,i) -> Ind (sh_kn kn,i) | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j) | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *) @@ -179,15 +184,16 @@ module Hconstr = struct type t = constr type u = (constr -> constr) * - ((sorts -> sorts) * (kernel_name -> kernel_name) - * (name -> name) * (identifier -> identifier)) + ((sorts -> sorts) * (constant -> constant) * + (kernel_name -> kernel_name) * (name -> name) * + (identifier -> identifier)) let hash_sub = hash_term let equal = comp_term let hash = Hashtbl.hash end) -let hcons_term (hsorts,hkn,hname,hident) = - Hashcons.recursive_hcons Hconstr.f (hsorts,hkn,hname,hident) +let hcons_term (hsorts,hcon,hkn,hname,hident) = + Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident) (* Constructs a DeBrujin index with number n *) let rels = @@ -206,11 +212,12 @@ let mkVar id = Var id let mkSort s = Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) -(* (that means t2 is declared as the type of t1) *) -let mkCast (t1,t2) = +(* (that means t2 is declared as the type of t1) + [s] is the strategy to use when *) +let mkCast (t1,k2,t2) = match t1 with - | Cast (t,_) -> Cast (t,t2) - | _ -> Cast (t1,t2) + | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2) + | _ -> Cast (t1,k2,t2) (* Constructs the product (x:t1)t2 *) let mkProd (x,t1,t2) = Prod (x,t1,t2) @@ -225,7 +232,7 @@ let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2) (* We ensure applicative terms have at least one argument and the function is not itself an applicative term *) let mkApp (f, a) = - if a=[||] then f else + if Array.length a = 0 then f else match f with | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) @@ -309,22 +316,22 @@ let destSort c = match kind_of_term c with let rec isprop c = match kind_of_term c with | Sort (Prop _) -> true - | Cast (c,_) -> isprop c + | 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 + | 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 + | 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 + | Cast (c,_,_) -> is_Type c | _ -> false let isType = function @@ -344,10 +351,11 @@ let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false (* Destructs a casted term *) let destCast c = match kind_of_term c with - | Cast (t1, t2) -> (t1,t2) + | Cast (t1,k,t2) -> (t1,k,t2) | _ -> invalid_arg "destCast" -let isCast c = match kind_of_term c with Cast (_,_) -> true | _ -> false +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 @@ -374,12 +382,16 @@ let destLetIn c = match kind_of_term c with | _ -> invalid_arg "destProd" (* Destructs an application *) -let destApplication c = match kind_of_term c with +let destApp c = match kind_of_term c with | App (f,a) -> (f, a) | _ -> invalid_arg "destApplication" +let destApplication = destApp + let isApp c = match kind_of_term c with App _ -> true | _ -> false +let isProd c = match kind_of_term c with | Prod(_) -> true | _ -> false + (* Destructs a constant *) let destConst c = match kind_of_term c with | Const kn -> kn @@ -422,25 +434,42 @@ let destCoFix c = match kind_of_term c with | CoFix cofix -> cofix | _ -> invalid_arg "destCoFix" +(******************************************************************) +(* Cast management *) +(******************************************************************) + +let rec strip_outer_cast c = match kind_of_term c with + | Cast (c,_,_) -> strip_outer_cast c + | _ -> c + +(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) + +let under_outer_cast f c = match kind_of_term c with + | Cast (b,k,t) -> mkCast (f b, k, f t) + | _ -> f c + +let rec under_casts f c = match kind_of_term c with + | Cast (c,k,t) -> mkCast (under_casts f c, k, t) + | _ -> f c + (******************************************************************) (* Flattening and unflattening of embedded applications and casts *) (******************************************************************) -(* flattens application lists *) +(* flattens application lists throwing casts in-between *) let rec collapse_appl c = match kind_of_term c with | App (f,cl) -> - let rec collapse_rec f cl2 = match kind_of_term f with + let rec collapse_rec f cl2 = + match kind_of_term (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | Cast (c,_) when isApp c -> collapse_rec c cl2 - | _ -> if cl2 = [||] then f else mkApp (f,cl2) - in + | _ -> mkApp (f,cl2) + in collapse_rec f cl | _ -> c -let rec decompose_app c = - match kind_of_term (collapse_appl c) with +let decompose_app c = + match kind_of_term c with | App (f,cl) -> (f, Array.to_list cl) - | Cast (c,t) -> decompose_app c | _ -> (c,[]) (* strips head casts and flattens head applications *) @@ -448,11 +477,11 @@ let rec strip_head_cast c = match kind_of_term c with | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | Cast (c,_) -> collapse_rec c cl2 - | _ -> if cl2 = [||] then f else mkApp (f,cl2) + | Cast (c,_,_) -> collapse_rec c cl2 + | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2) in collapse_rec f cl - | Cast (c,t) -> strip_head_cast c + | Cast (c,_,_) -> strip_head_cast c | _ -> c (****************************************************************************) @@ -466,7 +495,7 @@ let rec strip_head_cast c = match kind_of_term c with let fold_constr f acc c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc - | Cast (c,t) -> f (f acc c) t + | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c @@ -487,7 +516,7 @@ let fold_constr f acc c = match kind_of_term c with let iter_constr f c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () - | Cast (c,t) -> f c; f t + | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c @@ -506,7 +535,7 @@ let iter_constr f c = match kind_of_term c with let iter_constr_with_binders g f n c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () - | Cast (c,t) -> f n c; f n t + | Cast (c,_,t) -> f n c; f n t | 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 @@ -527,7 +556,7 @@ let iter_constr_with_binders g f n c = match kind_of_term c with let map_constr f c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c - | Cast (c,t) -> mkCast (f c, f t) + | Cast (c,k,t) -> mkCast (f c, k, f t) | Prod (na,t,c) -> mkProd (na, f t, f c) | Lambda (na,t,c) -> mkLambda (na, f t, f c) | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c) @@ -548,7 +577,7 @@ let map_constr f c = match kind_of_term c with let map_constr_with_binders g f l c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c - | Cast (c,t) -> mkCast (f l c, f l t) + | Cast (c,k,t) -> mkCast (f l c, k, f l t) | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c) | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c) @@ -573,8 +602,8 @@ let compare_constr f t1 t2 = | Meta m1, Meta m2 -> m1 = m2 | Var id1, Var id2 -> id1 = id2 | Sort s1, Sort s2 -> s1 = s2 - | Cast (c1,_), _ -> f c1 t2 - | _, Cast (c2,_) -> f t1 c2 + | Cast (c1,_,_), _ -> f c1 t2 + | _, Cast (c2,_,_) -> f t1 c2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 @@ -605,6 +634,8 @@ let compare_constr f t1 t2 = type types = constr +type strategy = types option + let type_app f tt = f tt let body_of_type ty = ty @@ -671,7 +702,7 @@ let noccur_with_meta n m term = | Rel p -> if n<=p & p (match kind_of_term f with - | Cast (c,_) when isMeta c -> () + | Cast (c,_,_) when isMeta c -> () | Meta _ -> () | _ -> iter_constr_with_binders succ occur_rec n c) | Evar (_, _) -> () @@ -746,7 +777,7 @@ let substl laml = substn_many (Array.map make_substituend (Array.of_list laml)) 0 let subst1 lam = substl [lam] -let substl_decl laml (id,bodyopt,typ as d) = +let substl_decl laml (id,bodyopt,typ) = match bodyopt with | None -> (id,None,substl laml typ) | Some body -> (id, Some (substl laml body), type_app (substl laml) typ) @@ -789,32 +820,6 @@ let substn_vars p vars = let subst_vars = substn_vars 1 -(* -map_kn : (kernel_name -> kernel_name) -> constr -> constr - -This should be rewritten to prevent duplication of constr's when not -necessary. -For now, it uses map_constr and is rather ineffective -*) - -let rec map_kn f c = - let func = map_kn f in - match kind_of_term c with - | Const kn -> - mkConst (f kn) - | Ind (kn,i) -> - mkInd (f kn,i) - | Construct ((kn,i),j) -> - mkConstruct ((f kn,i),j) - | Case (ci,p,c,l) -> - let ci' = { ci with ci_ind = let (kn,i) = ci.ci_ind in f kn, i } in - mkCase (ci', func p, func c, array_smartmap func l) - | _ -> map_constr func c - -let subst_mps sub = - map_kn (subst_kn sub) - - (*********************) (* Term constructors *) (*********************) @@ -965,20 +970,6 @@ let mkCoFix = mkCoFix let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0)) let mkImplicit = mkSort implicit_sort -let rec strip_outer_cast c = match kind_of_term c with - | Cast (c,_) -> strip_outer_cast c - | _ -> c - -(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) - -let under_outer_cast f c = match kind_of_term c with - | Cast (b,t) -> mkCast (f b,f t) - | _ -> f c - -let rec under_casts f c = match kind_of_term c with - | Cast (c,t) -> mkCast (under_casts f c, t) - | _ -> f c - (***************************) (* Other term constructors *) (***************************) @@ -1027,7 +1018,7 @@ let rec to_lambda n prod = else match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) - | Cast (c,_) -> to_lambda n c + | Cast (c,_,_) -> to_lambda n c | _ -> errorlabstrm "to_lambda" (mt ()) let rec to_prod n lam = @@ -1036,7 +1027,7 @@ let rec to_prod n lam = else match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) - | Cast (c,_) -> to_prod n c + | Cast (c,_,_) -> to_prod n c | _ -> errorlabstrm "to_prod" (mt ()) (* pseudo-reduction rule: @@ -1066,7 +1057,7 @@ let prod_applist t nL = List.fold_left prod_app t nL let decompose_prod = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c - | Cast (c,_) -> prodec_rec l c + | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in prodec_rec [] @@ -1076,7 +1067,7 @@ let decompose_prod = let decompose_lam = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c - | Cast (c,_) -> lamdec_rec l c + | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec [] @@ -1089,7 +1080,7 @@ let decompose_prod_n n = if n=0 then l,c else match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c - | Cast (c,_) -> prodec_rec l n c + | Cast (c,_,_) -> prodec_rec l n c | _ -> error "decompose_prod_n: not enough products" in prodec_rec [] n @@ -1102,7 +1093,7 @@ let decompose_lam_n n = if n=0 then l,c else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c - | Cast (c,_) -> lamdec_rec l n c + | Cast (c,_,_) -> lamdec_rec l n c | _ -> error "decompose_lam_n: not enough abstractions" in lamdec_rec [] n @@ -1112,7 +1103,7 @@ let decompose_lam_n n = let nb_lam = let rec nbrec n c = match kind_of_term c with | Lambda (_,_,c) -> nbrec (n+1) c - | Cast (c,_) -> nbrec n c + | Cast (c,_,_) -> nbrec n c | _ -> n in nbrec 0 @@ -1121,7 +1112,7 @@ let nb_lam = let nb_prod = let rec nbrec n c = match kind_of_term c with | Prod (_,_,c) -> nbrec (n+1) c - | Cast (c,_) -> nbrec n c + | Cast (c,_,_) -> nbrec n c | _ -> n in nbrec 0 @@ -1137,6 +1128,7 @@ let nb_prod = let rec eq_constr m n = (m==n) or compare_constr eq_constr m n + let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) (*******************) @@ -1177,10 +1169,18 @@ module Hsorts = let hsort = Hsorts.f -let hcons_constr (hkn,hdir,hname,hident,hstr) = +let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) = let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in - let hcci = hcons_term (hsortscci,hkn,hname,hident) in + let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in (hcci,htcci) let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names()) + + +(*******) +(* Type of abstract machine values *) +type values + + + diff --git a/kernel/term.mli b/kernel/term.mli index a5e5c081..0eccd170 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -6,12 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: term.mli,v 1.101.2.1 2004/07/16 19:30:26 herbelin Exp $ i*) +(*i $Id: term.mli 8049 2006-02-16 10:42:18Z coq $ i*) (*i*) open Names (*i*) + (*s The sorts of CCI. *) type contents = Pos | Null @@ -49,6 +50,7 @@ type case_printing = type case_info = { ci_ind : inductive; ci_npar : int; + ci_cstr_nargs : int array; (* number of real args of each constructor *) ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -99,9 +101,13 @@ val mkProp : types val mkSet : types val mkType : Univ.universe -> types + +(* This defines the strategy to use for verifiying a Cast *) +type cast_kind = VMcast | DEFAULTcast + (* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the type $t_2$ (that means t2 is declared as the type of t1). *) -val mkCast : constr * types -> constr +val mkCast : constr * cast_kind * constr -> constr (* Constructs the product [(x:t1)t2] *) val mkProd : name * types * types -> types @@ -192,7 +198,7 @@ type ('constr, 'types) kind_of_term = | Meta of metavariable | Evar of 'constr pexistential | Sort of sorts - | Cast of 'constr * 'types + | Cast of 'constr * cast_kind * 'types | Prod of name * 'types * 'types | Lambda of name * 'types * 'constr | LetIn of name * 'constr * 'types * 'constr @@ -213,7 +219,7 @@ val kind_of_term : constr -> (constr, types) kind_of_term (* Experimental *) type ('constr, 'types) kind_of_type = | SortType of sorts - | CastType of 'types * 'types + | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array @@ -230,6 +236,7 @@ val isMeta : constr -> bool val isSort : constr -> bool val isCast : constr -> bool val isApp : constr -> bool +val isProd : constr -> bool val isConst : constr -> bool val isConstruct : constr -> bool @@ -258,7 +265,7 @@ val destVar : constr -> identifier val destSort : constr -> sorts (* Destructs a casted term *) -val destCast : constr -> constr * types +val destCast : constr -> constr * cast_kind * constr (* Destructs the product $(x:t_1)t_2$ *) val destProd : types -> name * types * types @@ -270,8 +277,12 @@ val destLambda : constr -> name * types * constr val destLetIn : constr -> name * constr * types * constr (* Destructs an application *) +val destApp : constr -> constr * constr array + +(* Obsolete synonym of destApp *) val destApplication : constr -> constr * constr array -(* ... removing casts *) + +(* Decompose any term as an applicative term; the list of args can be empty *) val decompose_app : constr -> constr * constr list (* Destructs a constant *) @@ -410,6 +421,9 @@ val strip_outer_cast : constr -> constr (* Apply a function letting Casted types in place *) val under_casts : (constr -> constr) -> constr -> constr +(* Apply a function under components of Cast if any *) +val under_outer_cast : (constr -> constr) -> constr -> constr + (*s Occur checks *) (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) @@ -460,11 +474,6 @@ val subst_vars : identifier list -> constr -> constr val substn_vars : int -> identifier list -> constr -> constr -(* [subst_mps sub c] performs the substitution [sub] on all kernel - names appearing in [c] *) -val subst_mps : substitution -> constr -> constr - - (*s Functionals working on the immediate subterm of a construction *) (* [fold_constr f acc c] folds [f] on the immediate subterms of [c] @@ -512,6 +521,7 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool (*********************************************************************) val hcons_constr: + (constant -> constant) * (kernel_name -> kernel_name) * (dir_path -> dir_path) * (name -> name) * @@ -523,3 +533,7 @@ val hcons_constr: val hcons1_constr : constr -> constr val hcons1_types : types -> types + +(**************************************) + +type values diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 5347583f..fde5fa25 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: term_typing.ml,v 1.5.6.1 2004/07/16 19:30:27 herbelin Exp $ *) +(* $Id: term_typing.ml 7639 2005-12-02 10:01:15Z gregoire $ *) open Util open Names @@ -26,15 +26,9 @@ let constrain_type env j cst1 = function | None -> j.uj_type, cst1 | Some t -> let (tj,cst2) = infer_type env t in - let cst3 = - try conv_leq env j.uj_type tj.utj_val - with NotConvertible -> error_actual_type env j tj.utj_val in - let typ = - if t = tj.utj_val then t else - (error "Kernel built a type different from its input\n"; - flush stdout; tj.utj_val) in - typ, Constraint.union (Constraint.union cst1 cst2) cst3 - + let (_,cst3) = judge_of_cast env j DEFAULTcast tj in + assert (t = tj.utj_val); + t, Constraint.union (Constraint.union cst1 cst2) cst3 let translate_local_def env (b,topt) = let (j,cst) = infer env b in @@ -85,33 +79,38 @@ let infer_declaration env dcl = | DefinitionEntry c -> let (j,cst) = infer env c.const_entry_body in let (typ,cst) = constrain_type env j cst c.const_entry_type in - Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque + Some (Declarations.from_val j.uj_val), typ, cst, + c.const_entry_opaque, c.const_entry_boxed | ParameterEntry t -> let (j,cst) = infer env t in - None, Typeops.assumption_of_judgment env j, cst, false + None, Typeops.assumption_of_judgment env j, cst, false, false -let build_constant_declaration env (body,typ,cst,op) = - let ids = match body with +let build_constant_declaration env kn (body,typ,cst,op,boxed) = + let ids = + match body with | None -> global_vars_set env typ | Some b -> Idset.union (global_vars_set env (Declarations.force b)) - (global_vars_set env typ) + (global_vars_set env typ) in + let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in let hyps = keep_hyps env ids in - { const_body = body; + { const_hyps = hyps; + const_body = body; const_type = typ; - const_hyps = hyps; + const_body_code = tps; + (* const_type_code = to_patch env typ;*) const_constraints = cst; const_opaque = op } (*s Global and local constant declaration. *) -let translate_constant env ce = - build_constant_declaration env (infer_declaration env ce) +let translate_constant env kn ce = + build_constant_declaration env kn (infer_declaration env ce) -let translate_recipe env r = - build_constant_declaration env (Cooking.cook_constant env r) +let translate_recipe env kn r = + build_constant_declaration env kn (Cooking.cook_constant env r) (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 67d479ba..cf111b6b 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: term_typing.mli,v 1.2.8.1 2004/07/16 19:30:27 herbelin Exp $ i*) +(*i $Id: term_typing.mli 6245 2004-10-20 13:50:08Z barras $ i*) (*i*) open Names @@ -24,11 +24,11 @@ val translate_local_def : env -> constr * types option -> val translate_local_assum : env -> types -> types * Univ.constraints - -val translate_constant : env -> constant_entry -> constant_body + +val translate_constant : env -> constant -> constant_entry -> constant_body val translate_mind : env -> mutual_inductive_entry -> mutual_inductive_body val translate_recipe : - env -> Cooking.recipe -> constant_body + env -> constant -> Cooking.recipe -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index c3d4726f..3807ecdb 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: type_errors.ml,v 1.31.2.1 2004/07/16 19:30:27 herbelin Exp $ *) +(* $Id: type_errors.ml 8673 2006-03-29 21:21:52Z herbelin $ *) open Names open Term @@ -19,7 +19,7 @@ open Reduction type guard_error = (* Fixpoints *) | NotEnoughAbstractionInFixBody - | RecursionNotOnInductiveType + | RecursionNotOnInductiveType of constr | RecursionOnIllegalTerm of int * constr * int list * int list | NotEnoughArgumentsForFixCall of int (* CoFixpoints *) @@ -103,7 +103,7 @@ let error_cant_apply_not_functional env rator randl = raise (TypeError (env, CantApplyNonFunctional (rator,randl))) let error_cant_apply_bad_type env t rator randl = - raise(TypeError (env, CantApplyBadType (t,rator,randl))) + raise (TypeError (env, CantApplyBadType (t,rator,randl))) let error_ill_formed_rec_body env why lna i = raise (TypeError (env, IllFormedRecBody (why,lna,i))) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 2e8a7138..c56b174b 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: type_errors.mli,v 1.36.2.1 2004/07/16 19:30:27 herbelin Exp $ i*) +(*i $Id: type_errors.mli 6019 2004-08-06 18:15:24Z herbelin $ i*) (*i*) open Names @@ -21,7 +21,7 @@ open Environ type guard_error = (* Fixpoints *) | NotEnoughAbstractionInFixBody - | RecursionNotOnInductiveType + | RecursionNotOnInductiveType of constr | RecursionOnIllegalTerm of int * constr * int list * int list | NotEnoughArgumentsForFixCall of int (* CoFixpoints *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 66b2e24d..779a427a 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: typeops.ml,v 1.89.2.1 2004/07/16 19:30:28 herbelin Exp $ *) +(* $Id: typeops.ml 8673 2006-03-29 21:21:52Z herbelin $ *) open Util open Names @@ -19,11 +19,24 @@ open Entries open Reduction open Inductive open Type_errors - + +let conv = default_conv CONV +let conv_leq = default_conv CUMUL + +let conv_leq_vecti env v1 v2 = + array_fold_left2_i + (fun i c t1 t2 -> + let c' = + try default_conv CUMUL env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i) in + Constraint.union c c') + Constraint.empty + v1 + v2 (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = - match kind_of_term(whd_betadeltaiota env (body_of_type j.uj_type)) with + match kind_of_term(whd_betadeltaiota env j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j @@ -34,11 +47,9 @@ let assumption_of_judgment env j = with TypeError _ -> error_assumption env j -(* -let aojkey = Profile.declare_profile "assumption_of_judgment";; -let assumption_of_judgment env j - = Profile.profile2 aojkey assumption_of_judgment env j;; -*) +let sort_judgment env j = (type_judgment env j).utj_type + +let on_judgment_type f j = { j with uj_type = f j.uj_type } (************************************************) (* Incremental typing rules: builds a typing judgement given the *) @@ -49,11 +60,11 @@ let assumption_of_judgment env j (* Prop and Set *) let judge_of_prop = - { uj_val = body_of_type mkProp; + { uj_val = mkProp; uj_type = mkSort type_0 } let judge_of_set = - { uj_val = body_of_type mkSet; + { uj_val = mkSet; uj_type = mkSort type_0 } let judge_of_prop_contents = function @@ -64,7 +75,7 @@ let judge_of_prop_contents = function let judge_of_type u = let uu = super u in - { uj_val = body_of_type (mkType u); + { uj_val = mkType u; uj_type = mkType uu } (*s Type of a de Bruijn index. *) @@ -77,30 +88,23 @@ let judge_of_relative env n = with Not_found -> error_unbound_rel env n -(* -let relativekey = Profile.declare_profile "judge_of_relative";; -let judge_of_relative env n = - Profile.profile2 relativekey judge_of_relative env n;; -*) - (* Type of variables *) let judge_of_variable env id = try - let (_,_,ty) = lookup_named id env in + let ty = named_type id env in make_judge (mkVar id) ty with Not_found -> error_unbound_var env id (* Management of context of variables. *) -(* Checks if a context of variable can be instanciated by the +(* Checks if a context of variable can be instantiated by the variables of the current env *) (* TODO: check order? *) let rec check_hyps_inclusion env sign = - let env_sign = named_context env in Sign.fold_named_context (fun (id,_,ty1) () -> - let (_,_,ty2) = Sign.lookup_named id env_sign in + let ty2 = named_type id env in if not (eq_constr ty2 ty1) then error "types do not match") sign @@ -108,7 +112,6 @@ let rec check_hyps_inclusion env sign = let check_args env c hyps = - let hyps' = named_context env in try check_hyps_inclusion env hyps with UserError _ | Not_found -> error_reference_variables env c @@ -132,12 +135,6 @@ let judge_of_constant env cst = check_args env constr ce.const_hyps in make_judge constr (constant_type env cst) -(* -let tockey = Profile.declare_profile "type_of_constant";; -let type_of_constant env c - = Profile.profile3 tockey type_of_constant env c;; -*) - (* Type of a lambda-abstraction. *) (* [judge_of_abstraction env name var j] implements the rule @@ -203,9 +200,11 @@ let sort_of_product env domsort rangsort = rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - domsort + Type (sup u1 base_univ) (* Product rule (Prop,Type_i,Type_i) *) - | (Prop _, Type _) -> rangsort + | (Prop Pos, Type u2) -> Type (sup base_univ u2) + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (sup u1 u2) @@ -231,11 +230,14 @@ let judge_of_product env name t1 t2 = env |- c:typ2 *) -let judge_of_cast env cj tj = +let judge_of_cast env cj k tj = let expected_type = tj.utj_val in try - let cst = conv_leq env cj.uj_type expected_type in - { uj_val = mkCast (j_val cj, expected_type); + let cst = + match k with + | VMcast -> vm_conv CUMUL env cj.uj_type expected_type + | DEFAULTcast -> conv_leq env cj.uj_type expected_type in + { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type }, cst with NotConvertible -> @@ -249,13 +251,8 @@ let judge_of_inductive env i = let (kn,_) = i in let mib = lookup_mind kn env in check_args env constr mib.mind_hyps in - make_judge constr (type_of_inductive env i) - -(* -let toikey = Profile.declare_profile "judge_of_inductive";; -let judge_of_inductive env i - = Profile.profile2 toikey judge_of_inductive env i;; -*) + let specif = lookup_mind_specif env i in + make_judge constr (type_of_inductive specif) (* Constructors. *) @@ -265,21 +262,16 @@ let judge_of_constructor env c = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_args env constr mib.mind_hyps in - make_judge constr (type_of_constructor env c) - -(* -let tockey = Profile.declare_profile "judge_of_constructor";; -let judge_of_constructor env cstr - = Profile.profile2 tockey judge_of_constructor env cstr;; -*) + let specif = lookup_mind_specif env (inductive_of_constructor c) in + make_judge constr (type_of_constructor c specif) (* Case. *) -let check_branch_types env cj (lft,explft) = - try conv_leq_vecti env lft explft +let check_branch_types env cj (lfj,explft) = + try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> - error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i) + error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) @@ -290,20 +282,12 @@ let judge_of_case env ci pj cj lfj = let _ = check_case_info env (fst indspec) ci in let (bty,rslty,univ) = type_case_branches env indspec pj cj.uj_val in - let (_,kind) = dest_arity env pj.uj_type in - let lft = Array.map j_type lfj in - let univ' = check_branch_types env cj (lft,bty) in + let univ' = check_branch_types env cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty }, Constraint.union univ univ') -(* -let tocasekey = Profile.declare_profile "judge_of_case";; -let judge_of_case env ci pj cj lfj - = Profile.profile6 tocasekey judge_of_case env ci pj cj lfj;; -*) - (* Fixpoints. *) (* Checks the type of a general (co)fixpoint, i.e. without checking *) @@ -313,9 +297,7 @@ let type_fixpoint env lna lar vdefj = let lt = Array.length vdefj in assert (Array.length lar = lt); try - conv_leq_vecti env - (Array.map (fun j -> body_of_type j.uj_type) vdefj) - (Array.map (fun ty -> lift lt ty) lar) + conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar) with NotConvertibleVect i -> error_ill_typed_rec_body env i lna vdefj lar @@ -354,8 +336,12 @@ let rec execute env cstr cu = | App (f,args) -> let (j,cu1) = execute env f cu in let (jl,cu2) = execute_array env args cu1 in - univ_combinator cu2 - (judge_of_apply env j jl) + let (j',cu) = univ_combinator cu2 (judge_of_apply env j jl) in + if isInd f then + (* Sort-polymorphism of inductive types *) + adjust_inductive_level env (destInd f) args (j',cu) + else + (j',cu) | Lambda (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in @@ -372,16 +358,17 @@ let rec execute env cstr cu = | LetIn (name,c1,c2,c3) -> let (j1,cu1) = execute env c1 cu in let (j2,cu2) = execute_type env c2 cu1 in - let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 j2) in + let (_,cu3) = + univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let (j',cu4) = execute env1 c3 cu3 in (judge_of_letin env name j1 j2 j', cu4) - | Cast (c,t) -> + | Cast (c,k, t) -> let (cj,cu1) = execute env c cu in let (tj,cu2) = execute_type env t cu1 in univ_combinator cu2 - (judge_of_cast env cj tj) + (judge_of_cast env cj k tj) (* Inductive types *) | Ind ind -> @@ -430,27 +417,32 @@ and execute_recdef env (names,lar,vdef) i cu = univ_combinator cu2 ((lara.(i),(names,lara,vdefv)),cst) -and execute_array env v cu = - let (jl,cu1) = execute_list env (Array.to_list v) cu in - (Array.of_list jl, cu1) - -and execute_list env l cu = - match l with - | [] -> - ([], cu) - | c::r -> - let (j,cu1) = execute env c cu in - let (jr,cu2) = execute_list env r cu1 in - (j::jr, cu2) +and execute_array env = array_fold_map' (execute env) + +and execute_list env = list_fold_map' (execute env) + +and adjust_inductive_level env ind args (j,cu) = + let specif = lookup_mind_specif env ind in + if is_small_inductive specif then + (* No polymorphism *) + (j,cu) + else + (* Retyping constructor with the actual arguments *) + let env',llc,ls0 = constructor_instances env specif ind args in + let (llj,cu1) = array_fold_map' (execute_array env') llc cu in + let ls = + Array.map (fun lj -> + max_inductive_sort (Array.map (sort_judgment env) lj)) llj + in + let s = find_inductive_level env specif ind ls0 ls in + (on_judgment_type (set_inductive_level env s) j, cu1) (* Derived functions *) let infer env constr = let (j,(cst,_)) = execute env constr (Constraint.empty, universes env) in - let j = if j.uj_val = constr then { j with uj_val = constr } else - (error "Kernel built a body different from its input\n"; - flush stdout; j) in - (j, cst) + assert (j.uj_val = constr); + ({ j with uj_val = constr }, cst) let infer_type env constr = let (j,(cst,_)) = diff --git a/kernel/typeops.mli b/kernel/typeops.mli index ffe9d861..34ecd103 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: typeops.mli,v 1.44.8.1 2004/07/16 19:30:28 herbelin Exp $ i*) +(*i $Id: typeops.mli 8673 2006-03-29 21:21:52Z herbelin $ i*) (*i*) open Names @@ -33,6 +33,8 @@ val infer_local_decls : val assumption_of_judgment : env -> unsafe_judgment -> types val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment +val on_judgment_type : + (types -> types) -> unsafe_judgment -> unsafe_judgment (*s Type of sorts. *) val judge_of_prop_contents : contents -> unsafe_judgment @@ -69,8 +71,8 @@ val judge_of_letin : (*s Type of a cast. *) val judge_of_cast : - env -> unsafe_judgment -> unsafe_type_judgment - -> unsafe_judgment * constraints + env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> + unsafe_judgment * constraints (*s Inductive types. *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 5e9fbd81..23e50282 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -6,29 +6,41 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: univ.ml,v 1.17.10.3 2005/09/08 12:27:46 herbelin Exp $ *) +(* $Id: univ.ml 8673 2006-03-29 21:21:52Z herbelin $ *) -(* Universes are stratified by a partial ordering $\ge$. +(* Universes are stratified by a partial ordering $\le$. Let $\~{}$ be the associated equivalence. We also have a strict ordering - $>$ between equivalence classes, and we maintain that $>$ is acyclic, - and contained in $\ge$ in the sense that $[U]>[V]$ implies $U\ge V$. + $<$ between equivalence classes, and we maintain that $<$ is acyclic, + and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. At every moment, we have a finite number of universes, and we - maintain the ordering in the presence of assertions $U>V$ and $U\ge V$. + maintain the ordering in the presence of assertions $U$ and $\ge$ are represented by + union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) open Pp open Util +(* An algebraic universe [universe] is either a universe variable + [universe_level] or a formal universe known to be greater than some + universe variables and strictly greater than some (other) universe + variables + + Universes variables denote universes initially present in the term + to type-check and non variable algebraic universes denote the + universes inferred while type-checking: it is either the successor + of a universe present in the initial term to type-check or the + maximum of two algebraic universes + *) + type universe_level = - { u_mod : Names.dir_path; - u_num : int } + | Base + | Level of Names.dir_path * int type universe = - | Variable of universe_level + | Atom of universe_level | Max of universe_level list * universe_level list module UniverseOrdered = struct @@ -36,61 +48,60 @@ module UniverseOrdered = struct let compare = Pervasives.compare end -let string_of_univ_level u = - Names.string_of_dirpath u.u_mod^"."^string_of_int u.u_num +let string_of_univ_level = function + | Base -> "0" + | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n -let make_univ (m,n) = Variable { u_mod=m; u_num=n } - -let string_of_univ = function - | Variable u -> string_of_univ_level u - | Max (gel,gtl) -> - "max("^ - (String.concat "," - ((List.map string_of_univ_level gel)@ - (List.map (fun u -> "("^(string_of_univ_level u)^")+1") gtl)))^")" +let make_univ (m,n) = Atom (Level (m,n)) let pr_uni_level u = str (string_of_univ_level u) let pr_uni = function - | Variable u -> + | Atom u -> pr_uni_level u + | Max ([],[Base]) -> + int 1 | Max (gel,gtl) -> - str "max(" ++ - prlist_with_sep pr_coma pr_uni_level gel ++ - (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++ - prlist_with_sep pr_coma - (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl ++ + str "max(" ++ hov 0 + (prlist_with_sep pr_coma pr_uni_level gel ++ + (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++ + prlist_with_sep pr_coma + (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++ str ")" -(* Returns a fresh universe, juste above u. Does not create new universes - for Type_0 (the sort of Prop and Set). +(* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super = function - | Variable u -> + | Atom u -> Max ([],[u]) | Max _ -> - anomaly ("Cannot take the successor of a non variable universes\n"^ + anomaly ("Cannot take the successor of a non variable universes:\n"^ "(maybe a bugged tactic)") -(* returns the least upper bound of universes u and v. If they are not - constrained, then a new universe is created. +(* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) -let sup u v = +let sup u v = match u,v with - | Variable u, Variable v -> Max ((if u = v then [u] else [u;v]),[]) - | Variable u, Max (gel,gtl) -> Max (list_add_set u gel,gtl) - | Max (gel,gtl), Variable v -> Max (list_add_set v gel,gtl) + | Atom u, Atom v -> if u = v then Atom u else Max ([u;v],[]) + | u, Max ([],[]) -> u + | Max ([],[]), v -> v + | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl) + | Max (gel,gtl), Atom v -> Max (list_add_set v gel,gtl) | Max (gel,gtl), Max (gel',gtl') -> - Max (list_union gel gel',list_union gtl gtl') + let gel'' = list_union gel gel' in + let gtl'' = list_union gtl gtl' in + Max (list_subtract gel'' gtl'',gtl'') + +let sup_array ls = Array.fold_right sup ls (Max ([],[])) (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: universe_level; gt: universe_level list; ge: universe_level list } + { univ: universe_level; lt: universe_level list; le: universe_level list } -let terminal u = {univ=u; gt=[]; ge=[]} +let terminal u = {univ=u; lt=[]; le=[]} -(* A universe is either an alias for another one, or a canonical one, - for which we know the universes that are smaller *) +(* A universe_level is either an alias for another one, or a canonical one, + for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc | Equiv of universe_level * universe_level @@ -111,15 +122,23 @@ let declare_univ u g = else g -(* When typing Prop and Set, there is no constraint on the level, - hence the definition of prop_univ *) +(* The level of Set *) +let base_univ = Atom Base + +let is_base = function + | Atom Base -> true + | Max ([Base],[]) -> warning "Non canonical Set"; true + | u -> false + +(* When typing [Prop] and [Set], there is no constraint on the level, + hence the definition of [prop_univ], the type of [Prop] *) let initial_universes = UniverseMap.empty -let prop_univ = Max ([],[]) +let prop_univ = Max ([],[Base]) -(* Every universe has a unique canonical arc representative *) +(* Every universe_level has a unique canonical arc representative *) -(* repr : universes -> universe -> canonical_arc *) +(* repr : universes -> universe_level -> canonical_arc *) (* canonical representative : we follow the Equiv links *) let repr g u = let rec repr_rec u = @@ -136,30 +155,30 @@ let repr g u = let can g = List.map (repr g) -(* transitive closure : we follow the Greater links *) +(* transitive closure : we follow the Less links *) (* collect : canonical_arc -> canonical_arc list * canonical_arc list *) -(* collect u = (V,W) iff V={v canonical | u>v} W={w canonical | u>=w}-V *) -(* i.e. collect does the transitive closure of what is known about u *) -let collect g arcu = - let rec coll_rec gt ge = function - | [],[] -> (gt, list_subtractq ge gt) - | arcv::gt', ge' -> - if List.memq arcv gt then - coll_rec gt ge (gt',ge') +(* collect u = (V,W) iff V={v canonical | u (lt, list_subtractq le lt) + | arcv::lt', le' -> + if List.memq arcv lt then + coll_rec lt le (lt',le') else - coll_rec (arcv::gt) ge ((can g (arcv.gt@arcv.ge))@gt',ge') - | [], arcw::ge' -> - if (List.memq arcw gt) or (List.memq arcw ge) then - coll_rec gt ge ([],ge') + coll_rec (arcv::lt) le ((can g (arcv.lt@arcv.le))@lt',le') + | [], arcw::le' -> + if (List.memq arcw lt) or (List.memq arcw le) then + coll_rec lt le ([],le') else - coll_rec gt (arcw::ge) (can g arcw.gt, (can g arcw.ge)@ge') + coll_rec lt (arcw::le) (can g arcw.lt, (can g arcw.le)@le') in coll_rec [] [] ([],[arcu]) -(* reprgeq : canonical_arc -> canonical_arc list *) -(* All canonical arcv such that arcu>=arcc with arcv#arcu *) -let reprgeq g arcu = +(* reprleq : canonical_arc -> canonical_arc list *) +(* All canonical arcv such that arcu<=arcv with arcv#arcu *) +let reprleq g arcu = let rec searchrec w = function | [] -> w | v :: vl -> @@ -169,17 +188,17 @@ let reprgeq g arcu = else searchrec (arcv :: w) vl in - searchrec [] arcu.ge + searchrec [] arcu.le -(* between : universe -> canonical_arc -> canonical_arc list *) -(* between u v = {w|u>=w>=v, w canonical} *) +(* between : universe_level -> canonical_arc -> canonical_arc list *) +(* between u v = {w|u<=w<=v, w canonical} *) (* between is the most costly operation *) let between g u arcv = - (* good are all w | u >= w >= v *) - (* bad are all w | u >= w ~>= v *) - (* find good and bad nodes in {w | u >= w} *) + (* good are all w | u <= w <= v *) + (* bad are all w | u <= w ~<= v *) + (* find good and bad nodes in {w | u <= w} *) (* explore b u = (b or "u is good") *) let rec explore ((good, bad, b) as input) arcu = if List.memq arcu good then @@ -187,12 +206,12 @@ let between g u arcv = else if List.memq arcu bad then input (* (good, bad, b or false) *) else - let childs = reprgeq g arcu in - (* are any children of u good ? *) - let good, bad, b_childs = - List.fold_left explore (good, bad, false) childs + let leq = reprleq g arcu in + (* is some universe >= u good ? *) + let good, bad, b_leq = + List.fold_left explore (good, bad, false) leq in - if b_childs then + if b_leq then arcu::good, bad, true (* b or true *) else good, arcu::bad, b (* b or false *) @@ -200,64 +219,64 @@ let between g u arcv = let good,_,_ = explore ([arcv],[],false) (repr g u) in good -(* We assume compare(u,v) = GE with v canonical (see compare below). +(* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u Otherwise, between g u v = [] *) -type order = EQ | GT | GE | NGE +type order = EQ | LT | LE | NLE -(* compare : universe -> universe -> order *) +(* compare : universe_level -> universe_level -> order *) let compare g u v = let arcu = repr g u and arcv = repr g v in if arcu==arcv then EQ else - let (gt,geq) = collect g arcu in - if List.memq arcv gt then - GT - else if List.memq arcv geq then - GE + let (lt,leq) = collect g arcu in + if List.memq arcv lt then + LT + else if List.memq arcv leq then + LE else - NGE + NLE (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ - compare(u,v) = GT or GE => compare(v,u) = NGE - compare(u,v) = NGE => compare(v,u) = NGE or GE or GT + compare(u,v) = LT or LE => compare(v,u) = NLE + compare(u,v) = NLE => compare(v,u) = NLE or LE or LT - Adding u>=v is consistent iff compare(v,u) # GT - and then it is redundant iff compare(u,v) # NGE - Adding u>v is consistent iff compare(v,u) = NGE - and then it is redundant iff compare(u,v) = GT *) + Adding u>=v is consistent iff compare(v,u) # LT + and then it is redundant iff compare(u,v) # NLE + Adding u>v is consistent iff compare(v,u) = NLE + and then it is redundant iff compare(u,v) = LT *) -(* setgt : universe -> universe -> unit *) +(* setlt : universe_level -> universe_level -> unit *) (* forces u > v *) -let setgt g u v = +let setlt g u v = let arcu = repr g u in - enter_arc {arcu with gt=v::arcu.gt} g + enter_arc {arcu with lt=v::arcu.lt} g -(* checks that non-redondant *) -let setgt_if g u v = match compare g u v with - | GT -> g - | _ -> setgt g u v +(* checks that non-redundant *) +let setlt_if g u v = match compare g u v with + | LT -> g + | _ -> setlt g u v -(* setgeq : universe -> universe -> unit *) +(* setleq : universe_level -> universe_level -> unit *) (* forces u >= v *) -let setgeq g u v = +let setleq g u v = let arcu = repr g u in - enter_arc {arcu with ge=v::arcu.ge} g + enter_arc {arcu with le=v::arcu.le} g -(* checks that non-redondant *) -let setgeq_if g u v = match compare g u v with - | NGE -> setgeq g u v +(* checks that non-redundant *) +let setleq_if g u v = match compare g u v with + | NLE -> setleq g u v | _ -> g -(* merge : universe -> universe -> unit *) -(* we assume compare(u,v) = GE *) +(* merge : universe_level -> universe_level -> unit *) +(* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g u v = match between g u (repr g v) with @@ -265,23 +284,23 @@ let merge g u v = (* redirected to it *) let redirect (g,w,w') arcv = let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',list_unionq arcv.gt w,arcv.ge@w') + (g',list_unionq arcv.lt w,arcv.le@w') in let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' w in - let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' w' in + let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in + let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in g''' | [] -> anomaly "Univ.between" -(* merge_disc : universe -> universe -> unit *) -(* we assume compare(u,v) = compare(v,u) = NGE *) +(* merge_disc : universe_level -> universe_level -> unit *) +(* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g u v = let arcu = repr g u in let arcv = repr g v in let g' = enter_equiv_arc arcv.univ arcu.univ g in - let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' arcv.gt in - let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' arcv.ge in + let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in + let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in g''' (* Universe inconsistency: error raised when trying to enforce a relation @@ -291,55 +310,55 @@ exception UniverseInconsistency let error_inconsistency () = raise UniverseInconsistency -(* enforcegeq : universe -> universe -> unit *) -(* enforcegeq u v will force u>=v if possible, will fail otherwise *) -let enforce_univ_geq u v g = +(* enforce_univ_leq : universe_level -> universe_level -> unit *) +(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) +let enforce_univ_leq u v g = let g = declare_univ u g in let g = declare_univ v g in match compare g u v with - | NGE -> + | NLE -> (match compare g v u with - | GT -> error_inconsistency() - | GE -> merge g v u - | NGE -> setgeq g u v + | LT -> error_inconsistency() + | LE -> merge g v u + | NLE -> setleq g u v | EQ -> anomaly "Univ.compare") | _ -> g -(* enforceq : universe -> universe -> unit *) -(* enforceq u v will force u=v if possible, will fail otherwise *) +(* enforc_univ_eq : universe_level -> universe_level -> unit *) +(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let g = declare_univ u g in let g = declare_univ v g in match compare g u v with | EQ -> g - | GT -> error_inconsistency() - | GE -> merge g u v - | NGE -> + | LT -> error_inconsistency() + | LE -> merge g u v + | NLE -> (match compare g v u with - | GT -> error_inconsistency() - | GE -> merge g v u - | NGE -> merge_disc g u v + | LT -> error_inconsistency() + | LE -> merge g v u + | NLE -> merge_disc g u v | EQ -> anomaly "Univ.compare") -(* enforcegt u v will force u>v if possible, will fail otherwise *) -let enforce_univ_gt u v g = +(* enforce_univ_lt u v will force u g - | GE -> setgt g u v + | LT -> g + | LE -> setlt g u v | EQ -> error_inconsistency() - | NGE -> + | NLE -> (match compare g v u with - | NGE -> setgt g u v + | NLE -> setlt g u v | _ -> error_inconsistency()) (* let enforce_univ_relation g = function | Equiv (u,v) -> enforce_univ_eq u v g - | Canonical {univ=u; gt=gt; ge=ge} -> - let g' = List.fold_right (enforce_univ_gt u) gt g in - List.fold_right (enforce_univ_geq u) ge g' + | Canonical {univ=u; lt=lt; le=le} -> + let g' = List.fold_right (enforce_univ_lt u) lt g in + List.fold_right (enforce_univ_leq u) le g' *) (* Merging 2 universe graphs *) @@ -351,14 +370,14 @@ let merge_universes sp u1 u2 = (* Constraints and sets of consrtaints. *) -type constraint_type = Gt | Geq | Eq +type constraint_type = Lt | Leq | Eq type univ_constraint = universe_level * constraint_type * universe_level let enforce_constraint cst g = match cst with - | (u,Gt,v) -> enforce_univ_gt u v g - | (u,Geq,v) -> enforce_univ_geq u v g + | (u,Lt,v) -> enforce_univ_lt u v g + | (u,Leq,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g @@ -373,25 +392,84 @@ type constraints = Constraint.t type constraint_function = universe -> universe -> constraints -> constraints -let enforce_gt u v c = Constraint.add (u,Gt,v) c +let constraint_add_leq v u c = + if v = Base then c else Constraint.add (v,Leq,u) c let enforce_geq u v c = - match u with - | Variable u -> (match v with - | Variable v -> Constraint.add (u,Geq,v) c - | Max (l1, l2) -> - let d = List.fold_right (fun v -> Constraint.add (u,Geq,v)) l1 c in - List.fold_right (fun v -> Constraint.add (u,Gt,v)) l2 d) - | Max _ -> anomaly "A universe bound can only be a variable" + match u, v with + | Atom u, Atom v -> constraint_add_leq v u c + | Atom u, Max (gel,gtl) -> + let d = List.fold_right (fun v -> constraint_add_leq v u) gel c in + List.fold_right (fun v -> Constraint.add (v,Lt,u)) gtl d + | _ -> anomaly "A universe bound can only be a variable" let enforce_eq u v c = match (u,v) with - | Variable u, Variable v -> Constraint.add (u,Eq,v) c + | Atom u, Atom v -> Constraint.add (u,Eq,v) c | _ -> anomaly "A universe comparison can only happen between variables" let merge_constraints c g = Constraint.fold enforce_constraint c g +(**********************************************************************) +(* Tools for sort-polymorphic inductive types *) + +(* Temporary inductive type levels *) + +let fresh_level = + let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n) + +let fresh_local_univ () = Atom (fresh_level ()) + +(* Miscellaneous functions to remove or test local univ assumed to + occur only in the le constraints *) + +let make_max = function + | ([u],[]) -> Atom u + | (le,lt) -> Max (le,lt) + +let remove_constraint u = function + | Atom u' as x -> if u = u' then Max ([],[]) else x + | Max (le,lt) -> make_max (list_remove u le,lt) + +let is_empty_universe = function + | Max ([],[]) -> true + | _ -> false + +let is_direct_constraint u = function + | Atom u' -> u = u' + | Max (le,lt) -> List.mem u le + +(* + Solve a system of universe constraint of the form + + u_s11, ..., u_s1p1, w1 <= u1 + ... + u_sn1, ..., u_snpn, wn <= un + +where + + - the ui (1 <= i <= n) are universe variables, + - the sjk select subsets of the ui for each equations, + - the wi are arbitrary complex universes that do not mention the ui. +*) + +let solve_constraints_system levels level_bounds = + let levels = + Array.map (function Atom u -> u | _ -> anomaly "expects Atom") levels in + let v = Array.copy level_bounds in + let nind = Array.length v in + for i=0 to nind-1 do + for j=0 to nind-1 do + if i<>j & is_direct_constraint levels.(j) v.(i) then + v.(i) <- sup v.(i) v.(j) + done; + for j=0 to nind-1 do + v.(i) <- remove_constraint levels.(j) v.(i) + done + done; + v + (* Pretty-printing *) let num_universes g = @@ -400,19 +478,19 @@ let num_universes g = let num_edges g = let reln_len = function | Equiv _ -> 1 - | Canonical {gt=gt;ge=ge} -> List.length gt + List.length ge + | Canonical {lt=lt;le=le} -> List.length lt + List.length le in UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0 let pr_arc = function - | Canonical {univ=u; gt=[]; ge=[]} -> + | Canonical {univ=u; lt=[]; le=[]} -> mt () - | Canonical {univ=u; gt=gt; ge=ge} -> + | Canonical {univ=u; lt=lt; le=le} -> pr_uni_level u ++ str " " ++ v 0 - (prlist_with_sep pr_spc (fun v -> str "> " ++ pr_uni_level v) gt ++ - (if ge <> [] & gt <> [] then spc () else mt ()) ++ - prlist_with_sep pr_spc (fun v -> str ">= " ++ pr_uni_level v) ge) ++ + (prlist_with_sep pr_spc (fun v -> str "< " ++ pr_uni_level v) lt ++ + (if lt <> [] & le <> [] then spc () else mt()) ++ + prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++ fnl () | Equiv (u,v) -> pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () @@ -426,44 +504,48 @@ let pr_universes g = let dump_universes output g = let dump_arc _ = function - | Canonical {univ=u; gt=gt; ge=ge} -> + | Canonical {univ=u; lt=lt; le=le} -> let u_str = string_of_univ_level u in List.iter (fun v -> Printf.fprintf output "%s > %s ;\n" u_str (string_of_univ_level v)) - gt; + lt; List.iter (fun v -> Printf.fprintf output "%s >= %s ;\n" u_str (string_of_univ_level v)) - ge + le | Equiv (u,v) -> Printf.fprintf output "%s = %s ;\n" (string_of_univ_level u) (string_of_univ_level v) in UniverseMap.iter dump_arc g +(* Hash-consing *) + module Huniv = Hashcons.Make( struct type t = universe type u = Names.dir_path -> Names.dir_path - let hash_aux hdir u = { u with u_mod=hdir u.u_mod } + let hash_aux hdir = function + | Base -> Base + | Level (d,n) -> Level (hdir d,n) let hash_sub hdir = function - | Variable u -> Variable (hash_aux hdir u) + | Atom u -> Atom (hash_aux hdir u) | Max (gel,gtl) -> Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl) let equal u v = match u, v with - | Variable u, Variable v -> u == v + | Atom u, Atom v -> u == v | Max (gel,gtl), Max (gel',gtl') -> - (List.for_all2 (==) gel gel') && (List.for_all2 (==) gtl gtl') + (list_for_all2eq (==) gel gel') && + (list_for_all2eq (==) gtl gtl') | _ -> false let hash = Hashtbl.hash end) let hcons1_univ u = - let _,hdir,_,_,_ = Names.hcons_names() in + let _,_,hdir,_,_,_ = Names.hcons_names() in Hashcons.simple_hcons Huniv.f hdir u - diff --git a/kernel/univ.mli b/kernel/univ.mli index e15971eb..f39f05d9 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -6,20 +6,27 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: univ.mli,v 1.21.14.1 2004/07/16 19:30:28 herbelin Exp $ i*) +(*i $Id: univ.mli 8673 2006-03-29 21:21:52Z herbelin $ i*) (* Universes. *) type universe +val base_univ : universe val prop_univ : universe val make_univ : Names.dir_path * int -> universe +val is_base : universe -> bool + (* The type of a universe *) val super : universe -> universe + (* The max of 2 universes *) val sup : universe -> universe -> universe +(* The max of an array of universes *) +val sup_array : universe array -> universe + (*s Graphs of universes. *) type universes @@ -47,13 +54,20 @@ exception UniverseInconsistency val merge_constraints : constraints -> universes -> universes +(*s Support for sort-polymorphic inductive types *) + +val fresh_local_univ : unit -> universe + +val solve_constraints_system : universe array -> universe array -> + universe array + +val is_empty_universe : universe -> bool + (*s Pretty-printing of universes. *) val pr_uni : universe -> Pp.std_ppcmds val pr_universes : universes -> Pp.std_ppcmds -val string_of_univ : universe -> string - (*s Dumping to a file *) val dump_universes : out_channel -> universes -> unit diff --git a/kernel/vconv.ml b/kernel/vconv.ml new file mode 100644 index 00000000..f038c04f --- /dev/null +++ b/kernel/vconv.ml @@ -0,0 +1,555 @@ +open Names +open Declarations +open Term +open Environ +open Conv_oracle +open Reduction +open Closure +open Vm +open Csymtable +open Univ + +let val_of_constr env c = + val_of_constr (pre_env env) c + +(* Test la structure des piles *) + +let compare_zipper z1 z2 = + match z1, z2 with + | Zapp args1, Zapp args2 -> nargs args1 = nargs args2 + | Zfix _, Zfix _ -> true + | Zswitch _, Zswitch _ -> true + | _ , _ -> false + +let rec compare_stack stk1 stk2 = + match stk1, stk2 with + | [], [] -> true + | z1::stk1, z2::stk2 -> + if compare_zipper z1 z2 then compare_stack stk1 stk2 + else false + | _, _ -> false + +(* Conversion *) +let conv_vect fconv vect1 vect2 cu = + let n = Array.length vect1 in + if n = Array.length vect2 then + let rcu = ref cu in + for i = 0 to n - 1 do + rcu := fconv vect1.(i) vect2.(i) !rcu + done; + !rcu + else raise NotConvertible + +let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) + +let rec conv_val pb k v1 v2 cu = + if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu + +and conv_whd pb k whd1 whd2 cu = + match whd1, whd2 with + | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vprod p1, Vprod p2 -> + let cu = conv_val CONV k (dom p1) (dom p2) cu in + conv_fun pb k (codom p1) (codom p2) cu + | Vfun f1, Vfun f2 -> conv_fun CONV k f1 f2 cu + | Vfix f1, Vfix f2 -> conv_fix k f1 f2 cu + | Vfix_app fa1, Vfix_app fa2 -> + let f1 = fix fa1 in + let args1 = args_of_fix fa1 in + let f2 = fix fa2 in + let args2 = args_of_fix fa2 in + conv_arguments k args1 args2 (conv_fix k f1 f2 cu) + | Vcofix cf1, Vcofix cf2 -> + conv_cofix k cf1 cf2 cu + | Vcofix_app cfa1, Vcofix_app cfa2 -> + let cf1 = cofix cfa1 in + let args1 = args_of_cofix cfa1 in + let cf2 = cofix cfa2 in + let args2 = args_of_cofix cfa2 in + conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu) + | Vconstr_const i1, Vconstr_const i2 -> + if i1 = i2 then cu else raise NotConvertible + | Vconstr_block b1, Vconstr_block b2 -> + let sz = bsize b1 in + if btag b1 = btag b2 && sz = bsize b2 then + let rcu = ref cu in + for i = 0 to sz - 1 do + rcu := conv_val CONV k (bfield b1 i) (bfield b2 i) !rcu + done; + !rcu + else raise NotConvertible + | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> + conv_atom pb k a1 stk1 a2 stk2 cu + | _, Vatom_stk(Aiddef(_,v),stk) -> + conv_whd pb k whd1 (force_whd v stk) cu + | Vatom_stk(Aiddef(_,v),stk), _ -> + conv_whd pb k (force_whd v stk) whd2 cu + | _, _ -> raise NotConvertible + +and conv_atom pb k a1 stk1 a2 stk2 cu = + match a1, a2 with + | Aind (kn1,i1), Aind(kn2,i2) -> + if i1 = i2 && mind_equiv !infos kn1 kn2 && compare_stack stk1 stk2 then + conv_stack k stk1 stk2 cu + else raise NotConvertible + | Aid ik1, Aid ik2 -> + if ik1 = ik2 && compare_stack stk1 stk2 then + conv_stack k stk1 stk2 cu + else raise NotConvertible + | Aiddef(ik1,v1), Aiddef(ik2,v2) -> + begin + try + if ik1 = ik2 && compare_stack stk1 stk2 then + conv_stack k stk1 stk2 cu + else raise NotConvertible + with NotConvertible -> + if oracle_order ik1 ik2 then + conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu + else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu + end + | Aiddef(ik1,v1), _ -> + conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu + | _, Aiddef(ik2,v2) -> + conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu + | Afix_app _, _ | _, Afix_app _ | Aswitch _, _ | _, Aswitch _ -> + Util.anomaly "Vconv.conv_atom : Vm.whd_val doesn't work" + | _, _ -> raise NotConvertible + +and conv_stack k stk1 stk2 cu = + match stk1, stk2 with + | [], [] -> cu + | Zapp args1 :: stk1, Zapp args2 :: stk2 -> + conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) + | Zfix fa1 :: stk1, Zfix fa2 :: stk2 -> + let f1 = fix fa1 in + let args1 = args_of_fix fa1 in + let f2 = fix fa2 in + let args2 = args_of_fix fa2 in + conv_stack k stk1 stk2 + (conv_arguments k args1 args2 (conv_fix k f1 f2 cu)) + | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> + if eq_tbl sw1 sw2 then + let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in + let rcu = ref (conv_val CONV k vt1 vt2 cu) in + let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in + for i = 0 to Array.length b1 - 1 do + rcu := + conv_val CONV (k + fst b1.(i)) + (snd b1.(i)) (snd b2.(i)) !rcu + done; + conv_stack k stk1 stk2 !rcu + else raise NotConvertible + | _, _ -> raise NotConvertible + +and conv_fun pb k f1 f2 cu = + if f1 == f2 then cu + else + let arity,b1,b2 = decompose_vfun2 k f1 f2 in + conv_val pb (k+arity) b1 b2 cu + +and conv_fix k f1 f2 cu = + if f1 == f2 then cu + else + if check_fix f1 f2 then + let tf1 = types_of_fix f1 in + let tf2 = types_of_fix f2 in + let cu = conv_vect (conv_val CONV k) tf1 tf2 cu in + let bf1 = bodies_of_fix k f1 in + let bf2 = bodies_of_fix k f2 in + conv_vect (conv_fun CONV (k + (fix_ndef f1))) bf1 bf2 cu + else raise NotConvertible + +and conv_cofix k cf1 cf2 cu = + if cf1 == cf2 then cu + else + if check_cofix cf1 cf2 then + let tcf1 = types_of_cofix cf1 in + let tcf2 = types_of_cofix cf2 in + let cu = conv_vect (conv_val CONV k) tcf1 tcf2 cu in + let bcf1 = bodies_of_cofix k cf1 in + let bcf2 = bodies_of_cofix k cf2 in + conv_vect (conv_val CONV (k + (cofix_ndef cf1))) bcf1 bcf2 cu + else raise NotConvertible + +and conv_arguments k args1 args2 cu = + if args1 == args2 then cu + else + let n = nargs args1 in + if n = nargs args2 then + let rcu = ref cu in + for i = 0 to n - 1 do + rcu := conv_val CONV k (arg args1 i) (arg args2 i) !rcu + done; + !rcu + else raise NotConvertible + +let rec conv_eq pb t1 t2 cu = + if t1 == t2 then cu + else + match kind_of_term t1, kind_of_term t2 with + | Rel n1, Rel n2 -> + if n1 = n2 then cu else raise NotConvertible + | Meta m1, Meta m2 -> + if m1 = m2 then cu else raise NotConvertible + | Var id1, Var id2 -> + if id1 = id2 then cu else raise NotConvertible + | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu + | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu + | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu + | Prod (_,t1,c1), Prod (_,t2,c2) -> + conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu) + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu) + | App (c1,l1), App (c2,l2) -> + conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu) + | Evar (e1,l1), Evar (e2,l2) -> + if e1 = e2 then conv_eq_vect l1 l2 cu + else raise NotConvertible + | Const c1, Const c2 -> + if c1 = c2 then cu else raise NotConvertible + | Ind c1, Ind c2 -> + if c1 = c2 then cu else raise NotConvertible + | Construct c1, Construct c2 -> + if c1 = c2 then cu else raise NotConvertible + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + let pcu = conv_eq CONV p1 p2 cu in + let ccu = conv_eq CONV c1 c2 pcu in + conv_eq_vect bl1 bl2 ccu + | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> + if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) + else raise NotConvertible + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) + else raise NotConvertible + | _ -> raise NotConvertible + +and conv_eq_vect vt1 vt2 cu = + let len = Array.length vt1 in + if len = Array.length vt2 then + let rcu = ref cu in + for i = 0 to len-1 do + rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu + done; !rcu + else raise NotConvertible + +let vconv pb env t1 t2 = + let cu = + try conv_eq pb t1 t2 Constraint.empty + with NotConvertible -> + infos := create_clos_infos betaiotazeta env; + let v1 = val_of_constr env t1 in + let v2 = val_of_constr env t2 in + let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in + cu + in cu + +let _ = Reduction.set_vm_conv vconv + +let use_vm = ref false + +let set_use_vm b = + use_vm := b; + if b then Reduction.set_default_conv vconv + else Reduction.set_default_conv Reduction.conv_cmp + +let use_vm _ = !use_vm + +(*******************************************) +(* Calcul de la forme normal d'un terme *) +(*******************************************) + +let crazy_type = mkSet + +let decompose_prod env t = + let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in + if name = Anonymous then (Name (id_of_string "x"),dom,codom) + else res + +exception Find_at of int + +(* rend le numero du constructeur correspondant au tag [tag], + [cst] = true si c'est un constructeur constant *) + +let invert_tag cst tag reloc_tbl = + try + for j = 0 to Array.length reloc_tbl - 1 do + let tagj,arity = reloc_tbl.(j) in + if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then + raise (Find_at j) + else () + done;raise Not_found + with Find_at j -> (j+1) + (* Argggg, ces constructeurs de ... qui commencent a 1*) + +(* Build the substitution that replaces Rels by the appropriate + inductives *) +let ind_subst mind mib = + let ntypes = mib.mind_ntypes in + let make_Ik k = mkInd (mind,ntypes-k-1) in + Util.list_tabulate make_Ik ntypes + +(* Instantiate inductives and parameters in constructor type + in normal form *) +let constructor_instantiate mind mib params ctyp = + let si = ind_subst mind mib in + let ctyp1 = substl si ctyp in + let nparams = Array.length params in + if nparams = 0 then ctyp1 + else + let _,ctyp2 = decompose_prod_n nparams ctyp1 in + let sp = List.rev (Array.to_list params) in substl sp ctyp2 + +let destApplication t = + try destApp t + with _ -> t,[||] + +let construct_of_constr_const env tag typ = + let cind,params = destApplication (whd_betadeltaiota env typ) in + let ind = destInd cind in + let (_,mip) = Inductive.lookup_mind_specif env ind in + let rtbl = mip.mind_reloc_tbl in + let i = invert_tag true tag rtbl in + mkApp(mkConstruct(ind,i), params) + +let find_rectype typ = + let cind,args = destApplication typ in + let ind = destInd cind in + ind, args + +let construct_of_constr_block env tag typ = + let (mind,_ as ind),allargs = find_rectype (whd_betadeltaiota env typ) in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nparams = mib.mind_nparams in + let rtbl = mip.mind_reloc_tbl in + let i = invert_tag false tag rtbl in + let params = Array.sub allargs 0 nparams in + let specif = mip.mind_nf_lc in + let ctyp = constructor_instantiate mind mib params specif.(i-1) in + (mkApp(mkConstruct(ind,i), params), ctyp) + +let constr_type_of_idkey env idkey = + match idkey with + | ConstKey cst -> + let ty = (lookup_constant cst env).const_type in + mkConst cst, ty + | VarKey id -> + let (_,_,ty) = lookup_named id env in + mkVar id, ty + | RelKey i -> + let n = (nb_rel env - i) in + let (_,_,ty) = lookup_rel n env in + mkRel n, lift n ty + +let type_of_ind env ind = + let (_,mip) = Inductive.lookup_mind_specif env ind in + mip.mind_nf_arity + +let build_branches_type (mind,_ as _ind) mib mip params dep p rtbl = + (* [build_one_branch i cty] construit le type de la ieme branche (commence + a 0) et les lambda correspondant aux realargs *) + let build_one_branch i cty = + let typi = constructor_instantiate mind mib params cty in + let decl,indapp = Term.decompose_prod typi in + let ind,cargs = find_rectype indapp in + let nparams = Array.length params in + let carity = snd (rtbl.(i)) in + let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in + let codom = + let papp = mkApp(p,crealargs) in + if dep then + let cstr = ith_constructor_of_inductive ind (i+1) in + let relargs = Array.init carity (fun i -> mkRel (carity-i)) in + let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + mkApp(papp,[|dep_cstr|]) + else papp + in + decl, codom + in Array.mapi build_one_branch mip.mind_nf_lc + +(* La fonction de normalisation *) + +let rec nf_val env v t = nf_whd env (whd_val v) t + +and nf_whd env whd typ = + match whd with + | Vsort s -> mkSort s + | Vprod p -> + let dom = nf_val env (dom p) crazy_type in + let name = Name (id_of_string "x") in + let vc = body_of_vfun (nb_rel env) (codom p) in + let codom = nf_val (push_rel (name,None,dom) env) vc crazy_type in + mkProd(name,dom,codom) + | Vfun f -> nf_fun env f typ + | Vfix f -> nf_fix env f + | Vfix_app fa -> + let f = fix fa in + let vargs = args_of_fix fa in + let fd = nf_fix env f in + let (_,i),(_,ta,_) = destFix fd in + let t = ta.(i) in + let _, args = nf_args env vargs t in + mkApp(fd,args) + | Vcofix cf -> nf_cofix env cf + | Vcofix_app cfa -> + let cf = cofix cfa in + let vargs = args_of_cofix cfa in + let cfd = nf_cofix env cf in + let i,(_,ta,_) = destCoFix cfd in + let t = ta.(i) in + let _, args = nf_args env vargs t in + mkApp(cfd,args) + | Vconstr_const n -> construct_of_constr_const env n typ + | Vconstr_block b -> + let capp,ctyp = construct_of_constr_block env (btag b) typ in + let args = nf_bargs env b ctyp in + mkApp(capp,args) + | Vatom_stk(Aid idkey, stk) -> + let c,typ = constr_type_of_idkey env idkey in + nf_stk env c typ stk + | Vatom_stk(Aiddef(idkey,v), stk) -> + nf_whd env (whd_stack v stk) typ + | Vatom_stk(Aind ind, stk) -> + nf_stk env (mkInd ind) (type_of_ind env ind) stk + | Vatom_stk(_,stk) -> assert false + +and nf_stk env c t stk = + match stk with + | [] -> c + | Zapp vargs :: stk -> + let t, args = nf_args env vargs t in + nf_stk env (mkApp(c,args)) t stk + | Zfix fa :: stk -> + let f = fix fa in + let vargs = args_of_fix fa in + let fd = nf_fix env f in + let (_,i),(_,ta,_) = destFix fd in + let tf = ta.(i) in + let typ, args = nf_args env vargs tf in + let _,_,codom = decompose_prod env typ in + nf_stk env (mkApp(mkApp(fd,args),[|c|])) (subst1 c codom) stk + | Zswitch sw :: stk -> + let (mind,_ as ind),allargs = find_rectype (whd_betadeltaiota env t) in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nparams = mib.mind_nparams in + let params,realargs = Util.array_chop nparams allargs in + (* calcul du predicat du case, + [dep] indique si c'est un case dependant *) + let dep,p = + let dep = ref false in + let rec nf_predicate env v pT = + match whd_val v, kind_of_term pT with + | Vfun f, Prod _ -> + let k = nb_rel env in + let vb = body_of_vfun k f in + let name,dom,codom = decompose_prod env pT in + let body = + nf_predicate (push_rel (name,None,dom) env) vb codom in + mkLambda(name,dom,body) + | Vfun f, _ -> + dep := true; + let k = nb_rel env in + let vb = body_of_vfun k f in + let name = Name (id_of_string "c") in + let n = mip.mind_nrealargs in + let rargs = Array.init n (fun i -> mkRel (n-i)) in + let dom = mkApp(mkApp(mkInd ind,params),rargs) in + let body = + nf_val (push_rel (name,None,dom) env) vb crazy_type in + mkLambda(name,dom,body) + | _, _ -> nf_val env v crazy_type + in + let aux = + nf_predicate env (type_of_switch sw) + (hnf_prod_applist env mip.mind_nf_arity (Array.to_list params)) in + !dep,aux in + (* Calcul du type des branches *) + let btypes = + build_branches_type ind mib mip params dep p mip.mind_reloc_tbl in + (* calcul des branches *) + let bsw = branch_of_switch (nb_rel env) sw in + let mkbranch i (n,v) = + let decl,codom = btypes.(i) in + let env = + List.fold_right + (fun (name,t) env -> push_rel (name,None,t) env) decl env in + let b = nf_val env v codom in + compose_lam decl b + in + let branchs = Array.mapi mkbranch bsw in + let tcase = + if dep then mkApp(mkApp(p, params), [|c|]) + else mkApp(p, params) + in + let ci = case_info sw in + nf_stk env (mkCase(ci, p, c, branchs)) tcase stk + +and nf_args env vargs t = + let t = ref t in + let len = nargs vargs in + let targs = + Array.init len + (fun i -> + let _,dom,codom = decompose_prod env !t in + let c = nf_val env (arg vargs i) dom in + t := subst1 c codom; c) in + !t,targs + +and nf_bargs env b t = + let t = ref t in + let len = bsize b in + let args = Array.create len crazy_type in + for i = 0 to len - 1 do + let _,dom,codom = decompose_prod env !t in + let c = nf_val env (bfield b i) dom in + args.(i) <- c; + t := subst1 c codom + done; + args +(* Array.init len + (fun i -> + let _,dom,codom = decompose_prod env !t in + let c = nf_val env (bfield b i) dom in + t := subst1 c codom; c) *) + +and nf_fun env f typ = + let k = nb_rel env in + let vb = body_of_vfun k f in + let name,dom,codom = decompose_prod env typ in + let body = nf_val (push_rel (name,None,dom) env) vb codom in + mkLambda(name,dom,body) + +and nf_fix env f = + let init = fix_init f in + let rec_args = rec_args f in + let ndef = fix_ndef f in + let vt = types_of_fix f in + let ft = Array.map (fun v -> nf_val env v crazy_type) vt in + let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in + let k = nb_rel env in + let vb = bodies_of_fix k f in + let env = push_rec_types (name,ft,ft) env in + let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in + mkFix ((rec_args,init),(name,ft,fb)) + +and nf_cofix env cf = + let init = cofix_init cf in + let ndef = cofix_ndef cf in + let vt = types_of_cofix cf in + let cft = Array.map (fun v -> nf_val env v crazy_type) vt in + let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in + let k = nb_rel env in + let vb = bodies_of_cofix k cf in + let env = push_rec_types (name,cft,cft) env in + let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in + mkCoFix (init,(name,cft,cfb)) + +let cbv_vm env c t = + let transp = transp_values () in + if not transp then set_transp_values true; + let v = val_of_constr env c in + let c = nf_val env v t in + if not transp then set_transp_values false; + c + + diff --git a/kernel/vconv.mli b/kernel/vconv.mli new file mode 100644 index 00000000..4aed5d05 --- /dev/null +++ b/kernel/vconv.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bool +val set_use_vm : bool -> unit +val vconv : conv_pb -> types conversion_function + +(***********************************************************************) +(*s Reduction functions *) +val cbv_vm : env -> constr -> types -> constr + + + + + +val nf_val : env -> values -> types -> constr + +val nf_whd : env -> Vm.whd -> types -> constr + +val nf_stk : env -> constr -> types -> Vm.stack -> constr + +val nf_args : env -> Vm.arguments -> types -> types * constr array + +val nf_bargs : env -> Vm.vblock -> types -> constr array + +val nf_fun : env -> Vm.vfun -> types -> constr + +val nf_fix : env -> Vm.vfix -> constr + +val nf_cofix : env -> Vm.vcofix -> constr + + diff --git a/kernel/vm.ml b/kernel/vm.ml new file mode 100644 index 00000000..c8be979e --- /dev/null +++ b/kernel/vm.ml @@ -0,0 +1,601 @@ +open Obj +open Names +open Term +open Conv_oracle +open Cbytecodes + + +external set_drawinstr : unit -> unit = "coq_set_drawinstr" + +(******************************************) +(* Fonctions en plus du module Obj ********) +(******************************************) + +external offset_closure : t -> int -> t = "coq_offset_closure" +external offset : t -> int = "coq_offset" +let first o = (offset_closure o (offset o)) +let last o = (field o (size o - 1)) + +let accu_tag = 0 + +(*******************************************) +(* Initalisation de la machine abstraite ***) +(*******************************************) + +external init_vm : unit -> unit = "init_coq_vm" + +let _ = init_vm () + +external transp_values : unit -> bool = "get_coq_transp_value" +external set_transp_values : bool -> unit = "coq_set_transp_value" + +(*******************************************) +(* Le code machine ************************) +(*******************************************) + +type tcode +let tcode_of_obj v = ((obj v):tcode) +let fun_code v = tcode_of_obj (field (repr v) 0) + +external mkAccuCode : int -> tcode = "coq_makeaccu" +external mkPopStopCode : int -> tcode = "coq_pushpop" +external mkAccuCond : int -> tcode = "coq_accucond" + +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 = + let len = Array.length !popstop_tbl in + if i < len then !popstop_tbl.(i) + else + begin + popstop_tbl := + Array.init (i+10) + (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); + !popstop_tbl.(i) + end + +let stop = popstop_code 0 + +(******************************************************) +(* Types de donnees abstraites et fonctions associees *) +(******************************************************) + +(* Values of the abstract machine *) +let val_of_obj v = ((obj v):values) +let crasy_val = (val_of_obj (repr 0)) + + +(* Functions *) +type vfun +(* v = [Tc | c | fv1 | ... | fvn ] *) +(* ^ *) +(* [Tc | (Restart : c) | v | a1 | ... an] *) +(* ^ *) + +(* Products *) +type vprod +(* [0 | dom : codom] *) +(* ^ *) +let dom : vprod -> values = fun p -> val_of_obj (field (repr p) 0) +let codom : vprod -> vfun = fun p -> (obj (field (repr p) 1)) + +(* Arguments *) +type arguments +(* arguments = [_ | _ | _ | a1 | ... | an] *) +(* ^ *) +let nargs : arguments -> int = fun args -> (size (repr args)) - 2 + +let unsafe_arg : arguments -> int -> values = + fun args i -> val_of_obj (field (repr args) (i+2)) + +let arg args i = + if 0 <= i && i < (nargs args) then unsafe_arg args i + else raise (Invalid_argument + ("Vm.arg size = "^(string_of_int (nargs args))^ + " acces "^(string_of_int i))) + +(* Fixpoints *) +type vfix + +(* [Tc|c0|Ti|c1|...|Ti|cn|fv1|...|fvn| [ct0|...|ctn]] *) +(* ^ *) +type vfix_block + +let fix_init : vfix -> int = fun vf -> (offset (repr vf)/2) + +let block_of_fix : vfix -> vfix_block = fun vf -> obj (first (repr vf)) + +let fix_block_type : vfix_block -> tcode array = + fun fb -> (obj (last (repr fb))) + +let fix_block_ndef : vfix_block -> int = + fun fb -> size (last (repr fb)) + +let fix_ndef vf = fix_block_ndef (block_of_fix vf) + +let unsafe_fb_code : vfix_block -> int -> tcode = + fun fb i -> tcode_of_obj (field (repr fb) (2 * i)) + +let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 + +let rec_args vf = + let fb = block_of_fix vf in + let size = fix_block_ndef fb in + Array.init size (unsafe_rec_arg fb) + +exception FALSE + +let check_fix f1 f2 = + let i1, i2 = fix_init f1, fix_init f2 in + (* Verification du point de depart *) + if i1 = i2 then + let fb1,fb2 = block_of_fix f1, block_of_fix f2 in + let n = fix_block_ndef fb1 in + (* Verification du nombre de definition *) + if n = fix_block_ndef fb2 then + (* Verification des arguments recursifs *) + try + for i = 0 to n - 1 do + if not (unsafe_rec_arg fb1 i = unsafe_rec_arg fb2 i) then + raise FALSE + done; + true + with FALSE -> false + else false + else false + +(* Partials applications of Fixpoints *) +type vfix_app +let fix : vfix_app -> vfix = + fun vfa -> ((obj (field (repr vfa) 1)):vfix) +let args_of_fix : vfix_app -> arguments = + fun vfa -> ((magic vfa) : arguments) + +(* CoFixpoints *) +type vcofix +type vcofix_block +let cofix_init : vcofix -> int = fun vcf -> (offset (repr vcf)/2) + +let block_of_cofix : vcofix -> vcofix_block = fun vcf -> obj (first (repr vcf)) + +let cofix_block_ndef : vcofix_block -> int = + fun fb -> size (last (repr fb)) + +let cofix_ndef vcf= cofix_block_ndef (block_of_cofix vcf) + +let cofix_block_type : vcofix_block -> tcode array = + fun cfb -> (obj (last (repr cfb))) + +let check_cofix cf1 cf2 = + cofix_init cf1 = cofix_init cf2 && + cofix_ndef cf1 = cofix_ndef cf2 + +let cofix_arity c = int_tcode c 1 + +let unsafe_cfb_code : vcofix_block -> int -> tcode = + fun cfb i -> tcode_of_obj (field (repr cfb) (2 * i)) + +(* Partials applications of CoFixpoints *) +type vcofix_app +let cofix : vcofix_app -> vcofix = + fun vcfa -> ((obj (field (repr vcfa) 1)):vcofix) +let args_of_cofix : vcofix_app -> arguments = + fun vcfa -> ((magic vcfa) : arguments) + +(* Blocks *) +type vblock (* la representation Ocaml *) +let btag : vblock -> int = fun b -> tag (repr b) +let bsize : vblock -> int = fun b -> size (repr b) +let bfield b i = + if 0 <= i && i < (bsize b) then + val_of_obj (field (repr b) i) + else raise (Invalid_argument "Vm.bfield") + +(* Accumulators and atoms *) + +type accumulator +(* [Ta | accumulate | at | a1 | ... | an ] *) + +type inv_rel_key = int + +type id_key = inv_rel_key tableKey + +type vstack = values array + +type vm_env + +type vswitch = { + sw_type_code : tcode; + sw_code : tcode; + sw_annot : annot_switch; + sw_stk : vstack; + sw_env : vm_env + } + +(* Ne pas changer ce type sans modifier le code C *) +type atom = + | Aid of id_key + | Aiddef of id_key * values + | Aind of inductive + | Afix_app of accumulator * vfix_app + | Aswitch of accumulator * vswitch + +let atom_of_accu : accumulator -> atom = + fun a -> ((obj (field (repr a) 1)) : atom) + +let args_of_accu : accumulator -> arguments = + fun a -> ((magic a) : arguments) + +let nargs_of_accu a = nargs (args_of_accu a) + +(* Les zippers *) + +type zipper = + | Zapp of arguments + | Zfix of vfix_app + | Zswitch of vswitch + +type stack = zipper list + +type whd = + | Vsort of sorts + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix + | Vfix_app of vfix_app + | Vcofix of vcofix + | Vcofix_app of vcofix_app + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack +(* Les atomes sont forcement Aid Aiddef Aind *) + +(**********************************************) +(* Constructeurs ******************************) +(**********************************************) +(* obj_of_atom : atom -> t *) +let obj_of_atom : atom -> t = + fun a -> + let res = Obj.new_block accu_tag 2 in + set_field res 0 (repr accumulate); + set_field res 1 (repr a); + res + +(* obj_of_str_const : structured_constant -> t *) +let rec obj_of_str_const str = + match str with + | Const_sorts s -> repr (Vsort s) + | Const_ind ind -> obj_of_atom (Aind ind) + | Const_b0 tag -> repr tag + | Const_bn(tag, args) -> + let len = Array.length args in + let res = new_block tag len in + for i = 0 to len - 1 do + set_field res i (obj_of_str_const args.(i)) + done; + res + +let val_of_obj o = ((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 idkey_tbl = Hashtbl.create 31 + +let val_of_idkey key = + try Hashtbl.find idkey_tbl key + with Not_found -> + let v = val_of_atom (Aid key) in + Hashtbl.add idkey_tbl key v; + v + +let val_of_rel k = val_of_idkey (RelKey k) +let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v)) + +let val_of_named id = val_of_idkey (VarKey id) +let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v)) + +let val_of_constant c = val_of_idkey (ConstKey c) +let val_of_constant_def n c v = + let res = Obj.new_block accu_tag 2 in + set_field res 0 (repr (mkAccuCond n)); + set_field res 1 (repr (Aiddef(ConstKey c, v))); + val_of_obj res + + + +(*************************************************) +(* Destructors ***********************************) +(*************************************************) + + +let rec whd_accu a stk = + let stk = + if nargs_of_accu a = 0 then stk + else Zapp (args_of_accu a) :: stk in + let at = atom_of_accu a in + match at with + | Aid _ | Aiddef _ | Aind _ -> Vatom_stk(at, stk) + | Afix_app(a,fa) -> whd_accu a (Zfix fa :: stk) + | Aswitch(a,sw) -> whd_accu a (Zswitch sw :: stk) + +external kind_of_closure : t -> int = "coq_kind_of_closure" + +let whd_val : values -> whd = + fun v -> + let o = repr v in + if is_int o then Vconstr_const (obj o) + else + let tag = tag o in + if tag = accu_tag then + if is_accumulate (fun_code o) then whd_accu (obj o) [] + else + if size o = 1 then Vsort(obj (field o 0)) + else Vprod(obj o) + else + if tag = closure_tag || tag = infix_tag then + match kind_of_closure o with + | 0 -> Vfun(obj o) + | 1 -> Vfix(obj o) + | 2 -> Vfix_app(obj o) + | 3 -> Vcofix(obj o) + | 4 -> Vcofix_app(obj o) + | 5 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) + | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work" + else Vconstr_block(obj o) + + + +(************************************************) +(* La machine abstraite *************************) +(************************************************) + + +(* gestion de la pile *) +external push_ra : tcode -> unit = "coq_push_ra" +external push_val : values -> unit = "coq_push_val" +external push_arguments : arguments -> unit = "coq_push_arguments" +external push_vstack : vstack -> unit = "coq_push_vstack" + + +(* interpreteur *) +external interprete : tcode -> values -> vm_env -> int -> values = + "coq_interprete_ml" + +let apply_arguments vf vargs = + let n = nargs vargs in + if n = 0 then vf + else + begin + push_ra stop; + push_arguments vargs; + interprete (fun_code vf) vf (magic vf) (n - 1) + end + +let apply_vstack vf vstk = + let n = Array.length vstk in + if n = 0 then vf + else + begin + push_ra stop; + push_vstack vstk; + interprete (fun_code vf) vf (magic vf) (n - 1) + end + +let apply_fix_app vfa arg = + let vf = fix vfa in + let vargs = args_of_fix vfa in + push_ra stop; + push_val arg; + push_arguments vargs; + interprete (fun_code vf) (magic vf) (magic vf) (nargs vargs) + +external set_forcable : unit -> unit = "coq_set_forcable" +let force_cofix v = + match whd_val v with + | Vcofix _ | Vcofix_app _ -> + push_ra stop; + set_forcable (); + interprete (fun_code v) (magic v) (magic v) 0 + | _ -> v + +let apply_switch sw arg = + let arg = force_cofix arg in + let tc = sw.sw_annot.tailcall in + if tc then + (push_ra stop;push_vstack sw.sw_stk) + else + (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); + interprete sw.sw_code arg sw.sw_env 0 + +let is_accu v = + is_block (repr v) && tag (repr v) = accu_tag && + fun_code v == accumulate + +let rec whd_stack v stk = + match stk with + | [] -> whd_val v + | Zapp a :: stkt -> whd_stack (apply_arguments v a) stkt + | Zfix fa :: stkt -> + if is_accu v then whd_accu (magic v) stk + else whd_stack (apply_fix_app fa v) stkt + | Zswitch sw :: stkt -> + if is_accu v then whd_accu (magic v) stk + else whd_stack (apply_switch sw v) stkt + +let rec force_whd v stk = + match whd_stack v stk with + | Vatom_stk(Aiddef(_,v),stk) -> force_whd v stk + | res -> res + + + +(* Function *) +external closure_arity : vfun -> int = "coq_closure_arity" + +(* [apply_rel v k arity] applique la valeurs [v] aux arguments + [k],[k+1], ... , [k+arity-1] *) +let mkrel_vstack k arity = + let max = k + arity - 1 in + Array.init arity (fun i -> val_of_rel (max - i)) + +let body_of_vfun k vf = + let vargs = mkrel_vstack k 1 in + apply_vstack (magic 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_vstack (magic vf1) vargs in + let v2 = apply_vstack (magic vf2) vargs in + arity, v1, v2 + + +(* Fix *) +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 jump_grabrec c = offset_tcode c 2 +let jump_grabrecrestart c = offset_tcode c 3 + +let bodies_of_fix k vf = + let fb = block_of_fix vf in + let ndef = fix_block_ndef fb in + (* Construction de l' environnement des corps des points fixes *) + let e = dup (repr fb) in + for i = 0 to ndef - 1 do + set_field e (2 * i) (repr (relaccu_code (k + i))) + done; + let fix_body i = + let c = jump_grabrec (unsafe_fb_code fb i) in + let res = Obj.new_block closure_tag 2 in + set_field res 0 (repr c); + set_field res 1 (offset_closure e (2*i)); + ((obj res) : vfun) + in Array.init ndef fix_body + +let types_of_fix vf = + let fb = block_of_fix vf in + let type_code = fix_block_type fb in + let type_val c = interprete c crasy_val (magic fb) 0 in + Array.map type_val type_code + + +(* CoFix *) +let jump_cograb c = offset_tcode c 2 +let jump_cograbrestart c = offset_tcode c 3 + +let bodies_of_cofix k vcf = + let cfb = block_of_cofix vcf in + let ndef = cofix_block_ndef cfb in + (* Construction de l' environnement des corps des cofix *) + let e = dup (repr cfb) in + for i = 0 to ndef - 1 do + set_field e (2 * i) (repr (relaccu_code (k + i))) + done; + let cofix_body i = + let c = unsafe_cfb_code cfb i in + let arity = int_tcode c 1 in + if arity = 0 then + begin + push_ra stop; + interprete (jump_cograbrestart c) crasy_val + (obj (offset_closure e (2*i))) 0 + end + else + let res = Obj.new_block closure_tag 2 in + set_field res 0 (repr (jump_cograb c)); + set_field res 1 (offset_closure e (2*i)); + ((obj res) : values) + in Array.init ndef cofix_body + +let types_of_cofix vcf = + let cfb = block_of_cofix vcf in + let type_code = cofix_block_type cfb in + let type_val c = interprete c crasy_val (magic cfb) 0 in + Array.map type_val type_code + +(* Switch *) + +let eq_tbl sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl + +let case_info sw = sw.sw_annot.ci + +let type_of_switch sw = + push_vstack sw.sw_stk; + interprete sw.sw_type_code crasy_val sw.sw_env 0 + +let branch_arg k (tag,arity) = + if arity = 0 then ((magic tag):values) + else + let b = new_block tag arity in + for i = 0 to arity - 1 do + set_field b i (repr (val_of_rel (k+i))) + done; + val_of_obj b + + +let branch_of_switch k sw = + let eval_branch (_,arity as ta) = + let arg = branch_arg k ta in + let v = apply_switch sw arg in + (arity, v) + in + Array.map eval_branch sw.sw_annot.rtbl + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/kernel/vm.mli b/kernel/vm.mli new file mode 100644 index 00000000..b5fd9b9d --- /dev/null +++ b/kernel/vm.mli @@ -0,0 +1,109 @@ +open Names +open Term +open Cbytecodes +open Cemitcodes + + +val set_drawinstr : unit -> unit + +val transp_values : unit -> bool +val set_transp_values : bool -> unit +(* le code machine *) +type tcode + +(* Les valeurs ***********) + +type accumulator +type vprod +type vfun +type vfix +type vfix_app +type vcofix +type vcofix_app +type vblock +type vswitch +type arguments + +type zipper = + | Zapp of arguments + | Zfix of vfix_app + | Zswitch of vswitch + +type stack = zipper list + + +type atom = + | Aid of id_key + | Aiddef of id_key * values + | Aind of inductive + | Afix_app of accumulator * vfix_app + | Aswitch of accumulator * vswitch + +type whd = + | Vsort of sorts + | Vprod of vprod + | Vfun of vfun + | Vfix of vfix + | Vfix_app of vfix_app + | Vcofix of vcofix + | Vcofix_app of vcofix_app + | Vconstr_const of int + | Vconstr_block of vblock + | Vatom_stk of atom * stack + +(* Constructors *) +val val_of_str_const : structured_constant -> values + +val val_of_rel : int -> values +val val_of_rel_def : int -> values -> values + +val val_of_named : identifier -> values +val val_of_named_def : identifier -> values -> values + +val val_of_constant : constant -> values +val val_of_constant_def : int -> constant -> values -> values + +(* Destructors *) +val whd_val : values -> whd + +(* 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 fix : vfix_app -> vfix +val args_of_fix : vfix_app -> arguments +val fix_init : vfix -> int +val fix_ndef : vfix -> int +val rec_args : vfix -> int array +val check_fix : vfix -> vfix -> bool +val bodies_of_fix : int -> vfix -> vfun array +val types_of_fix : vfix -> values array +(* CoFix *) +val cofix : vcofix_app -> vcofix +val args_of_cofix : vcofix_app -> arguments +val cofix_init : vcofix -> int +val cofix_ndef : vcofix -> int +val check_cofix : vcofix -> vcofix -> bool +val bodies_of_cofix : int -> vcofix -> values array +val types_of_cofix : vcofix -> values array +(* Block *) +val btag : vblock -> int +val bsize : vblock -> int +val bfield : vblock -> int -> values +(* Switch *) +val eq_tbl : vswitch -> vswitch -> bool +val case_info : vswitch -> case_info +val type_of_switch : vswitch -> values +val branch_of_switch : int -> vswitch -> (int * values) array +(* Arguments *) +val nargs : arguments -> int +val arg : arguments -> int -> values + +(* Evaluation *) +val whd_stack : values -> stack -> whd +val force_whd : values -> stack -> whd + + -- cgit v1.2.3