diff options
Diffstat (limited to 'kernel')
101 files changed, 6372 insertions, 5361 deletions
diff --git a/kernel/.merlin.in b/kernel/.merlin.in index 912ff61496..29da7d2cf6 100644 --- a/kernel/.merlin.in +++ b/kernel/.merlin.in @@ -1,4 +1,4 @@ -FLG -rectypes -thread -safe-string -w +a-4-44-50 +FLG -rectypes -thread -safe-string -w +a-4-44 S ../clib B ../clib diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index be2b05da8d..0865487c98 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -36,20 +36,15 @@ void init_arity () { 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[APPLY3]=arity[APPLY4]=arity[RESTART]=arity[OFFSETCLOSUREM2]= arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]= arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]= arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= - arity[ADDINT31]=arity[ADDCINT31]=arity[ADDCARRYCINT31]= - arity[SUBINT31]=arity[SUBCINT31]=arity[SUBCARRYCINT31]= - arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]= - arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]= - arity[HEAD0INT31]=arity[TAIL0INT31]= - arity[COMPINT31]=arity[DECOMPINT31]= - arity[ORINT31]=arity[ANDINT31]=arity[XORINT31]=0; + arity[ADDINT63]=arity[SUBINT63]=arity[LTINT63]=arity[LEINT63]= + arity[ISINT]=arity[AREINT2]=0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= @@ -58,10 +53,20 @@ void init_arity () { arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ISCONST]=arity[ENSURESTACKCAPACITY]=1; + arity[BRANCH]=arity[ENSURESTACKCAPACITY]= + arity[CHECKADDINT63]=arity[CHECKADDCINT63]=arity[CHECKADDCARRYCINT63]= + arity[CHECKSUBINT63]=arity[CHECKSUBCINT63]=arity[CHECKSUBCARRYCINT63]= + arity[CHECKMULINT63]=arity[CHECKMULCINT63]= + arity[CHECKDIVINT63]=arity[CHECKMODINT63]=arity[CHECKDIVEUCLINT63]= + arity[CHECKDIV21INT63]= + arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= + arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= + arity[CHECKLSLINT63CONST1]=arity[CHECKLSRINT63CONST1]= + arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= + arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[ARECONST]=arity[PROJ]=2; + arity[PROJ]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 638d6b5ab5..5a233e6178 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -29,6 +29,7 @@ void init_arity(); value coq_tcode_of_code(value code); value coq_makeaccu (value i); value coq_pushpop (value i); +value coq_accucond (value i); value coq_is_accumulate_code(value code); #endif /* _COQ_FIX_CODE_ */ diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h deleted file mode 100644 index d92e85fdf8..0000000000 --- a/kernel/byterun/coq_instruct.h +++ /dev/null @@ -1,61 +0,0 @@ -/***********************************************************************/ -/* */ -/* Coq Compiler */ -/* */ -/* Benjamin Gregoire, projets Logical and Cristal */ -/* INRIA Rocquencourt */ -/* */ -/* */ -/***********************************************************************/ - -#ifndef _COQ_INSTRUCT_ -#define _COQ_INSTRUCT_ - -/* Nota: this list of instructions is parsed to produce derived files */ -/* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase */ -/* and alone on lines starting by two spaces. */ -/* If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c */ -/* with the arity of the instruction and maybe coq_tcode_of_code. */ - -enum instructions { - ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, - PUSH, - PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, PUSHACC4, - PUSHACC5, PUSHACC6, PUSHACC7, PUSHACC, - POP, - ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, - PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, - PUSH_RETADDR, - APPLY, APPLY1, APPLY2, APPLY3, - APPTERM, APPTERM1, APPTERM2, APPTERM3, - RETURN, RESTART, GRAB, GRABREC, - CLOSURE, CLOSUREREC, CLOSURECOFIX, - OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, - PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, PUSHOFFSETCLOSURE2, - PUSHOFFSETCLOSURE, - GETGLOBAL, PUSHGETGLOBAL, - MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEBLOCK4, - SWITCH, PUSHFIELDS, - GETFIELD0, GETFIELD1, GETFIELD, - SETFIELD0, SETFIELD1, SETFIELD, - PROJ, - ENSURESTACKCAPACITY, - CONST0, CONST1, CONST2, CONST3, CONSTINT, - PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, - ACCUMULATE, - MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, -/* spiwack: */ - BRANCH, - ADDINT31, ADDCINT31, ADDCARRYCINT31, - SUBINT31, SUBCINT31, SUBCARRYCINT31, - MULCINT31, MULINT31, DIV21INT31, DIVINT31, - ADDMULDIVINT31, COMPAREINT31, - HEAD0INT31, TAIL0INT31, - ISCONST, ARECONST, - COMPINT31, DECOMPINT31, - ORINT31, ANDINT31, XORINT31, -/* /spiwack */ - STOP -}; - -#endif /* _COQ_INSTRUCT_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a944dbb06c..d2c88bffcc 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -23,6 +23,12 @@ #include "coq_memory.h" #include "coq_values.h" +#ifdef ARCH_SIXTYFOUR +#include "coq_uint63_native.h" +#else +#include "coq_uint63_emul.h" +#endif + /* spiwack: I append here a few macros for value/number manipulation */ #define uint32_of_value(val) (((uint32_t)(val)) >> 1) #define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) @@ -155,6 +161,38 @@ if (sp - num_args < coq_stack_threshold) { \ #endif #endif +#define CheckInt1() do{ \ + if (Is_uint63(accu)) pc++; \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ + goto apply1; \ + } \ + }while(0) + +#define CheckInt2() do{ \ + if (Is_uint63(accu) && Is_uint63(sp[0])) pc++; \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ + goto apply2; \ + } \ + }while(0) + + + +#define CheckInt3() do{ \ + if (Is_uint63(accu) && Is_uint63(sp[0]) && Is_uint63(sp[1]) ) pc++; \ + else{ \ + *--sp=accu; \ + accu = Field(coq_global_data, *pc++); \ + goto apply3; \ + } \ + }while(0) + +#define AllocCarry(cond) Alloc_small(accu, 1, (cond)? coq_tag_C1 : coq_tag_C0) +#define AllocPair() Alloc_small(accu, 2, coq_tag_pair) + /* For signal handling, we hijack some code from the caml runtime */ extern intnat caml_signals_are_pending; @@ -372,8 +410,10 @@ value coq_interprete goto check_stack; } Instruct(APPLY1) { - value arg1 = sp[0]; + value arg1; + apply1: print_instr("APPLY1"); + arg1 = sp[0]; sp -= 3; sp[0] = arg1; sp[1] = (value)pc; @@ -388,10 +428,14 @@ value coq_interprete coq_extra_args = 0; goto check_stack; } + Instruct(APPLY2) { - value arg1 = sp[0]; - value arg2 = sp[1]; + value arg1; + value arg2; + apply2: print_instr("APPLY2"); + arg1 = sp[0]; + arg2 = sp[1]; sp -= 3; sp[0] = arg1; sp[1] = arg2; @@ -403,11 +447,16 @@ value coq_interprete coq_extra_args = 1; goto check_stack; } + Instruct(APPLY3) { - value arg1 = sp[0]; - value arg2 = sp[1]; - value arg3 = sp[2]; + value arg1; + value arg2; + value arg3; + apply3: print_instr("APPLY3"); + arg1 = sp[0]; + arg2 = sp[1]; + arg3 = sp[2]; sp -= 3; sp[0] = arg1; sp[1] = arg2; @@ -420,7 +469,28 @@ value coq_interprete coq_extra_args = 2; goto check_stack; } - /* Stack checks */ + + Instruct(APPLY4) { + value arg1 = sp[0]; + value arg2 = sp[1]; + value arg3 = sp[2]; + value arg4 = sp[3]; + print_instr("APPLY4"); + sp -= 3; + sp[0] = arg1; + sp[1] = arg2; + sp[2] = arg3; + sp[3] = arg4; + sp[4] = (value)pc; + sp[5] = coq_env; + sp[6] = Val_long(coq_extra_args); + pc = Code_val(accu); + coq_env = accu; + coq_extra_args = 3; + goto check_stack; + } + + /* Stack checks */ check_stack: print_instr("check_stack"); @@ -1127,7 +1197,6 @@ value coq_interprete Next; } - /* spiwack: code for interpreting compiled integers */ Instruct(BRANCH) { /* unconditional branching */ print_instr("BRANCH"); @@ -1136,338 +1205,339 @@ value coq_interprete Next; } - Instruct(ADDINT31) { + Instruct(CHECKADDINT63){ + print_instr("CHECKADDINT63"); + CheckInt2(); + } + Instruct(ADDINT63) { /* Adds the integer in the accumulator with the one ontop of the stack (which is poped)*/ - print_instr("ADDINT31"); - accu = - (value)((uint32_t) accu + (uint32_t) *sp++ - 1); - /* nota,unlike CaML we don't want - to have a different behavior depending on the - architecture. Thus we cast the operand to uint32 */ + print_instr("ADDINT63"); + accu = uint63_add(accu, *sp++); Next; } - Instruct (ADDCINT31) { - print_instr("ADDCINT31"); + Instruct (CHECKADDCINT63) { + print_instr("CHECKADDCINT63"); + CheckInt2(); /* returns the sum with a carry */ - uint32_t s; - s = (uint32_t)accu + (uint32_t)*sp++ - 1; - if( (uint32_t)s < (uint32_t)accu ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value s; + s = uint63_add(accu, *sp++); + AllocCarry(uint63_lt(s,accu)); + Field(accu, 0) = s; Next; } - Instruct (ADDCARRYCINT31) { - print_instr("ADDCARRYCINT31"); + Instruct (CHECKADDCARRYCINT63) { + print_instr("ADDCARRYCINT63"); + CheckInt2(); /* returns the sum plus one with a carry */ - uint32_t s; - s = (uint32_t)accu + (uint32_t)*sp++ + 1; - if( (uint32_t)s <= (uint32_t)accu ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value s; + s = uint63_addcarry(accu, *sp++); + AllocCarry(uint63_leq(s, accu)); + Field(accu, 0) = s; Next; } - Instruct (SUBINT31) { - print_instr("SUBINT31"); + Instruct (CHECKSUBINT63) { + print_instr("CHECKSUBINT63"); + CheckInt2(); + } + Instruct (SUBINT63) { + print_instr("SUBINT63"); /* returns the subtraction */ - accu = - (value)((uint32_t) accu - (uint32_t) *sp++ + 1); + accu = uint63_sub(accu, *sp++); Next; } - Instruct (SUBCINT31) { - print_instr("SUBCINT31"); + Instruct (CHECKSUBCINT63) { + print_instr("SUBCINT63"); + CheckInt2(); /* returns the subtraction with a carry */ - uint32_t b; - uint32_t s; - b = (uint32_t)*sp++; - s = (uint32_t)accu - b + 1; - if( (uint32_t)accu < b ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value b; + value s; + b = *sp++; + s = uint63_sub(accu,b); + AllocCarry(uint63_lt(accu,b)); + Field(accu, 0) = s; Next; } - Instruct (SUBCARRYCINT31) { - print_instr("SUBCARRYCINT31"); + Instruct (CHECKSUBCARRYCINT63) { + print_instr("SUBCARRYCINT63"); + CheckInt2(); /* returns the subtraction minus one with a carry */ - uint32_t b; - uint32_t s; - b = (uint32_t)*sp++; - s = (value)((uint32_t)accu - b - 1); - if( (uint32_t)accu <= b ) { - /* carry */ - Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ - } - else { - /*no carry */ - Alloc_small(accu, 1, 1); - } - Field(accu, 0)=(value)s; + value b; + value s; + b = *sp++; + s = uint63_subcarry(accu,b); + AllocCarry(uint63_leq(accu,b)); + Field(accu, 0) = s; Next; } - Instruct (MULINT31) { + Instruct (CHECKMULINT63) { + print_instr("MULINT63"); + CheckInt2(); /* returns the multiplication */ - print_instr("MULINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) * (uint32_of_value(*sp++))); + accu = uint63_mul(accu,*sp++); Next; } - Instruct (MULCINT31) { - /*returns the multiplication on a double size word - (special case for 0) */ - print_instr("MULCINT31"); - uint64_t p; + Instruct (CHECKMULCINT63) { + /*returns the multiplication on a pair */ + print_instr("MULCINT63"); + CheckInt2(); /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - p = UI64_of_value (accu) * UI64_of_uint32 ((*sp++)^1); - if (p == 0) { - accu = (value)1; + /* TODO: implement + p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); + AllocPair(); */ + /* Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; */ /*higher part*/ + /* Field(accu, 1) = (value)(I64_to_int32(p)|1); */ /*lower part*/ + value x = accu; + AllocPair(); + Field(accu, 1) = uint63_mulc(x, *sp++, &Field(accu, 0)); + Next; + } + + Instruct(CHECKDIVINT63) { + print_instr("CHEKDIVINT63"); + CheckInt2(); + /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag + since it probably only concerns negative number. + needs to be checked at this point */ + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { + accu = divisor; } else { - /* the output type is supposed to have a constant constructor - and a non-constant constructor (in that order), the tag - of the non-constant constructor is then 1 */ - Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - /*unsigned shift*/ - Field(accu, 0) = (value)((p >> 31)|1) ; /*higher part*/ - Field(accu, 1) = (value)((uint32_t)p|1); /*lower part*/ - } + accu = uint63_div(accu, divisor); + } Next; } - Instruct (DIV21INT31) { - print_instr("DIV21INT31"); - /* spiwack: takes three int31 (the two first ones represent an - int62) and performs the euclidian division of the - int62 by the int31 */ - uint64_t bigint; - bigint = UI64_of_value(accu); - bigint = (bigint << 31) | UI64_of_value(*sp++); - uint64_t divisor; - divisor = UI64_of_value(*sp++); - Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - if (divisor == 0) { - Field(accu, 0) = 1; /* 2*0+1 */ - Field(accu, 1) = 1; /* 2*0+1 */ + Instruct(CHECKMODINT63) { + print_instr("CHEKMODINT63"); + CheckInt2(); + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { + accu = divisor; } - else { - uint64_t quo, mod; - quo = bigint / divisor; - mod = bigint % divisor; - Field(accu, 0) = value_of_uint32((uint32_t)(quo)); - Field(accu, 1) = value_of_uint32((uint32_t)(mod)); + else { + accu = uint63_mod(accu,divisor); } Next; } - Instruct (DIVINT31) { - print_instr("DIVINT31"); + Instruct (CHECKDIVEUCLINT63) { + print_instr("DIVEUCLINT63"); + CheckInt2(); /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ - uint32_t divisor; - divisor = uint32_of_value(*sp++); - if (divisor == 0) { + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - Field(accu, 0) = 1; /* 2*0+1 */ - Field(accu, 1) = 1; /* 2*0+1 */ + Field(accu, 0) = divisor; + Field(accu, 1) = divisor; } else { - uint32_t modulus; - modulus = uint32_of_value(accu); + value modulus; + modulus = accu; Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - Field(accu, 0) = value_of_uint32(modulus/divisor); - Field(accu, 1) = value_of_uint32(modulus%divisor); + Field(accu, 0) = uint63_div(modulus,divisor); + Field(accu, 1) = uint63_mod(modulus,divisor); } Next; } - Instruct (ADDMULDIVINT31) { - print_instr("ADDMULDIVINT31"); - /* higher level shift (does shifts and cycles and such) */ - uint32_t shiftby; - shiftby = uint32_of_value(accu); - if (shiftby > 31) { - if (shiftby < 62) { - sp++; - accu = (value)(((((uint32_t)*sp++)^1) << (shiftby - 31)) | 1); - } - else { - sp+=2; - accu = (value)(1); - } + Instruct (CHECKDIV21INT63) { + print_instr("DIV21INT63"); + CheckInt3(); + /* spiwack: takes three int31 (the two first ones represent an + int62) and performs the euclidian division of the + int62 by the int31 */ + /* TODO: implement this + bigint = UI64_of_value(accu); + bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); + uint64 divisor; + divisor = UI64_of_value(*sp++); + Alloc_small(accu, 2, 1); */ /* ( _ , arity, tag ) */ + /* if (I64_is_zero (divisor)) { + Field(accu, 0) = 1; */ /* 2*0+1 */ + /* Field(accu, 1) = 1; */ /* 2*0+1 */ + /* } + else { + uint64 quo, mod; + I64_udivmod(bigint, divisor, &quo, &mod); + Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); + Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); + } */ + value bigint; /* TODO: fix */ + bigint = *sp++; /* TODO: take accu into account */ + value divisor; + divisor = *sp++; + if (uint63_eq0(divisor)) { + Alloc_small(accu, 2, 1); + Field(accu, 0) = divisor; + Field(accu, 1) = divisor; } - else{ - /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ - accu = (value)((((uint32_t)*sp++)^1) << shiftby); - /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ - accu = (value)((accu | (((uint32_t)(*sp++)) >> (31-shiftby)))|1); + else { + value quo, mod; + mod = uint63_div21(accu, bigint, divisor, &quo); + Alloc_small(accu, 2, 1); + Field(accu, 0) = quo; + Field(accu, 1) = mod; } Next; } - Instruct (COMPAREINT31) { - /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ - /* assumes Inductive _ : _ := Eq | Lt | Gt */ - print_instr("COMPAREINT31"); - if ((uint32_t)accu == (uint32_t)*sp) { - accu = 1; /* 2*0+1 */ - sp++; - } - else{if ((uint32_t)accu < (uint32_t)(*sp++)) { - accu = 3; /* 2*1+1 */ - } - else{ - accu = 5; /* 2*2+1 */ - }} + Instruct(CHECKLXORINT63) { + print_instr("CHECKLXORINT63"); + CheckInt2(); + accu = uint63_lxor(accu,*sp++); Next; } - - Instruct (HEAD0INT31) { - int r = 0; - uint32_t x; - print_instr("HEAD0INT31"); - x = (uint32_t) accu; - if (!(x & 0xFFFF0000)) { x <<= 16; r += 16; } - if (!(x & 0xFF000000)) { x <<= 8; r += 8; } - if (!(x & 0xF0000000)) { x <<= 4; r += 4; } - if (!(x & 0xC0000000)) { x <<= 2; r += 2; } - if (!(x & 0x80000000)) { x <<=1; r += 1; } - if (!(x & 0x80000000)) { r += 1; } - accu = value_of_uint32(r); + + Instruct(CHECKLORINT63) { + print_instr("CHECKLORINT63"); + CheckInt2(); + accu = uint63_lor(accu,*sp++); Next; } - - Instruct (TAIL0INT31) { - int r = 0; - uint32_t x; - print_instr("TAIL0INT31"); - x = (((uint32_t) accu >> 1) | 0x80000000); - if (!(x & 0xFFFF)) { x >>= 16; r += 16; } - if (!(x & 0x00FF)) { x >>= 8; r += 8; } - if (!(x & 0x000F)) { x >>= 4; r += 4; } - if (!(x & 0x0003)) { x >>= 2; r += 2; } - if (!(x & 0x0001)) { x >>=1; r += 1; } - if (!(x & 0x0001)) { r += 1; } - accu = value_of_uint32(r); + + Instruct(CHECKLANDINT63) { + print_instr("CHECKLANDINT63"); + CheckInt2(); + accu = uint63_land(accu,*sp++); Next; } - Instruct (ISCONST) { - /* Branches if the accu does not contain a constant - (i.e., a non-block value) */ - print_instr("ISCONST"); - if ((accu & 1) == 0) /* last bit is 0 -> it is a block */ - pc += *pc; - else - pc++; + Instruct(CHECKLSLINT63) { + print_instr("CHECKLSLINT63"); + CheckInt2(); + value p = *sp++; + accu = uint63_lsl(accu,p); Next; + } + Instruct(CHECKLSRINT63) { + print_instr("CHECKLSRINT63"); + CheckInt2(); + value p = *sp++; + accu = uint63_lsr(accu,p); + Next; } - Instruct (ARECONST) { - /* Branches if the n first values on the stack are not - all constansts */ - print_instr("ARECONST"); - int i, n, ok; - ok = 1; - n = *pc++; - for(i=0; i < n; i++) { - if ((sp[i] & 1) == 0) { - ok = 0; - break; - } + Instruct(CHECKLSLINT63CONST1) { + print_instr("CHECKLSLINT63CONST1"); + if (Is_uint63(accu)) { + pc++; + accu = uint63_lsl1(accu); + Next; + } else { + *--sp = uint63_one(); + *--sp = accu; + accu = Field(coq_global_data, *pc++); + goto apply2; } - if(ok) pc++; else pc += *pc; + } + + Instruct(CHECKLSRINT63CONST1) { + print_instr("CHECKLSRINT63CONST1"); + if (Is_uint63(accu)) { + pc++; + accu = uint63_lsr1(accu); + Next; + } else { + *--sp = uint63_one(); + *--sp = accu; + accu = Field(coq_global_data, *pc++); + goto apply2; + } + } + + Instruct (CHECKADDMULDIVINT63) { + print_instr("CHECKADDMULDIVINT63"); + CheckInt3(); + value x; + value y; + x = *sp++; + y = *sp++; + accu = uint63_addmuldiv(accu,x,y); Next; } - Instruct (COMPINT31) { - /* makes an 31-bit integer out of the accumulator and - the 30 first values of the stack - and put it in the accumulator (the accumulator then the - topmost get to be the heavier bits) */ - print_instr("COMPINT31"); - int i; - /*accu=accu or accu = (value)((unsigned long)1-accu) if bool - is used for the bits */ - for(i=0; i < 30; i++) { - accu = (value) ((((uint32_t)accu-1) << 1) | *sp++); - /* -1 removes the tag bit, << 1 multiplies the value by 2, - | *sp++ pops the last value and add it (no carry involved) - not that it reintroduces a tag bit */ - /* alternative, if bool is used for the bits : - accu = (value) ((((unsigned long)accu) << 1) & !*sp++); */ + Instruct (CHECKEQINT63) { + print_instr("CHECKEQINT63"); + CheckInt2(); + accu = uint63_eq(accu,*sp++) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLTINT63) { + print_instr("CHECKLTINT63"); + CheckInt2(); + } + Instruct (LTINT63) { + print_instr("LTINT63"); + accu = uint63_lt(accu,*sp++) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLEINT63) { + print_instr("CHECKLEINT63"); + CheckInt2(); + } + Instruct (LEINT63) { + print_instr("LEINT63"); + accu = uint63_leq(accu,*sp++) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKCOMPAREINT63) { + /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ + /* assumes Inductive _ : _ := Eq | Lt | Gt */ + print_instr("CHECKCOMPAREINT63"); + CheckInt2(); + if (uint63_eq(accu,*sp)) { + accu = coq_Eq; + sp++; } + else accu = uint63_lt(accu,*sp++) ? coq_Lt : coq_Gt; Next; } - Instruct (DECOMPINT31) { - /* builds a block out of a 31-bit integer (from the accumulator), - used before cases */ - int i; - value block; - print_instr("DECOMPINT31"); - Alloc_small(block, 31, 1); // Alloc_small(*, size, tag) - for(i = 30; i >= 0; i--) { - Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */ - //Field(block, i) = 3; - accu = (value) ((uint32_t)accu >> 1) | 1; /* last bit must be a one */ - }; - accu = block; + Instruct (CHECKHEAD0INT63) { + print_instr("CHECKHEAD0INT63"); + CheckInt1(); + accu = uint63_head0(accu); Next; } - Instruct (ORINT31) { - /* returns the bitwise or */ - print_instr("ORINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) | (uint32_of_value(*sp++))); - Next; + Instruct (CHECKTAIL0INT63) { + print_instr("CHECKTAIL0INT63"); + CheckInt1(); + accu = uint63_tail0(accu); + Next; } - Instruct (ANDINT31) { - /* returns the bitwise and */ - print_instr("ANDINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) & (uint32_of_value(*sp++))); + Instruct (ISINT){ + print_instr("ISINT"); + accu = (Is_uint63(accu)) ? coq_true : coq_false; Next; } - Instruct (XORINT31) { - /* returns the bitwise xor */ - print_instr("XORINT31"); - accu = - value_of_uint32((uint32_of_value(accu)) ^ (uint32_of_value(*sp++))); + Instruct (AREINT2){ + print_instr("AREINT2"); + accu = (Is_uint63(accu) && Is_uint63(sp[0])) ? coq_true : coq_false; + sp++; Next; } - /* /spiwack */ - - /* Debugging and machine control */ diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h new file mode 100644 index 0000000000..5499f124a2 --- /dev/null +++ b/kernel/byterun/coq_uint63_emul.h @@ -0,0 +1,97 @@ +# pragma once + +# include <caml/callback.h> +# include <caml/stack.h> + + +#define Is_uint63(v) (Tag_val(v) == Custom_tag) + +# define DECLARE_NULLOP(name) \ +value uint63_##name() { \ + static value* cb = 0; \ + CAMLparam0(); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(*cb); \ + } + +# define DECLARE_UNOP(name) \ +value uint63_##name(value x) { \ + static value* cb = 0; \ + CAMLparam1(x); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(caml_callback(*cb, x)); \ + } + +# define DECLARE_PREDICATE(name) \ +value uint63_##name(value x) { \ + static value* cb = 0; \ + CAMLparam1(x); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(Int_val(caml_callback(*cb, x))); \ + } + +# define DECLARE_BINOP(name) \ +value uint63_##name(value x, value y) { \ + static value* cb = 0; \ + CAMLparam2(x, y); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(caml_callback2(*cb, x, y)); \ + } + +# define DECLARE_RELATION(name) \ +value uint63_##name(value x, value y) { \ + static value* cb = 0; \ + CAMLparam2(x, y); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(Int_val(caml_callback2(*cb, x, y))); \ + } + +# define DECLARE_TEROP(name) \ +value uint63_##name(value x, value y, value z) { \ + static value* cb = 0; \ + CAMLparam3(x, y, z); \ + if (!cb) cb = caml_named_value("uint63 " #name); \ + CAMLreturn(caml_callback3(*cb, x, y, z)); \ + } + + +DECLARE_NULLOP(one) +DECLARE_BINOP(add) +DECLARE_BINOP(addcarry) +DECLARE_TEROP(addmuldiv) +DECLARE_BINOP(div) +DECLARE_TEROP(div21_ml) +DECLARE_RELATION(eq) +DECLARE_PREDICATE(eq0) +DECLARE_UNOP(head0) +DECLARE_BINOP(land) +DECLARE_RELATION(leq) +DECLARE_BINOP(lor) +DECLARE_BINOP(lsl) +DECLARE_UNOP(lsl1) +DECLARE_BINOP(lsr) +DECLARE_UNOP(lsr1) +DECLARE_RELATION(lt) +DECLARE_BINOP(lxor) +DECLARE_BINOP(mod) +DECLARE_BINOP(mul) +DECLARE_BINOP(mulc_ml) +DECLARE_BINOP(sub) +DECLARE_BINOP(subcarry) +DECLARE_UNOP(tail0) + +value uint63_div21(value x, value y, value z, value* q) { + CAMLparam3(x, y, z); + CAMLlocal1(qr); + qr = uint63_div21_ml(x, y, z); + *q = Field(qr, 0); + CAMLreturn(Field(qr, 1)); +} + +value uint63_mulc(value x, value y, value* h) { + CAMLparam2(x, y); + CAMLlocal1(hl); + hl = uint63_mulc_ml(x, y); + *h = Field(hl, 0); + CAMLreturn(Field(hl, 1)); +} diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h new file mode 100644 index 0000000000..92f4dc79bc --- /dev/null +++ b/kernel/byterun/coq_uint63_native.h @@ -0,0 +1,125 @@ +#define Is_uint63(v) (Is_long(v)) + +#define uint63_of_value(val) ((uint64_t)(val) >> 1) + +/* 2^63 * y + x as a value */ +//#define Val_intint(x,y) ((value)(((uint64_t)(x)) << 1 + ((uint64_t)(y) << 64))) + +#define uint63_zero ((value) 1) /* 2*0 + 1 */ +#define uint63_one() ((value) 3) /* 2*1 + 1 */ + +#define uint63_eq(x,y) ((x) == (y)) +#define uint63_eq0(x) ((x) == (uint64_t)1) +#define uint63_lt(x,y) ((uint64_t) (x) < (uint64_t) (y)) +#define uint63_leq(x,y) ((uint64_t) (x) <= (uint64_t) (y)) + +#define uint63_add(x,y) ((value)((uint64_t) (x) + (uint64_t) (y) - 1)) +#define uint63_addcarry(x,y) ((value)((uint64_t) (x) + (uint64_t) (y) + 1)) +#define uint63_sub(x,y) ((value)((uint64_t) (x) - (uint64_t) (y) + 1)) +#define uint63_subcarry(x,y) ((value)((uint64_t) (x) - (uint64_t) (y) - 1)) +#define uint63_mul(x,y) (Val_long(uint63_of_value(x) * uint63_of_value(y))) +#define uint63_div(x,y) (Val_long(uint63_of_value(x) / uint63_of_value(y))) +#define uint63_mod(x,y) (Val_long(uint63_of_value(x) % uint63_of_value(y))) + +#define uint63_lxor(x,y) ((value)(((uint64_t)(x) ^ (uint64_t)(y)) | 1)) +#define uint63_lor(x,y) ((value)((uint64_t)(x) | (uint64_t)(y))) +#define uint63_land(x,y) ((value)((uint64_t)(x) & (uint64_t)(y))) + +/* TODO: is + or | better? OCAML uses + */ +/* TODO: is - or ^ better? */ +#define uint63_lsl(x,y) ((y) < (uint64_t) 127 ? ((value)((((uint64_t)(x)-1) << (uint63_of_value(y))) | 1)) : uint63_zero) +#define uint63_lsr(x,y) ((y) < (uint64_t) 127 ? ((value)(((uint64_t)(x) >> (uint63_of_value(y))) | 1)) : uint63_zero) +#define uint63_lsl1(x) ((value)((((uint64_t)(x)-1) << 1) +1)) +#define uint63_lsr1(x) ((value)(((uint64_t)(x) >> 1) |1)) + +/* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ +/* (modulo 2^63) for p <= 63 */ +value uint63_addmuldiv(uint64_t p, uint64_t x, uint64_t y) { + uint64_t shiftby = uint63_of_value(p); + value r = (value)((uint64_t)(x^1) << shiftby); + r |= ((uint64_t)y >> (63-shiftby)) | 1; + return r; +} + +value uint63_head0(uint64_t x) { + int r = 0; + if (!(x & 0xFFFFFFFF00000000)) { x <<= 32; r += 32; } + if (!(x & 0xFFFF000000000000)) { x <<= 16; r += 16; } + if (!(x & 0xFF00000000000000)) { x <<= 8; r += 8; } + if (!(x & 0xF000000000000000)) { x <<= 4; r += 4; } + if (!(x & 0xC000000000000000)) { x <<= 2; r += 2; } + if (!(x & 0x8000000000000000)) { x <<=1; r += 1; } + return Val_int(r); +} + +value uint63_tail0(value x) { + int r = 0; + x = (uint64_t)x >> 1; + if (!(x & 0xFFFFFFFF)) { x >>= 32; r += 32; } + if (!(x & 0x0000FFFF)) { x >>= 16; r += 16; } + if (!(x & 0x000000FF)) { x >>= 8; r += 8; } + if (!(x & 0x0000000F)) { x >>= 4; r += 4; } + if (!(x & 0x00000003)) { x >>= 2; r += 2; } + if (!(x & 0x00000001)) { x >>=1; r += 1; } + return Val_int(r); +} + +value uint63_mulc(value x, value y, value* h) { + x = (uint64_t)x >> 1; + y = (uint64_t)y >> 1; + uint64_t lx = x & 0xFFFFFFFF; + uint64_t ly = y & 0xFFFFFFFF; + uint64_t hx = x >> 32; + uint64_t hy = y >> 32; + uint64_t hr = hx * hy; + uint64_t lr = lx * ly; + lx *= hy; + ly *= hx; + hr += (lx >> 32) + (ly >> 32); + lx <<= 32; + lr += lx; + if (lr < lx) { hr++; } + ly <<= 32; + lr += ly; + if (lr < ly) { hr++; } + hr = (hr << 1) | (lr >> 63); + *h = Val_int(hr); + return Val_int(lr); +} + +#define lt128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_lt(xl,yl))) +#define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) + +value uint63_div21(value xh, value xl, value y, value* q) { + xh = (uint64_t)xh >> 1; + xl = ((uint64_t)xl >> 1) | ((uint64_t)xh << 63); + xh = (uint64_t)xh >> 1; + uint64_t maskh = 0; + uint64_t maskl = 1; + uint64_t dh = 0; + uint64_t dl = (uint64_t)y >> 1; + int cmp = 1; + while (dh >= 0 && cmp) { + cmp = lt128(dh,dl,xh,xl); + dh = (dh << 1) | (dl >> 63); + dl = dl << 1; + maskh = (maskh << 1) | (maskl >> 63); + maskl = maskl << 1; + } + uint64_t remh = xh; + uint64_t reml = xl; + uint64_t quotient = 0; + while (maskh | maskl) { + if (le128(dh,dl,remh,reml)) { + quotient = quotient | maskl; + if (uint63_lt(reml,dl)) {remh = remh - dh - 1;} else {remh = remh - dh;} + reml = reml - dl; + } + maskl = (maskl >> 1) | (maskh << 63); + maskh = maskh >> 1; + dl = (dl >> 1) | (dh << 63); + dh = dh >> 1; + } + *q = Val_int(quotient); + return Val_int(reml); +} diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index bb0f0eb5e4..0cf6ccf532 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -28,6 +28,16 @@ /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) - #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) + +/* */ +#define coq_tag_C1 2 +#define coq_tag_C0 1 +#define coq_tag_pair 1 +#define coq_true Val_int(0) +#define coq_false Val_int(1) +#define coq_Eq Val_int(0) +#define coq_Lt Val_int(1) +#define coq_Gt Val_int(2) + #endif /* _COQ_VALUES_ */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index 3a714a8a59..20bdf28e54 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -5,6 +5,9 @@ (c_names coq_fix_code coq_memory coq_values coq_interp)) (rule + (targets coq_instruct.h) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe enum)))) + +(rule (targets coq_jumptbl.h) - (deps (:h-file coq_instruct.h)) - (action (run ./make_jumptbl.sh %{h-file} %{targets}))) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe jump)))) diff --git a/kernel/byterun/make_jumptbl.sh b/kernel/byterun/make_jumptbl.sh deleted file mode 100755 index eacd4daac8..0000000000 --- a/kernel/byterun/make_jumptbl.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash - -sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' -e '/^}/q' ${1} > ${2} diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 819a66c190..412637c4b6 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -21,13 +21,17 @@ (* This file implements a lazy reduction for the Calculus of Inductive Constructions *) +[@@@ocaml.warning "+4"] + open CErrors open Util open Pp open Names open Constr -open Vars +open Declarations +open Context open Environ +open Vars open Esubst let stats = ref false @@ -70,11 +74,8 @@ let with_stats c = end else Lazy.force c -let all_opaque = (Id.Pred.empty, Cpred.empty) -let all_transparent = (Id.Pred.full, Cpred.full) - -let is_transparent_variable (ids, _) id = Id.Pred.mem id ids -let is_transparent_constant (_, csts) cst = Cpred.mem cst csts +let all_opaque = TransparentState.empty +let all_transparent = TransparentState.full module type RedFlagsSig = sig type reds @@ -91,24 +92,26 @@ module type RedFlagsSig = sig val no_red : reds val red_add : reds -> red_kind -> reds val red_sub : reds -> red_kind -> reds - val red_add_transparent : reds -> transparent_state -> reds - val red_transparent : reds -> transparent_state + val red_add_transparent : reds -> TransparentState.t -> reds + val red_transparent : reds -> TransparentState.t val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool val red_projection : reds -> Projection.t -> bool end -module RedFlags = (struct +module RedFlags : RedFlagsSig = struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) (* [r_delta=true] just mean [r_const=(true,[])] *) + open TransparentState + type reds = { r_beta : bool; r_delta : bool; r_eta : bool; - r_const : transparent_state; + r_const : TransparentState.t; r_zeta : bool; r_match : bool; r_fix : bool; @@ -141,30 +144,30 @@ module RedFlags = (struct | ETA -> { red with r_eta = true } | DELTA -> { red with r_delta = true; r_const = all_transparent } | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.add kn l2 } + let r = red.r_const in + { red with r_const = { r with tr_cst = Cpred.add kn r.tr_cst } } | MATCH -> { red with r_match = true } | FIX -> { red with r_fix = true } | COFIX -> { red with r_cofix = true } | ZETA -> { red with r_zeta = true } | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.add id l1, l2 } + let r = red.r_const in + { red with r_const = { r with tr_var = Id.Pred.add id r.tr_var } } let red_sub red = function | BETA -> { red with r_beta = false } | ETA -> { red with r_eta = false } | DELTA -> { red with r_delta = false } | CONST kn -> - let (l1,l2) = red.r_const in - { red with r_const = l1, Cpred.remove kn l2 } + let r = red.r_const in + { red with r_const = { r with tr_cst = Cpred.remove kn r.tr_cst } } | MATCH -> { red with r_match = false } | FIX -> { red with r_fix = false } | COFIX -> { red with r_cofix = false } | ZETA -> { red with r_zeta = false } | VAR id -> - let (l1,l2) = red.r_const in - { red with r_const = Id.Pred.remove id l1, l2 } + let r = red.r_const in + { red with r_const = { r with tr_var = Id.Pred.remove id r.tr_var } } let red_transparent red = red.r_const @@ -177,12 +180,10 @@ module RedFlags = (struct | BETA -> incr_cnt red.r_beta beta | ETA -> incr_cnt red.r_eta eta | CONST kn -> - let (_,l) = red.r_const in - let c = Cpred.mem kn l in + let c = is_transparent_constant red.r_const kn in incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) - let (l,_) = red.r_const in - let c = Id.Pred.mem id l in + let c = is_transparent_variable red.r_const id in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | MATCH -> incr_cnt red.r_match nb_match @@ -195,7 +196,7 @@ module RedFlags = (struct if Projection.unfolded p then true else red_set red (fCONST (Projection.constant p)) -end : RedFlagsSig) +end open RedFlags @@ -224,11 +225,6 @@ let unfold_red kn = * abstractions, storing a representation (of type 'a) of the body of * this constant or abstraction. * * i_tab is the cache table of the results - * * i_repr is the function to get the representation from the current - * state of the cache and the body of the constant. The result - * is stored in the table. - * * i_rels is the array of free rel variables together with their optional - * body * * ref_value_cache searchs in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't @@ -256,73 +252,11 @@ end module KeyTable = Hashtbl.Make(IdKeyHash) -let eq_table_key = IdKeyHash.equal - -type 'a infos_tab = 'a KeyTable.t - -type 'a infos_cache = { - i_repr : 'a infos -> 'a infos_tab -> constr -> 'a; - i_env : env; - i_sigma : existential -> constr option; - i_rels : (Constr.rel_declaration * lazy_val) Range.t; - i_share : bool; -} - -and 'a infos = { - i_flags : reds; - i_cache : 'a infos_cache } - -let info_flags info = info.i_flags -let info_env info = info.i_cache.i_env - open Context.Named.Declaration let assoc_defined id env = match Environ.lookup_named id env with | LocalDef (_, c, _) -> c -| _ -> raise Not_found - -let ref_value_cache ({i_cache = cache;_} as infos) tab ref = - try - Some (KeyTable.find tab ref) - with Not_found -> - try - let body = - match ref with - | RelKey n -> - let open! Context.Rel.Declaration in - let i = n - 1 in - let (d, _) = - try Range.get cache.i_rels i - with Invalid_argument _ -> raise Not_found - in - begin match d with - | LocalAssum _ -> raise Not_found - | LocalDef (_, t, _) -> lift n t - end - | VarKey id -> assoc_defined id cache.i_env - | ConstKey cst -> constant_value_in cache.i_env cst - in - let v = cache.i_repr infos tab body in - KeyTable.add tab ref v; - Some v - with - | Not_found (* List.assoc *) - | NotEvaluableConst _ (* Const *) - -> None - -let evar_value cache ev = - cache.i_sigma ev - -let create ~repr ~share flgs env evars = - let cache = - { i_repr = repr; - i_env = env; - i_sigma = evars; - i_rels = env.env_rel_context.env_rel_map; - i_share = share; - } - in { i_flags = flgs; i_cache = cache } - +| LocalAssum _ -> raise Not_found (**********************************************************************) (* Lazy reduction: the one used in kernel operations *) @@ -349,12 +283,63 @@ let create ~repr ~share flgs env evars = type red_state = Norm | Cstr | Whnf | Red let neutr = function - | (Whnf|Norm) -> Whnf - | (Red|Cstr) -> Red + | Whnf|Norm -> Whnf + | Red|Cstr -> Red + +type optrel = Unknown | KnownR | KnownI + +let opt_of_rel = function + | Sorts.Relevant -> KnownR + | Sorts.Irrelevant -> KnownI + +module Mark : sig + + type t + + val mark : red_state -> optrel -> t + val relevance : t -> optrel + val red_state : t -> red_state + + val neutr : t -> t + + val set_norm : t -> t + +end = struct + type t = int + + let[@inline] of_state = function + | Norm -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 + + let[@inline] of_relevance = function + | Unknown -> 0 + | KnownR -> 0b01 + | KnownI -> 0b10 + + let[@inline] mark state relevance = (of_state state) * 4 + (of_relevance relevance) + + let[@inline] relevance x = match x land 0b11 with + | 0b00 -> Unknown + | 0b01 -> KnownR + | 0b10 -> KnownI + | _ -> assert false + + let[@inline] red_state x = match x land 0b1100 with + | 0b0000 -> Norm + | 0b0100 -> Cstr + | 0b1000 -> Whnf + | 0b1100 -> Red + | _ -> assert false + + let[@inline] neutr x = x lor 0b1000 (* Whnf|Norm -> Whnf | Red|Cstr -> Red *) + + let[@inline] set_norm x = x land 0b0011 +end +let mark = Mark.mark type fconstr = { - mutable norm: red_state; - mutable term: fterm } + mutable mark : Mark.t; + mutable term: fterm; +} and fterm = | FRel of int @@ -367,38 +352,59 @@ and fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * fconstr - | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs + | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs + | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs + | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs + | FInt of Uint63.t | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED let fterm_of v = v.term -let set_norm v = v.norm <- Norm -let is_val v = match v.norm with Norm -> true | _ -> false +let set_norm v = v.mark <- Mark.set_norm v.mark +let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false -let mk_atom c = {norm=Norm;term=FAtom c} -let mk_red f = {norm=Red;term=f} +let mk_atom c = {mark=mark Norm Unknown;term=FAtom c} +let mk_red f = {mark=mark Red Unknown;term=f} (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) -let update ~share v1 no t = +let update ~share v1 mark t = if share then - (v1.norm <- no; + (v1.mark <- mark; v1.term <- t; v1) - else {norm=no;term=t} + else {mark;term=t;} + +(** Reduction cache *) + +type infos_cache = { + i_env : env; + i_sigma : existential -> constr option; + i_share : bool; +} + +type clos_infos = { + i_flags : reds; + i_cache : infos_cache } + +type clos_tab = fconstr constant_def KeyTable.t + +let info_flags info = info.i_flags +let info_env info = info.i_cache.i_env (**********************************************************************) (* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack + | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args + (* operator, constr def, arguments already seen (in rev order), next arguments *) | Zshift of int | Zupdate of fconstr @@ -409,75 +415,39 @@ let append_stack v s = if Int.equal (Array.length v) 0 then s else match s with | Zapp l :: s -> Zapp (Array.append v l) :: s - | _ -> Zapp v :: s + | (ZcaseT _ | Zproj _ | Zfix _ | Zshift _ | Zupdate _ | Zprimitive _) :: _ | [] -> + Zapp v :: s (* Collapse the shifts in the stack *) let zshift n s = match (n,s) with (0,_) -> s | (_,Zshift(k)::s) -> Zshift(n+k)::s - | _ -> Zshift(n)::s + | (_,(ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zupdate _ | Zprimitive _) :: _) | _,[] -> Zshift(n)::s let rec stack_args_size = function | Zapp v :: s -> Array.length v + stack_args_size s | Zshift(_)::s -> stack_args_size s | Zupdate(_)::s -> stack_args_size s - | _ -> 0 - -(* When used as an argument stack (only Zapp can appear) *) -let rec decomp_stack = function - | Zapp v :: s -> - (match Array.length v with - 0 -> decomp_stack s - | 1 -> Some (v.(0), s) - | _ -> - Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) - | _ -> None -let array_of_stack s = - let rec stackrec = function - | [] -> [] - | Zapp args :: s -> args :: (stackrec s) - | _ -> assert false - in Array.concat (stackrec s) -let rec stack_assign s p c = match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then - Zapp args :: stack_assign s (p-q) c - else - (let nargs = Array.copy args in - nargs.(p) <- c; - Zapp nargs :: s) - | _ -> s -let rec stack_tail p s = - if Int.equal p 0 then s else - match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then stack_tail (p-q) s - else Zapp (Array.sub args p (q-p)) :: s - | _ -> failwith "stack_tail" -let rec stack_nth s p = match s with - | Zapp args :: s -> - let q = Array.length args in - if p >= q then stack_nth s (p-q) - else args.(p) - | _ -> raise Not_found + | (ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | [] -> 0 (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = + let r = Mark.relevance ft.mark in match ft.term with - | (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))} - | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} + | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _) -> ft + | FRel i -> {mark=mark Norm r;term=FRel(i+n)} + | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} + | FFix(fx,e) -> + {mark=mark Cstr r; term=FFix(fx,subs_shft(n,e))} + | FCoFix(cfx,e) -> + {mark=mark Cstr r; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false - | FFlex _ | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ - | FLetIn _ | FEvar _ | FCLOS _ -> {norm=ft.norm; term=FLIFT(n,ft)} + | FFlex (RelKey _) | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ + | FLetIn _ | FEvar _ | FCLOS _ -> {mark=ft.mark; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = @@ -486,9 +456,9 @@ let lift_fconstr_vect k v = let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt - | Inr(k,None) -> {norm=Norm; term= FRel k} + | Inr(k,None) -> {mark=mark Norm Unknown; term= FRel k} | Inr(k,Some p) -> - lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} + lift_fconstr (k-p) {mark=mark Red Unknown;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = @@ -499,15 +469,16 @@ let compact_stack head stk = lost by the update operation *) let h' = lft_fconstr depth head in (** The stack contains [Zupdate] marks only if in sharing mode *) - let _ = update ~share:true m h'.norm h'.term in + let _ = update ~share:true m h'.mark h'.term in strip_rec depth s - | stk -> zshift depth stk in + | ((ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zprimitive _) :: _ | []) as stk -> zshift depth stk + in strip_rec 0 stk (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match m.norm with Red -> true | _ -> false end + if share && begin match Mark.red_state m.mark with Red -> true | Norm | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -519,25 +490,28 @@ let mk_lambda env t = FLambda(List.length rvars, List.rev rvars, t', env) let destFLambda clos_fun t = - match t.term with + match [@ocaml.warning "-4"] t.term with FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) | FLambda(n,(na,ty)::tys,b,e) -> - (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) + (na,clos_fun e ty,{mark=t.mark;term=FLambda(n-1,tys,b,subs_lift e)}) | _ -> assert false - (* t must be a FLambda and binding list cannot be empty *) + (* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match kind t with | Rel i -> clos_rel e i - | Var x -> { norm = Red; term = FFlex (VarKey x) } - | Const c -> { norm = Red; term = FFlex (ConstKey c) } - | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } - | Ind kn -> { norm = Norm; term = FInd kn } - | Construct kn -> { norm = Cstr; term = FConstruct kn } + | Var x -> {mark = mark Red Unknown; term = FFlex (VarKey x) } + | Const c -> {mark = mark Red Unknown; term = FFlex (ConstKey c) } + | Meta _ | Sort _ -> {mark = mark Norm KnownR; term = FAtom t } + | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } + | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } + | Int i -> {mark = mark Cstr Unknown; term = FInt i} | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> - {norm = Red; term = FCLOS(t,e)} + {mark = mark Red Unknown; term = FCLOS(t,e)} + +let inject c = mk_clos (subs_id 0) c (** Hand-unrolling of the map function to bypass the call to the generic array allocation *) @@ -550,6 +524,37 @@ let mk_clos_vect env v = match v with [|mk_clos env v0; mk_clos env v1; mk_clos env v2; mk_clos env v3|] | v -> Array.Fun1.map mk_clos env v +let ref_value_cache ({ i_cache = cache; _ }) tab ref = + try + KeyTable.find tab ref + with Not_found -> + let v = + try + let body = + match ref with + | RelKey n -> + let open! Context.Rel.Declaration in + let i = n - 1 in + let (d, _) = + try Range.get cache.i_env.env_rel_context.env_rel_map i + with Invalid_argument _ -> raise Not_found + in + begin match d with + | LocalAssum _ -> raise Not_found + | LocalDef (_, t, _) -> lift n t + end + | VarKey id -> assoc_defined id cache.i_env + | ConstKey cst -> constant_value_in cache.i_env cst + in + Def (inject body) + with + | NotEvaluableConst (IsPrimitive op) (* Const *) -> Primitive op + | Not_found (* List.assoc *) + | NotEvaluableConst _ (* Const *) + -> Undef None + in + KeyTable.add tab ref v; v + (* The inverse of mk_clos: move back to constr *) let rec to_constr lfts v = match v.term with @@ -602,9 +607,12 @@ let rec to_constr lfts v = let tys = List.mapi (fun i (na, c) -> na, subst_constr (subs_liftn i subs) c) tys in let f = subst_constr (subs_liftn len subs) f in Term.compose_lam (List.rev tys) f - | FProd (n,t,c) -> - mkProd (n, to_constr lfts t, - to_constr (el_lift lfts) c) + | FProd (n, t, c, e) -> + if is_subs_id e && is_lift_id lfts then + mkProd (n, to_constr lfts t, c) + else + let subs' = comp_subs lfts e in + mkProd (n, to_constr lfts t, subst_constr (subs_lift subs') c) | FLetIn (n,b,t,f,e) -> let subs = comp_subs (el_lift lfts) (subs_lift e) in mkLetIn (n, to_constr lfts b, @@ -614,6 +622,10 @@ let rec to_constr lfts v = let subs = comp_subs lfts env in mkEvar(ev,Array.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a + + | FInt i -> + Constr.mkInt i + | FCLOS (t,env) -> if is_subs_id env && is_lift_id lfts then t else @@ -621,7 +633,7 @@ let rec to_constr lfts v = subst_constr subs t | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*) -and subst_constr subst c = match Constr.kind c with +and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with | Rel i -> begin match expand_rel i subst with | Inl (k, lazy v) -> Vars.lift k v @@ -649,19 +661,25 @@ let rec fstrong unfreeze_fun lfts v = let rec zip m stk = match stk with | [] -> m - | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s + | Zapp args :: s -> zip {mark=Mark.neutr m.mark; term=FApp(m, args)} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in - zip {norm=neutr m.norm; term=t} s + let mark = mark (neutr (Mark.red_state m.mark)) Unknown in + zip {mark; term=t} s | Zproj p :: s -> - zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s + let mark = mark (neutr (Mark.red_state m.mark)) Unknown in + zip {mark; term=FProj(Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) - zip (update ~share:true rf m.norm m.term) s + zip (update ~share:true rf m.mark m.term) s + | Zprimitive(_op,c,rargs,kargs)::s -> + let args = List.rev_append rargs (m::List.map snd kargs) in + let f = {mark = mark Red Unknown;term = FFlex (ConstKey c)} in + zip {mark=mark (neutr (Mark.red_state m.mark)) KnownR; term = FApp (f, Array.of_list args)} s let fapp_stack (m,stk) = zip m stk @@ -679,19 +697,21 @@ let strip_update_shift_app_red head stk = strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) - {norm=h.norm;term=FApp(h,args)} depth s + {mark=h.mark;term=FApp(h,args)} depth s | Zupdate(m)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) - strip_rec rstk (update ~share:true m h.norm h.term) depth s - | stk -> (depth,List.rev rstk, stk) in + strip_rec rstk (update ~share:true m h.mark h.term) depth s + | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> + (depth,List.rev rstk, stk) + in strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match head.norm with Red -> false | _ -> true); + assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match head.norm with Red -> false | _ -> true); + assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -699,7 +719,7 @@ let get_nth_arg head n stk = let q = Array.length args in if n >= q then - strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' + strip_rec (Zapp args::rstk) {mark=h.mark;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in @@ -708,17 +728,16 @@ let get_nth_arg head n stk = (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> (** The stack contains [Zupdate] mark only if in sharing mode *) - strip_rec rstk (update ~share:true m h.norm h.term) n s - | s -> (None, List.rev rstk @ s) in + strip_rec rstk (update ~share:true m h.mark h.term) n s + | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk (* Beta reduction: look for an applied argument in the stack. Since the encountered update marks are removed, h must be a whnf *) -let rec get_args n tys f e stk = - match stk with - Zupdate r :: s -> +let rec get_args n tys f e = function + | Zupdate r :: s -> (** The stack contains [Zupdate] mark only if in sharing mode *) - let _hd = update ~share:true r Cstr (FLambda(n,tys,f,e)) in + let _hd = update ~share:true r (mark Cstr (Mark.relevance r.mark)) (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 @@ -732,31 +751,76 @@ let rec get_args n tys f e stk = else (* more lambdas *) let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s - | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) + | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> + (Inr {mark=mark Cstr Unknown;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _ - | Zshift _ | Zupdate _ as e) :: s -> + | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> - [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] + [Zshift 1; Zapp [|{mark=mark Norm Unknown; term= FRel 1}|]] + +(* Get the arguments of a native operator *) +let rec skip_native_args rargs nargs = + match nargs with + | (kd, a) :: nargs' -> + if kd = CPrimitives.Kwhnf then rargs, nargs + else skip_native_args (a::rargs) nargs' + | [] -> rargs, [] + +let get_native_args op c stk = + let kargs = CPrimitives.kind op in + let rec get_args rnargs kargs args = + match kargs, args with + | kd::kargs, a::args -> get_args ((kd,a)::rnargs) kargs args + | _, _ -> rnargs, kargs, args in + let rec strip_rec rnargs h depth kargs = function + | Zshift k :: s -> + strip_rec (List.map (fun (kd,f) -> kd,lift_fconstr k f) rnargs) + (lift_fconstr k h) (depth+k) kargs s + | Zapp args :: s' -> + begin match get_args rnargs kargs (Array.to_list args) with + | rnargs, [], [] -> + (skip_native_args [] (List.rev rnargs), s') + | rnargs, [], eargs -> + (skip_native_args [] (List.rev rnargs), + Zapp (Array.of_list eargs) :: s') + | rnargs, kargs, _ -> + strip_rec rnargs {mark = h.mark;term=FApp(h, args)} depth kargs s' + end + | Zupdate(m) :: s -> + strip_rec rnargs (update ~share:true m h.mark h.term) depth kargs s + | (Zprimitive _ | ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> assert false + in strip_rec [] {mark = mark Red Unknown;term = FFlex(ConstKey c)} 0 kargs stk + +let get_native_args1 op c stk = + match get_native_args op c stk with + | ((rargs, (kd,a):: nargs), stk) -> + assert (kd = CPrimitives.Kwhnf); + (rargs, a, nargs, stk) + | _ -> assert false + +let check_native_args op stk = + let nargs = CPrimitives.arity op in + let rargs = stack_args_size stk in + nargs <= rargs + (* Iota reduction: extract the arguments to be passed to the Case branches *) -let rec reloc_rargs_rec depth stk = - match stk with - Zapp args :: s -> - Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s - | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s - | _ -> stk +let rec reloc_rargs_rec depth = function + | Zapp args :: s -> + Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s + | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s + | ((ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ | []) as stk -> stk let reloc_rargs depth stk = if Int.equal depth 0 then stk else reloc_rargs_rec depth stk -let rec try_drop_parameters depth n argstk = - match argstk with - Zapp args::s -> +let rec try_drop_parameters depth n = function + | Zapp args::s -> let q = Array.length args in if n > q then try_drop_parameters depth (n-q) s else if Int.equal n q then reloc_rargs depth s @@ -767,7 +831,7 @@ let rec try_drop_parameters depth n argstk = | [] -> if Int.equal n 0 then [] else raise Not_found - | _ -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) let drop_parameters depth n argstk = @@ -800,20 +864,19 @@ let eta_expand_ind_stack env ind m s (f, s') = (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in let hstack = Array.map (fun p -> - { norm = Red; (* right can't be a constructor though *) + { mark = mark Red Unknown; (* right can't be a constructor though *) term = FProj (Projection.make p true, right) }) projs in argss, [Zapp hstack] | None -> raise Not_found (* disallow eta-exp for non-primitive records *) -let rec project_nth_arg n argstk = - match argstk with +let rec project_nth_arg n = function | Zapp args :: s -> let q = Array.length args in if n >= q then project_nth_arg (n - q) s else (* n < q *) args.(n) - | _ -> assert false + | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _ | Zprimitive _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) @@ -828,14 +891,16 @@ let rec project_nth_arg n argstk = (* does not deal with FLIFT *) let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = - match fix with - | FFix (((reci,i),(_,_,bds as rdcl)),env) -> + match [@ocaml.warning "-4"] fix with + | FFix (((reci,i),(nas,_,bds as rdcl)),env) -> (bds.(i), - (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), + (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); + term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) - | FCoFix ((i,(_,_,bds as rdcl)),env) -> + | FCoFix ((i,(nas,_,bds as rdcl)),env) -> (bds.(i), - (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), + (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); + term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in @@ -859,7 +924,7 @@ let rec knh info m stk = | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) - | FFix(((ri,n),(_,_,_)),_) -> + | FFix(((ri,n),_),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) @@ -870,7 +935,7 @@ let rec knh info m stk = (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| - FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> + FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _|FInt _) -> (m, stk) (* The same for pure terms *) @@ -880,19 +945,175 @@ and knht info e t stk = knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk) - | Fix fx -> knh info { norm = Cstr; term = FFix (fx, e) } stk + | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk - | Proj (p, c) -> knh info { norm = Red; term = FProj (p, mk_clos e c) } stk - | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> (mk_clos e t, stk) - | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk - | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk + | Proj (p, c) -> knh info { mark = mark Red Unknown; term = FProj (p, mk_clos e c) } stk + | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _ | Int _) -> (mk_clos e t, stk) + | CoFix cfx -> { mark = mark Cstr Unknown; term = FCoFix (cfx,e) }, stk + | Lambda _ -> { mark = mark Cstr Unknown; term = mk_lambda e t }, stk | Prod (n, t, c) -> - { norm = Whnf; term = FProd (n, mk_clos e t, mk_clos (subs_lift e) c) }, stk + { mark = mark Whnf KnownR; term = FProd (n, mk_clos e t, c, e) }, stk | LetIn (n,b,t,c) -> - { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk - | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk + { mark = mark Red Unknown; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk + | Evar ev -> { mark = mark Red Unknown; term = FEvar (ev, e) }, stk + +let inject c = mk_clos (subs_id 0) c +(************************************************************************) +(* Reduction of Native operators *) + +open Primred + +module FNativeEntries = + struct + type elem = fconstr + type args = fconstr array + type evd = unit + + let get = Array.get + + let get_int () e = + match [@ocaml.warning "-4"] e.term with + | FInt i -> i + | _ -> raise Primred.NativeDestKO + + let dummy = {mark = mark Norm KnownR; term = FRel 0} + + let current_retro = ref Retroknowledge.empty + let defined_int = ref false + let fint = ref dummy + + let init_int retro = + match retro.Retroknowledge.retro_int63 with + | Some c -> + defined_int := true; + fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + | None -> defined_int := false + + let defined_bool = ref false + let ftrue = ref dummy + let ffalse = ref dummy + + let init_bool retro = + match retro.Retroknowledge.retro_bool with + | Some (ct,cf) -> + defined_bool := true; + ftrue := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs ct) }; + ffalse := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cf) } + | None -> defined_bool :=false + + let defined_carry = ref false + let fC0 = ref dummy + let fC1 = ref dummy + + let init_carry retro = + match retro.Retroknowledge.retro_carry with + | Some(c0,c1) -> + defined_carry := true; + fC0 := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c0) }; + fC1 := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c1) } + | None -> defined_carry := false + + let defined_pair = ref false + let fPair = ref dummy + + let init_pair retro = + match retro.Retroknowledge.retro_pair with + | Some c -> + defined_pair := true; + fPair := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c) } + | None -> defined_pair := false + + let defined_cmp = ref false + let fEq = ref dummy + let fLt = ref dummy + let fGt = ref dummy + + let init_cmp retro = + match retro.Retroknowledge.retro_cmp with + | Some (cEq, cLt, cGt) -> + defined_cmp := true; + fEq := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cEq) }; + fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; + fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) } + | None -> defined_cmp := false + + let defined_refl = ref false + + let frefl = ref dummy + + let init_refl retro = + match retro.Retroknowledge.retro_refl with + | Some crefl -> + defined_refl := true; + frefl := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs crefl) } + | None -> defined_refl := false + + let init env = + current_retro := env.retroknowledge; + init_int !current_retro; + init_bool !current_retro; + init_carry !current_retro; + init_pair !current_retro; + init_cmp !current_retro; + init_refl !current_retro + + let check_env env = + if not (!current_retro == env.retroknowledge) then init env + + let check_int env = + check_env env; + assert (!defined_int) + + let check_bool env = + check_env env; + assert (!defined_bool) + + let check_carry env = + check_env env; + assert (!defined_carry && !defined_int) + + let check_pair env = + check_env env; + assert (!defined_pair && !defined_int) + + let check_cmp env = + check_env env; + assert (!defined_cmp) + + let mkInt env i = + check_int env; + { mark = mark Norm KnownR; term = FInt i } + + let mkBool env b = + check_bool env; + if b then !ftrue else !ffalse + + let mkCarry env b e = + check_carry env; + {mark = mark Cstr KnownR; + term = FApp ((if b then !fC1 else !fC0),[|!fint;e|])} + + let mkIntPair env e1 e2 = + check_pair env; + { mark = mark Cstr KnownR; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } + + let mkLt env = + check_cmp env; + !fLt + + let mkEq env = + check_cmp env; + !fEq + + let mkGt env = + check_cmp env; + !fGt + + end + +module FredNative = RedNative(FNativeEntries) (************************************************************************) @@ -905,21 +1126,26 @@ let rec knr info tab m stk = | Inr lam, s -> (lam,s)) | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info tab (ConstKey c) with - Some v -> kni info tab v stk - | None -> (set_norm m; (m,stk))) + | Def v -> kni info tab v stk + | Primitive op when check_native_args op stk -> + let rargs, a, nargs, stk = get_native_args1 op c stk in + kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) + | Undef _ | OpaqueDef _ | Primitive _ -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info tab (VarKey id) with - Some v -> kni info tab v stk - | None -> (set_norm m; (m,stk))) + | Def v -> kni info tab v stk + | Primitive _ -> assert false + | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) | FFlex(RelKey k) when red_set info.i_flags fDELTA -> (match ref_value_cache info tab (RelKey k) with - Some v -> kni info tab v stk - | None -> (set_norm m; (m,stk))) + | Def v -> kni info tab v stk + | Primitive _ -> assert false + | OpaqueDef _ | Undef _ -> (set_norm m; (m,stk))) | FConstruct((_ind,c),_u) -> let use_match = red_set info.i_flags fMATCH in let use_fix = red_set info.i_flags fFIX in if use_match || use_fix then - (match strip_update_shift_app m stk with + (match [@ocaml.warning "-4"] strip_update_shift_app m stk with | (depth, args, ZcaseT(ci,_,br,e)::s) when use_match -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in @@ -937,17 +1163,36 @@ let rec knr info tab m stk = else (m,stk) | FCoFix _ when red_set info.i_flags fCOFIX -> (match strip_update_shift_app m stk with - (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> + | (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info tab fxe fxbd (args@stk') - | (_,args,s) -> (m,args@s)) + | (_,args, ((Zapp _ | Zfix _ | Zshift _ | Zupdate _ | Zprimitive _) :: _ | [] as s)) -> (m,args@s)) | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info tab (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> - (match evar_value info.i_cache ev with + (match info.i_cache.i_sigma ev with Some c -> knit info tab env c stk | None -> (m,stk)) - | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FApp _ | FProj _ + | FInt _ -> + (match [@ocaml.warning "-4"] strip_update_shift_app m stk with + | (_, _, Zprimitive(op,c,rargs,nargs)::s) -> + let (rargs, nargs) = skip_native_args (m::rargs) nargs in + begin match nargs with + | [] -> + let args = Array.of_list (List.rev rargs) in + begin match FredNative.red_prim (info_env info) () op args with + | Some m -> kni info tab m s + | None -> + let f = {mark = mark Whnf KnownR; term = FFlex (ConstKey c)} in + let m = {mark = mark Whnf KnownR; term = FApp(f,args)} in + (m,s) + end + | (kd,a)::nargs -> + assert (kd = CPrimitives.Kwhnf); + kni info tab a (Zprimitive(op,c,rargs,nargs)::s) + end + | (_, _, s) -> (m, s)) + | FLOCKED | FRel _ | FAtom _ | FFlex (RelKey _ | ConstKey _ | VarKey _) | FInd _ | FApp _ | FProj _ | FFix _ | FCoFix _ | FCaseT _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ | FCLOS _ -> (m, stk) @@ -983,6 +1228,12 @@ let rec zip_term zfun m stk = zip_term zfun (lift n m) s | Zupdate(_rf)::s -> zip_term zfun m s + | Zprimitive(_,c,rargs, kargs)::s -> + let kargs = List.map (fun (_,a) -> zfun a) kargs in + let args = + List.fold_left (fun args a -> zfun a ::args) (m::kargs) rargs in + let h = mkApp (mkConstU c, Array.of_list args) in + zip_term zfun h s (* Computes the strong normal form of a term. 1- Calls kni @@ -1002,17 +1253,17 @@ and norm_head info tab m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with | FLambda(_n,tys,f,e) -> - let (e',rvtys) = - List.fold_left (fun (e,ctxt) (na,ty) -> - (subs_lift e, (na,kl info tab (mk_clos e ty))::ctxt)) - (e,[]) tys in - let bd = kl info tab (mk_clos e' f) in - List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys + let (e',info,rvtys) = + List.fold_left (fun (e,info,ctxt) (na,ty) -> + (subs_lift e, info, (na,kl info tab (mk_clos e ty))::ctxt)) + (e,info,[]) tys in + let bd = kl info tab (mk_clos e' f) in + List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) - | FProd(na,dom,rng) -> - mkProd(na, kl info tab dom, kl info tab rng) + | FProd(na,dom,rng,e) -> + mkProd(na, kl info tab dom, kl info tab (mk_clos (subs_lift e) rng)) | FCoFix((n,(na,tys,bds)),e) -> let ftys = Array.Fun1.map mk_clos e tys in let fbds = @@ -1028,7 +1279,7 @@ and norm_head info tab m = | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ - | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ -> term_of_fconstr m + | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ | FInt _ -> term_of_fconstr m (* Initialization and then normalization *) @@ -1040,9 +1291,7 @@ let whd_val info tab v = let norm_val info tab v = with_stats (lazy (kl info tab v)) -let inject c = mk_clos (subs_id 0) c - -let whd_stack infos tab m stk = match m.norm with +let whd_stack infos tab m stk = match Mark.red_state m.mark with | Whnf | Norm -> (** No need to perform [kni] nor to unlock updates because every head subterm of [m] is [Whnf] or [Norm] *) @@ -1052,19 +1301,19 @@ let whd_stack infos tab m stk = match m.norm with let () = if infos.i_cache.i_share then ignore (fapp_stack k) in (* to unlock Zupdates! *) k -(* cache of constants: the body is computed only when needed. *) -type clos_infos = fconstr infos - let create_clos_infos ?(evars=fun _ -> None) flgs env = let share = (Environ.typing_flags env).Declarations.share_reduction in - create ~share ~repr:(fun _ _ c -> inject c) flgs env evars + let cache = { + i_env = env; + i_sigma = evars; + i_share = share; + } in + { i_flags = flgs; i_cache = cache } let create_tab () = KeyTable.create 17 let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env -let env_of_infos infos = infos.i_cache.i_env - let infos_with_reds infos reds = { infos with i_flags = reds } @@ -1073,9 +1322,12 @@ let unfold_reference info tab key = | ConstKey (kn,_) -> if red_set info.i_flags (fCONST kn) then ref_value_cache info tab key - else None + else Undef None | VarKey i -> if red_set info.i_flags (fVAR i) then ref_value_cache info tab key - else None - | _ -> ref_value_cache info tab key + else Undef None + | RelKey _ -> ref_value_cache info tab key + +let relevance_of f = Mark.relevance f.mark +let set_relevance r f = f.mark <- Mark.mark (Mark.red_state f.mark) (opt_of_rel r) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 2a018d172a..b1b69dded8 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -10,6 +10,7 @@ open Names open Constr +open Declarations open Environ open Esubst @@ -24,14 +25,6 @@ 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 *) - - -val all_opaque : transparent_state -val all_transparent : transparent_state - -val is_transparent_variable : transparent_state -> variable -> bool -val is_transparent_constant : transparent_state -> Constant.t -> bool - (** Sets of reduction kinds. *) module type RedFlagsSig = sig type reds @@ -60,10 +53,10 @@ module type RedFlagsSig = sig val red_sub : reds -> red_kind -> reds (** Adds a reduction kind to a set *) - val red_add_transparent : reds -> transparent_state -> reds + val red_add_transparent : reds -> TransparentState.t -> reds (** Retrieve the transparent state of the reduction flags *) - val red_transparent : reds -> transparent_state + val red_transparent : reds -> TransparentState.t (** Build a reduction set from scratch = iter [red_add] on [no_red] *) val mkflags : red_kind list -> reds @@ -98,25 +91,7 @@ val unfold_red : evaluable_global_reference -> reds (***********************************************************************) type table_key = Constant.t Univ.puniverses tableKey -type 'a infos_cache -type 'a infos_tab -type 'a infos = { - i_flags : reds; - i_cache : 'a infos_cache } - -val ref_value_cache: 'a infos -> 'a infos_tab -> table_key -> 'a option -val create: - repr:('a infos -> 'a infos_tab -> constr -> 'a) -> - share:bool -> - reds -> - env -> - (existential -> constr option) -> - 'a infos -val create_tab : unit -> 'a infos_tab -val evar_value : 'a infos_cache -> existential -> constr option - -val info_env : 'a infos -> env -val info_flags: 'a infos -> reds +module KeyTable : Hashtbl.S with type key = table_key (*********************************************************************** s Lazy reduction. *) @@ -139,24 +114,27 @@ type fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * fconstr - | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs + | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs + | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs + | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs + | FInt of Uint63.t | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED (*********************************************************************** s A [stack] is a context of arguments, arguments are pushed by - [append_stack] one array at a time but popped with [decomp_stack] - one by one *) + [append_stack] one array at a time *) +type 'a next_native_args = (CPrimitives.arg_kind * 'a) list type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of Projection.Repr.t | Zfix of fconstr * stack + | Zprimitive of CPrimitives.t * pconstant * fconstr list * fconstr next_native_args + (* operator, constr def, reduced arguments rev, next arguments *) | Zshift of int | Zupdate of fconstr @@ -165,15 +143,12 @@ and stack = stack_member list val empty_stack : stack val append_stack : fconstr array -> stack -> stack -val decomp_stack : stack -> (fconstr * stack) option -val array_of_stack : stack -> fconstr array -val stack_assign : stack -> int -> fconstr -> stack +val check_native_args : CPrimitives.t -> stack -> bool +val get_native_args1 : CPrimitives.t -> pconstant -> stack -> + fconstr list * fconstr * fconstr next_native_args * stack + val stack_args_size : stack -> int -val stack_tail : int -> stack -> stack -val stack_nth : stack -> int -> fconstr -val zip_term : (fconstr -> constr) -> constr -> stack -> constr val eta_expand_stack : stack -> stack -val unfold_projection : 'a infos -> Projection.t -> stack_member option (** To lazy reduce a constr, create a [clos_infos] with [create_clos_infos], inject the term to reduce with [inject]; then use @@ -190,30 +165,40 @@ val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : - (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr + (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t Context.binder_annot * fconstr * fconstr + +type optrel = Unknown | KnownR | KnownI + +val relevance_of : fconstr -> optrel +val set_relevance : Sorts.relevance -> fconstr -> unit (** Global and local constant cache *) -type clos_infos = fconstr infos +type clos_infos +type clos_tab val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos val oracle_of_infos : clos_infos -> Conv_oracle.oracle -val env_of_infos : 'a infos -> env +val create_tab : unit -> clos_tab + +val info_env : clos_infos -> env +val info_flags: clos_infos -> reds +val unfold_projection : clos_infos -> Projection.t -> stack_member option val infos_with_reds : clos_infos -> reds -> clos_infos (** Reduction function *) (** [norm_val] is for strong normalization *) -val norm_val : clos_infos -> fconstr infos_tab -> fconstr -> constr +val norm_val : clos_infos -> clos_tab -> fconstr -> constr (** [whd_val] is for weak head normalization *) -val whd_val : clos_infos -> fconstr infos_tab -> fconstr -> constr +val whd_val : clos_infos -> clos_tab -> fconstr -> constr (** [whd_stack] performs weak head normalization in a given stack. It stops whenever a reduction is blocked. *) val whd_stack : - clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack + clos_infos -> clos_tab -> fconstr -> stack -> fconstr * stack (** [eta_expand_ind_stack env ind c s t] computes stacks correspoding to the conversion of the eta expansion of t, considered as an inhabitant @@ -230,9 +215,7 @@ val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) -val unfold_reference : clos_infos -> fconstr infos_tab -> table_key -> fconstr option - -val eq_table_key : table_key -> table_key -> bool +val unfold_reference : clos_infos -> clos_tab -> table_key -> fconstr constant_def (*********************************************************************** i This is for lazy debug *) @@ -243,9 +226,9 @@ val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array -val kni: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack -val knr: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack -val kl : clos_infos -> fconstr infos_tab -> fconstr -> constr +val kni: clos_infos -> clos_tab -> fconstr -> stack -> fconstr * stack +val knr: clos_infos -> clos_tab -> fconstr -> stack -> fconstr * stack +val kl : clos_infos -> clos_tab -> fconstr -> constr val to_constr : lift -> fconstr -> constr diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 5b91a9b572..fdc93cfa89 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -9,85 +9,147 @@ (************************************************************************) type t = - | Int31head0 - | Int31tail0 - | Int31add - | Int31sub - | Int31mul - | Int31div - | Int31mod -(* - | Int31lsr - | Int31lsl - *) - | Int31land - | Int31lor - | Int31lxor - | Int31addc - | Int31subc - | Int31addcarryc - | Int31subcarryc - | Int31mulc - | Int31diveucl - | Int31div21 - | Int31addmuldiv - | Int31eq - | Int31lt - | Int31le - | Int31compare + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC + | Int63mulc + | Int63diveucl + | Int63div21 + | Int63addMulDiv + | Int63eq + | Int63lt + | Int63le + | Int63compare + +let equal (p1 : t) (p2 : t) = + p1 == p2 let hash = function - | Int31head0 -> 1 - | Int31tail0 -> 2 - | Int31add -> 3 - | Int31sub -> 4 - | Int31mul -> 5 - | Int31div -> 6 - | Int31mod -> 7 -(* - | Int31lsr -> 8 - | Int31lsl -> 9 - *) - | Int31land -> 10 - | Int31lor -> 11 - | Int31lxor -> 12 - | Int31addc -> 13 - | Int31subc -> 14 - | Int31addcarryc -> 15 - | Int31subcarryc -> 16 - | Int31mulc -> 17 - | Int31diveucl -> 18 - | Int31div21 -> 19 - | Int31addmuldiv -> 20 - | Int31eq -> 21 - | Int31lt -> 22 - | Int31le -> 23 - | Int31compare -> 24 + | Int63head0 -> 1 + | Int63tail0 -> 2 + | Int63add -> 3 + | Int63sub -> 4 + | Int63mul -> 5 + | Int63div -> 6 + | Int63mod -> 7 + | Int63lsr -> 8 + | Int63lsl -> 9 + | Int63land -> 10 + | Int63lor -> 11 + | Int63lxor -> 12 + | Int63addc -> 13 + | Int63subc -> 14 + | Int63addCarryC -> 15 + | Int63subCarryC -> 16 + | Int63mulc -> 17 + | Int63diveucl -> 18 + | Int63div21 -> 19 + | Int63addMulDiv -> 20 + | Int63eq -> 21 + | Int63lt -> 22 + | Int63le -> 23 + | Int63compare -> 24 +(* Should match names in nativevalues.ml *) let to_string = function - | Int31head0 -> "head0" - | Int31tail0 -> "tail0" - | Int31add -> "add" - | Int31sub -> "sub" - | Int31mul -> "mul" - | Int31div -> "div" - | Int31mod -> "mod" -(* - | Int31lsr -> "l_sr" - | Int31lsl -> "l_sl" - *) - | Int31land -> "l_and" - | Int31lor -> "l_or" - | Int31lxor -> "l_xor" - | Int31addc -> "addc" - | Int31subc -> "subc" - | Int31addcarryc -> "addcarryc" - | Int31subcarryc -> "subcarryc" - | Int31mulc -> "mulc" - | Int31diveucl -> "diveucl" - | Int31div21 -> "div21" - | Int31addmuldiv -> "addmuldiv" - | Int31eq -> "eq" - | Int31lt -> "lt" - | Int31le -> "le" - | Int31compare -> "compare" + | Int63head0 -> "head0" + | Int63tail0 -> "tail0" + | Int63add -> "add" + | Int63sub -> "sub" + | Int63mul -> "mul" + | Int63div -> "div" + | Int63mod -> "rem" + | Int63lsr -> "l_sr" + | Int63lsl -> "l_sl" + | Int63land -> "l_and" + | Int63lor -> "l_or" + | Int63lxor -> "l_xor" + | Int63addc -> "addc" + | Int63subc -> "subc" + | Int63addCarryC -> "addCarryC" + | Int63subCarryC -> "subCarryC" + | Int63mulc -> "mulc" + | Int63diveucl -> "diveucl" + | Int63div21 -> "div21" + | Int63addMulDiv -> "addMulDiv" + | Int63eq -> "eq" + | Int63lt -> "lt" + | Int63le -> "le" + | Int63compare -> "compare" + +type arg_kind = + | Kparam (* not needed for the evaluation of the primitive when it reduces *) + | Kwhnf (* need to be reduced in whnf before reducing the primitive *) + | Karg (* no need to be reduced in whnf. example: [v] in [Array.set t i v] *) + +type args_red = arg_kind list + +(* Invariant only argument of type int63 or an inductive can + have kind Kwhnf *) + +let kind = function + | Int63head0 | Int63tail0 -> [Kwhnf] + + | Int63add | Int63sub | Int63mul + | Int63div | Int63mod + | Int63lsr | Int63lsl + | Int63land | Int63lor | Int63lxor + | Int63addc | Int63subc + | Int63addCarryC | Int63subCarryC | Int63mulc | Int63diveucl + | Int63eq | Int63lt | Int63le | Int63compare -> [Kwhnf; Kwhnf] + + | Int63div21 | Int63addMulDiv -> [Kwhnf; Kwhnf; Kwhnf] + +let arity = function + | Int63head0 | Int63tail0 -> 1 + | Int63add | Int63sub | Int63mul + | Int63div | Int63mod + | Int63lsr | Int63lsl + | Int63land | Int63lor | Int63lxor + | Int63addc | Int63subc + | Int63addCarryC | Int63subCarryC | Int63mulc | Int63diveucl + | Int63eq | Int63lt | Int63le + | Int63compare -> 2 + + | Int63div21 | Int63addMulDiv -> 3 + +(** Special Entries for Register **) + +type prim_ind = + | PIT_bool + | PIT_carry + | PIT_pair + | PIT_cmp + +type prim_type = + | PT_int63 + +type op_or_type = + | OT_op of t + | OT_type of prim_type + +let prim_ind_to_string = function + | PIT_bool -> "bool" + | PIT_carry -> "carry" + | PIT_pair -> "pair" + | PIT_cmp -> "cmp" + +let prim_type_to_string = function + | PT_int63 -> "int63_type" + +let op_or_type_to_string = function + | OT_op op -> to_string op + | OT_type t -> prim_type_to_string t diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index 1e99a69d2f..3f8174bd7b 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -9,33 +9,62 @@ (************************************************************************) type t = - | Int31head0 - | Int31tail0 - | Int31add - | Int31sub - | Int31mul - | Int31div - | Int31mod -(* - | Int31lsr - | Int31lsl - *) - | Int31land - | Int31lor - | Int31lxor - | Int31addc - | Int31subc - | Int31addcarryc - | Int31subcarryc - | Int31mulc - | Int31diveucl - | Int31div21 - | Int31addmuldiv - | Int31eq - | Int31lt - | Int31le - | Int31compare + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC + | Int63mulc + | Int63diveucl + | Int63div21 + | Int63addMulDiv + | Int63eq + | Int63lt + | Int63le + | Int63compare + +val equal : t -> t -> bool + +type arg_kind = + | Kparam (* not needed for the elavuation of the primitive*) + | Kwhnf (* need to be reduced in whnf before reducing the primitive *) + | Karg (* no need to be reduced in whnf *) + +type args_red = arg_kind list val hash : t -> int val to_string : t -> string + +val arity : t -> int + +val kind : t -> args_red + +(** Special Entries for Register **) + +type prim_ind = + | PIT_bool + | PIT_carry + | PIT_pair + | PIT_cmp + +type prim_type = + | PT_int63 + +type op_or_type = + | OT_op of t + | OT_type of prim_type + +val prim_ind_to_string : prim_ind -> string +val op_or_type_to_string : op_or_type -> string diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index c63795b295..7570004fe5 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -16,6 +16,7 @@ open Names open Vmvalues +open Constr module Label = struct @@ -26,7 +27,6 @@ module Label = let reset_label_counter () = counter := no end - type instruction = | Klabel of Label.t | Kacc of int @@ -59,46 +59,9 @@ type instruction = | Ksequence of bytecodes * bytecodes | Kproj of Projection.Repr.t | Kensurestackcapacity of int -(* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) - | Kaddint31 (* adds the int31 in the accu - and the one ontop of the stack *) - | Kaddcint31 (* makes the sum and keeps the carry *) - | Kaddcarrycint31 (* sum +1, keeps the carry *) - | Ksubint31 (* subtraction modulo *) - | Ksubcint31 (* subtraction, keeps the carry *) - | Ksubcarrycint31 (* subtraction -1, keeps the carry *) - | Kmulint31 (* multiplication modulo *) - | Kmulcint31 (* multiplication, result in two - int31, for exact computation *) - | Kdiv21int31 (* divides a double size integer - (represented by an int31 in the - accumulator and one on the top of - the stack) by an int31. The result - is a pair of the quotient and the - rest. - If the divisor is 0, it returns - 0. *) - | Kdivint31 (* euclidian division (returns a pair - quotient,rest) *) - | Kaddmuldivint31 (* generic operation for shifting and - cycling. Takes 3 int31 i j and s, - and returns x*2^s+y/(2^(31-s) *) - | Kcompareint31 (* unsigned comparison of int31 - cf COMPAREINT31 in - kernel/byterun/coq_interp.c - for more info *) - | Khead0int31 (* Give the numbers of 0 in head of a in31*) - | Ktail0int31 (* Give the numbers of 0 in tail of a in31 - ie low bits *) - | Kisconst of Label.t (* conditional jump *) - | Kareconst of int*Label.t (* conditional jump *) - | Kcompint31 (* dynamic compilation of int31 *) - | Kdecompint31 (* dynamic decompilation of int31 *) - | Klorint31 (* bitwise operations: or and xor *) - | Klandint31 - | Klxorint31 -(* /spiwack *) + | Kprim of CPrimitives.t * pconstant option + | Kareint of int and bytecodes = instruction list @@ -110,53 +73,6 @@ type fv_elem = type fv = fv_elem array -(* spiwack: this exception is expected to be raised by function expecting - closed terms. *) -exception NotClosed - - -module Fv_elem = -struct -type t = fv_elem - -let compare e1 e2 = match e1, e2 with -| FVnamed id1, FVnamed id2 -> Id.compare id1 id2 -| FVnamed _, (FVrel _ | FVuniv_var _ | FVevar _) -> -1 -| FVrel _, FVnamed _ -> 1 -| FVrel r1, FVrel r2 -> Int.compare r1 r2 -| FVrel _, (FVuniv_var _ | FVevar _) -> -1 -| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 -| FVuniv_var _i1, (FVnamed _ | FVrel _) -> 1 -| FVuniv_var _i1, FVevar _ -> -1 -| FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1 -| FVevar e1, FVevar e2 -> Evar.compare e1 e2 - -end - -module FvMap = Map.Make(Fv_elem) - -(*spiwack: both type have been moved from Cbytegen because I needed then - for the retroknowledge *) -type vm_env = { - size : int; (* longueur de la liste [n] *) - fv_rev : fv_elem list; (* [fvn; ... ;fv1] *) - fv_fwd : int FvMap.t; (* reverse mapping *) - } - - -type comp_env = { - arity : int; (* arity of the current function, 0 if none *) - nb_uni_stack : int ; (* number of universes on the stack, *) - (* universes are always at the bottom. *) - nb_stack : int; (* number of variables on the stack *) - in_stack : int list; (* position in the stack *) - nb_rec : int; (* number of mutually recursive functions *) - pos_rec : instruction list; (* instruction d'acces pour les variables *) - (* de point fix ou de cofix *) - offset : int; - in_env : vm_env ref (* The free variables of the expression *) - } - (* --- Pretty print *) open Pp open Util @@ -228,28 +144,10 @@ let rec pp_instr i = | Kensurestackcapacity size -> str "growstack " ++ int size - | Kaddint31 -> str "addint31" - | Kaddcint31 -> str "addcint31" - | Kaddcarrycint31 -> str "addcarrycint31" - | Ksubint31 -> str "subint31" - | Ksubcint31 -> str "subcint31" - | Ksubcarrycint31 -> str "subcarrycint31" - | Kmulint31 -> str "mulint31" - | Kmulcint31 -> str "mulcint31" - | Kdiv21int31 -> str "div21int31" - | Kdivint31 -> str "divint31" - | Kcompareint31 -> str "compareint31" - | Khead0int31 -> str "head0int31" - | Ktail0int31 -> str "tail0int31" - | Kaddmuldivint31 -> str "addmuldivint31" - | Kisconst lbl -> str "isconst " ++ int lbl - | Kareconst(n,lbl) -> str "areconst " ++ int n ++ spc () ++ int lbl - | Kcompint31 -> str "compint31" - | Kdecompint31 -> str "decompint" - | Klorint31 -> str "lorint31" - | Klandint31 -> str "landint31" - | Klxorint31 -> str "lxorint31" + | Kprim (op, id) -> str (CPrimitives.to_string op) ++ str " " ++ + (match id with Some (id,_u) -> Constant.print id | None -> str "") + | Kareint n -> str "areint " ++ int n and pp_bytecodes c = match c with diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 9c04c166a2..423e7bbe65 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -12,6 +12,7 @@ open Names open Vmvalues +open Constr module Label : sig @@ -57,48 +58,15 @@ type instruction = | Kproj of Projection.Repr.t | Kensurestackcapacity of int -(** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) - | Kaddint31 (** adds the int31 in the accu - and the one ontop of the stack *) - | Kaddcint31 (** makes the sum and keeps the carry *) - | Kaddcarrycint31 (** sum +1, keeps the carry *) - | Ksubint31 (** subtraction modulo *) - | Ksubcint31 (** subtraction, keeps the carry *) - | Ksubcarrycint31 (** subtraction -1, keeps the carry *) - | Kmulint31 (** multiplication modulo *) - | Kmulcint31 (** multiplication, result in two - int31, for exact computation *) - | Kdiv21int31 (** divides a double size integer - (represented by an int31 in the - accumulator and one on the top of - the stack) by an int31. The result - is a pair of the quotient and the - rest. - If the divisor is 0, it returns - 0. *) - | Kdivint31 (** euclidian division (returns a pair - quotient,rest) *) - | Kaddmuldivint31 (** generic operation for shifting and - cycling. Takes 3 int31 i j and s, - and returns x*2^s+y/(2^(31-s) *) - | Kcompareint31 (** unsigned comparison of int31 - cf COMPAREINT31 in - kernel/byterun/coq_interp.c - for more info *) - | Khead0int31 (** Give the numbers of 0 in head of a in31*) - | Ktail0int31 (** Give the numbers of 0 in tail of a in31 - ie low bits *) - | Kisconst of Label.t (** conditional jump *) - | Kareconst of int*Label.t (** conditional jump *) - | Kcompint31 (** dynamic compilation of int31 *) - | Kdecompint31 (** dynamix decompilation of int31 *) - | Klorint31 (** bitwise operations: or and xor *) - | Klandint31 - | Klxorint31 + | Kprim of CPrimitives.t * pconstant option + + | Kareint of int and bytecodes = instruction list +val pp_bytecodes : bytecodes -> Pp.t + type fv_elem = FVnamed of Id.t | FVrel of int @@ -107,34 +75,4 @@ type fv_elem = type fv = fv_elem array - -(** spiwack: this exception is expected to be raised by function expecting - closed terms. *) -exception NotClosed - -module FvMap : Map.S with type key = fv_elem - -(*spiwack: both type have been moved from Cbytegen because I needed them - for the retroknowledge *) -type vm_env = { - size : int; (** length of the list [n] *) - fv_rev : fv_elem list; (** [fvn; ... ;fv1] *) - fv_fwd : int FvMap.t; (** reverse mapping *) - } - - -type comp_env = { - arity : int; (* arity of the current function, 0 if none *) - nb_uni_stack : int ; (** number of universes on the stack *) - nb_stack : int; (** number of variables on the stack *) - in_stack : int list; (** position in the stack *) - nb_rec : int; (** number of mutually recursive functions *) - (** (= nbr) *) - pos_rec : instruction list; (** instruction d'acces pour les variables *) - (** de point fix ou de cofix *) - offset : int; - in_env : vm_env ref (** the variables that are accessed *) - } - -val pp_bytecodes : bytecodes -> Pp.t val pp_fv_elem : fv_elem -> Pp.t diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 73620ae578..69f004307d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -17,7 +17,6 @@ open Names open Vmvalues open Cbytecodes open Cemitcodes -open Cinstr open Clambda open Constr open Declarations @@ -97,6 +96,48 @@ open Environ (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) +module Fv_elem = +struct +type t = fv_elem + +let compare e1 e2 = match e1, e2 with +| FVnamed id1, FVnamed id2 -> Id.compare id1 id2 +| FVnamed _, (FVrel _ | FVuniv_var _ | FVevar _) -> -1 +| FVrel _, FVnamed _ -> 1 +| FVrel r1, FVrel r2 -> Int.compare r1 r2 +| FVrel _, (FVuniv_var _ | FVevar _) -> -1 +| FVuniv_var i1, FVuniv_var i2 -> Int.compare i1 i2 +| FVuniv_var _, (FVnamed _ | FVrel _) -> 1 +| FVuniv_var _, FVevar _ -> -1 +| FVevar _, (FVnamed _ | FVrel _ | FVuniv_var _) -> 1 +| FVevar e1, FVevar e2 -> Evar.compare e1 e2 + +end + +module FvMap = Map.Make(Fv_elem) + +(*spiwack: both type have been moved from Cbytegen because I needed then + for the retroknowledge *) +type vm_env = { + size : int; (* longueur de la liste [n] *) + fv_rev : fv_elem list; (* [fvn; ... ;fv1] *) + fv_fwd : int FvMap.t; (* reverse mapping *) + } + + +type comp_env = { + arity : int; (* arity of the current function, 0 if none *) + nb_uni_stack : int ; (* number of universes on the stack, *) + (* universes are always at the bottom. *) + nb_stack : int; (* number of variables on the stack *) + in_stack : int list; (* position in the stack *) + nb_rec : int; (* number of mutually recursive functions *) + pos_rec : instruction list; (* instruction d'acces pour les variables *) + (* de point fix ou de cofix *) + offset : int; + in_env : vm_env ref (* The free variables of the expression *) + } + module Config = struct let stack_threshold = 256 (* see byterun/coq_memory.h *) let stack_safety_margin = 15 @@ -391,7 +432,6 @@ let init_fun_code () = fun_code := [] (* Compilation of constructors and inductive types *) -(* Inv: arity > 0 *) (* If [tag] hits the OCaml limitation for non constant constructors, we switch to @@ -437,7 +477,7 @@ let comp_app comp_fun comp_arg cenv f args sz cont = comp_fun cenv f (sz + nargs) (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> - if nargs < 4 then + if nargs <= 4 then comp_args comp_arg cenv args sz (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) else @@ -476,15 +516,6 @@ let rec get_alias env kn = | BCalias kn' -> get_alias env kn' | _ -> kn) -(* spiwack: additional function which allow different part of compilation of the - 31-bit integers *) - -let make_areconst n else_lbl cont = - if n <= 0 then - cont - else - Kareconst (n, else_lbl)::cont - (* sz is the size of the local stack *) let rec compile_lam env cenv lam sz cont = set_max_stack_size sz; @@ -495,6 +526,8 @@ let rec compile_lam env cenv lam sz cont = | Lval v -> compile_structured_constant cenv (Const_val v) sz cont + | Luint i -> compile_structured_constant cenv (Const_uint i) sz cont + | Lproj (p,arg) -> compile_lam env cenv arg sz (Kproj p :: cont) @@ -517,7 +550,7 @@ let rec compile_lam env cenv lam sz cont = else comp_app compile_structured_constant compile_universe cenv (Const_ind ind) (Univ.Instance.to_array u) sz cont - | Lsort (Sorts.Prop | Sorts.Set as s) -> + | Lsort (Sorts.SProp | Sorts.Prop | Sorts.Set as s) -> compile_structured_constant cenv (Const_sort s) sz cont | Lsort (Sorts.Type u) -> (* We represent universes as a global constant with local universes @@ -529,10 +562,10 @@ let rec compile_lam env cenv lam sz cont = compile_fv_elem cenv (FVuniv_var idx) sz cont in if List.is_empty s then - compile_structured_constant cenv (Const_sort (Sorts.Type u)) sz cont + compile_structured_constant cenv (Const_sort (Sorts.sort_of_univ u)) sz cont else comp_app compile_structured_constant compile_get_univ cenv - (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont + (Const_sort (Sorts.sort_of_univ u)) (Array.of_list s) sz cont | Llet (_id,def,body) -> compile_lam env cenv def sz @@ -629,6 +662,17 @@ let rec compile_lam env cenv lam sz cont = compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) + | Lif(t, bt, bf) -> + let branch, cont = make_branch cont in + let lbl_true = Label.create() in + let lbl_false = Label.create() in + compile_lam env cenv t sz + (Kswitch([|lbl_true;lbl_false|],[||]) :: + Klabel lbl_false :: + compile_lam env cenv bf sz + (branch :: + Klabel lbl_true :: + compile_lam env cenv bt sz cont)) | Lcase(ci,rtbl,t,a,branches) -> let ind = ci.ci_ind in @@ -729,41 +773,9 @@ let rec compile_lam env cenv lam sz cont = let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args (compile_lam env) cenv args sz cont - | Lprim (kn, ar, op, args) -> - op_compilation env ar op kn cenv args sz cont - - | Luint v -> - (match v with - | UintVal i -> compile_structured_constant cenv (Const_b0 (Uint31.to_int i)) sz cont - | UintDigits ds -> - let nargs = Array.length ds in - if Int.equal nargs 31 then - let (escape,labeled_cont) = make_branch cont in - let else_lbl = Label.create() in - comp_args (compile_lam env) cenv ds sz - ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) - else - let code_construct cont = (* spiwack: variant of the global code_construct - which handles dynamic compilation of - integers *) - let f_cont = - let else_lbl = Label.create () in - [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); - Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] - in - let lbl = Label.create() in - fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; - Kclosure(lbl,0) :: cont - in - comp_app (fun _ _ _ cont -> code_construct cont) - (compile_lam env) cenv () ds sz cont - | UintDecomp t -> - let escape_lbl, labeled_cont = label_code cont in - compile_lam env cenv t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont)) - - -(* spiwack : compilation of constants with their arguments. - Makes a special treatment with 31-bit integer addition *) + | Lprim (kn, op, args) -> + comp_args (compile_lam env) cenv args sz (Kprim(op, kn)::cont) + and compile_get_global cenv (kn,u) sz cont = set_max_stack_size sz; if Univ.Instance.is_empty u then @@ -800,43 +812,6 @@ and compile_constant env cenv kn u args sz cont = comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) compile_arg cenv () all sz cont -(*template for n-ary operation, invariant: n>=1, - the operations does the following : - 1/ checks if all the arguments are constants (i.e. non-block values) - 2/ if they are, uses the "op" instruction to execute - 3/ if at least one is not, branches to the normal behavior: - Kgetglobal (get_alias !global_env kn) *) -and op_compilation env n op = - let code_construct cenv kn sz cont = - let f_cont = - let else_lbl = Label.create () in - Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: - op:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) - compile_get_global cenv kn sz ( - Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in - fun kn cenv args sz cont -> - let nargs = Array.length args in - if Int.equal nargs n then (*if it is a fully applied addition*) - let (escape, labeled_cont) = make_branch cont in - let else_lbl = Label.create () in - assert (n < 4); - comp_args (compile_lam env) cenv args sz - (Kisconst else_lbl::(make_areconst (n-1) else_lbl - (*Kaddint31::escape::Klabel else_lbl::Kpush::*) - (op::escape::Klabel else_lbl::Kpush:: - (* works as comp_app with nargs < 4 and non-tailcall cont*) - compile_get_global cenv kn (sz+n) (Kapply n::labeled_cont)))) - else - comp_app (fun cenv _ sz cont -> code_construct cenv kn sz cont) - (compile_lam env) cenv () args sz cont - - let is_univ_copy max u = let u = Univ.Instance.to_array u in if Array.length u = max then @@ -903,14 +878,10 @@ let compile ~fail_on_error ?universes:(universes=0) env c = fn msg; None let compile_constant_body ~fail_on_error env univs = function - | Undef _ | OpaqueDef _ -> Some BCconstant + | Undef _ | OpaqueDef _ | Primitive _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in - let instance_size = - match univs with - | Monomorphic_const _ -> 0 - | Polymorphic_const univ -> Univ.AUContext.size univ - in + let instance_size = Univ.AUContext.size (Declareops.universes_context univs) in match kind body with | Const (kn',u) when is_univ_copy instance_size u -> (* we use the canonical name of the constant*) @@ -923,41 +894,3 @@ let compile_constant_body ~fail_on_error env univs = function (* Shortcut of the previous function used during module strengthening *) let compile_alias kn = BCalias (Constant.make1 (Constant.canonical kn)) - -(*(* template compilation for 2ary operation, it probably possible - to make a generic such function with arity abstracted *) -let op2_compilation op = - let code_construct normal cont = (*kn cont =*) - let f_cont = - let else_lbl = Label.create () in - Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: - op:: Kreturn 0:: Klabel else_lbl:: - (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) - (*Kgetglobal (get_alias !global_env kn):: *) - normal:: - Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in - fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; - Kclosure(lbl, 0)::cont - in - fun normal fc _ cenv args sz cont -> - if not fc then raise Not_found else - let nargs = Array.length args in - if nargs=2 then (*if it is a fully applied addition*) - let (escape, labeled_cont) = make_branch cont in - let else_lbl = Label.create () in - comp_args compile_constr cenv args sz - (Kisconst else_lbl::(make_areconst 1 else_lbl - (*Kaddint31::escape::Klabel else_lbl::Kpush::*) - (op::escape::Klabel else_lbl::Kpush:: - (* works as comp_app with nargs = 2 and non-tailcall cont*) - (*Kgetglobal (get_alias !global_env kn):: *) - normal:: - Kapply 2::labeled_cont))) - else if nargs=0 then - code_construct normal cont - else - comp_app (fun _ _ _ cont -> code_construct normal cont) - compile_constr cenv () args sz cont *) - diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 57d3e6fc27..6a9550342c 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -20,7 +20,8 @@ val compile : fail_on_error:bool -> (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> - env -> constant_universes -> constant_def -> body_code option + env -> universes -> Constr.t Mod_subst.substituted constant_def -> + body_code option (** Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 50f5607e31..a84a7c0cf9 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -18,6 +18,7 @@ open Vmvalues open Cbytecodes open Copcodes open Mod_subst +open CPrimitives type emitcodes = String.t @@ -129,6 +130,8 @@ let out_word env b1 b2 b3 b4 = let out env opcode = out_word env opcode 0 0 0 +let is_immed i = Uint63.le (Uint63.of_int i) Uint63.maxuint31 + let out_int env n = out_word env n (n asr 8) (n asr 16) (n asr 24) @@ -198,6 +201,39 @@ let slot_for_proj_name env p = (* Emission of one instruction *) +let nocheck_prim_op = function + | Int63add -> opADDINT63 + | Int63sub -> opSUBINT63 + | Int63lt -> opLTINT63 + | Int63le -> opLEINT63 + | _ -> assert false + + +let check_prim_op = function + | Int63head0 -> opCHECKHEAD0INT63 + | Int63tail0 -> opCHECKTAIL0INT63 + | Int63add -> opCHECKADDINT63 + | Int63sub -> opCHECKSUBINT63 + | Int63mul -> opCHECKMULINT63 + | Int63div -> opCHECKDIVINT63 + | Int63mod -> opCHECKMODINT63 + | Int63lsr -> opCHECKLSRINT63 + | Int63lsl -> opCHECKLSLINT63 + | Int63land -> opCHECKLANDINT63 + | Int63lor -> opCHECKLORINT63 + | Int63lxor -> opCHECKLXORINT63 + | Int63addc -> opCHECKADDCINT63 + | Int63subc -> opCHECKSUBCINT63 + | Int63addCarryC -> opCHECKADDCARRYCINT63 + | Int63subCarryC -> opCHECKSUBCARRYCINT63 + | Int63mulc -> opCHECKMULCINT63 + | Int63diveucl -> opCHECKDIVEUCLINT63 + | Int63div21 -> opCHECKDIV21INT63 + | Int63addMulDiv -> opCHECKADDMULDIVINT63 + | Int63eq -> opCHECKEQINT63 + | Int63lt -> opCHECKLTINT63 + | Int63le -> opCHECKLEINT63 + | Int63compare -> opCHECKCOMPAREINT63 let emit_instr env = function | Klabel lbl -> define_label env lbl @@ -218,7 +254,7 @@ let emit_instr env = function | Kpush_retaddr lbl -> out env opPUSH_RETADDR; out_label env lbl | Kapply n -> - if n < 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) + if n <= 4 then out env(opAPPLY1 + n - 1) else (out env opAPPLY; out_int env n) | Kappterm(n, sz) -> if n < 4 then (out env(opAPPTERM1 + n - 1); out_int env sz) else (out env opAPPTERM; out_int env n; out_int env sz) @@ -250,7 +286,7 @@ let emit_instr env = function Array.iter (out_label_with_orig env org) lbl_bodies | Kgetglobal q -> out env opGETGLOBAL; slot_for_getglobal env q - | Kconst (Const_b0 i) -> + | Kconst (Const_b0 i) when is_immed i -> if i >= 0 && i <= 3 then out env (opCONST0 + i) else (out env opCONSTINT; out_int env i) @@ -287,32 +323,20 @@ let emit_instr env = function | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size - (* spiwack *) | Kbranch lbl -> out env opBRANCH; out_label env lbl - | Kaddint31 -> out env opADDINT31 - | Kaddcint31 -> out env opADDCINT31 - | Kaddcarrycint31 -> out env opADDCARRYCINT31 - | Ksubint31 -> out env opSUBINT31 - | Ksubcint31 -> out env opSUBCINT31 - | Ksubcarrycint31 -> out env opSUBCARRYCINT31 - | Kmulint31 -> out env opMULINT31 - | Kmulcint31 -> out env opMULCINT31 - | Kdiv21int31 -> out env opDIV21INT31 - | Kdivint31 -> out env opDIVINT31 - | Kaddmuldivint31 -> out env opADDMULDIVINT31 - | Kcompareint31 -> out env opCOMPAREINT31 - | Khead0int31 -> out env opHEAD0INT31 - | Ktail0int31 -> out env opTAIL0INT31 - | Kisconst lbl -> out env opISCONST; out_label env lbl - | Kareconst(n,lbl) -> out env opARECONST; out_int env n; out_label env lbl - | Kcompint31 -> out env opCOMPINT31 - | Kdecompint31 -> out env opDECOMPINT31 - | Klorint31 -> out env opORINT31 - | Klandint31 -> out env opANDINT31 - | Klxorint31 -> out env opXORINT31 - (*/spiwack *) - | Kstop -> - out env opSTOP + | Kprim (op,None) -> + out env (nocheck_prim_op op) + + | Kprim(op,Some (q,_u)) -> + out env (check_prim_op op); + slot_for_getglobal env q + + | Kareint 1 -> out env opISINT + | Kareint 2 -> out env opAREINT2; + + | Kstop -> out env opSTOP + + | Kareint _ -> assert false (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) @@ -337,7 +361,7 @@ let rec emit env insns remaining = match insns with emit env c remaining | Kpush :: Kgetglobal id :: c -> out env opPUSHGETGLOBAL; slot_for_getglobal env id; emit env c remaining - | Kpush :: Kconst (Const_b0 i) :: c -> + | Kpush :: Kconst (Const_b0 i) :: c when is_immed i -> if i >= 0 && i <= 3 then out env (opPUSHCONST0 + i) else (out env opPUSHCONSTINT; out_int env i); @@ -360,7 +384,7 @@ type to_patch = emitcodes * patches * fv (* Substitution *) let subst_strcst s sc = match sc with - | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ -> sc + | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ | Const_uint _ -> sc | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_reloc s ri = diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 39ddf4a047..41cc641dc8 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -1,3 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) open Names open Vmvalues open Cbytecodes diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli deleted file mode 100644 index dca1757b7d..0000000000 --- a/kernel/cinstr.mli +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -open Names -open Constr -open Vmvalues -open Cbytecodes - -(** This file defines the lambda code for the bytecode compiler. It has been -extracted from Clambda.ml because of the retroknowledge architecture. *) - -type uint = - | UintVal of Uint31.t - | UintDigits of lambda array - | UintDecomp of lambda - -and lambda = - | Lrel of Name.t * int - | Lvar of Id.t - | Levar of Evar.t * lambda array - | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda - | Lapp of lambda * lambda array - | Lconst of pconstant - | Lprim of pconstant * int (* arity *) * instruction * lambda array - | Lcase of case_info * reloc_table * lambda * lambda * lam_branches - | Lfix of (int array * int) * fix_decl - | Lcofix of int * fix_decl (* must be in eta-expanded form *) - | Lmakeblock of int * lambda array - | Lval of structured_values - | Lsort of Sorts.t - | Lind of pinductive - | Lproj of Projection.Repr.t * lambda - | Lint of int - | Luint of uint - -(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation -to be correct. Otherwise, memoization of previous evaluations will be applied -again to extra arguments (see #7333). *) - -and lam_branches = - { constant_branches : lambda array; - nonconstant_branches : (Name.t array * lambda) array } - -and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/clambda.ml b/kernel/clambda.ml index c21ce22421..a764cca354 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -5,17 +5,50 @@ open Term open Constr open Declarations open Vmvalues -open Cbytecodes -open Cinstr open Environ open Pp let pr_con sp = str(Names.Label.to_string (Constant.label sp)) +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Levar of Evar.t * lambda array + | Lprod of lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of pconstant + | Lprim of pconstant option * CPrimitives.t * lambda array + (* No check if None *) + | Lcase of case_info * reloc_table * lambda * lambda * lam_branches + | Lif of lambda * lambda * lambda + | Lfix of (int array * int) * fix_decl + | Lcofix of int * fix_decl + | Lint of int + | Lmakeblock of int * lambda array + | Luint of Uint63.t + | Lval of structured_values + | Lsort of Sorts.t + | Lind of pinductive + | Lproj of Projection.Repr.t * lambda + +(* We separate branches for constant and non-constant constructors. If the OCaml + limitation on non-constant constructors is reached, remaining branches are + stored in [extra_branches]. *) +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array } +(* extra_branches : (name array * lambda) array } *) + +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array + (** Printing **) +let pr_annot x = Name.print x.Context.binder_name + let pp_names ids = - prlist_with_sep (fun _ -> brk(1,1)) Name.print (Array.to_list ids) + prlist_with_sep (fun _ -> brk(1,1)) pr_annot (Array.to_list ids) let pp_rel name n = Name.print name ++ str "##" ++ int n @@ -24,6 +57,7 @@ let pp_sort s = match Sorts.family s with | InSet -> str "Set" | InProp -> str "Prop" + | InSProp -> str "SProp" | InType -> str "Type" let rec pp_lam lam = @@ -48,7 +82,7 @@ let rec pp_lam lam = str ")") | Llet(id,def,body) -> hov 0 (str "let " ++ - Name.print id ++ + pr_annot id ++ str ":=" ++ pp_lam def ++ str " in" ++ @@ -77,6 +111,10 @@ let rec pp_lam lam = pp_names ids ++ str " => " ++ pp_lam c) (Array.to_list branches.nonconstant_branches))) ++ cut() ++ str "end") + | Lif (t, bt, bf) -> + v 0 (str "(if " ++ pp_lam t ++ + cut () ++ str "then " ++ pp_lam bt ++ + cut() ++ str "else " ++ pp_lam bf ++ str ")") | Lfix((t,i),(lna,tl,bl)) -> let fixl = Array.mapi (fun i id -> (id,t.(i),tl.(i),bl.(i))) lna in hov 1 @@ -84,7 +122,7 @@ let rec pp_lam lam = v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> - Name.print na ++ str"/" ++ int i ++ str":" ++ + pr_annot na ++ str"/" ++ int i ++ str":" ++ pp_lam ty ++ cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ str"}") @@ -96,7 +134,7 @@ let rec pp_lam lam = v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - Name.print na ++ str":" ++ pp_lam ty ++ + pr_annot na ++ str":" ++ pp_lam ty ++ cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ str"}") | Lmakeblock(tag, args) -> @@ -104,22 +142,26 @@ let rec pp_lam lam = (str "(makeblock " ++ int tag ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") + | Luint i -> str (Uint63.to_string i) | Lval _ -> str "values" | Lsort s -> pp_sort s | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i - | Lprim((kn,_u),_ar,_op,args) -> - hov 1 - (str "(PRIM " ++ pr_con kn ++ spc() ++ - prlist_with_sep spc pp_lam (Array.to_list args) ++ - str")") + | Lprim(Some (kn,_u),_op,args) -> + hov 1 + (str "(PRIM " ++ pr_con kn ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") + | Lprim(None,op,args) -> + hov 1 + (str "(PRIM_NC " ++ str (CPrimitives.to_string op) ++ spc() ++ + prlist_with_sep spc pp_lam (Array.to_list args) ++ + str")") | Lproj(p,arg) -> hov 1 (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg ++ str ")") | Lint i -> Pp.(str "(int:" ++ int i ++ str ")") - | Luint _ -> - str "(uint)" (*s Constructors *) @@ -151,9 +193,9 @@ let shift subst = subs_shft (1, subst) (* A generic map function *) -let rec map_lam_with_binders g f n lam = +let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> lam + | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ -> lam | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') @@ -192,6 +234,11 @@ let rec map_lam_with_binders g f n lam = in if t == t' && a == a' && branches == branches' then lam else Lcase(ci,rtbl,t',a',branches') + | Lif(t,bt,bf) -> + let t' = f n t in + let bt' = f n bt in + let bf' = f n bf in + if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> let ltypes' = Array.Smart.map (f n) ltypes in let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in @@ -205,25 +252,12 @@ let rec map_lam_with_binders g f n lam = | Lmakeblock(tag,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(tag,args') - | Lprim(kn,ar,op,args) -> + | Lprim(kn,op,args) -> let args' = Array.Smart.map (f n) args in - if args == args' then lam else Lprim(kn,ar,op,args') + if args == args' then lam else Lprim(kn,op,args') | Lproj(p,arg) -> let arg' = f n arg in if arg == arg' then lam else Lproj(p,arg') - | Luint u -> - let u' = map_uint g f n u in - if u == u' then lam else Luint u' - -and map_uint _g f n u = - match u with - | UintVal _ -> u - | UintDigits(args) -> - let args' = Array.Smart.map (f n) args in - if args == args' then u else UintDigits(args') - | UintDecomp(a) -> - let a' = f n a in - if a == a' then u else UintDecomp(a') (*s Lift and substitution *) @@ -271,28 +305,58 @@ let lam_subst_args subst args = let can_subst lam = match lam with - | Lrel _ | Lvar _ | Lconst _ + | Lrel _ | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ -> true | _ -> false + +let can_merge_if bt bf = + match bt, bf with + | Llam(_idst,_), Llam(_idsf,_) -> true + | _ -> false + +let merge_if t bt bf = + let (idst,bodyt) = decompose_Llam bt in + let (idsf,bodyf) = decompose_Llam bf in + let nt = Array.length idst in + let nf = Array.length idsf in + let common,idst,idsf = + if nt = nf then idst, [||], [||] + else + if nt < nf then idst,[||], Array.sub idsf nt (nf - nt) + else idsf, Array.sub idst nf (nt - nf), [||] in + Llam(common, + Lif(lam_lift (Array.length common) t, + mkLlam idst bodyt, + mkLlam idsf bodyf)) + + let rec simplify subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst | Llet(id,def,body) -> - let def' = simplify subst def in - if can_subst def' then simplify (cons def' subst) body - else - let body' = simplify (lift subst) body in - if def == def' && body == body' then lam - else Llet(id,def',body') + let def' = simplify subst def in + if can_subst def' then simplify (cons def' subst) body + else + let body' = simplify (lift subst) body in + if def == def' && body == body' then lam + else Llet(id,def',body') | Lapp(f,args) -> - begin match simplify_app subst f subst args with + begin match simplify_app subst f subst args with | Lapp(f',args') when f == f' && args == args' -> lam | lam' -> lam' - end + end + | Lif(t,bt,bf) -> + let t' = simplify subst t in + let bt' = simplify subst bt in + let bf' = simplify subst bf in + if can_merge_if bt' bf' then merge_if t' bt' bf' + else + if t == t' && bt == bt' && bf == bf' then lam + else Lif(t',bt',bf') | _ -> map_lam_with_binders liftn simplify subst lam and simplify_app substf f substa args = @@ -332,8 +396,8 @@ and reduce_lapp substf lids body substa largs = Llet(id, a, body) | [], [] -> simplify substf body | _::_, _ -> - Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) - | [], _::_ -> simplify_app substf body substa (Array.of_list largs) + Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) + | [], _ -> simplify_app substf body substa (Array.of_list largs) @@ -352,7 +416,7 @@ let rec occurrence k kind lam = if n = k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> kind + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ -> kind | Levar (_, args) -> occurrence_args k kind args | Lprod(dom, codom) -> @@ -363,7 +427,7 @@ let rec occurrence k kind lam = occurrence (k+1) (occurrence k kind def) body | Lapp(f, args) -> occurrence_args k (occurrence k kind f) args - | Lprim(_,_,_,args) | Lmakeblock(_,args) -> + | Lprim(_,_,args) | Lmakeblock(_,args) -> occurrence_args k kind args | Lcase(_ci,_rtbl,t,a,branches) -> let kind = occurrence k (occurrence k kind t) a in @@ -374,6 +438,9 @@ let rec occurrence k kind lam = in Array.iter on_b branches.nonconstant_branches; !r + | Lif (t, bt, bf) -> + let kind = occurrence k kind t in + kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> let kind = occurrence_args k kind ltypes in @@ -381,17 +448,10 @@ let rec occurrence k kind lam = kind | Lproj(_,arg) -> occurrence k kind arg - | Luint u -> occurrence_uint k kind u and occurrence_args k kind args = Array.fold_left (occurrence k) kind args -and occurrence_uint k kind u = - match u with - | UintVal _ -> kind - | UintDigits args -> occurrence_args k kind args - | UintDecomp t -> occurrence k kind t - let occur_once lam = try let _ = occurrence 1 true lam in true with Not_found -> false @@ -439,11 +499,12 @@ let check_compilable ib = let is_value lc = match lc with - | Lval _ | Lint _ -> true + | Lval _ | Lint _ | Luint _ -> true | _ -> false let get_value lc = match lc with + | Luint i -> val_of_uint i | Lval v -> v | Lint i -> val_of_int i | _ -> raise Not_found @@ -453,7 +514,8 @@ let make_args start _end = (* Translation of constructors *) let expand_constructor tag nparams arity = - let ids = Array.make (nparams + arity) Anonymous in + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make (nparams + arity) anon in if arity = 0 then mkLlam ids (Lint tag) else let args = make_args arity 1 in @@ -491,26 +553,19 @@ let rec get_alias env kn = (* Compilation of primitive *) -let _h = Name(Id.of_string "f") +let prim kn p args = + Lprim(Some kn, p, args) -(* let expand_prim kn op arity = - let ids = Array.make arity Anonymous in + (* primitives are always Relevant *) + let ids = Array.make arity Context.anonR in let args = make_args arity 1 in Llam(ids, prim kn op args) -*) - -let compile_prim n op kn fc args = - if not fc then raise Not_found - else - Lprim(kn, n, op, args) - (* - let (nparams, arity) = CPrimitives.arity op in - let expected = nparams + arity in - if Array.length args >= expected then prim kn op args - else mkLapp (expand_prim kn op expected) args -*) +let lambda_of_prim kn op args = + let arity = CPrimitives.arity op in + if Array.length args >= arity then prim kn op args + else mkLapp (expand_prim kn op arity) args (*i Global environment *) @@ -578,7 +633,7 @@ struct construct_tbl = Hashtbl.create 111 } - let push_rel env id = Vect.push env.name_rel id + let push_rel env id = Vect.push env.name_rel id.Context.binder_name let push_rels env ids = Array.iter (push_rel env) ids @@ -628,7 +683,7 @@ let rec lambda_of_constr env c = Renv.push_rel env id; let lc = lambda_of_constr env codom in Renv.pop env; - Lprod(ld, Llam([|id|], lc)) + Lprod(ld, Llam([|id|], lc)) | Lambda _ -> let params, body = decompose_lam c in @@ -661,13 +716,6 @@ let rec lambda_of_constr env c = (* translation of the argument *) let la = lambda_of_constr env a in - let gr = GlobRef.IndRef ind in - let la = - try - Retroknowledge.get_vm_before_match_info env.global_env.retroknowledge - gr la - with Not_found -> la - in (* translation of the type *) let lt = lambda_of_constr env t in (* translation of branches *) @@ -682,7 +730,8 @@ let rec lambda_of_constr env c = match b with | Llam(ids, body) when Array.length ids = arity -> (ids, body) | _ -> - let ids = Array.make arity Anonymous in + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make arity anon in let args = make_args arity 1 in let ll = lam_lift arity b in (ids, mkLapp ll args) @@ -713,88 +762,30 @@ let rec lambda_of_constr env c = let lc = lambda_of_constr env c in Lproj (Projection.repr p,lc) + | Int i -> Luint i + and lambda_of_app env f args = match Constr.kind f with - | Const (kn,_u as c) -> - let kn = get_alias env.global_env kn in - (* spiwack: checks if there is a specific way to compile the constant - if there is not, Not_found is raised, and the function - falls back on its normal behavior *) - (try - (* We delay the compilation of arguments to avoid an exponential behavior *) - let f = Retroknowledge.get_vm_compiling_info env.global_env.retroknowledge - (GlobRef.ConstRef kn) in - let args = lambda_of_args env 0 args in - f args - with Not_found -> - let cb = lookup_constant kn env.global_env in - begin match cb.const_body with + | Const (kn,u as c) -> + let kn = get_alias env.global_env kn in + let cb = lookup_constant kn env.global_env in + begin match cb.const_body with + | Primitive op -> lambda_of_prim (kn,u) op (lambda_of_args env 0 args) | Def csubst when cb.const_inline_code -> - lambda_of_app env (Mod_subst.force_constr csubst) args + lambda_of_app env (Mod_subst.force_constr csubst) args | Def _ | OpaqueDef _ | Undef _ -> mkLapp (Lconst c) (lambda_of_args env 0 args) - end) + end | Construct (c,_) -> - let tag, nparams, arity = Renv.get_construct_info env c in - let nargs = Array.length args in - let gr = GlobRef.ConstructRef c in - if Int.equal (nparams + arity) nargs then (* fully applied *) - (* spiwack: *) - (* 1/ tries to compile the constructor in an optimal way, - it is supposed to work only if the arguments are - all fully constructed, fails with Cbytecodes.NotClosed. - it can also raise Not_found when there is no special - treatment for this constructor - for instance: tries to to compile an integer of the - form I31 D1 D2 ... D31 to [D1D2...D31] as - a processor number (a caml number actually) *) - try - try - Retroknowledge.get_vm_constant_static_info - env.global_env.retroknowledge - gr args - with NotClosed -> - (* 2/ if the arguments are not all closed (this is - expectingly (and it is currently the case) the only - reason why this exception is raised) tries to - give a clever, run-time behavior to the constructor. - Raises Not_found if there is no special treatment - for this integer. - this is done in a lazy fashion, using the constructor - Bspecial because it needs to know the continuation - and such, which can't be done at this time. - for instance, for int31: if one of the digit is - not closed, it's not impossible that the number - gets fully instanciated at run-time, thus to ensure - uniqueness of the representation in the vm - it is necessary to try and build a caml integer - during the execution *) - let rargs = Array.sub args nparams arity in - let args = lambda_of_args env nparams rargs in - Retroknowledge.get_vm_constant_dynamic_info - env.global_env.retroknowledge - gr args - with Not_found -> - (* 3/ if no special behavior is available, then the compiler - falls back to the normal behavior *) + let tag, nparams, arity = Renv.get_construct_info env c in + let nargs = Array.length args in + if nparams < nargs then (* got all parameters *) let args = lambda_of_args env nparams args in makeblock tag 0 arity args - else - let args = lambda_of_args env nparams args in - (* spiwack: tries first to apply the run-time compilation - behavior of the constructor, as in 2/ above *) - (try - (Retroknowledge.get_vm_constant_dynamic_info - env.global_env.retroknowledge - gr) args - with Not_found -> - if nparams <= nargs then (* got all parameters *) - makeblock tag 0 arity args - else (* still expecting some parameters *) - makeblock tag (nparams - nargs) arity empty_args) + else makeblock tag (nparams - nargs) arity empty_args | _ -> - let f = lambda_of_constr env f in - let args = lambda_of_args env 0 args in - mkLapp f args + let f = lambda_of_constr env f in + let args = lambda_of_args env 0 args in + mkLapp f args and lambda_of_args env start args = let nargs = Array.length args in @@ -815,50 +806,10 @@ let optimize_lambda lam = let lambda_of_constr ~optimize genv c = let env = Renv.make genv in - let ids = List.rev_map Context.Rel.Declaration.get_name (rel_context genv) in + let ids = List.rev_map Context.Rel.Declaration.get_annot (rel_context genv) in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env c in let lam = if optimize then optimize_lambda lam else lam in if !dump_lambda then Feedback.msg_debug (pp_lam lam); lam - -(** Retroknowledge, to be removed once we move to primitive machine integers *) -let compile_structured_int31 fc args = - if not fc then raise Not_found else - Luint (UintVal - (Uint31.of_int (Array.fold_left - (fun temp_i -> fun t -> match kind t with - | Construct ((_,d),_) -> 2*temp_i+d-1 - | _ -> raise NotClosed) - 0 args))) - -let dynamic_int31_compilation fc args = - if not fc then raise Not_found else - Luint (UintDigits args) - -let d0 = Lint 0 -let d1 = Lint 1 - -(* We are relying here on the tags of digits constructors *) -let digits_from_uint i = - let digits = Array.make 31 d0 in - for k = 0 to 30 do - if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then - digits.(30-k) <- d1 - done; - digits - -let int31_escape_before_match fc t = - if not fc then - raise Not_found - else - match t with - | Luint (UintVal i) -> - let digits = digits_from_uint i in - Lmakeblock (1, digits) - | Luint (UintDigits args) -> - Lmakeblock (1,args) - | Luint (UintDecomp _) -> - assert false - | _ -> Luint (UintDecomp t) diff --git a/kernel/clambda.mli b/kernel/clambda.mli index 8ff10b4549..1476bb6e45 100644 --- a/kernel/clambda.mli +++ b/kernel/clambda.mli @@ -1,31 +1,44 @@ open Names -open Cinstr +open Constr +open Vmvalues open Environ +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Levar of Evar.t * lambda array + | Lprod of lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of pconstant + | Lprim of pconstant option * CPrimitives.t * lambda array + (* No check if None *) + | Lcase of case_info * reloc_table * lambda * lambda * lam_branches + | Lif of lambda * lambda * lambda + | Lfix of (int array * int) * fix_decl + | Lcofix of int * fix_decl + | Lint of int + | Lmakeblock of int * lambda array + | Luint of Uint63.t + | Lval of structured_values + | Lsort of Sorts.t + | Lind of pinductive + | Lproj of Projection.Repr.t * lambda + +and lam_branches = + { constant_branches : lambda array; + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array } + +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array + exception TooLargeInductive of Pp.t val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda -val decompose_Llam : lambda -> Name.t array * lambda +val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda val get_alias : env -> Constant.t -> Constant.t -val compile_prim : int -> Cbytecodes.instruction -> Constr.pconstant -> bool -> lambda array -> lambda - -(** spiwack: this function contains the information needed to perform - the static compilation of int31 (trying and obtaining - a 31-bit integer in processor representation at compile time) *) -val compile_structured_int31 : bool -> Constr.t array -> lambda - -(** this function contains the information needed to perform - the dynamic compilation of int31 (trying and obtaining a - 31-bit integer in processor representation at runtime when - it failed at compile time *) -val dynamic_int31_compilation : bool -> lambda array -> lambda - -(*spiwack: compiling function to insert dynamic decompilation before - matching integers (in case they are in processor representation) *) -val int31_escape_before_match : bool -> lambda -> lambda - (** Dump the VM lambda code after compilation (for debugging purposes) *) val dump_lambda : bool ref diff --git a/kernel/constr.ml b/kernel/constr.ml index c97969c0e0..d74c96af84 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -28,6 +28,7 @@ open Util open Names open Univ +open Context type existential_key = Evar.t type metavariable = int @@ -60,6 +61,7 @@ type case_info = in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) + ci_relevance : Sorts.relevance; ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -71,7 +73,7 @@ type case_info = the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array + Name.t binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = @@ -90,9 +92,9 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr + | Prod of Name.t binder_annot * 'types * 'types + | Lambda of Name.t binder_annot * 'types * 'constr + | LetIn of Name.t binder_annot * 'constr * 'types * 'constr | App of 'constr * 'constr array | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) @@ -101,6 +103,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr + | Int of Uint63.t (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t, t, Sorts.t, Instance.t) kind_of_term @@ -126,13 +129,15 @@ let rels = let mkRel n = if 0<n && n<=16 then rels.(n-1) else Rel n (* Construct a type *) +let mkSProp = Sort Sorts.sprop let mkProp = Sort Sorts.prop let mkSet = Sort Sorts.set -let mkType u = Sort (Sorts.Type u) +let mkType u = Sort (Sorts.sort_of_univ u) let mkSort = function + | Sorts.SProp -> mkSProp | Sorts.Prop -> mkProp (* Easy sharing *) | Sorts.Set -> mkSet - | s -> Sort s + | Sorts.Type _ as 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) *) @@ -227,6 +232,15 @@ let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id +let mkRef (gr,u) = let open GlobRef in match gr with + | ConstRef c -> mkConstU (c,u) + | IndRef ind -> mkIndU (ind,u) + | ConstructRef c -> mkConstructU (c,u) + | VarRef x -> mkVar x + +(* Constructs a primitive integer *) +let mkInt i = Int i + (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -401,6 +415,12 @@ let destCoFix c = match kind c with | CoFix cofix -> cofix | _ -> raise DestKO +let destRef c = let open GlobRef in match kind c with + | Var x -> VarRef x, Univ.Instance.empty + | Const (c,u) -> ConstRef c, u + | Ind (ind,u) -> IndRef ind, u + | Construct (c,u) -> ConstructRef c, u + | _ -> raise DestKO (******************************************************************) (* Flattening and unflattening of embedded applications and casts *) @@ -426,7 +446,7 @@ let decompose_appvect c = let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc + | Construct _ | Int _) -> acc | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c @@ -446,7 +466,7 @@ let fold f acc c = match kind c with let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () + | Construct _ | Int _) -> () | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c @@ -466,7 +486,7 @@ let iter f c = match kind c with let iter_with_binders g f n c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () + | Construct _ | Int _) -> () | 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 @@ -492,7 +512,7 @@ let iter_with_binders g f n c = match kind c with let fold_constr_with_binders g f n acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc + | Construct _ | Int _) -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (_na,t,c) -> f (g n) (f n acc t) c | Lambda (_na,t,c) -> f (g n) (f n acc t) c @@ -501,12 +521,12 @@ let fold_constr_with_binders g f n acc c = | Proj (_p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in + | Fix (_,(_,tl,bl)) -> + let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in + | CoFix (_,(_,tl,bl)) -> + let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -588,7 +608,7 @@ let map_return_predicate_with_full_binders g f l ci p = let map_gen userview f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c + | Construct _ | Int _) -> c | Cast (b,k,t) -> let b' = f b in let t' = f t in @@ -653,7 +673,7 @@ let map = map_gen false let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> accu, c + | Construct _ | Int _) -> accu, c | Cast (b,k,t) -> let accu, b' = f accu b in let accu, t' = f accu t in @@ -713,7 +733,7 @@ let fold_map f accu c = match kind c with let map_with_binders g f l c0 = match kind c0 with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c0 + | Construct _ | Int _) -> c0 | Cast (c, k, t) -> let c' = f l c in let t' = f l t in @@ -766,6 +786,49 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) +(*********************) +(* Lifting *) +(*********************) + +(* The generic lifting function *) +let rec exliftn el c = + let open Esubst in + match kind c with + | Rel i -> mkRel(reloc_rel i el) + | _ -> map_with_binders el_lift exliftn el c + +(* Lifting the binding depth across k bindings *) + +let liftn n k c = + let open Esubst in + match el_liftn (pred k) (el_shft n el_id) with + | ELID -> c + | el -> exliftn el c + +let lift n = liftn n 1 + +let fold_with_full_binders g f n acc c = + let open Context.Rel.Declaration in + match kind c with + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (_,c) -> f n acc c + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + + type 'univs instance_compare_fn = GlobRef.t -> int -> 'univs -> 'univs -> bool @@ -788,6 +851,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 + | Int i1, Int i2 -> Uint63.equal i1 i2 | Sort s1, Sort s2 -> leq_sorts s1 s2 | Prod (_,t1,c1), Prod (_,t2,c2) -> eq 0 t1 t2 && leq 0 c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq 0 t1 t2 && eq 0 c1 c2 @@ -796,7 +860,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | App (c1, l1), App (c2, l2) -> let len = Array.length l1 in Int.equal len (Array.length l2) && - eq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 + leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> @@ -814,7 +878,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _), _ -> false + | CoFix _ | Int _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -989,6 +1053,8 @@ let constr_ord_int f t1 t2 = ln1 ln2 tl1 tl2 bl1 bl2 | CoFix _, _ -> -1 | _, CoFix _ -> 1 | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 + | Proj _, _ -> -1 | _, Proj _ -> 1 + | Int i1, Int i2 -> Uint63.compare i1 i2 let rec compare m n= constr_ord_int compare m n @@ -1072,9 +1138,10 @@ let hasheq t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 + | Int i1, Int i2 -> i1 == i2 | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ - | Fix _ | CoFix _), _ -> false + | Fix _ | CoFix _ | Int _), _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) @@ -1118,16 +1185,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Prod (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in - (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Name.hash na) ht hc)) + (Prod (sh_na na, t, c), combinesmall 4 (combine3 (hash_annot Name.hash na) ht hc)) | Lambda (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in - (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Name.hash na) ht hc)) + (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (hash_annot Name.hash na) ht hc)) | LetIn (na,b,t,c) -> let b, hb = sh_rec b in let t, ht = sh_rec t in let c, hc = sh_rec c in - (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Name.hash na) hb ht hc)) + (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (hash_annot Name.hash na) hb ht hc)) | App (c,l) -> let c, hc = sh_rec c in let l, hl = hash_term_array l in @@ -1135,10 +1202,6 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Evar (e,l) -> let l, hl = hash_term_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) - | Proj (p,c) -> - let c, hc = sh_rec c in - let p' = Projection.hcons p in - (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) | Const (c,u) -> let c' = sh_con c in let u', hu = sh_instance u in @@ -1155,28 +1218,35 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let p, hp = sh_rec p and c, hc = sh_rec c in let bl,hbl = hash_term_array bl in - let hbl = combine (combine hc hp) hbl in + let hbl = combine (combine hc hp) hbl in (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> - let bl,hbl = hash_term_array bl in + let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in - let fold accu na = combine (Name.hash na) accu in + let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in - (Fix (ln,(lna,tl,bl)), combinesmall 13 h) + (Fix (ln,(lna,tl,bl)), combinesmall 13 h) | CoFix(ln,(lna,tl,bl)) -> - let bl,hbl = hash_term_array bl in + let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in - let fold accu na = combine (Name.hash na) accu in + let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in - (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) + (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) | Meta n -> (t, combinesmall 15 n) | Rel n -> (t, combinesmall 16 n) + | Proj (p,c) -> + let c, hc = sh_rec c in + let p' = Projection.hcons p in + (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) + | Int i -> + let (h,l) = Uint63.to_int2 i in + (t, combinesmall 18 (combine h l)) and sh_rec t = let (y, h) = hash_term t in @@ -1222,8 +1292,6 @@ let rec hash t = | App (Cast(c, _, _),l) -> hash (mkApp (c,l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) - | Proj (p,c) -> - combinesmall 17 (combine (Projection.hash p) (hash c)) | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) | Const (c,u) -> @@ -1240,6 +1308,9 @@ let rec hash t = combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl)) | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n + | Proj (p,c) -> + combinesmall 17 (combine (Projection.hash p) (hash c)) + | Int i -> combinesmall 18 (Uint63.hash i) and hash_term_array t = Array.fold_left (fun acc t -> combine (hash t) acc) 0 t @@ -1255,6 +1326,7 @@ struct info1.style == info2.style let eq ci ci' = ci.ci_ind == ci'.ci_ind && + ci.ci_relevance == ci'.ci_relevance && Int.equal ci.ci_npar ci'.ci_npar && Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *) Array.equal Int.equal ci.ci_cstr_nargs ci'.ci_cstr_nargs && (* we use [Array.equal] on purpose *) @@ -1278,7 +1350,7 @@ struct let h3 = Array.fold_left combine 0 ci.ci_cstr_ndecls in let h4 = Array.fold_left combine 0 ci.ci_cstr_nargs in let h5 = hash_pp_info ci.ci_pp_info in - combine5 h1 h2 h3 h4 h5 + combinesmall (Sorts.relevance_hash ci.ci_relevance) (combine5 h1 h2 h3 h4 h5) end module Hcaseinfo = Hashcons.Make(CaseinfoHash) @@ -1287,6 +1359,18 @@ let case_info_hash = CaseinfoHash.hash let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate Hcaseinfo.hcons hcons_ind +module Hannotinfo = struct + type t = Name.t binder_annot + type u = Name.t -> Name.t + let hash = hash_annot Name.hash + let eq = eq_annot (fun na1 na2 -> na1 == na2) + let hashcons h {binder_name=na;binder_relevance} = + {binder_name=h na;binder_relevance} + end +module Hannot = Hashcons.Make(Hannotinfo) + +let hcons_annot = Hashcons.simple_hcons Hannot.generate Hannot.hcons Name.hcons + let hcons = hashcons (Sorts.hcons, @@ -1294,7 +1378,7 @@ let hcons = hcons_construct, hcons_ind, hcons_con, - Name.hcons, + hcons_annot, Id.hcons) (* let hcons_types = hcons_constr *) @@ -1305,3 +1389,69 @@ type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list + +(** Minimalistic constr printer, typically for debugging *) + +let debug_print_fix pr_constr ((t,i),(lna,tl,bl)) = + let open Pp in + let fixl = Array.mapi (fun i na -> (na.binder_name,t.(i),tl.(i),bl.(i))) lna in + hov 1 + (str"fix " ++ int i ++ spc() ++ str"{" ++ + v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> + Name.print na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++ + cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ + str"}") + +let pr_puniverses p u = + if Univ.Instance.is_empty u then p + else Pp.(p ++ str"(*" ++ Univ.Instance.pr Univ.Level.pr u ++ str"*)") + +let rec debug_print c = + let open Pp in + match kind c with + | Rel n -> str "#"++int n + | Meta n -> str "Meta(" ++ int n ++ str ")" + | Var id -> Id.print id + | Sort s -> Sorts.debug_print s + | Cast (c,_, t) -> hov 1 + (str"(" ++ debug_print c ++ cut() ++ + str":" ++ debug_print t ++ str")") + | Prod ({binder_name=Name id;_},t,c) -> hov 1 + (str"forall " ++ Id.print id ++ str":" ++ debug_print t ++ str"," ++ + spc() ++ debug_print c) + | Prod ({binder_name=Anonymous;_},t,c) -> hov 0 + (str"(" ++ debug_print t ++ str " ->" ++ spc() ++ + debug_print c ++ str")") + | Lambda (na,t,c) -> hov 1 + (str"fun " ++ Name.print na.binder_name ++ str":" ++ + debug_print t ++ str" =>" ++ spc() ++ debug_print c) + | LetIn (na,b,t,c) -> hov 0 + (str"let " ++ Name.print na.binder_name ++ str":=" ++ debug_print b ++ + str":" ++ brk(1,2) ++ debug_print t ++ cut() ++ + debug_print c) + | App (c,l) -> hov 1 + (str"(" ++ debug_print c ++ spc() ++ + prlist_with_sep spc debug_print (Array.to_list l) ++ str")") + | Evar (e,l) -> hov 1 + (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ + prlist_with_sep spc debug_print (Array.to_list l) ++str"}") + | Const (c,u) -> str"Cst(" ++ pr_puniverses (Constant.debug_print c) u ++ str")" + | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i) u ++ str")" + | Construct (((sp,i),j),u) -> + str"Constr(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" + | Proj (p,c) -> str"Proj(" ++ Constant.debug_print (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ debug_print c ++ str")" + | Case (_ci,p,c,bl) -> v 0 + (hv 0 (str"<"++debug_print p++str">"++ cut() ++ str"Case " ++ + debug_print c ++ str"of") ++ cut() ++ + prlist_with_sep (fun _ -> brk(1,2)) debug_print (Array.to_list bl) ++ + cut() ++ str"end") + | Fix f -> debug_print_fix debug_print f + | CoFix(i,(lna,tl,bl)) -> + let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in + hov 1 + (str"cofix " ++ int i ++ spc() ++ str"{" ++ + v 0 (prlist_with_sep spc (fun (na,ty,bd) -> + Name.print na.binder_name ++ str":" ++ debug_print ty ++ + cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ + str"}") + | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index 3c9cc96a0d..7fc57cdb8a 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -45,6 +45,7 @@ type case_info = in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) + ci_relevance : Sorts.relevance; (* relevance of the predicate (not of the inductive!) *) ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -72,6 +73,9 @@ val mkRel : int -> constr (** Constructs a Variable *) val mkVar : Id.t -> constr +(** Constructs a machine integer *) +val mkInt : Uint63.t -> constr + (** Constructs an patvar named "?n" *) val mkMeta : metavariable -> constr @@ -81,6 +85,7 @@ val mkEvar : existential -> constr (** Construct a sort *) val mkSort : Sorts.t -> types +val mkSProp : types val mkProp : types val mkSet : types val mkType : Univ.Universe.t -> types @@ -94,13 +99,13 @@ type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast val mkCast : constr * cast_kind * constr -> constr (** Constructs the product [(x:t1)t2] *) -val mkProd : Name.t * types * types -> types +val mkProd : Name.t Context.binder_annot * types * types -> types (** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *) -val mkLambda : Name.t * types * constr -> constr +val mkLambda : Name.t Context.binder_annot * types * constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) -val mkLetIn : Name.t * constr * types * constr -> constr +val mkLetIn : Name.t Context.binder_annot * constr * types * constr -> constr (** [mkApp (f, [|t1; ...; tN|]] constructs the application {%html:(f t<sub>1</sub> ... t<sub>n</sub>)%} @@ -128,6 +133,9 @@ val mkConstruct : constructor -> constr val mkConstructU : pconstructor -> constr val mkConstructUi : pinductive * int -> constr +(** Make a constant, inductive, constructor or variable. *) +val mkRef : GlobRef.t Univ.puniverses -> constr + (** Constructs a destructor of inductive type. [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] @@ -154,7 +162,7 @@ val mkCase : case_info * constr * constr * constr array -> constr where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array + Name.t Context.binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration (* The array of [int]'s tells for each component of the array of @@ -207,9 +215,9 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) - | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) - | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) + | Prod of Name.t Context.binder_annot * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) + | Lambda of Name.t Context.binder_annot * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) + | LetIn of Name.t Context.binder_annot * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: @@ -225,6 +233,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr + | Int of Uint63.t (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -290,13 +299,13 @@ val destSort : constr -> Sorts.t val destCast : constr -> constr * cast_kind * constr (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) -val destProd : types -> Name.t * types * types +val destProd : types -> Name.t Context.binder_annot * types * types (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) -val destLambda : constr -> Name.t * types * constr +val destLambda : constr -> Name.t Context.binder_annot * types * constr (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) -val destLetIn : constr -> Name.t * constr * types * constr +val destLetIn : constr -> Name.t Context.binder_annot * constr * types * constr (** Destructs an application *) val destApp : constr -> constr * constr array @@ -340,6 +349,8 @@ val destFix : constr -> fixpoint val destCoFix : constr -> cofixpoint +val destRef : constr -> GlobRef.t Univ.puniverses + (** {6 Equality} *) (** [equal a b] is true if [a] equals [b] modulo alpha, casts, @@ -378,6 +389,17 @@ type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list +(** {6 Relocation and substitution } *) + +(** [exliftn el c] lifts [c] with lifting [el] *) +val exliftn : Esubst.lift -> constr -> constr + +(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) +val liftn : int -> int -> constr -> constr + +(** [lift n c] lifts by [n] the positive indexes in [c] *) +val lift : int -> constr -> constr + (** {6 Functionals working on expressions canonically abstracted over a local context (possibly with let-ins)} *) @@ -465,6 +487,10 @@ val map_return_predicate_with_full_binders : ((constr, constr) Context.Rel.Decla val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a +val fold_with_full_binders : + (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> + 'a -> 'b -> constr -> 'b + (** [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) @@ -581,3 +607,6 @@ val case_info_hash : case_info -> int (*********************************************************************) val hcons : constr -> constr + +val debug_print : constr -> Pp.t +val debug_print_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t diff --git a/kernel/context.ml b/kernel/context.ml index 3d98381fbb..290e85294b 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -31,6 +31,27 @@ open Util open Names +type 'a binder_annot = { binder_name : 'a; binder_relevance : Sorts.relevance } + +let eq_annot eq {binder_name=na1;binder_relevance=r1} {binder_name=na2;binder_relevance=r2} = + eq na1 na2 && Sorts.relevance_equal r1 r2 + +let hash_annot h {binder_name=n;binder_relevance=r} = + Hashset.Combine.combinesmall (Sorts.relevance_hash r) (h n) + +let map_annot f {binder_name=na;binder_relevance} = + {binder_name=f na;binder_relevance} + +let make_annot x r = {binder_name=x;binder_relevance=r} + +let binder_name x = x.binder_name +let binder_relevance x = x.binder_relevance + +let annotR x = make_annot x Sorts.Relevant + +let nameR x = annotR (Name x) +let anonR = annotR Anonymous + (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel = @@ -40,13 +61,14 @@ struct struct (* local declaration *) type ('constr, 'types) pt = - | LocalAssum of Name.t * 'types (** name, type *) - | LocalDef of Name.t * 'constr * 'types (** name, value, type *) + | LocalAssum of Name.t binder_annot * 'types (** name, type *) + | LocalDef of Name.t binder_annot * 'constr * 'types (** name, value, type *) + + let get_annot = function + | LocalAssum (na,_) | LocalDef (na,_,_) -> na (** Return the name bound by a given declaration. *) - let get_name = function - | LocalAssum (na,_) - | LocalDef (na,_,_) -> na + let get_name x = (get_annot x).binder_name (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function @@ -57,11 +79,13 @@ struct let get_type = function | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty - + + let get_relevance x = (get_annot x).binder_relevance + (** Set the name that is bound by a given declaration. *) let set_name na = function - | LocalAssum (_,ty) -> LocalAssum (na, ty) - | LocalDef (_,v,ty) -> LocalDef (na, v, ty) + | LocalAssum (x,ty) -> LocalAssum ({x with binder_name=na}, ty) + | LocalDef (x,v,ty) -> LocalDef ({x with binder_name=na}, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function @@ -92,20 +116,17 @@ struct let equal eq decl1 decl2 = match decl1, decl2 with | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> - Name.equal n1 n2 && eq ty1 ty2 + eq_annot Name.equal n1 n2 && eq ty1 ty2 | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> - Name.equal n1 n2 && eq v1 v2 && eq ty1 ty2 + eq_annot Name.equal n1 n2 && eq v1 v2 && eq ty1 ty2 | _ -> false (** Map the name bound by a given declaration. *) - let map_name f = function - | LocalAssum (na, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalAssum (na', ty) - | LocalDef (na, v, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalDef (na', v, ty) + let map_name f x = + let na = get_name x in + let na' = f na in + if na == na' then x else set_name na' x (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) @@ -120,7 +141,7 @@ struct | LocalAssum (na, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (na, ty') - | LocalDef (na, v, ty) as decl -> + | LocalDef (na, v, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalDef (na, v, ty') @@ -134,6 +155,15 @@ struct let ty' = f ty in if v == v' && ty == ty' then decl else LocalDef (na, v', ty') + let map_constr_het f = function + | LocalAssum (na, ty) -> + let ty' = f ty in + LocalAssum (na, ty') + | LocalDef (na, v, ty) -> + let v' = f v in + let ty' = f ty in + LocalDef (na, v', ty') + (** Perform a given action on all terms in a given declaration. *) let iter_constr f = function | LocalAssum (_,ty) -> f ty @@ -241,13 +271,14 @@ struct struct (** local declaration *) type ('constr, 'types) pt = - | LocalAssum of Id.t * 'types (** identifier, type *) - | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) + | LocalAssum of Id.t binder_annot * 'types (** identifier, type *) + | LocalDef of Id.t binder_annot * 'constr * 'types (** identifier, value, type *) + + let get_annot = function + | LocalAssum (na,_) | LocalDef (na,_,_) -> na (** Return the identifier bound by a given declaration. *) - let get_id = function - | LocalAssum (id,_) -> id - | LocalDef (id,_,_) -> id + let get_id x = (get_annot x).binder_name (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function @@ -259,10 +290,14 @@ struct | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty + let get_relevance x = (get_annot x).binder_relevance + (** Set the identifier that is bound by a given declaration. *) - let set_id id = function - | LocalAssum (_,ty) -> LocalAssum (id, ty) - | LocalDef (_, v, ty) -> LocalDef (id, v, ty) + let set_id id = + let set x = {x with binder_name = id} in + function + | LocalAssum (x,ty) -> LocalAssum (set x, ty) + | LocalDef (x, v, ty) -> LocalDef (set x, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function @@ -293,20 +328,17 @@ struct let equal eq decl1 decl2 = match decl1, decl2 with | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> - Id.equal id1 id2 && eq ty1 ty2 + eq_annot Id.equal id1 id2 && eq ty1 ty2 | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> - Id.equal id1 id2 && eq v1 v2 && eq ty1 ty2 + eq_annot Id.equal id1 id2 && eq v1 v2 && eq ty1 ty2 | _ -> false (** Map the identifier bound by a given declaration. *) - let map_id f = function - | LocalAssum (id, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalAssum (id', ty) - | LocalDef (id, v, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalDef (id', v, ty) + let map_id f x = + let id = get_id x in + let id' = f id in + if id == id' then x else set_id id' x (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) @@ -360,15 +392,17 @@ struct let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> - LocalAssum (f na, t) + LocalAssum (map_annot f na, t) | Rel.Declaration.LocalDef (na,v,t) -> - LocalDef (f na, v, t) - - let to_rel_decl = function + LocalDef (map_annot f na, v, t) + + let to_rel_decl = + let name x = {binder_name=Name x.binder_name;binder_relevance=x.binder_relevance} in + function | LocalAssum (id,t) -> - Rel.Declaration.LocalAssum (Name id, t) + Rel.Declaration.LocalAssum (name id, t) | LocalDef (id,v,t) -> - Rel.Declaration.LocalDef (Name id,v,t) + Rel.Declaration.LocalDef (name id,v,t) end (** Named-context is represented as a list of declarations. @@ -421,7 +455,7 @@ struct gives [Var id1, Var id3]. All [idj] are supposed distinct. *) let to_instance mk l = let filter = function - | Declaration.LocalAssum (id, _) -> Some (mk id) + | Declaration.LocalAssum (id, _) -> Some (mk id.binder_name) | _ -> None in List.map_filter filter l @@ -432,8 +466,8 @@ module Compacted = module Declaration = struct type ('constr, 'types) pt = - | LocalAssum of Id.t list * 'types - | LocalDef of Id.t list * 'constr * 'types + | LocalAssum of Id.t binder_annot list * 'types + | LocalDef of Id.t binder_annot list * 'constr * 'types let map_constr f = function | LocalAssum (ids, ty) as decl -> diff --git a/kernel/context.mli b/kernel/context.mli index 2b0d36cb8c..7b67e54ba4 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -24,6 +24,27 @@ open Names +type 'a binder_annot = { binder_name : 'a; binder_relevance : Sorts.relevance } +val eq_annot : ('a -> 'a -> bool) -> 'a binder_annot -> 'a binder_annot -> bool + +val hash_annot : ('a -> int) -> 'a binder_annot -> int + +val map_annot : ('a -> 'b) -> 'a binder_annot -> 'b binder_annot + +val make_annot : 'a -> Sorts.relevance -> 'a binder_annot + +val binder_name : 'a binder_annot -> 'a +val binder_relevance : 'a binder_annot -> Sorts.relevance + +val annotR : 'a -> 'a binder_annot +(** Always Relevant *) + +val nameR : Id.t -> Name.t binder_annot +(** Relevant + Name *) + +val anonR : Name.t binder_annot +(** Relevant + Anonymous *) + (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel : @@ -32,8 +53,10 @@ sig sig (* local declaration *) type ('constr, 'types) pt = - | LocalAssum of Name.t * 'types (** name, type *) - | LocalDef of Name.t * 'constr * 'types (** name, value, type *) + | LocalAssum of Name.t binder_annot * 'types (** name, type *) + | LocalDef of Name.t binder_annot * 'constr * 'types (** name, value, type *) + + val get_annot : _ pt -> Name.t binder_annot (** Return the name bound by a given declaration. *) val get_name : ('c, 't) pt -> Name.t @@ -44,6 +67,8 @@ sig (** Return the type of the name bound by a given declaration. *) val get_type : ('c, 't) pt -> 't + val get_relevance : ('c, 't) pt -> Sorts.relevance + (** Set the name that is bound by a given declaration. *) val set_name : Name.t -> ('c, 't) pt -> ('c, 't) pt @@ -78,13 +103,16 @@ sig (** Map all terms in a given declaration. *) val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt + (** Map all terms, with an heterogeneous function. *) + val map_constr_het : ('a -> 'b) -> ('a, 'a) pt -> ('b, 'b) pt + (** Perform a given action on all terms in a given declaration. *) val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + val to_tuple : ('c, 't) pt -> Name.t binder_annot * 'c option * 't (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) val drop_body : ('c, 't) pt -> ('c, 't) pt @@ -153,8 +181,10 @@ sig module Declaration : sig type ('constr, 'types) pt = - | LocalAssum of Id.t * 'types (** identifier, type *) - | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) + | LocalAssum of Id.t binder_annot * 'types (** identifier, type *) + | LocalDef of Id.t binder_annot * 'constr * 'types (** identifier, value, type *) + + val get_annot : _ pt -> Id.t binder_annot (** Return the identifier bound by a given declaration. *) val get_id : ('c, 't) pt -> Id.t @@ -165,6 +195,8 @@ sig (** Return the type of the name bound by a given declaration. *) val get_type : ('c, 't) pt -> 't + val get_relevance : ('c, 't) pt -> Sorts.relevance + (** Set the identifier that is bound by a given declaration. *) val set_id : Id.t -> ('c, 't) pt -> ('c, 't) pt @@ -205,8 +237,8 @@ sig (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't - val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + val to_tuple : ('c, 't) pt -> Id.t binder_annot * 'c option * 't + val of_tuple : Id.t binder_annot * 'c option * 't -> ('c, 't) pt (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) val drop_body : ('c, 't) pt -> ('c, 't) pt @@ -273,8 +305,8 @@ sig module Declaration : sig type ('constr, 'types) pt = - | LocalAssum of Id.t list * 'types - | LocalDef of Id.t list * 'constr * 'types + | LocalAssum of Id.t binder_annot list * 'types + | LocalDef of Id.t binder_annot list * 'constr * 'types val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt val of_named_decl : ('c, 't) Named.Declaration.pt -> ('c, 't) pt diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index c74f2ab318..fe82353b70 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -81,20 +81,30 @@ let fold_strategy f { var_opacity; cst_opacity; _ } accu = let accu = Id.Map.fold fvar var_opacity accu in Cmap.fold fcst cst_opacity accu -let get_transp_state { var_trstate; cst_trstate; _ } = (var_trstate, cst_trstate) +let get_transp_state { var_trstate; cst_trstate; _ } = + { TransparentState.tr_var = var_trstate; tr_cst = cst_trstate } + +let dep_order l2r k1 k2 = match k1, k2 with +| RelKey _, RelKey _ -> l2r +| RelKey _, (VarKey _ | ConstKey _) -> true +| VarKey _, RelKey _ -> false +| VarKey _, VarKey _ -> l2r +| VarKey _, ConstKey _ -> true +| ConstKey _, (RelKey _ | VarKey _) -> false +| ConstKey _, ConstKey _ -> l2r (* Unfold the first constant only if it is "more transparent" than the second one. In case of tie, use the recommended default. *) let oracle_order f o l2r k1 k2 = match get_strategy o f k1, get_strategy o f k2 with - | Expand, Expand -> l2r + | Expand, Expand -> dep_order l2r k1 k2 | Expand, (Opaque | Level _) -> true | (Opaque | Level _), Expand -> false - | Opaque, Opaque -> l2r + | Opaque, Opaque -> dep_order l2r k1 k2 | Level _, Opaque -> true | Opaque, Level _ -> false | Level n1, Level n2 -> - if Int.equal n1 n2 then l2r + if Int.equal n1 n2 then dep_order l2r k1 k2 else n1 < n2 let get_strategy o = get_strategy o (fun x -> x) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 67add5dd35..bc06cc21b6 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -41,5 +41,5 @@ val set_strategy : oracle -> Constant.t tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) val fold_strategy : (Constant.t tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a -val get_transp_state : oracle -> transparent_state +val get_transp_state : oracle -> TransparentState.t diff --git a/kernel/cooking.ml b/kernel/cooking.ml index b39aed01e8..9b974c4ecc 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -21,6 +21,7 @@ open Term open Constr open Declarations open Univ +open Context module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -134,12 +135,12 @@ let abstract_context hyps = | NamedDecl.LocalDef (id, b, t) -> let b = Vars.subst_vars subst b in let t = Vars.subst_vars subst t in - id, RelDecl.LocalDef (Name id, b, t) + id, RelDecl.LocalDef (map_annot Name.mk_name id, b, t) | NamedDecl.LocalAssum (id, t) -> let t = Vars.subst_vars subst t in - id, RelDecl.LocalAssum (Name id, t) + id, RelDecl.LocalAssum (map_annot Name.mk_name id, t) in - (decl :: ctx, id :: subst) + (decl :: ctx, id.binder_name :: subst) in Context.Named.fold_outside fold hyps ~init:([], []) @@ -155,9 +156,11 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { - cook_body : constant_def; + cook_body : constr Mod_subst.substituted constant_def; cook_type : types; - cook_universes : constant_universes; + cook_universes : universes; + cook_private_univs : Univ.ContextSet.t option; + cook_relevance : Sorts.relevance; cook_inline : inline; cook_context : Constr.named_context option; } @@ -168,6 +171,7 @@ let on_body ml hy f = function | OpaqueDef o -> OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f { Opaqueproof.modlist = ml; abstract = hy } o) + | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") let expmod_constr_subst cache modlist subst c = let subst = Univ.make_instance_subst subst in @@ -183,10 +187,10 @@ let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c = let lift_univs cb subst auctx0 = match cb.const_universes with - | Monomorphic_const ctx -> + | Monomorphic ctx -> assert (AUContext.is_empty auctx0); - subst, (Monomorphic_const ctx) - | Polymorphic_const auctx -> + subst, (Monomorphic ctx) + | Polymorphic auctx -> (** Given a named instance [subst := u₀ ... uₙ₋₁] together with an abstract context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length, and another abstract context relative to the former context @@ -200,12 +204,13 @@ let lift_univs cb subst auctx0 = *) if (Univ.Instance.is_empty subst) then (** Still need to take the union for the constraints between globals *) - subst, (Polymorphic_const (AUContext.union auctx0 auctx)) + subst, (Polymorphic (AUContext.union auctx0 auctx)) else let ainst = Univ.make_abstract_instance auctx in let subst = Instance.append subst ainst in - let auctx' = Univ.subst_univs_level_abstract_universe_context (Univ.make_instance_subst subst) auctx in - subst, (Polymorphic_const (AUContext.union auctx0 auctx')) + let substf = Univ.make_instance_subst subst in + let auctx' = Univ.subst_univs_level_abstract_universe_context substf auctx in + subst, (Polymorphic (AUContext.union auctx0 auctx')) let cook_constant ~hcons { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in @@ -229,10 +234,16 @@ let cook_constant ~hcons { from = cb; info } = hyps) hyps0 ~init:cb.const_hyps in let typ = abstract_constant_type (expmod cb.const_type) hyps in + let private_univs = Option.map (on_snd (Univ.subst_univs_level_constraints + (Univ.make_instance_subst usubst))) + cb.const_private_poly_univs + in { cook_body = body; cook_type = typ; cook_universes = univs; + cook_private_univs = private_univs; + cook_relevance = cb.const_relevance; cook_inline = cb.const_inline_code; cook_context = Some const_hyps; } diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 6ebe691b83..b0f143c47d 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -18,9 +18,11 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = { - cook_body : constant_def; + cook_body : constr Mod_subst.substituted constant_def; cook_type : types; - cook_universes : constant_universes; + cook_universes : universes; + cook_private_univs : Univ.ContextSet.t option; + cook_relevance : Sorts.relevance; cook_inline : inline; cook_context : Constr.named_context option; } diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 61fcb4832a..5551742c02 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -47,35 +47,54 @@ type inline = int option transparent body, or an opaque one *) (* Global declarations (i.e. constants) can be either: *) -type constant_def = +type 'a constant_def = | Undef of inline (** a global assumption *) - | Def of constr Mod_subst.substituted (** or a transparent global definition *) + | Def of 'a (** or a transparent global definition *) | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) + | Primitive of CPrimitives.t (** or a primitive operation *) -type constant_universes = - | Monomorphic_const of Univ.ContextSet.t - | Polymorphic_const of Univ.AUContext.t +type universes = + | Monomorphic of Univ.ContextSet.t + | Polymorphic of Univ.AUContext.t (** The [typing_flags] are instructions to the type-checker which modify its behaviour. The typing flags used in the type-checking of a constant are tracked in their {!constant_body} so that they can be displayed to the user. *) type typing_flags = { - check_guarded : bool; (** If [false] then fixed points and co-fixed - points are assumed to be total. *) - check_universes : bool; (** If [false] universe constraints are not checked *) - conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *) - share_reduction : bool; (** Use by-need reduction algorithm *) + check_guarded : bool; + (** If [false] then fixed points and co-fixed points are assumed to + be total. *) + + check_universes : bool; + (** If [false] universe constraints are not checked *) + + conv_oracle : Conv_oracle.oracle; + (** Unfolding strategies for conversion *) + + share_reduction : bool; + (** Use by-need reduction algorithm *) + + enable_VM : bool; + (** If [false], all VM conversions fall back to interpreted ones *) + + enable_native_compiler : bool; + (** If [false], all native conversions fall back to VM ones *) + + indices_matter: bool; + (** The universe of an inductive type must be above that of its indices. *) } (* some contraints are in constant_constraints, some other may be in * the OpaqueDef *) type constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) - const_body : constant_def; + const_body : Constr.t Mod_subst.substituted constant_def; const_type : types; + const_relevance : Sorts.relevance; const_body_code : Cemitcodes.to_patch_substituted option; - const_universes : constant_universes; + const_universes : universes; + const_private_poly_univs : Univ.ContextSet.t option; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which were used for @@ -115,7 +134,7 @@ v} type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Label.t array * types array) array +| PrimRecord of (Id.t * Label.t array * Sorts.relevance array * types array) array type regular_inductive_arity = { mind_user_arity : types; @@ -148,7 +167,7 @@ type one_inductive_body = { mind_kelim : Sorts.family list; (** List of allowed elimination sorts *) - mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) + mind_nf_lc : (rel_context * types) array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) mind_consnrealargs : int array; (** Number of expected proper arguments of the constructors (w/o params) *) @@ -158,6 +177,8 @@ type one_inductive_body = { mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *) + mind_relevance : Sorts.relevance; + (** {8 Datas for bytecode compilation } *) mind_nb_constant : int; (** number of constant constructor *) @@ -167,11 +188,6 @@ type one_inductive_body = { mind_reloc_tbl : Vmvalues.reloc_table; } -type abstract_inductive_universes = - | Monomorphic_ind of Univ.ContextSet.t - | Polymorphic_ind of Univ.AUContext.t - | Cumulative_ind of Univ.ACumulativityInfo.t - type recursivity_kind = | Finite (** = inductive *) | CoFinite (** = coinductive *) @@ -195,7 +211,9 @@ type mutual_inductive_body = { mind_params_ctxt : Constr.rel_context; (** The context of parameters (includes let-in declaration) *) - mind_universes : abstract_inductive_universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) + mind_universes : universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) + + mind_variance : Univ.Variance.t array option; (** Variance info, [None] when non-cumulative. *) mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index d995786d97..de9a052096 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -22,6 +22,9 @@ let safe_flags oracle = { check_universes = true; conv_oracle = oracle; share_reduction = true; + enable_VM = true; + enable_native_compiler = true; + indices_matter = true; } (** {6 Arities } *) @@ -46,25 +49,36 @@ let hcons_template_arity ar = (* List.Smart.map (Option.Smart.map Univ.hcons_univ_level) ar.template_param_levels; *) template_level = Univ.hcons_univ ar.template_level } +let universes_context = function + | Monomorphic _ -> Univ.AUContext.empty + | Polymorphic ctx -> ctx + +let abstract_universes = function + | Entries.Monomorphic_entry ctx -> + Univ.empty_level_subst, Monomorphic ctx + | Entries.Polymorphic_entry (nas, ctx) -> + let (inst, auctx) = Univ.abstract_universes nas ctx in + let inst = Univ.make_instance_subst inst in + (inst, Polymorphic auctx) + (** {6 Constants } *) let constant_is_polymorphic cb = match cb.const_universes with - | Monomorphic_const _ -> false - | Polymorphic_const _ -> true + | Monomorphic _ -> false + | Polymorphic _ -> true + let constant_has_body cb = match cb.const_body with - | Undef _ -> false + | Undef _ | Primitive _ -> false | Def _ | OpaqueDef _ -> true let constant_polymorphic_context cb = - match cb.const_universes with - | Monomorphic_const _ -> Univ.AUContext.empty - | Polymorphic_const ctx -> ctx + universes_context cb.const_universes let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true - | Undef _ | Def _ -> false + | Undef _ | Def _ | Primitive _ -> false (** {7 Constant substitutions } *) @@ -80,7 +94,7 @@ let subst_const_type sub arity = (** No need here to check for physical equality after substitution, at least for Def due to the delayed substitution [subst_constr_subst]. *) let subst_const_def sub def = match def with - | Undef _ -> def + | Undef _ | Primitive _ -> def | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) @@ -99,6 +113,8 @@ let subst_const_body sub cb = const_body_code = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; + const_private_poly_univs = cb.const_private_poly_univs; + const_relevance = cb.const_relevance; const_inline_code = cb.const_inline_code; const_typing_flags = cb.const_typing_flags } @@ -115,23 +131,30 @@ let hcons_rel_context l = List.Smart.map hcons_rel_decl l let hcons_const_def = function | Undef inl -> Undef inl + | Primitive p -> Primitive p | Def l_constr -> let constr = force_constr l_constr in Def (from_val (Constr.hcons constr)) | OpaqueDef _ as x -> x (* hashconsed when turned indirect *) -let hcons_const_universes cbu = +let hcons_universes cbu = match cbu with - | Monomorphic_const ctx -> - Monomorphic_const (Univ.hcons_universe_context_set ctx) - | Polymorphic_const ctx -> - Polymorphic_const (Univ.hcons_abstract_universe_context ctx) + | Monomorphic ctx -> + Monomorphic (Univ.hcons_universe_context_set ctx) + | Polymorphic ctx -> + Polymorphic (Univ.hcons_abstract_universe_context ctx) + +let hcons_const_private_univs = function + | None -> None + | Some univs -> Some (Univ.hcons_universe_context_set univs) let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = Constr.hcons cb.const_type; - const_universes = hcons_const_universes cb.const_universes } + const_universes = hcons_universes cb.const_universes; + const_private_poly_univs = hcons_const_private_univs cb.const_private_poly_univs; + } (** {6 Inductive types } *) @@ -192,7 +215,7 @@ let subst_mind_packet sub mbp = mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.Smart.map (fun (ctx, c) -> Context.Rel.map (subst_mps sub) ctx, subst_mps sub c) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc; @@ -200,6 +223,7 @@ let subst_mind_packet sub mbp = mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_relevance = mbp.mind_relevance; mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } @@ -208,10 +232,10 @@ let subst_mind_record sub r = match r with | NotRecord -> NotRecord | FakeRecord -> FakeRecord | PrimRecord infos -> - let map (id, ps, pb as info) = + let map (id, ps, rs, pb as info) = let pb' = Array.Smart.map (subst_mps sub) pb in if pb' == pb then info - else (id, ps, pb') + else (id, ps, rs, pb') in let infos' = Array.Smart.map map infos in if infos' == infos then r else PrimRecord infos' @@ -227,47 +251,52 @@ let subst_mind_body sub mib = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; + mind_variance = mib.mind_variance; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } let inductive_polymorphic_context mib = - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.AUContext.empty - | Polymorphic_ind ctx -> ctx - | Cumulative_ind cumi -> Univ.ACumulativityInfo.univ_context cumi + universes_context mib.mind_universes let inductive_is_polymorphic mib = match mib.mind_universes with - | Monomorphic_ind _ -> false - | Polymorphic_ind _ctx -> true - | Cumulative_ind _cumi -> true + | Monomorphic _ -> false + | Polymorphic _ctx -> true let inductive_is_cumulative mib = - match mib.mind_universes with - | Monomorphic_ind _ -> false - | Polymorphic_ind _ctx -> false - | Cumulative_ind _cumi -> true + Option.has_some mib.mind_variance let inductive_make_projection ind mib ~proj_arg = match mib.mind_record with | NotRecord | FakeRecord -> None | PrimRecord infos -> + let _, labs, _, _ = infos.(snd ind) in Some (Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg - (pi2 infos.(snd ind)).(proj_arg)) + labs.(proj_arg)) let inductive_make_projections ind mib = match mib.mind_record with | NotRecord | FakeRecord -> None | PrimRecord infos -> + let _, labs, _, _ = infos.(snd ind) in let projs = Array.mapi (fun proj_arg lab -> Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) - (pi2 infos.(snd ind)) + labs in Some projs +let relevance_of_projection_repr mib p = + let _mind,i = Names.Projection.Repr.inductive p in + match mib.mind_record with + | NotRecord | FakeRecord -> + CErrors.anomaly ~label:"relevance_of_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,_,rs,_ = infos.(i) in + rs.(Names.Projection.Repr.arg p) + (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = @@ -283,9 +312,8 @@ let hcons_ind_arity = let hcons_mind_packet oib = let user = Array.Smart.map Constr.hcons oib.mind_user_lc in - let nf = Array.Smart.map Constr.hcons oib.mind_nf_lc in - (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *) - let nf = if Array.equal (==) user nf then user else nf in + let map (ctx, c) = Context.Rel.map Constr.hcons ctx, Constr.hcons c in + let nf = Array.Smart.map map oib.mind_nf_lc in { oib with mind_typename = Names.Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; @@ -294,17 +322,11 @@ let hcons_mind_packet oib = mind_user_lc = user; mind_nf_lc = nf } -let hcons_mind_universes miu = - match miu with - | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context_set ctx) - | Polymorphic_ind ctx -> Polymorphic_ind (Univ.hcons_abstract_universe_context ctx) - | Cumulative_ind cui -> Cumulative_ind (Univ.hcons_abstract_cumulativity_info cui) - let hcons_mind mib = { mib with mind_packets = Array.Smart.map hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; - mind_universes = hcons_mind_universes mib.mind_universes } + mind_universes = hcons_universes mib.mind_universes } (** Hashconsing of modules *) diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 35490ceef9..54a853fc81 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -15,6 +15,10 @@ open Univ (** Operations concerning types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) +val universes_context : universes -> AUContext.t + +val abstract_universes : Entries.universes_entry -> Univ.universe_level_subst * universes + (** {6 Arities} *) val map_decl_arity : ('a -> 'c) -> ('b -> 'd) -> @@ -66,6 +70,8 @@ val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj val inductive_make_projections : Names.inductive -> mutual_inductive_body -> Names.Projection.Repr.t array option +val relevance_of_projection_repr : mutual_inductive_body -> Names.Projection.Repr.t -> Sorts.relevance + (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) diff --git a/kernel/dune b/kernel/dune index a503238907..5b23a705ae 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,13 +3,26 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules_without_implementation cinstr nativeinstr) - (libraries clib config lib byterun)) + (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) + (libraries lib byterun dynlink)) + +(executable + (name genOpcodeFiles) + (modules genOpcodeFiles)) (rule (targets copcodes.ml) - (deps (:h-file byterun/coq_instruct.h) make-opcodes) - (action (run ./make_opcodes.sh %{h-file} %{targets}))) + (action (with-stdout-to %{targets} (run ./genOpcodeFiles.exe copml)))) + +(executable + (name write_uint63) + (modules write_uint63) + (libraries unix)) + +(rule + (targets uint63.ml) + (deps (:gen ./write_uint63.exe) uint63_x86.ml uint63_amd64.ml) + (action (run %{gen}))) (documentation (package coq)) @@ -18,3 +31,4 @@ ; warnings. (env (dev (flags :standard -w +a-4-44-50))) + ; (ocaml408 (flags :standard -w +a-3-4-44-50))) diff --git a/kernel/entries.ml b/kernel/entries.ml index 94248ad26b..a3d32267a7 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -16,13 +16,11 @@ open Constr constants/axioms, mutual inductive definitions, modules and module types *) +type universes_entry = + | Monomorphic_entry of Univ.ContextSet.t + | Polymorphic_entry of Name.t array * Univ.UContext.t -(** {6 Local entries } *) - -type local_entry = - | LocalDefEntry of constr - | LocalAssumEntry of constr - +type 'a in_universes_entry = 'a * universes_entry (** {6 Declaration of inductive types. } *) @@ -36,11 +34,6 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; [mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]]. *) -type inductive_universes = - | Monomorphic_ind_entry of Univ.ContextSet.t - | Polymorphic_ind_entry of Univ.UContext.t - | Cumulative_ind_entry of Univ.CumulativityInfo.t - type one_inductive_entry = { mind_entry_typename : Id.t; mind_entry_arity : constr; @@ -54,9 +47,10 @@ type mutual_inductive_entry = { record in their respective projections. Not used by the kernel. Some None: non-primitive record *) mind_entry_finite : Declarations.recursivity_kind; - mind_entry_params : (Id.t * local_entry) list; + mind_entry_params : Constr.rel_context; mind_entry_inds : one_inductive_entry list; - mind_entry_universes : inductive_universes; + mind_entry_universes : universes_entry; + mind_entry_variance : Univ.Variance.t array option; (* universe constraints and the constraints for subtyping of inductive types in the block. *) mind_entry_private : bool option; @@ -66,12 +60,6 @@ type mutual_inductive_entry = { type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation -type constant_universes_entry = - | Monomorphic_const_entry of Univ.ContextSet.t - | Polymorphic_const_entry of Univ.UContext.t - -type 'a in_constant_universes_entry = 'a * constant_universes_entry - type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) @@ -79,7 +67,7 @@ type 'a definition_entry = { (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; - const_entry_universes : constant_universes_entry; + const_entry_universes : universes_entry; const_entry_opaque : bool; const_entry_inline_code : bool } @@ -93,11 +81,18 @@ type section_def_entry = { type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Constr.named_context option * types in_constant_universes_entry * inline + Constr.named_context option * types in_universes_entry * inline + +type primitive_entry = { + prim_entry_type : types option; + prim_entry_univs : Univ.ContextSet.t; (* always monomorphic *) + prim_entry_content : CPrimitives.op_or_type; +} type 'a constant_entry = | DefinitionEntry of 'a definition_entry | ParameterEntry of parameter_entry + | PrimitiveEntry of primitive_entry (** {6 Modules } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index dffcd70282..97c9f8654a 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -59,7 +59,8 @@ type globals = { type stratification = { env_universes : UGraph.t; - env_engagement : engagement + env_engagement : engagement; + env_sprop_allowed : bool; } type val_kind = @@ -117,9 +118,11 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet }; + env_engagement = PredicativeSet; + env_sprop_allowed = false; + }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; - retroknowledge = Retroknowledge.initial_retroknowledge; + retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab } @@ -222,6 +225,10 @@ let lookup_constant kn env = let lookup_mind kn env = fst (Mindmap_env.find kn env.env_globals.env_inductives) +let mind_context env mind = + let mib = lookup_mind mind env in + Declareops.inductive_polymorphic_context mib + let lookup_mind_key kn env = Mindmap_env.find kn env.env_globals.env_inductives @@ -238,9 +245,18 @@ let is_impredicative_set env = | ImpredicativeSet -> true | _ -> false +let is_impredicative_sort env = function + | Sorts.SProp | Sorts.Prop -> true + | Sorts.Set -> is_impredicative_set env + | Sorts.Type _ -> false + +let is_impredicative_univ env u = is_impredicative_sort env (Sorts.sort_of_univ u) + let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded +let indices_matter env = env.env_typing_flags.indices_matter + let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context @@ -350,9 +366,6 @@ let map_universes f env = { env with env_stratification = { s with env_universes = f s.env_universes } } -let set_universes env u = - { env with env_stratification = { env.env_stratification with env_universes = u } } - let add_constraints c env = if Univ.Constraint.is_empty c then env else map_universes (UGraph.merge_constraints c) env @@ -383,12 +396,52 @@ let add_universes_set strict ctx g = let push_context_set ?(strict=false) ctx env = map_universes (add_universes_set strict ctx) env +let push_subgraph (levels,csts) env = + let add_subgraph g = + let newg = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) levels g in + let newg = UGraph.merge_constraints csts newg in + (if not (Univ.Constraint.is_empty csts) then + let restricted = UGraph.constraints_for ~kept:(UGraph.domain g) newg in + (if not (UGraph.check_constraints restricted g) then + CErrors.anomaly Pp.(str "Local constraints imply new transitive constraints."))); + newg + in + map_universes add_subgraph env + let set_engagement c env = (* Unsafe *) { env with env_stratification = { env.env_stratification with env_engagement = c } } +(* It's convenient to use [{flags with foo = bar}] so we're smart wrt to it. *) +let same_flags { + check_guarded; + check_universes; + conv_oracle; + indices_matter; + share_reduction; + enable_VM; + enable_native_compiler; + } alt = + check_guarded == alt.check_guarded && + check_universes == alt.check_universes && + conv_oracle == alt.conv_oracle && + indices_matter == alt.indices_matter && + share_reduction == alt.share_reduction && + enable_VM == alt.enable_VM && + enable_native_compiler == alt.enable_native_compiler +[@warning "+9"] + let set_typing_flags c env = (* Unsafe *) - { env with env_typing_flags = c } + if same_flags env.env_typing_flags c then env + else { env with env_typing_flags = c } + +let make_sprop_cumulative = map_universes UGraph.make_sprop_cumulative + +let set_allow_sprop b env = + { env with env_stratification = + { env.env_stratification with env_sprop_allowed = b } } + +let sprop_allowed env = env.env_stratification.env_sprop_allowed (* Global constants *) @@ -405,46 +458,40 @@ let add_constant_key kn cb linkinfo env = let add_constant kn cb env = add_constant_key kn cb no_link_info env -let constraints_of cb u = - match cb.const_universes with - | Monomorphic_const _ -> Univ.Constraint.empty - | Polymorphic_const ctx -> Univ.AUContext.instantiate u ctx - (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in - match cb.const_universes with - | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty - | Polymorphic_const _ctx -> - let csts = constraints_of cb u in - (subst_instance_constr u cb.const_type, csts) - -let constant_context env kn = - let cb = lookup_constant kn env in - match cb.const_universes with - | Monomorphic_const _ -> Univ.AUContext.empty - | Polymorphic_const ctx -> ctx + let uctx = Declareops.constant_polymorphic_context cb in + let csts = Univ.AUContext.instantiate u uctx in + (subst_instance_constr u cb.const_type, csts) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = + | NoBody + | Opaque + | IsPrimitive of CPrimitives.t exception NotEvaluableConst of const_evaluation_result let constant_value_and_type env (kn, u) = let cb = lookup_constant kn env in - if Declareops.constant_is_polymorphic cb then - let cst = constraints_of cb u in - let b' = match cb.const_body with - | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) - | OpaqueDef _ -> None - | Undef _ -> None - in - b', subst_instance_constr u cb.const_type, cst - else - let b' = match cb.const_body with - | Def l_body -> Some (Mod_subst.force_constr l_body) - | OpaqueDef _ -> None - | Undef _ -> None - in b', cb.const_type, Univ.Constraint.empty + let uctx = Declareops.constant_polymorphic_context cb in + let cst = Univ.AUContext.instantiate u uctx in + let b' = match cb.const_body with + | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) + | OpaqueDef _ -> None + | Undef _ | Primitive _ -> None + in + b', subst_instance_constr u cb.const_type, cst + +let body_of_constant_body env cb = + let otab = opaque_tables env in + match cb.const_body with + | Undef _ | Primitive _ -> + None + | Def c -> + Some (Mod_subst.force_constr c, Declareops.constant_polymorphic_context cb) + | OpaqueDef o -> + Some (Opaqueproof.force_proof otab o, Declareops.constant_polymorphic_context cb) (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant @@ -453,9 +500,7 @@ let constant_value_and_type env (kn, u) = (* constant_type gives the type of a constant *) let constant_type_in env (kn,u) = let cb = lookup_constant kn env in - if Declareops.constant_is_polymorphic cb then - subst_instance_constr u cb.const_type - else cb.const_type + subst_instance_constr u cb.const_type let constant_value_in env (kn,u) = let cb = lookup_constant kn env in @@ -465,6 +510,7 @@ let constant_value_in env (kn,u) = subst_instance_constr u b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) + | Primitive p -> raise (NotEvaluableConst (IsPrimitive p)) let constant_opt_value_in env cst = try Some (constant_value_in env cst) @@ -476,7 +522,13 @@ let evaluable_constant kn env = match cb.const_body with | Def _ -> true | OpaqueDef _ -> false - | Undef _ -> false + | Undef _ | Primitive _ -> false + +let is_primitive env c = + let cb = lookup_constant c env in + match cb.Declarations.const_body with + | Declarations.Primitive _ -> true + | _ -> false let polymorphic_constant cst env = Declareops.constant_is_polymorphic (lookup_constant cst env) @@ -496,7 +548,7 @@ let lookup_projection p env = match mib.mind_record with | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection") | PrimRecord infos -> - let _,_,typs = infos.(i) in + let _,_,_,typs = infos.(i) in typs.(Projection.arg p) let get_projection env ind ~proj_arg = @@ -550,28 +602,38 @@ let lookup_inductive_variables (kn,_i) env = let lookup_constructor_variables (ind,_) env = lookup_inductive_variables ind env +(* Universes *) +let constant_context env c = + let cb = lookup_constant c env in + Declareops.constant_polymorphic_context cb + +let universes_of_global env r = + let open GlobRef in + match r with + | VarRef _ -> Univ.AUContext.empty + | ConstRef c -> constant_context env c + | IndRef (mind,_) | ConstructRef ((mind,_),_) -> + let mib = lookup_mind mind env in + Declareops.inductive_polymorphic_context mib + (* Returns the list of global variables in a term *) -let vars_of_global env constr = - match kind constr with - Var id -> Id.Set.singleton id - | Const (kn, _) -> lookup_constant_variables kn env - | Ind (ind, _) -> lookup_inductive_variables ind env - | Construct (cstr, _) -> lookup_constructor_variables cstr env - (** FIXME: is Proj missing? *) - | _ -> raise Not_found +let vars_of_global env gr = + let open GlobRef in + match gr with + | VarRef id -> Id.Set.singleton id + | ConstRef kn -> lookup_constant_variables kn env + | IndRef ind -> lookup_inductive_variables ind env + | ConstructRef cstr -> lookup_constructor_variables cstr env let global_vars_set env constr = let rec filtrec acc c = - let acc = - match kind c with - | Var _ | Const _ | Ind _ | Construct _ -> - Id.Set.union (vars_of_global env c) acc - | _ -> - acc in - Constr.fold filtrec acc c + match destRef c with + | gr, _ -> + Id.Set.union (vars_of_global env gr) acc + | exception DestKO -> Constr.fold filtrec acc c in - filtrec Id.Set.empty constr + filtrec Id.Set.empty constr (* [keep_hyps env ids] keeps the part of the section context of [env] which @@ -631,6 +693,10 @@ type ('constr, 'types) punsafe_judgment = { uj_val : 'constr; uj_type : 'types } +let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } +let on_judgment_value f j = { j with uj_val = f j.uj_val } +let on_judgment_type f j = { j with uj_type = f j.uj_type } + type unsafe_judgment = (constr, types) punsafe_judgment let make_judge v tj = @@ -680,29 +746,30 @@ let remove_hyps ids check_context check_value ctxt = in fst (remove_hyps ctxt) -(*spiwack: the following functions assemble the pieces of the retroknowledge - note that the "consistent" register function is available in the module - Safetyping, Environ only synchronizes the proactive and the reactive parts*) - -open Retroknowledge - -(* lifting of the "get" functions works also for "mem"*) -let retroknowledge f env = - f env.retroknowledge - -let registered env field = - retroknowledge mem env field - -let register_one env field entry = - { env with retroknowledge = Retroknowledge.add_field env.retroknowledge field entry } - -(* [register env field entry] may register several fields when needed *) -let register env field gr = - match field with - | KInt31 Int31Type -> - let i31c = match gr with - | GlobRef.IndRef i31t -> GlobRef.ConstructRef (i31t, 1) - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type.") - in - register_one (register_one env (KInt31 Int31Constructor) i31c) field gr - | field -> register_one env field gr +(* A general request *) + +let is_polymorphic env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef c -> polymorphic_constant c env + | IndRef ind -> polymorphic_ind ind env + | ConstructRef cstr -> polymorphic_ind (inductive_of_constructor cstr) env + +let is_template_polymorphic env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef _c -> false + | IndRef ind -> template_polymorphic_ind ind env + | ConstructRef cstr -> template_polymorphic_ind (inductive_of_constructor cstr) env + +let is_type_in_type env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef c -> type_in_type_constant c env + | IndRef ind -> type_in_type_ind ind env + | ConstructRef cstr -> type_in_type_ind (inductive_of_constructor cstr) env + +let set_retroknowledge env r = { env with retroknowledge = r } diff --git a/kernel/environ.mli b/kernel/environ.mli index 55ff7ff162..8c6bc105c7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -51,7 +51,8 @@ type globals type stratification = { env_universes : UGraph.t; - env_engagement : engagement + env_engagement : engagement; + env_sprop_allowed : bool; } type named_context_val = private { @@ -96,6 +97,10 @@ val typing_flags : env -> typing_flags val is_impredicative_set : env -> bool val type_in_type : env -> bool val deactivated_guard : env -> bool +val indices_matter : env -> bool + +val is_impredicative_sort : env -> Sorts.t -> bool +val is_impredicative_univ : env -> Univ.Universe.t -> bool (** is the local context empty *) val empty_context : env -> bool @@ -155,8 +160,6 @@ val named_body : variable -> env -> constr option val fold_named_context : (env -> Constr.named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a -val set_universes : env -> UGraph.t -> env - (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : ('a -> Constr.named_declaration -> 'a) -> init:'a -> env -> 'a @@ -193,11 +196,15 @@ val type_in_type_constant : Constant.t -> env -> bool (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if - [c] is opaque and [NotEvaluableConst NoBody] if it has no - body and [NotEvaluableConst IsProj] if [c] is a projection + [c] is opaque, [NotEvaluableConst NoBody] if it has no + body, [NotEvaluableConst IsProj] if [c] is a projection, + [NotEvaluableConst (IsPrimitive p)] if [c] is primitive [p] and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = + | NoBody + | Opaque + | IsPrimitive of CPrimitives.t exception NotEvaluableConst of const_evaluation_result val constant_type : env -> Constant.t puniverses -> types constrained @@ -208,6 +215,12 @@ val constant_value_and_type : env -> Constant.t puniverses -> polymorphic *) val constant_context : env -> Constant.t -> Univ.AUContext.t +(** Returns the body of the constant if it has any, and the polymorphic context + it lives in. For monomorphic constant, the latter is empty, and for + polymorphic constants, the term contains De Bruijn universe variables that + need to be instantiated. *) +val body_of_constant_body : env -> constant_body -> (Constr.constr * Univ.AUContext.t) option + (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) @@ -215,6 +228,8 @@ val constant_value_in : env -> Constant.t puniverses -> constr val constant_type_in : env -> Constant.t puniverses -> types val constant_opt_value_in : env -> Constant.t puniverses -> constr option +val is_primitive : env -> Constant.t -> bool + (** {6 Primitive projections} *) (** Checks that the number of parameters is correct. *) @@ -232,6 +247,10 @@ val add_mind : MutInd.t -> mutual_inductive_body -> env -> env raises [Not_found] if the required path is not found *) val lookup_mind : MutInd.t -> env -> mutual_inductive_body +(** The universe context associated to the inductive, empty if not + polymorphic *) +val mind_context : env -> MutInd.t -> Univ.AUContext.t + (** New-style polymorphism *) val polymorphic_ind : inductive -> env -> bool val polymorphic_pind : pinductive -> env -> bool @@ -264,8 +283,19 @@ val push_context : ?strict:bool -> Univ.UContext.t -> env -> env val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env +val push_subgraph : Univ.ContextSet.t -> env -> env +(** [push_subgraph univs env] adds the universes and constraints in + [univs] to [env] as [push_context_set ~strict:false univs env], and + also checks that they do not imply new transitive constraints + between pre-existing universes in [env]. *) + val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env +val make_sprop_cumulative : env -> env +val set_allow_sprop : bool -> env -> env +val sprop_allowed : env -> bool + +val universes_of_global : env -> GlobRef.t -> AUContext.t (** {6 Sets of referred section variables } [global_vars_set env c] returns the list of [id]'s occurring either @@ -274,8 +304,7 @@ val set_typing_flags : typing_flags -> env -> env val global_vars_set : env -> constr -> Id.Set.t -(** the constr must be a global reference *) -val vars_of_global : env -> constr -> Id.Set.t +val vars_of_global : env -> GlobRef.t -> Id.Set.t (** closure of the input id set w.r.t. dependency *) val really_needed : env -> Id.Set.t -> Id.Set.t @@ -292,6 +321,10 @@ type ('constr, 'types) punsafe_judgment = { uj_val : 'constr; uj_type : 'types } +val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment +val on_judgment_value : ('c -> 'c) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment +val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment + type unsafe_judgment = (constr, types) punsafe_judgment val make_judge : 'constr -> 'types -> ('constr, 'types) punsafe_judgment @@ -315,15 +348,12 @@ val apply_to_hyp : named_context_val -> variable -> val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declaration) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val - - -open Retroknowledge -(** functions manipulating the retroknowledge - @author spiwack *) - -val registered : env -> field -> bool - -val register : env -> field -> GlobRef.t -> env +val is_polymorphic : env -> Names.GlobRef.t -> bool +val is_template_polymorphic : env -> GlobRef.t -> bool +val is_type_in_type : env -> GlobRef.t -> bool (** Native compiler *) val no_link_info : link_info + +(** Primitives *) +val set_retroknowledge : env -> Retroknowledge.retroknowledge -> env diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml new file mode 100644 index 0000000000..6564954dfd --- /dev/null +++ b/kernel/genOpcodeFiles.ml @@ -0,0 +1,193 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** List of opcodes. + + It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and + [copcodes.ml] files. + + If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c + with the arity of the instruction and maybe coq_tcode_of_code. +*) +let opcodes = + [| + "ACC0"; + "ACC1"; + "ACC2"; + "ACC3"; + "ACC4"; + "ACC5"; + "ACC6"; + "ACC7"; + "ACC"; + "PUSH"; + "PUSHACC0"; + "PUSHACC1"; + "PUSHACC2"; + "PUSHACC3"; + "PUSHACC4"; + "PUSHACC5"; + "PUSHACC6"; + "PUSHACC7"; + "PUSHACC"; + "POP"; + "ENVACC1"; + "ENVACC2"; + "ENVACC3"; + "ENVACC4"; + "ENVACC"; + "PUSHENVACC1"; + "PUSHENVACC2"; + "PUSHENVACC3"; + "PUSHENVACC4"; + "PUSHENVACC"; + "PUSH_RETADDR"; + "APPLY"; + "APPLY1"; + "APPLY2"; + "APPLY3"; + "APPLY4"; + "APPTERM"; + "APPTERM1"; + "APPTERM2"; + "APPTERM3"; + "RETURN"; + "RESTART"; + "GRAB"; + "GRABREC"; + "CLOSURE"; + "CLOSUREREC"; + "CLOSURECOFIX"; + "OFFSETCLOSUREM2"; + "OFFSETCLOSURE0"; + "OFFSETCLOSURE2"; + "OFFSETCLOSURE"; + "PUSHOFFSETCLOSUREM2"; + "PUSHOFFSETCLOSURE0"; + "PUSHOFFSETCLOSURE2"; + "PUSHOFFSETCLOSURE"; + "GETGLOBAL"; + "PUSHGETGLOBAL"; + "MAKEBLOCK"; + "MAKEBLOCK1"; + "MAKEBLOCK2"; + "MAKEBLOCK3"; + "MAKEBLOCK4"; + "SWITCH"; + "PUSHFIELDS"; + "GETFIELD0"; + "GETFIELD1"; + "GETFIELD"; + "SETFIELD0"; + "SETFIELD1"; + "SETFIELD"; + "PROJ"; + "ENSURESTACKCAPACITY"; + "CONST0"; + "CONST1"; + "CONST2"; + "CONST3"; + "CONSTINT"; + "PUSHCONST0"; + "PUSHCONST1"; + "PUSHCONST2"; + "PUSHCONST3"; + "PUSHCONSTINT"; + "ACCUMULATE"; + "MAKESWITCHBLOCK"; + "MAKEACCU"; + "MAKEPROD"; + "BRANCH"; + "CHECKADDINT63"; + "ADDINT63"; + "CHECKADDCINT63"; + "CHECKADDCARRYCINT63"; + "CHECKSUBINT63"; + "SUBINT63"; + "CHECKSUBCINT63"; + "CHECKSUBCARRYCINT63"; + "CHECKMULINT63"; + "CHECKMULCINT63"; + "CHECKDIVINT63"; + "CHECKMODINT63"; + "CHECKDIVEUCLINT63"; + "CHECKDIV21INT63"; + "CHECKLXORINT63"; + "CHECKLORINT63"; + "CHECKLANDINT63"; + "CHECKLSLINT63"; + "CHECKLSRINT63"; + "CHECKADDMULDIVINT63"; + "CHECKLSLINT63CONST1"; + "CHECKLSRINT63CONST1"; + "CHECKEQINT63"; + "CHECKLTINT63"; + "LTINT63"; + "CHECKLEINT63"; + "LEINT63"; + "CHECKCOMPAREINT63"; + "CHECKHEAD0INT63"; + "CHECKTAIL0INT63"; + "ISINT"; + "AREINT2"; + "STOP" + |] + +let pp_c_comment fmt = + Format.fprintf fmt "/* %a */" + +let pp_ocaml_comment fmt = + Format.fprintf fmt "(* %a *)" + +let pp_header isOcaml fmt = + Format.fprintf fmt "%a" + (fun fmt -> + (if isOcaml then pp_ocaml_comment else pp_c_comment) fmt + Format.pp_print_string) + "DO NOT EDIT: automatically generated by kernel/genOpcodeFiles.ml" + +let pp_with_commas fmt k = + Array.iteri (fun n s -> + Format.fprintf fmt " %a%s@." + k s + (if n + 1 < Array.length opcodes + then "," else "") + ) opcodes + +let pp_coq_instruct_h fmt = + let line = Format.fprintf fmt "%s@." in + pp_header false fmt; + line "#pragma once"; + line "enum instructions {"; + pp_with_commas fmt Format.pp_print_string; + line "};" + +let pp_coq_jumptbl_h fmt = + pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") + +let pp_copcodes_ml fmt = + pp_header true fmt; + Array.iteri (fun n s -> + Format.fprintf fmt "let op%s = %d@.@." s n + ) opcodes + +let usage () = + Format.eprintf "usage: %s [enum|jump|copml]@." Sys.argv.(0); + exit 1 + +let main () = + match Sys.argv.(1) with + | "enum" -> pp_coq_instruct_h Format.std_formatter + | "jump" -> pp_coq_jumptbl_h Format.std_formatter + | "copml" -> pp_copcodes_ml Format.std_formatter + | _ -> usage () + | exception Invalid_argument _ -> usage () + +let () = main () diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml new file mode 100644 index 0000000000..4e6e595331 --- /dev/null +++ b/kernel/indTyping.ml @@ -0,0 +1,356 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Univ +open Term +open Constr +open Declarations +open Environ +open Entries +open Type_errors +open Context.Rel.Declaration + +(** Check name unicity. + Redundant with safe_typing's add_field checks -> to remove?. *) + +(* [check_constructors_names id s cl] checks that all the constructors names + appearing in [l] are not present in the set [s], and returns the new set + of names. The name [id] is the name of the current inductive type, used + when reporting the error. *) + +let check_constructors_names = + let rec check idset = function + | [] -> idset + | c::cl -> + if Id.Set.mem c idset then + raise (InductiveError (SameNamesConstructors c)) + else + check (Id.Set.add c idset) cl + in + check + +(* [mind_check_names mie] checks the names of an inductive types declaration, + and raises the corresponding exceptions when two types or two constructors + have the same name. *) + +let mind_check_names mie = + let rec check indset cstset = function + | [] -> () + | ind::inds -> + let id = ind.mind_entry_typename in + let cl = ind.mind_entry_consnames in + if Id.Set.mem id indset then + raise (InductiveError (SameNamesTypes id)) + else + let cstset' = check_constructors_names cstset cl in + check (Id.Set.add id indset) cstset' inds + in + check Id.Set.empty Id.Set.empty mie.mind_entry_inds +(* The above verification is not necessary from the kernel point of + vue since inductive and constructors are not referred to by their + name, but only by the name of the inductive packet and an index. *) + + +(************************************************************************) +(************************** Cumulativity checking************************) +(************************************************************************) + +(* Check arities and constructors *) +let check_subtyping_arity_constructor env subst arcn numparams is_arity = + let numchecked = ref 0 in + let basic_check ev tp = + if !numchecked < numparams then () else Reduction.conv_leq ev tp (subst tp); + numchecked := !numchecked + 1 + in + let check_typ typ typ_env = + match typ with + | LocalAssum (_, typ') -> + begin + try + basic_check typ_env typ'; Environ.push_rel typ typ_env + with Reduction.NotConvertible -> + CErrors.anomaly ~label:"bad inductive subtyping relation" + Pp.(str "Invalid subtyping relation") + end + | _ -> CErrors.anomaly Pp.(str "") + in + let typs, codom = Reduction.dest_prod env arcn in + let last_env = Context.Rel.fold_outside check_typ typs ~init:env in + if not is_arity then basic_check last_env codom else () + +let check_cumulativity univs variances env_ar params data = + let uctx = match univs with + | Monomorphic_entry _ -> raise (InductiveError BadUnivs) + | Polymorphic_entry (_,uctx) -> uctx + in + let instance = UContext.instance uctx in + if Instance.length instance != Array.length variances then raise (InductiveError BadUnivs); + let numparams = Context.Rel.nhyps params in + let new_levels = Array.init (Instance.length instance) + (fun i -> Level.(make (UGlobal.make DirPath.empty i))) + in + let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) + LMap.empty (Instance.to_array instance) new_levels + in + let dosubst = Vars.subst_univs_level_constr lmap in + let instance_other = Instance.of_array new_levels in + let constraints_other = Univ.subst_univs_level_constraints lmap (UContext.constraints uctx) in + let uctx_other = Univ.UContext.make (instance_other, constraints_other) in + let env = Environ.push_context uctx_other env_ar in + let subtyp_constraints = + Univ.enforce_leq_variance_instances variances + instance instance_other + Constraint.empty + in + let env = Environ.add_constraints subtyp_constraints env in + (* process individual inductive types: *) + List.iter (fun (arity,lc) -> + check_subtyping_arity_constructor env dosubst arity numparams true; + Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc) + data + +(************************************************************************) +(************************** Type checking *******************************) +(************************************************************************) + +type univ_info = { ind_squashed : bool; ind_has_relevant_arg : bool; + ind_min_univ : Universe.t option; (* Some for template *) + ind_univ : Universe.t } + +let check_univ_leq ?(is_real_arg=false) env u info = + let ind_univ = info.ind_univ in + let info = if not info.ind_has_relevant_arg && is_real_arg && not (Univ.Universe.is_sprop u) + then {info with ind_has_relevant_arg=true} + else info + in + (* Inductive types provide explicit lifting from SProp to other universes, so allow SProp <= any. *) + if type_in_type env || Univ.Universe.is_sprop u || UGraph.check_leq (universes env) u ind_univ + then { info with ind_min_univ = Option.map (Universe.sup u) info.ind_min_univ } + else if is_impredicative_univ env ind_univ + then if Option.is_empty info.ind_min_univ then { info with ind_squashed = true } + else raise (InductiveError BadUnivs) + else raise (InductiveError BadUnivs) + +let check_context_univs ~ctor env info ctx = + let check_one d (info,env) = + let info = match d with + | LocalAssum (_,t) -> + (* could be retyping if it becomes available in the kernel *) + let tj = Typeops.infer_type env t in + check_univ_leq ~is_real_arg:ctor env (Sorts.univ_of_sort tj.utj_type) info + | LocalDef _ -> info + in + info, push_rel d env + in + fst (Context.Rel.fold_outside ~init:(info,env) check_one ctx) + +let check_indices_matter env_params info indices = + if not (indices_matter env_params) then info + else check_context_univs ~ctor:false env_params info indices + +(* env_ar contains the inductives before the current ones in the block, and no parameters *) +let check_arity env_params env_ar ind = + let {utj_val=arity;utj_type=_} = Typeops.infer_type env_params ind.mind_entry_arity in + let indices, ind_sort = Reduction.dest_arity env_params arity in + let ind_min_univ = if ind.mind_entry_template then Some Universe.type0m else None in + let univ_info = { + ind_squashed=false; + ind_has_relevant_arg=false; + ind_min_univ; + ind_univ=Sorts.univ_of_sort ind_sort; + } + in + let univ_info = check_indices_matter env_params univ_info indices in + (* We do not need to generate the universe of the arity with params; + if later, after the validation of the inductive definition, + full_arity is used as argument or subject to cast, an upper + universe will be generated *) + let arity = it_mkProd_or_LetIn arity (Environ.rel_context env_params) in + let x = Context.make_annot (Name ind.mind_entry_typename) (Sorts.relevance_of_sort ind_sort) in + push_rel (LocalAssum (x, arity)) env_ar, + (arity, indices, univ_info) + +let check_constructor_univs env_ar_par info (args,_) = + (* We ignore the output, positivity will check that it's the expected inductive type *) + check_context_univs ~ctor:true env_ar_par info args + +let check_constructors env_ar_par isrecord params lc (arity,indices,univ_info) = + let lc = Array.map_of_list (fun c -> (Typeops.infer_type env_ar_par c).utj_val) lc in + let splayed_lc = Array.map (Reduction.dest_prod_assum env_ar_par) lc in + let univ_info = match Array.length lc with + (* Empty type: all OK *) + | 0 -> univ_info + + (* SProp primitive records are OK, if we squash and become fakerecord also OK *) + | 1 when isrecord -> univ_info + + (* Unit and identity types must squash if SProp *) + | 1 -> check_univ_leq env_ar_par Univ.Universe.type0m univ_info + + (* More than 1 constructor: must squash if Prop/SProp *) + | _ -> check_univ_leq env_ar_par Univ.Universe.type0 univ_info + in + let univ_info = Array.fold_left (check_constructor_univs env_ar_par) univ_info splayed_lc in + (* generalize the constructors over the parameters *) + let lc = Array.map (fun c -> Term.it_mkProd_or_LetIn c params) lc in + (arity, lc), (indices, splayed_lc), univ_info + +let check_record data = + List.for_all (fun (_,(_,splayed_lc),info) -> + (* records must have all projections definable -> equivalent to not being squashed *) + not info.ind_squashed + (* relevant records must have at least 1 relevant argument *) + && (Univ.Universe.is_sprop info.ind_univ + || info.ind_has_relevant_arg) + && (match splayed_lc with + (* records must have 1 constructor with at least 1 argument, and no anonymous fields *) + | [|ctx,_|] -> + let module D = Context.Rel.Declaration in + List.exists D.is_local_assum ctx && + List.for_all (fun d -> not (D.is_local_assum d) + || not (Name.is_anonymous (D.get_name d))) + ctx + | _ -> false)) + data + +(* Allowed eliminations *) + +(* Previous comment: *) +(* Unitary/empty Prop: elimination to all sorts are realizable *) +(* unless the type is large. If it is large, forbids large elimination *) +(* which otherwise allows simulating the inconsistent system Type:Type. *) +(* -> this is now handled by is_smashed: *) +(* - all_sorts in case of small, unitary Prop (not smashed) *) +(* - logical_sorts in case of large, unitary Prop (smashed) *) + +let all_sorts = [InSProp;InProp;InSet;InType] +let small_sorts = [InSProp;InProp;InSet] +let logical_sorts = [InSProp;InProp] +let sprop_sorts = [InSProp] + +let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} = + if not ind_squashed then all_sorts + else match Sorts.family (Sorts.sort_of_univ ind_univ) with + | InType -> assert false + | InSet -> small_sorts + | InProp -> logical_sorts + | InSProp -> sprop_sorts + +(* Returns the list [x_1, ..., x_n] of levels contributing to template + polymorphism. The elements x_k is None if the k-th parameter (starting + from the most recent and ignoring let-definitions) is not contributing + or is Some u_k if its level is u_k and is contributing. *) +let param_ccls paramsctxt = + let fold acc = function + | (LocalAssum (_, p)) -> + (let c = Term.strip_prod_assum p in + match kind c with + | Sort (Type u) -> Univ.Universe.level u + | _ -> None) :: acc + | LocalDef _ -> acc + in + List.fold_left fold [] paramsctxt + +let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = + let arity = Vars.subst_univs_level_constr usubst arity in + let lc = Array.map (Vars.subst_univs_level_constr usubst) lc in + let indices = Vars.subst_univs_level_context usubst indices in + let splayed_lc = Array.map (fun (args,out) -> + let args = Vars.subst_univs_level_context usubst args in + let out = Vars.subst_univs_level_constr usubst out in + args,out) + splayed_lc + in + let ind_univ = Univ.subst_univs_level_universe usubst univ_info.ind_univ in + + let arity = match univ_info.ind_min_univ with + | None -> RegularArity {mind_user_arity=arity;mind_sort=Sorts.sort_of_univ ind_univ} + | Some min_univ -> + ((match univs with + | Monomorphic _ -> () + | Polymorphic _ -> + CErrors.anomaly ~label:"polymorphic_template_ind" + Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.")); + TemplateArity {template_param_levels=param_ccls params; template_level=min_univ}) + in + + let kelim = allowed_sorts univ_info in + (arity,lc), (indices,splayed_lc), kelim + +let typecheck_inductive env (mie:mutual_inductive_entry) = + let () = match mie.mind_entry_inds with + | [] -> CErrors.anomaly Pp.(str "empty inductive types declaration.") + | _ -> () + in + (* Check unicity of names (redundant with safe_typing's add_field checks) *) + mind_check_names mie; + assert (List.is_empty (Environ.rel_context env)); + + (* universes *) + let env_univs = + match mie.mind_entry_universes with + | Monomorphic_entry ctx -> push_context_set ctx env + | Polymorphic_entry (_, ctx) -> push_context ctx env + in + + (* Params *) + let env_params, params = Typeops.check_context env_univs mie.mind_entry_params in + + (* Arities *) + let env_ar, data = List.fold_left_map (check_arity env_params) env_univs mie.mind_entry_inds in + let env_ar_par = push_rel_context params env_ar in + + (* Constructors *) + let isrecord = match mie.mind_entry_record with + | Some (Some _) -> true + | Some None | None -> false + in + let data = List.map2 (fun ind data -> + check_constructors env_ar_par isrecord params ind.mind_entry_lc data) + mie.mind_entry_inds data + in + + let record = mie.mind_entry_record in + let data, record = match record with + | None | Some None -> data, record + | Some (Some _) -> + if check_record data then + data, record + else + (* if someone tried to declare a record as SProp but it can't + be primitive we must squash. *) + let data = List.map (fun (a,b,univs) -> + a,b,check_univ_leq env_ar_par Univ.Universe.type0m univs) + data + in + data, Some None + in + + let () = match mie.mind_entry_variance with + | None -> () + | Some variances -> + check_cumulativity mie.mind_entry_universes variances env_ar params (List.map pi1 data) + in + + (* Abstract universes *) + let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in + let params = Vars.subst_univs_level_context usubst params in + let data = List.map (abstract_packets univs usubst params) data in + + let env_ar_par = + let ctx = Environ.rel_context env_ar_par in + let ctx = Vars.subst_univs_level_context usubst ctx in + let env = Environ.pop_rel_context (Environ.nb_rel env_ar_par) env_ar_par in + Environ.push_rel_context ctx env + in + + env_ar_par, univs, mie.mind_entry_variance, record, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli new file mode 100644 index 0000000000..ad51af66a2 --- /dev/null +++ b/kernel/indTyping.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Environ +open Entries +open Declarations + +(** Type checking for some inductive entry. + Returns: + - environment with inductives + parameters in rel context + - abstracted universes + - checked variance info + - record entry (checked to be OK) + - parameters + - for each inductive, + (arity * constructors) (with params) + * (indices * splayed constructor types) (both without params) + * allowed eliminations + *) +val typecheck_inductive : env -> mutual_inductive_entry -> + env + * universes * Univ.Variance.t array option + * Names.Id.t array option option + * Constr.rel_context + * ((inductive_arity * Constr.types array) * + (Constr.rel_context * (Constr.rel_context * Constr.types) array) * + Sorts.family list) + array diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index b976469ff7..009eb3da38 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -11,7 +11,6 @@ open CErrors open Util open Names -open Univ open Term open Constr open Vars @@ -20,9 +19,7 @@ open Declareops open Inductive open Environ open Reduction -open Typeops open Entries -open Pp open Context.Rel.Declaration (* Terminology: @@ -35,14 +32,6 @@ env_ar_par = env_ar + declaration of parameters nmr = ongoing computation of recursive parameters *) -(* Tell if indices (aka real arguments) contribute to size of inductive type *) -(* If yes, this is compatible with the univalent model *) - -let indices_matter = ref false - -let enforce_indices_matter () = indices_matter := true -let is_indices_matter () = !indices_matter - (* [weaker_noccur_between env n nvars t] (defined above), checks that no de Bruijn indices between [n] and [n+nvars] occur in [t]. If some such occurrences are found, then reduction is performed @@ -57,14 +46,11 @@ let weaker_noccur_between env x nvars t = if noccur_between x nvars t' then Some t' else None -let is_constructor_head t = - isRel(fst(decompose_app t)) - (************************************************************************) (* Various well-formedness check for inductive declarations *) (* Errors related to inductive constructions *) -type inductive_error = +type inductive_error = Type_errors.inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr | NotConstructor of env * Id.t * constr * constr * int * int @@ -75,339 +61,9 @@ type inductive_error = | NotAnArity of env * constr | BadEntry | LargeNonPropInductiveNotInType + | BadUnivs -exception InductiveError of inductive_error - -(* [check_constructors_names id s cl] checks that all the constructors names - appearing in [l] are not present in the set [s], and returns the new set - of names. The name [id] is the name of the current inductive type, used - when reporting the error. *) - -let check_constructors_names = - let rec check idset = function - | [] -> idset - | c::cl -> - if Id.Set.mem c idset then - raise (InductiveError (SameNamesConstructors c)) - else - check (Id.Set.add c idset) cl - in - check - -(* [mind_check_names mie] checks the names of an inductive types declaration, - and raises the corresponding exceptions when two types or two constructors - have the same name. *) - -let mind_check_names mie = - let rec check indset cstset = function - | [] -> () - | ind::inds -> - let id = ind.mind_entry_typename in - let cl = ind.mind_entry_consnames in - if Id.Set.mem id indset then - raise (InductiveError (SameNamesTypes id)) - else - let cstset' = check_constructors_names cstset cl in - check (Id.Set.add id indset) cstset' inds - in - check Id.Set.empty Id.Set.empty mie.mind_entry_inds -(* The above verification is not necessary from the kernel point of - vue since inductive and constructors are not referred to by their - name, but only by the name of the inductive packet and an index. *) - -(************************************************************************) -(************************************************************************) - -(* Typing the arities and constructor types *) - -let infos_and_sort env t = - let rec aux env t max = - let t = whd_all env t in - match kind t with - | Prod (name,c1,c2) -> - let varj = infer_type env c1 in - let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in - let max = Universe.sup max (Sorts.univ_of_sort varj.utj_type) in - aux env1 c2 max - | _ when is_constructor_head t -> max - | _ -> (* don't fail if not positive, it is tested later *) max - in aux env t Universe.type0m - -(* Computing the levels of polymorphic inductive types - - 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 that summarize all the other constraints. 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 -*) - -(* This (re)computes informations relevant to extraction and the sort of an - arity or type constructor; we do not to recompute universes constraints *) - -let infer_constructor_packet env_ar_par params lc = - (* type-check the constructors *) - let jlc = List.map (infer_type env_ar_par) lc in - let jlc = Array.of_list jlc in - (* generalize the constructor over the parameters *) - let lc'' = Array.map (fun j -> Term.it_mkProd_or_LetIn j.utj_val params) jlc in - (* compute the max of the sorts of the products of the constructors types *) - let levels = List.map (infos_and_sort env_ar_par) lc in - let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in - let level = List.fold_left (fun max l -> Universe.sup max l) min levels in - (lc'', level) - -(* If indices matter *) -let cumulate_arity_large_levels env sign = - fst (List.fold_right - (fun d (lev,env) -> - match d with - | LocalAssum (_,t) -> - let tj = infer_type env t in - let u = Sorts.univ_of_sort tj.utj_type in - (Universe.sup u lev, push_rel d env) - | LocalDef _ -> - lev, push_rel d env) - sign (Universe.type0m,env)) - -let is_impredicative env u = - is_type0m_univ u || (is_type0_univ u && is_impredicative_set env) - -(* Returns the list [x_1, ..., x_n] of levels contributing to template - polymorphism. The elements x_k is None if the k-th parameter (starting - from the most recent and ignoring let-definitions) is not contributing - or is Some u_k if its level is u_k and is contributing. *) -let param_ccls paramsctxt = - let fold acc = function - | (LocalAssum (_, p)) -> - (let c = Term.strip_prod_assum p in - match kind c with - | Sort (Type u) -> Univ.Universe.level u - | _ -> None) :: acc - | LocalDef _ -> acc - in - List.fold_left fold [] paramsctxt - -(* Check arities and constructors *) -let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : types) numparams is_arity = - let numchecked = ref 0 in - let basic_check ev tp = - if !numchecked < numparams then () else conv_leq ev tp (subst tp); - numchecked := !numchecked + 1 - in - let check_typ typ typ_env = - match typ with - | LocalAssum (_, typ') -> - begin - try - basic_check typ_env typ'; Environ.push_rel typ typ_env - with NotConvertible -> - anomaly ~label:"bad inductive subtyping relation" (Pp.str "Invalid subtyping relation") - end - | _ -> anomaly (Pp.str "") - in - let typs, codom = dest_prod env arcn in - let last_env = Context.Rel.fold_outside check_typ typs ~init:env in - if not is_arity then basic_check last_env codom else () - -(* Check that the subtyping information inferred for inductive types in the block is correct. *) -(* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) -let check_subtyping cumi paramsctxt env_ar inds = - let numparams = Context.Rel.nhyps paramsctxt in - let uctx = CumulativityInfo.univ_context cumi in - let new_levels = Array.init (UContext.size uctx) (Level.make DirPath.empty) in - let lmap = Array.fold_left2 (fun lmap u u' -> LMap.add u u' lmap) - LMap.empty (Instance.to_array @@ UContext.instance uctx) new_levels - in - let dosubst = subst_univs_level_constr lmap in - let instance_other = Instance.of_array new_levels in - let constraints_other = Univ.subst_univs_level_constraints lmap (Univ.UContext.constraints uctx) in - let uctx_other = Univ.UContext.make (instance_other, constraints_other) in - let env = Environ.push_context uctx_other env_ar in - let subtyp_constraints = - CumulativityInfo.leq_constraints cumi - (UContext.instance uctx) instance_other - Constraint.empty - in - let env = Environ.add_constraints subtyp_constraints env in - (* process individual inductive types: *) - Array.iter (fun (_id,_cn,lc,(_sign,arity)) -> - match arity with - | RegularArity (_, full_arity, _) -> - check_subtyping_arity_constructor env dosubst full_arity numparams true; - Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc - | TemplateArity _ -> - anomaly ~label:"check_subtyping" - Pp.(str "template polymorphism and cumulative polymorphism are not compatible") - ) inds - -(* Type-check an inductive definition. Does not check positivity - conditions. *) -(* TODO check that we don't overgeneralize construcors/inductive arities with - universes that are absent from them. Is it possible? -*) -let typecheck_inductive env mie = - let () = match mie.mind_entry_inds with - | [] -> anomaly (Pp.str "empty inductive types declaration.") - | _ -> () - in - (* Check unicity of names *) - mind_check_names mie; - (* Params are typed-checked here *) - let env' = - match mie.mind_entry_universes with - | Monomorphic_ind_entry ctx -> push_context_set ctx env - | Polymorphic_ind_entry ctx -> push_context ctx env - | Cumulative_ind_entry cumi -> push_context (Univ.CumulativityInfo.univ_context cumi) env - in - let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in - (* We first type arity of each inductive definition *) - (* This allows building the environment of arities and to share *) - (* the set of constraints *) - let env_arities, rev_arity_list = - List.fold_left - (fun (env_ar,l) ind -> - (* Arities (without params) are typed-checked here *) - let template = ind.mind_entry_template in - let arity = - if isArity ind.mind_entry_arity then - let (ctx,s) = dest_arity env_params ind.mind_entry_arity in - match s with - | Type u when Univ.universe_level u = None -> - (** We have an algebraic universe as the conclusion of the arity, - typecheck the dummy Π ctx, Prop and do a special case for the conclusion. - *) - let proparity = infer_type env_params (mkArity (ctx, Sorts.prop)) in - let (cctx, _) = destArity proparity.utj_val in - (* Any universe is well-formed, we don't need to check [s] here *) - mkArity (cctx, s) - | _ -> - let arity = infer_type env_params ind.mind_entry_arity in - arity.utj_val - else let arity = infer_type env_params ind.mind_entry_arity in - arity.utj_val - in - let (sign, deflev) = dest_arity env_params arity in - let inflev = - (* The level of the inductive includes levels of indices if - in indices_matter mode *) - if !indices_matter - then Some (cumulate_arity_large_levels env_params sign) - else None - in - (* We do not need to generate the universe of full_arity; if - later, after the validation of the inductive definition, - full_arity is used as argument or subject to cast, an - upper universe will be generated *) - let full_arity = it_mkProd_or_LetIn arity paramsctxt in - let id = ind.mind_entry_typename in - let env_ar' = - push_rel (LocalAssum (Name id, full_arity)) env_ar in - (* (add_constraints cst2 env_ar) in *) - (env_ar', (id,full_arity,sign @ paramsctxt,template,deflev,inflev)::l)) - (env',[]) - mie.mind_entry_inds in - - let arity_list = List.rev rev_arity_list in - - (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = push_rel_context paramsctxt env_arities in - - (* Now, we type the constructors (without params) *) - let inds = - List.fold_right2 - (fun ind arity_data inds -> - let (lc',cstrs_univ) = - infer_constructor_packet env_ar_par paramsctxt ind.mind_entry_lc in - let consnames = ind.mind_entry_consnames in - let ind' = (arity_data,consnames,lc',cstrs_univ) in - ind'::inds) - mie.mind_entry_inds - arity_list - ([]) in - - let inds = Array.of_list inds in - - (* Compute/check the sorts of the inductive types *) - - let inds = - Array.map (fun ((id,full_arity,sign,template,def_level,inf_level),cn,lc,clev) -> - let infu = - (** Inferred level, with parameters and constructors. *) - match inf_level with - | Some alev -> Universe.sup clev alev - | None -> clev - in - let full_polymorphic () = - let defu = Sorts.univ_of_sort def_level in - let is_natural = - type_in_type env || (UGraph.check_leq (universes env') infu defu) - in - let _ = - (** Impredicative sort, always allow *) - if is_impredicative env defu then () - else (** Predicative case: the inferred level must be lower or equal to the - declared level. *) - if not is_natural then - anomaly ~label:"check_inductive" - (Pp.str"Incorrect universe " ++ - Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr infu ++ Pp.str ".") - in - RegularArity (not is_natural,full_arity,defu) - in - let template_polymorphic () = - let _sign, s = - try dest_arity env full_arity - with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) - in - let u = Sorts.univ_of_sort s in - (* The polymorphic level is a function of the level of the *) - (* conclusions of the parameters *) - (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) - let b = type_in_type env || UGraph.check_leq (universes env') infu u in - if not b then - anomaly ~label:"check_inductive" - (Pp.str"Incorrect universe " ++ - Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " - ++ Universe.pr clev ++ Pp.str ".") - else - TemplateArity (param_ccls paramsctxt, infu) - in - let arity = - match mie.mind_entry_universes with - | Monomorphic_ind_entry _ -> - if template then template_polymorphic () - else full_polymorphic () - | Polymorphic_ind_entry _ | Cumulative_ind_entry _ -> - if template - then anomaly ~label:"polymorphic_template_ind" - Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") - else full_polymorphic () - in - (id,cn,lc,(sign,arity))) - inds - in - (* Check that the subtyping information inferred for inductive types in the block is correct. *) - (* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) - let () = - match mie.mind_entry_universes with - | Monomorphic_ind_entry _ -> () - | Polymorphic_ind_entry _ -> () - | Cumulative_ind_entry cumi -> check_subtyping cumi paramsctxt env_arities inds - in (env_arities, env_ar_par, paramsctxt, inds) +exception InductiveError = Type_errors.InductiveError (************************************************************************) (************************************************************************) @@ -517,7 +173,9 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = - let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lrecparams) in + let r = (snd (fst specif)).mind_relevance in + let anon = Context.make_annot Anonymous r in + let decl = LocalAssum (anon, hnf_prod_applist env ty lrecparams) in push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: @@ -530,8 +188,8 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in match kind c' with - Prod(na,a,b) -> - let ienv' = ienv_push_var ienv (na,a,mk_norec) in + Prod(na,a,b) -> + let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false @@ -559,7 +217,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_all env c) in match kind x with - | Prod (na,b,d) -> + | Prod (na,b,d) -> let () = assert (List.is_empty largs) in (** If one of the inductives of the mutually inductive block occurs in the left-hand side of a product, then @@ -711,21 +369,20 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( If [chkpos] is [false] then positivity is assumed, and [check_positivity_one] computes the subterms occurrences in a best-effort fashion. *) -let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = +let check_positivity ~chkpos kn names env_ar_par paramsctxt finite inds = let ntypes = Array.length inds in let recursive = finite != BiFinite in let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in let ra_env_ar = Array.rev_to_list rc in let nparamsctxt = Context.Rel.length paramsctxt in let nmr = Context.Rel.nhyps paramsctxt in - let check_one i (_,lcnames,lc,(sign,_)) = + let check_one i (_,lcnames) (nindices,lc) = let ra_env_ar_par = List.init nparamsctxt (fun _ -> (Norec,mk_norec)) @ ra_env_ar in let ienv = (env_ar_par, 1+nparamsctxt, ntypes, ra_env_ar_par) in - let nnonrecargs = Context.Rel.nhyps sign - nmr in - check_positivity_one ~chkpos recursive ienv paramsctxt (kn,i) nnonrecargs lcnames lc + check_positivity_one ~chkpos recursive ienv paramsctxt (kn,i) nindices lcnames lc in - let irecargs_nmr = Array.mapi check_one inds in + let irecargs_nmr = Array.map2_i check_one names inds in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',Rtree.mk_rec irecargs) @@ -735,68 +392,33 @@ let check_positivity ~chkpos kn env_ar_par paramsctxt finite inds = (************************************************************************) (* Build the inductive packet *) -(* Allowed eliminations *) - -let all_sorts = [InProp;InSet;InType] -let small_sorts = [InProp;InSet] -let logical_sorts = [InProp] - -let allowed_sorts is_smashed s = - if not is_smashed - then (** Naturally in the defined sort. - If [s] is Prop, it must be small and unitary. - Unsmashed, predicative Type and Set: all elimination allowed - as well. *) - all_sorts - else - match Sorts.family s with - (* Type: all elimination allowed: above and below *) - | InType -> all_sorts - (* Smashed Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts - (* Smashed to Prop, no informative eliminations allowed *) - | InProp -> logical_sorts - -(* Previous comment: *) -(* Unitary/empty Prop: elimination to all sorts are realizable *) -(* unless the type is large. If it is large, forbids large elimination *) -(* which otherwise allows simulating the inconsistent system Type:Type. *) -(* -> this is now handled by is_smashed: *) -(* - all_sorts in case of small, unitary Prop (not smashed) *) -(* - logical_sorts in case of large, unitary Prop (smashed) *) - -let arity_conclusion = function - | RegularArity (_, c, _) -> c - | TemplateArity (_, s) -> mkType s +let repair_arity indices = function + | RegularArity ar -> ar.mind_user_arity + | TemplateArity ar -> mkArity (indices,Sorts.sort_of_univ ar.template_level) let fold_inductive_blocks f = - Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> - f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (arity_conclusion ar) arsign)) + Array.fold_left (fun acc ((arity,lc),(indices,_),_) -> + f (Array.fold_left f acc lc) (repair_arity indices arity)) let used_section_variables env inds = - let ids = fold_inductive_blocks - (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) - Id.Set.empty inds in + let fold l c = Id.Set.union (Environ.global_vars_set env c) l in + let ids = fold_inductive_blocks fold Id.Set.empty inds in keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = Array.to_list (rel_vect n m) -exception UndefinableExpansion - (** From a rel context describing the constructor arguments, build an expansion function. The term built is expecting to be substituted first by a substitution of the form [params, x : ind params] *) let compute_projections (kn, i as ind) mib = let pkt = mib.mind_packets.(i) in - let u = match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Instance.empty - | Polymorphic_ind auctx -> Univ.make_abstract_instance auctx - | Cumulative_ind acumi -> Univ.make_abstract_instance (Univ.ACumulativityInfo.univ_context acumi) - in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in - let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in + let (ctx, cty) = pkt.mind_nf_lc.(0) in + let cty = it_mkProd_or_LetIn cty ctx in + let rctx, _ = decompose_prod_assum (substl subst cty) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not @@ -811,7 +433,7 @@ let compute_projections (kn, i as ind) mib = mkRel 1 :: List.map (lift 1) subst in subst in - let projections decl (i, j, labs, pbs, letsubst) = + let projections decl (i, j, labs, rs, pbs, letsubst) = match decl with | LocalDef (_na,c,_t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -823,10 +445,11 @@ let compute_projections (kn, i as ind) mib = (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in - (i, j+1, labs, pbs, letsubst) + (i, j+1, labs, rs, pbs, letsubst) | LocalAssum (na,t) -> - match na with + match na.Context.binder_name with | Name id -> + let r = na.Context.binder_relevance in let lab = Label.of_id id in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] @@ -838,65 +461,35 @@ let compute_projections (kn, i as ind) mib = (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let fterm = mkProj (Projection.make kn false, mkRel 1) in - (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) - | Anonymous -> raise UndefinableExpansion + (i + 1, j + 1, lab :: labs, r :: rs, projty :: pbs, fterm :: letsubst) + | Anonymous -> assert false (* checked by indTyping *) in - let (_, _, labs, pbs, _letsubst) = - List.fold_right projections ctx (0, 1, [], [], paramsletsubst) + let (_, _, labs, rs, pbs, _letsubst) = + List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst) in - Array.of_list (List.rev labs), - Array.of_list (List.rev pbs) - -let abstract_inductive_universes iu = - match iu with - | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) - | Polymorphic_ind_entry ctx -> - let (inst, auctx) = Univ.abstract_universes ctx in - let inst = Univ.make_instance_subst inst in - (inst, Polymorphic_ind auctx) - | Cumulative_ind_entry cumi -> - let (inst, acumi) = Univ.abstract_cumulativity_info cumi in - let inst = Univ.make_instance_subst inst in - (inst, Cumulative_ind acumi) - -let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr recargs = + Array.of_list (List.rev labs), + Array.of_list (List.rev rs), + Array.of_list (List.rev pbs) + +let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in let nparamargs = Context.Rel.nhyps paramsctxt in - let nparamsctxt = Context.Rel.length paramsctxt in - let substunivs, aiu = abstract_inductive_universes iu in - let paramsctxt = Vars.subst_univs_level_context substunivs paramsctxt in - let env_ar = - let ctxunivs = Environ.rel_context env_ar in - let ctxunivs' = Vars.subst_univs_level_context substunivs ctxunivs in - Environ.push_rel_context ctxunivs' env - in (* Check one inductive *) - let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg = + let build_one_packet (id,cnames) ((arity,lc),(indices,splayed_lc),kelim) recarg = (* Type of constructors in normal form *) - let lc = Array.map (Vars.subst_univs_level_constr substunivs) lc in - let splayed_lc = Array.map (dest_prod_assum env_ar) lc in - let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in + let nf_lc = Array.map (fun (d, b) -> (d@paramsctxt, b)) splayed_lc in let consnrealdecls = - Array.map (fun (d,_) -> Context.Rel.length d - nparamsctxt) + Array.map (fun (d,_) -> Context.Rel.length d) splayed_lc in let consnrealargs = - Array.map (fun (d,_) -> Context.Rel.nhyps d - nparamargs) - splayed_lc in - (* Elimination sorts *) - let arkind,kelim = - match ar_kind with - | TemplateArity (paramlevs, lev) -> - let ar = {template_param_levels = paramlevs; template_level = lev} in - TemplateArity ar, all_sorts - | RegularArity (info,ar,defs) -> - let s = Sorts.sort_of_univ defs in - let kelim = allowed_sorts info s in - let ar = RegularArity - { mind_user_arity = Vars.subst_univs_level_constr substunivs ar; - mind_sort = Sorts.sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in - ar, kelim in + Array.map (fun (d,_) -> Context.Rel.nhyps d) + splayed_lc in + let mind_relevance = match arity with + | RegularArity { mind_sort;_ } -> Sorts.relevance_of_sort mind_sort + | TemplateArity _ -> Sorts.Relevant + in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -913,22 +506,23 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; - mind_arity = arkind; - mind_arity_ctxt = Vars.subst_univs_level_context substunivs ar_sign; - mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; - mind_nrealdecls = Context.Rel.length ar_sign - nparamsctxt; + mind_arity = arity; + mind_arity_ctxt = indices @ paramsctxt; + mind_nrealargs = Context.Rel.nhyps indices; + mind_nrealdecls = Context.Rel.length indices; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealdecls; mind_consnrealargs = consnrealargs; mind_user_lc = lc; mind_nf_lc = nf_lc; - mind_recargs = recarg; - mind_nb_constant = !nconst; + mind_recargs = recarg; + mind_relevance; + mind_nb_constant = !nconst; mind_nb_args = !nblock; mind_reloc_tbl = rtbl; } in - let packets = Array.map2 build_one_packet inds recargs in + let packets = Array.map3 build_one_packet names inds recargs in let mib = (* Build the mutual inductive *) { mind_record = NotRecord; @@ -939,27 +533,20 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r mind_nparams_rec = nmr; mind_params_ctxt = paramsctxt; mind_packets = packets; - mind_universes = aiu; + mind_universes = univs; + mind_variance = variance; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } in let record_info = match isrecord with | Some (Some rid) -> - let is_record pkt = - pkt.mind_kelim == all_sorts - && Array.length pkt.mind_consnames == 1 - && pkt.mind_consnrealargs.(0) > 0 - in (** The elimination criterion ensures that all projections can be defined. *) - if Array.for_all is_record packets then - let map i id = - let labs, projs = compute_projections (kn, i) mib in - (id, labs, projs) - in - try PrimRecord (Array.mapi map rid) - with UndefinableExpansion -> FakeRecord - else FakeRecord + let map i id = + let labs, rs, projs = compute_projections (kn, i) mib in + (id, labs, rs, projs) + in + PrimRecord (Array.mapi map rid) | Some None -> FakeRecord | None -> NotRecord in @@ -970,11 +557,17 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, env_ar_par, paramsctxt, inds) = typecheck_inductive env mie in + let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_guarded in - let (nmr,recargs) = check_positivity ~chkpos kn env_ar_par paramsctxt mie.mind_entry_finite inds in + let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) + mie.mind_entry_inds + in + let (nmr,recargs) = check_positivity ~chkpos kn names + env_ar_par paramsctxt mie.mind_entry_finite + (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) + in (* Build the inductive packets *) - build_inductive env mie.mind_entry_private mie.mind_entry_universes - env_ar paramsctxt kn mie.mind_entry_record mie.mind_entry_finite + build_inductive env names mie.mind_entry_private univs variance + paramsctxt kn record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index cb09cfa827..7810c1723e 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -14,12 +14,10 @@ open Declarations open Environ open Entries -(** Inductive type checking and errors *) - -(** The different kinds of errors that may result of a malformed inductive - definition. *) +(** Check an inductive. *) +val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body -(** Errors related to inductive constructions *) +(** Deprecated *) type inductive_error = | NonPos of env * constr * constr | NotEnoughArgs of env * constr * constr @@ -31,14 +29,8 @@ type inductive_error = | NotAnArity of env * constr | BadEntry | LargeNonPropInductiveNotInType + | BadUnivs +[@@ocaml.deprecated "Use [Type_errors.inductive_error]"] -exception InductiveError of inductive_error - -(** The following function does checks on inductive declarations. *) - -val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - -(** The following enforces a system compatible with the univalent model *) - -val enforce_indices_matter : unit -> unit -val is_indices_matter : unit -> bool +exception InductiveError of Type_errors.inductive_error +[@@ocaml.deprecated "Use [Type_errors.InductiveError]"] diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 9bbcf07f7e..d9335d39b5 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -56,12 +56,7 @@ let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = - let process auctx = Univ.AUContext.instantiate u auctx in - match mib.mind_universes with - | Monomorphic_ind _ -> Univ.Constraint.empty - | Polymorphic_ind auctx -> process auctx - | Cumulative_ind cumi -> process (Univ.ACumulativityInfo.univ_context cumi) - + Univ.AUContext.instantiate u (Declareops.inductive_polymorphic_context mib) (************************************************************************) @@ -193,13 +188,17 @@ let instantiate_universes env ctx ar argsorts = (* Non singleton type not containing types are interpretable in Set *) else if is_type0_univ level then Sorts.set (* This is a Type with constraints *) - else Sorts.Type level + else Sorts.sort_of_univ level in (ctx, ty) (* Type of an inductive type *) -let type_of_inductive_gen ?(polyprop=true) env ((_mib,mip),u) paramtyps = +let relevance_of_inductive env ind = + let _, mip = lookup_mind_specif env ind in + mip.mind_relevance + +let type_of_inductive_gen ?(polyprop=true) env ((_,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> @@ -231,7 +230,10 @@ let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args = (* The max of an array of universes *) let cumulate_constructor_univ u = let open Sorts in function - | Prop -> u + | SProp | Prop -> + (* SProp is non cumulative but allowed in constructors of any + inductive (except non-sprop primitive records) *) + u | Set -> Universe.sup Universe.type0 u | Type u' -> Universe.sup u u' @@ -256,7 +258,11 @@ let constrained_type_of_constructor (_cstr,u as cstru) (mib,_mip as ind) = let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn u mib) specif + let map (ctx, c) = + let cty = Term.it_mkProd_or_LetIn c ctx in + constructor_instantiate kn u mib cty + in + Array.map map specif let arities_of_constructors ind specif = arities_of_specif (fst (fst ind), snd ind) specif @@ -299,16 +305,12 @@ let build_dependent_inductive ind (_,mip) params = @ Context.Rel.to_extended_list mkRel 0 realargs) (* This exception is local *) -exception LocalArity of (Sorts.family * Sorts.family * arity_error) option +exception LocalArity of (Sorts.family list * Sorts.family * Sorts.family * arity_error) option let check_allowed_sort ksort specif = - let open Sorts in - let eq_ksort s = match ksort, s with - | InProp, InProp | InSet, InSet | InType, InType -> true - | _ -> false in - if not (CList.exists eq_ksort (elim_sorts specif)) then + if not (CList.exists (Sorts.family_equal ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in - raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) + raise (LocalArity (Some(elim_sorts specif, ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity ind specif params in @@ -322,7 +324,7 @@ let is_correct_arity env c pj ind specif params = srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (LocalAssum (na1,a1)) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match kind (whd_all env' a2) with | Sort s -> Sorts.family s | _ -> raise (LocalArity None) in @@ -338,7 +340,7 @@ let is_correct_arity env c pj ind specif params = in try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> - error_elim_arity env ind (elim_sorts specif) c pj kinds + error_elim_arity env ind c pj kinds (************************************************************************) @@ -347,7 +349,8 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) let build_branches_type (ind,u) (_,mip as specif) params p = - let build_one_branch i cty = + let build_one_branch i (ctx, c) = + let cty = Term.it_mkProd_or_LetIn c ctx in let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = Term.decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in @@ -380,13 +383,14 @@ let type_case_branches env (pind,largs) pj c = (************************************************************************) (* Checking the case annotation is relevant *) -let check_case_info env (indsp,u) ci = +let check_case_info env (indsp,u) r ci = let (mib,mip as spec) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) || + not (ci.ci_relevance == r) || is_primitive_record spec then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) @@ -575,7 +579,9 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + let r = specif.mind_relevance in + let anon = Context.make_annot Anonymous r in + let decl = LocalAssum (anon, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in @@ -593,15 +599,17 @@ let rec ienv_decompose_prod (env,_ as ienv) n c = ienv_decompose_prod ienv' (n-1) b | _ -> assert false +let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) 0)) +let dummy_implicit_sort = mkType (Universe.make dummy_univ) let lambda_implicit_lift n a = - let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in - let implicit_sort = mkType (Universe.make level) in - let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in + let anon = Context.make_annot Anonymous Sorts.Relevant in + let lambda_implicit a = mkLambda (anon, dummy_implicit_sort, a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) let abstract_mind_lc ntyps npars lc = + let lc = Array.map (fun (ctx, c) -> Term.it_mkProd_or_LetIn c ctx) lc in if Int.equal npars 0 then lc else @@ -804,7 +812,7 @@ let rec subterm_specif renv stack t = | Not_subterm -> Not_subterm) | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ - | Construct _ | CoFix _ -> Not_subterm + | Construct _ | CoFix _ | Int _ -> Not_subterm (* Other terms are not subterms *) @@ -926,16 +934,30 @@ let check_one_fix renv recpos trees def = end | Case (ci,p,c_0,lrest) -> - List.iter (check_rec_call renv []) (c_0::p::l); - (* compute the recarg information for the arguments of - each branch *) - let case_spec = branches_specif renv - (lazy_subterm_specif renv [] c_0) ci in - let stack' = push_stack_closures renv l stack in - let stack' = filter_stack_domain renv.env p stack' in - Array.iteri (fun k br' -> - let stack_br = push_stack_args case_spec.(k) stack' in - check_rec_call renv stack_br br') lrest + begin try + List.iter (check_rec_call renv []) (c_0::p::l); + (* compute the recarg info for the arguments of each branch *) + let case_spec = + branches_specif renv (lazy_subterm_specif renv [] c_0) ci in + let stack' = push_stack_closures renv l stack in + let stack' = filter_stack_domain renv.env p stack' in + lrest |> Array.iteri (fun k br' -> + let stack_br = push_stack_args case_spec.(k) stack' in + check_rec_call renv stack_br br') + with (FixGuardError _ as exn) -> + let exn = CErrors.push exn in + (* we try hard to reduce the match away by looking for a + constructor in c_0 (we unfold definitions too) *) + let c_0 = whd_all renv.env c_0 in + let hd, _ = decompose_app c_0 in + match kind hd with + | Construct _ -> + (* the call to whd_betaiotazeta will reduce the + apparent iota redex away *) + check_rec_call renv [] + (Term.applist (mkCase (ci,p,c_0,lrest), l)) + | _ -> Exninfo.iraise exn + end (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : @@ -950,19 +972,33 @@ let check_one_fix renv recpos trees def = then f is guarded with respect to S in (g a1 ... am). Eduardo 7/9/98 *) | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> - List.iter (check_rec_call renv []) l; - Array.iter (check_rec_call renv []) typarray; let decrArg = recindxs.(i) in - let renv' = push_fix_renv renv recdef in - let stack' = push_stack_closures renv l stack in - Array.iteri - (fun j body -> - if Int.equal i j && (List.length stack' > decrArg) then - let recArg = List.nth stack' decrArg in - let arg_sp = stack_element_specif recArg in - check_nested_fix_body renv' (decrArg+1) arg_sp body - else check_rec_call renv' [] body) - bodies + begin try + List.iter (check_rec_call renv []) l; + Array.iter (check_rec_call renv []) typarray; + let renv' = push_fix_renv renv recdef in + let stack' = push_stack_closures renv l stack in + bodies |> Array.iteri (fun j body -> + if Int.equal i j && (List.length stack' > decrArg) then + let recArg = List.nth stack' decrArg in + let arg_sp = stack_element_specif recArg in + check_nested_fix_body renv' (decrArg+1) arg_sp body + else check_rec_call renv' [] body) + with (FixGuardError _ as exn) -> + let exn = CErrors.push exn in + (* we try hard to reduce the fix away by looking for a + constructor in l[decrArg] (we unfold definitions too) *) + if List.length l <= decrArg then Exninfo.iraise exn; + let recArg = List.nth l decrArg in + let recArg = whd_all renv.env recArg in + let hd, _ = decompose_app recArg in + match kind hd with + | Construct _ -> + let before, after = CList.(firstn decrArg l, skipn (decrArg+1) l) in + check_rec_call renv [] + (Term.applist (mkFix ((recindxs,i),recdef), (before @ recArg :: after))) + | _ -> Exninfo.iraise exn + end | Const (kn,_u as cu) -> if evaluable_constant kn renv.env then @@ -992,9 +1028,22 @@ let check_one_fix renv recpos trees def = | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l - | Proj (_p, c) -> - List.iter (check_rec_call renv []) l; - check_rec_call renv [] c + | Proj (p, c) -> + begin try + List.iter (check_rec_call renv []) l; + check_rec_call renv [] c + with (FixGuardError _ as exn) -> + let exn = CErrors.push exn in + (* we try hard to reduce the proj away by looking for a + constructor in c (we unfold definitions too) *) + let c = whd_all renv.env c in + let hd, _ = decompose_app c in + match kind hd with + | Construct _ -> + check_rec_call renv [] + (Term.applist (mkProj(Projection.unfold p,c), l)) + | _ -> Exninfo.iraise exn + end | Var id -> begin @@ -1008,7 +1057,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(c,l)) end - | Sort _ -> + | Sort _ | Int _ -> assert (List.is_empty l) (* l is not checked because it is considered as the meta's context *) @@ -1021,7 +1070,7 @@ let check_one_fix renv recpos trees def = check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match kind body with - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b @@ -1054,7 +1103,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match kind (whd_all env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (LocalAssum (x,a)) env in + let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1067,8 +1116,19 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = (mind, (env', b)) else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") - | _ -> raise_err env i NotEnoughAbstractionInFixBody in - check_occur fixenv 1 def in + | _ -> raise_err env i NotEnoughAbstractionInFixBody + in + let ((ind, _), _) as res = check_occur fixenv 1 def in + let _, ind = lookup_mind_specif env ind in + (* recursive sprop means non record with projections -> squashed *) + if Sorts.Irrelevant == ind.mind_relevance + then + begin + if names.(i).Context.binder_relevance == Sorts.Relevant + then raise_err env i FixpointOnIrrelevantInductive + end; + res + in (* Do it on every fixpoint *) let rv = Array.map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) @@ -1111,7 +1171,7 @@ let rec codomain_is_coind env c = let b = whd_all env c in match kind b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (LocalAssum (x,a)) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1149,7 +1209,7 @@ let check_one_cofix env nbfix def deftype = | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in @@ -1194,7 +1254,8 @@ let check_one_cofix env nbfix def deftype = | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ - | Ind _ | Fix _ | Proj _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + | Ind _ | Fix _ | Proj _ | Int _ -> + raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 3c1464c6c9..997a620742 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -45,6 +45,8 @@ val constrained_type_of_inductive : env -> mind_specif puniverses -> types const val constrained_type_of_inductive_knowing_parameters : env -> mind_specif puniverses -> types Lazy.t array -> types constrained +val relevance_of_inductive : env -> inductive -> Sorts.relevance + val type_of_inductive : env -> mind_specif puniverses -> types val type_of_inductive_knowing_parameters : @@ -93,7 +95,7 @@ val inductive_sort_family : one_inductive_body -> Sorts.family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) -val check_case_info : env -> pinductive -> case_info -> unit +val check_case_info : env -> pinductive -> Sorts.relevance -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) @@ -139,4 +141,4 @@ val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec val lambda_implicit_lift : int -> constr -> constr -val abstract_mind_lc : int -> Int.t -> constr array -> constr array +val abstract_mind_lc : int -> Int.t -> (rel_context * constr) array -> constr array diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index a18c5d1e20..59c1d5890f 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,5 +1,7 @@ Names -Uint31 +TransparentState +Uint63 +CPrimitives Univ UGraph Esubst @@ -18,12 +20,13 @@ Opaqueproof Declarations Entries Nativevalues -CPrimitives Declareops Retroknowledge Conv_oracle Environ +Primred CClosure +Retypeops Reduction Clambda Nativelambda @@ -38,6 +41,7 @@ Type_errors Modops Inductive Typeops +IndTyping Indtypes Cooking Term_typing diff --git a/kernel/make-opcodes b/kernel/make-opcodes deleted file mode 100644 index e1371b3d0c..0000000000 --- a/kernel/make-opcodes +++ /dev/null @@ -1,3 +0,0 @@ -$1=="enum" {n=0; next; } - {printf("(* THIS FILE IS GENERATED. DON'T EDIT. *)\n\n"); - for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} diff --git a/kernel/make_opcodes.sh b/kernel/make_opcodes.sh deleted file mode 100755 index bb8aba2f07..0000000000 --- a/kernel/make_opcodes.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -script_dir="$(dirname "$0")" -tr -d "\r" < "${1}" | sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' | awk -f "$script_dir"/make-opcodes > "${2}" diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 2a91c7dab0..9397772415 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -24,7 +24,7 @@ open Constr is the term into which we should inline. *) type delta_hint = - | Inline of int * (Univ.AUContext.t * constr) option + | Inline of int * constr Univ.univ_abstracted option | Equiv of KerName.t (* NB: earlier constructor Prefix_equiv of ModPath.t @@ -164,7 +164,7 @@ let find_prefix resolve mp = (** Applying a resolver to a kernel name *) -exception Change_equiv_to_inline of (int * (Univ.AUContext.t * constr)) +exception Change_equiv_to_inline of (int * constr Univ.univ_abstracted) let solve_delta_kn resolve kn = try @@ -294,43 +294,34 @@ let subst_ind sub (ind,i as indi) = let subst_pind sub (ind,u) = (subst_ind sub ind, u) -let subst_con0 sub (cst,u) = +let subst_con0 sub cst = let mpu,l = Constant.repr2 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in let knu = KerName.make mpu l in let knc = if mpu == mpc then knu else KerName.make mpc l in match search_delta_inline resolve knu knc with - | Some (ctx, t) -> + | Some t -> (* In case of inlining, discard the canonical part (cf #2608) *) - let () = assert (Int.equal (Univ.AUContext.size ctx) (Univ.Instance.length u)) in - Constant.make1 knu, Vars.subst_instance_constr u t + Constant.make1 knu, Some t | None -> let knc' = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in - cst', mkConstU (cst',u) + cst', None let subst_con sub cst = try subst_con0 sub cst - with No_subst -> fst cst, mkConstU cst + with No_subst -> cst, None -let subst_con_kn sub con = - subst_con sub (con,Univ.Instance.empty) - -let subst_pcon sub (_con,u as pcon) = - try let con', _can = subst_con0 sub pcon in +let subst_pcon sub (con,u as pcon) = + try let con', _can = subst_con0 sub con in con',u with No_subst -> pcon -let subst_pcon_term sub (_con,u as pcon) = - try let con', can = subst_con0 sub pcon in - (con',u), can - with No_subst -> pcon, mkConstU pcon - let subst_constant sub con = - try fst (subst_con0 sub (con,Univ.Instance.empty)) + try fst (subst_con0 sub con) with No_subst -> con let subst_proj_repr sub p = @@ -339,6 +330,16 @@ let subst_proj_repr sub p = let subst_proj sub p = Projection.map (subst_mind sub) p +let subst_retro_action subst action = + let open Retroknowledge in + match action with + | Register_ind(prim,ind) -> + let ind' = subst_ind subst ind in + if ind == ind' then action else Register_ind(prim, ind') + | Register_type(prim,c) -> + let c' = subst_constant subst c in + if c == c' then action else Register_type(prim, c') + (* 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" @@ -351,7 +352,7 @@ let subst_evaluable_reference subst = function let rec map_kn f f' c = let func = map_kn f f' in match kind c with - | Const kn -> (try snd (f' kn) with No_subst -> c) + | Const kn -> (try f' kn with No_subst -> c) | Proj (p,t) -> let p' = Projection.map f p in let t' = func t in @@ -420,8 +421,14 @@ let rec map_kn f f' c = | _ -> c let subst_mps sub c = + let subst_pcon_term sub (con,u) = + let con', can = subst_con0 sub con in + match can with + | None -> mkConstU (con',u) + | Some t -> Vars.univ_instantiate_constr u t + in if is_empty_subst sub then c - else map_kn (subst_mind sub) (subst_con0 sub) c + else map_kn (subst_mind sub) (subst_pcon_term sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with @@ -486,7 +493,7 @@ let gen_subst_delta_resolver dom subst resolver = | Equiv kequ -> (try Equiv (subst_kn_delta subst kequ) with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) - | Inline (lev,Some (ctx, t)) -> Inline (lev,Some (ctx, subst_mps subst t)) + | Inline (lev,Some t) -> Inline (lev,Some (Univ.map_univ_abstracted (subst_mps subst) t)) | Inline (_,None) -> hint in Deltamap.add_kn kkey' hint' rslv diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 8416094063..8ab3d04402 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -28,7 +28,7 @@ val add_kn_delta_resolver : KerName.t -> KerName.t -> delta_resolver -> delta_resolver val add_inline_delta_resolver : - KerName.t -> (int * (Univ.AUContext.t * constr) option) -> delta_resolver -> delta_resolver + KerName.t -> (int * constr Univ.univ_abstracted option) -> delta_resolver -> delta_resolver val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver @@ -133,23 +133,19 @@ val subst_kn : substitution -> KerName.t -> KerName.t val subst_con : - substitution -> pconstant -> Constant.t * constr + substitution -> Constant.t -> Constant.t * constr Univ.univ_abstracted option val subst_pcon : substitution -> pconstant -> pconstant -val subst_pcon_term : - substitution -> pconstant -> pconstant * constr - -val subst_con_kn : - substitution -> Constant.t -> Constant.t * constr - val subst_constant : substitution -> Constant.t -> Constant.t val subst_proj_repr : substitution -> Projection.Repr.t -> Projection.Repr.t val subst_proj : substitution -> Projection.t -> Projection.t +val subst_retro_action : substitution -> Retroknowledge.action -> Retroknowledge.action + (** 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" diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index d63dc057b4..2de5faa6df 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -68,18 +68,19 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = if List.is_empty idl then (* Toplevel definition *) let cb = match spec with - | SFBconst cb -> cb - | _ -> error_not_a_constant lab + | SFBconst cb -> cb + | _ -> error_not_a_constant lab in (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, - as long as they have the right type *) + as long as they have the right type *) let c', univs, ctx' = match cb.const_universes, ctx with - | Monomorphic_const _, None -> + | Monomorphic _, None -> let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in + assert (j.uj_val == c); (* relevances should already be correct here *) let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in @@ -87,60 +88,65 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = | Def cs -> let c' = Mod_subst.force_constr cs in c, Reduction.infer_conv env' (Environ.universes env') c c' + | Primitive _ -> + error_incorrect_with_constraint lab in - c', Monomorphic_const Univ.ContextSet.empty, cst - | Polymorphic_const uctx, Some ctx -> + c', Monomorphic Univ.ContextSet.empty, cst + | Polymorphic uctx, Some ctx -> let () = if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then error_incorrect_with_constraint lab in (** Terms are compared in a context with De Bruijn universe indices *) - let env' = Environ.push_context ~strict:false (Univ.AUContext.repr uctx) env in - let cst = match cb.const_body with - | Undef _ | OpaqueDef _ -> - let j = Typeops.infer env' c in - let typ = cb.const_type in - let cst' = Reduction.infer_conv_leq env' (Environ.universes env') - j.uj_type typ in - cst' - | Def cs -> - let c' = Mod_subst.force_constr cs in - let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in - cst' - in - if not (Univ.Constraint.is_empty cst) then - error_incorrect_with_constraint lab; - c, Polymorphic_const ctx, Univ.Constraint.empty + let env' = Environ.push_context ~strict:false (Univ.AUContext.repr uctx) env in + let cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + assert (j.uj_val == c); (* relevances should already be correct here *) + let typ = cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + cst' + | Def cs -> + let c' = Mod_subst.force_constr cs in + let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in + cst' + | Primitive _ -> + error_incorrect_with_constraint lab + in + if not (Univ.Constraint.is_empty cst) then + error_incorrect_with_constraint lab; + c, Polymorphic ctx, Univ.Constraint.empty | _ -> error_incorrect_with_constraint lab in let def = Def (Mod_subst.from_val c') in -(* let ctx' = Univ.UContext.make (newus, cst) in *) + (* let ctx' = Univ.UContext.make (newus, cst) in *) let cb' = - { cb with - const_body = def; + { cb with + const_body = def; const_universes = univs ; - const_body_code = Option.map Cemitcodes.from_val - (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } + const_body_code = Option.map Cemitcodes.from_val + (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else (* Definition inside a sub-module *) let mb = match spec with - | SFBmodule mb -> mb - | _ -> error_not_a_module (Label.to_string lab) + | SFBmodule mb -> mb + | _ -> error_not_a_module (Label.to_string lab) in begin match mb.mod_expr with - | Abstract -> - let struc = Modops.destr_nofunctor mb.mod_type in - let struc',c',cst = - check_with_def env' struc (idl,(c,ctx)) (MPdot(mp,lab)) mb.mod_delta - in - let mb' = { mb with - mod_type = NoFunctor struc'; - mod_type_alg = None } - in - before@(lab,SFBmodule mb')::after, c', cst - | _ -> error_generative_module_expected lab + | Abstract -> + let struc = Modops.destr_nofunctor mb.mod_type in + let struc',c',cst = + check_with_def env' struc (idl,(c,ctx)) (MPdot(mp,lab)) mb.mod_delta + in + let mb' = { mb with + mod_type = NoFunctor struc'; + mod_type_alg = None } + in + before@(lab,SFBmodule mb')::after, c', cst + | _ -> error_generative_module_expected lab end with | Not_found -> error_no_such_label lab diff --git a/kernel/modops.ml b/kernel/modops.ml index bab2eae3df..4f992d3972 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -47,10 +47,10 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.AUContext.t + | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } + | IncompatibleVariance type module_typing_error = | SignatureMismatch of @@ -198,9 +198,18 @@ let rec subst_structure sub do_delta sign = in List.Smart.map subst_body sign +and subst_retro : type a. Mod_subst.substitution -> a module_retroknowledge -> a module_retroknowledge = + fun subst retro -> + match retro with + | ModTypeRK as r -> r + | ModBodyRK l as r -> + let l' = List.Smart.map (subst_retro_action subst) l in + if l == l' then r else ModBodyRK l + and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = fun is_mod sub subst_impl do_delta mb -> - let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty; _ } = mb in + let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty; + mod_retroknowledge=retro; _ } = mb in let mp' = subst_mp sub mp in let sub = if ModPath.equal mp mp' then sub @@ -210,8 +219,10 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> let ty' = subst_signature sub do_delta ty in let me' = subst_impl sub me in let aty' = Option.Smart.map (subst_expression sub id_delta) aty in + let retro' = subst_retro sub retro in let delta' = do_delta mb.mod_delta sub in - if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta + if mp==mp' && me==me' && ty==ty' && aty==aty' + && retro==retro' && delta'==mb.mod_delta then mb else { mb with @@ -219,7 +230,9 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> mod_expr = me'; mod_type = ty'; mod_type_alg = aty'; - mod_delta = delta' } + mod_retroknowledge = retro'; + mod_delta = delta'; + } and subst_module sub do_delta mb = subst_body true sub subst_impl do_delta mb @@ -260,32 +273,12 @@ let do_delta_dom_codom reso sub = subst_dom_codom_delta_resolver sub reso let subst_signature subst = subst_signature subst do_delta_codom let subst_structure subst = subst_structure subst do_delta_codom -(** {6 Retroknowledge } *) - -(* spiwack: here comes the function which takes care of importing - the retroknowledge declared in the library *) -(* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) -let add_retroknowledge = - let perform rkaction env = match rkaction with - | Retroknowledge.RKRegister (f, ((GlobRef.ConstRef _ | GlobRef.IndRef _) as e)) -> - Environ.register env f e - | _ -> - CErrors.anomaly ~label:"Modops.add_retroknowledge" - (Pp.str "had to import an unsupported kind of term.") - in - fun (ModBodyRK lclrk) env -> - (* The order of the declaration matters, for instance (and it's at the - time this comment is being written, the only relevent instance) the - int31 type registration absolutely needs int31 bits to be registered. - Since the local_retroknowledge is stored in reverse order (each new - registration is added at the top of the list) we need a fold_right - for things to go right (the pun is not intented). So we lose - tail recursivity, but the world will have exploded before any module - imports 10 000 retroknowledge registration.*) - List.fold_right perform lclrk env - (** {6 Adding a module in the environment } *) +let add_retroknowledge r env = + match r with + | ModBodyRK l -> List.fold_left Primred.add_retroknowledge env l + let rec add_structure mp sign resolver linkinfo env = let add_one env (l,elem) = match elem with |SFBconst cb -> @@ -333,13 +326,10 @@ let strengthen_const mp_from l cb resolver = |_ -> let kn = KerName.make mp_from l in let con = constant_of_delta_kn resolver kn in - let u = - match cb.const_universes with - | Monomorphic_const _ -> Univ.Instance.empty - | Polymorphic_const ctx -> Univ.make_abstract_instance ctx - in + let u = Univ.make_abstract_instance (Declareops.constant_polymorphic_context cb) in { cb with - const_body = Def (Mod_subst.from_val (mkConstU (con,u))); + const_body = Def (Mod_subst.from_val (mkConstU (con,u))); + const_private_poly_univs = None; const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = @@ -399,11 +389,12 @@ let inline_delta_resolver env inl mp mbid mtb delta = let constant = lookup_constant con env in let l = make_inline delta r in match constant.const_body with - | Undef _ | OpaqueDef _ -> l + | Undef _ | OpaqueDef _ | Primitive _ -> l | Def body -> let constr = Mod_subst.force_constr body in let ctx = Declareops.constant_polymorphic_context constant in - add_inline_delta_resolver kn (lev, Some (ctx, constr)) l + let constr = Univ.{univ_abstracted_value=constr; univ_abstracted_binder=ctx} in + add_inline_delta_resolver kn (lev, Some constr) l with Not_found -> error_no_such_label_sub (Constant.label con) (ModPath.to_string (Constant.modpath con)) diff --git a/kernel/modops.mli b/kernel/modops.mli index 8e7e618fcd..119ce2b359 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -57,6 +57,8 @@ val add_linked_module : module_body -> link_info -> env -> env (** same, for a module type *) val add_module_type : ModPath.t -> module_type_body -> env -> env +val add_retroknowledge : module_implementation module_retroknowledge -> env -> env + (** {6 Strengthening } *) val strengthen : module_type_body -> ModPath.t -> module_type_body @@ -106,10 +108,10 @@ type signature_mismatch_error = | RecordFieldExpected of bool | RecordProjectionsExpected of Name.t list | NotEqualInductiveAliases - | IncompatibleInstances | IncompatibleUniverses of Univ.univ_inconsistency | IncompatiblePolymorphism of env * types * types - | IncompatibleConstraints of Univ.AUContext.t + | IncompatibleConstraints of { got : Univ.AUContext.t; expect : Univ.AUContext.t } + | IncompatibleVariance type module_typing_error = | SignatureMismatch of diff --git a/kernel/names.ml b/kernel/names.ml index 7cd749de1d..9f27212967 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -391,6 +391,8 @@ module KerName = struct let print kn = str (to_string kn) + let debug_print kn = str (debug_to_string kn) + let compare (kn1 : kernel_name) (kn2 : kernel_name) = if kn1 == kn2 then 0 else @@ -715,13 +717,6 @@ let hcons_construct = Hashcons.simple_hcons Hconstruct.generate Hconstruct.hcons (*****************) -type transparent_state = Id.Pred.t * Cpred.t - -let empty_transparent_state = (Id.Pred.empty, Cpred.empty) -let full_transparent_state = (Id.Pred.full, Cpred.full) -let var_full_transparent_state = (Id.Pred.full, Cpred.empty) -let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) - type 'a tableKey = | ConstKey of 'a | VarKey of Id.t @@ -872,6 +867,8 @@ struct let equal (c, b) (c', b') = Repr.equal c c' && b == b' + let repr_equal p p' = Repr.equal (repr p) (repr p') + let hash (c, b) = (if b then 0 else 1) + Repr.hash c module SyntacticOrd = struct diff --git a/kernel/names.mli b/kernel/names.mli index 37930c12e2..61df3bad0e 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -149,15 +149,15 @@ sig val is_empty : t -> bool (** Test whether a directory path is empty. *) - val to_string : t -> string - (** Print directory paths as ["coq_root.module.submodule"] *) - val initial : t (** Initial "seed" of the unique identifier generator *) val hcons : t -> t (** Hashconsing of directory paths. *) + val to_string : t -> string + (** Print non-empty directory paths as ["coq_root.module.submodule"] *) + val print : t -> Pp.t end @@ -180,15 +180,15 @@ sig val make : string -> t (** Create a label out of a string. *) - val to_string : t -> string - (** Conversion to string. *) - val of_id : Id.t -> t (** Conversion from an identifier. *) val to_id : t -> Id.t (** Conversion to an identifier. *) + val to_string : t -> string + (** Conversion to string. *) + val print : t -> Pp.t (** Pretty-printer. *) @@ -227,10 +227,10 @@ sig (** Return the identifier contained in the argument. *) val to_string : t -> string - (** Conversion to a string. *) + (** Encode as a string (not to be used for user-facing messages). *) val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) + (** Same as [to_string], but outputs extra information related to debug. *) end @@ -252,16 +252,17 @@ sig val is_bound : t -> bool - val to_string : t -> string - - val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) - val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) val dp : t -> DirPath.t + val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + end module MPset : Set.S with type elt = ModPath.t @@ -284,13 +285,17 @@ sig val modpath : t -> ModPath.t val label : t -> Label.t - (** Display *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) val debug_to_string : t -> string - (** Same as [to_string], but outputs information related to debug. *) + (** Same as [to_string], but outputs extra information related to debug. *) - val print : t -> Pp.t + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) (** Comparisons *) val compare : t -> t -> int @@ -365,9 +370,16 @@ sig (** Displaying *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) end @@ -444,9 +456,16 @@ sig (** Displaying *) val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + val debug_to_string : t -> string + (** Same as [to_string], but outputs extra information related to debug. *) + val debug_print : t -> Pp.t + (** Same as [print], but outputs extra information related to debug. *) end @@ -510,14 +529,6 @@ type 'a tableKey = | VarKey of Id.t | RelKey of Int.t -(** Sets of names *) -type transparent_state = Id.Pred.t * Cpred.t - -val empty_transparent_state : transparent_state -val full_transparent_state : transparent_state -val var_full_transparent_state : transparent_state -val cst_full_transparent_state : transparent_state - type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) @@ -575,8 +586,12 @@ module Projection : sig val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t - val print : t -> Pp.t val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) + end type t (* = Repr.t * bool *) @@ -608,13 +623,19 @@ module Projection : sig val hcons : t -> t (** Hashconsing of projections. *) + val repr_equal : t -> t -> bool + (** Ignoring the unfolding boolean. *) + val compare : t -> t -> int val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t val to_string : t -> string + (** Encode as a string (not to be used for user-facing messages). *) + val print : t -> Pp.t + (** Print internal representation (not to be used for user-facing messages). *) end diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 482a2f3a3c..2dab14e732 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -11,10 +11,10 @@ open CErrors open Names open Constr +open Context open Declarations open Util open Nativevalues -open Nativeinstr open Nativelambda open Environ @@ -286,8 +286,6 @@ type primitive = | Mk_int | Mk_bool | Val_to_int - | Mk_I31_accu - | Decomp_uint | Mk_meta | Mk_evar | MLand @@ -305,7 +303,7 @@ type primitive = | MLmagic | MLarrayget | Mk_empty_instance - | Coq_primitive of CPrimitives.t * (prefix * Constant.t) option + | Coq_primitive of CPrimitives.t * (prefix * pconstant) option let eq_primitive p1 p2 = match p1, p2 with @@ -351,29 +349,27 @@ let primitive_hash = function | Mk_int -> 16 | Mk_bool -> 17 | Val_to_int -> 18 - | Mk_I31_accu -> 19 - | Decomp_uint -> 20 - | Mk_meta -> 21 - | Mk_evar -> 22 - | MLand -> 23 - | MLle -> 24 - | MLlt -> 25 - | MLinteq -> 26 - | MLlsl -> 27 - | MLlsr -> 28 - | MLland -> 29 - | MLlor -> 30 - | MLlxor -> 31 - | MLadd -> 32 - | MLsub -> 33 - | MLmul -> 34 - | MLmagic -> 35 - | Coq_primitive (prim, None) -> combinesmall 36 (CPrimitives.hash prim) - | Coq_primitive (prim, Some (prefix,kn)) -> - combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) - | Mk_proj -> 38 - | MLarrayget -> 39 - | Mk_empty_instance -> 40 + | Mk_meta -> 19 + | Mk_evar -> 20 + | MLand -> 21 + | MLle -> 22 + | MLlt -> 23 + | MLinteq -> 24 + | MLlsl -> 25 + | MLlsr -> 26 + | MLland -> 27 + | MLlor -> 28 + | MLlxor -> 29 + | MLadd -> 30 + | MLsub -> 31 + | MLmul -> 32 + | MLmagic -> 33 + | Coq_primitive (prim, None) -> combinesmall 34 (CPrimitives.hash prim) + | Coq_primitive (prim, Some (prefix,(kn,_))) -> + combinesmall 35 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) + | Mk_proj -> 36 + | MLarrayget -> 37 + | Mk_empty_instance -> 38 type mllambda = | MLlocal of lname @@ -389,7 +385,7 @@ type mllambda = | MLconstruct of string * constructor * mllambda array (* prefix, constructor name, arguments *) | MLint of int - | MLuint of Uint31.t + | MLuint of Uint63.t | MLsetref of string * mllambda | MLsequence of mllambda * mllambda | MLarray of mllambda array @@ -455,7 +451,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = | MLint i1, MLint i2 -> Int.equal i1 i2 | MLuint i1, MLuint i2 -> - Uint31.equal i1 i2 + Uint63.equal i1 i2 | MLsetref (id1, ml1), MLsetref (id2, ml2) -> String.equal id1 id2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 @@ -534,7 +530,7 @@ let rec hash_mllambda gn n env t = | MLint i -> combinesmall 11 i | MLuint i -> - combinesmall 12 (Uint31.to_int i) + combinesmall 12 (Uint63.hash i) | MLsetref (id, ml) -> let hid = String.hash id in let hml = hash_mllambda gn n env ml in @@ -768,7 +764,7 @@ let empty_env univ () = } let push_rel env id = - let local = fresh_lname id in + let local = fresh_lname id.binder_name in local, { env with env_rel = MLlocal local :: env.env_rel; env_bound = env.env_bound + 1 @@ -777,7 +773,7 @@ let push_rel env id = let push_rels env ids = let lnames, env_rel = Array.fold_left (fun (names,env_rel) id -> - let local = fresh_lname id in + let local = fresh_lname id.binder_name in (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in Array.of_list (List.rev lnames), { env with env_rel = env_rel; @@ -947,9 +943,10 @@ let merge_branches t = Array.iter (fun (c,args,body) -> insert (c,args) body newt) t; Array.of_list (to_list newt) +let app_prim p args = MLapp(MLprimitive p, args) -type prim_aux = - | PAprim of string * Constant.t * CPrimitives.t * prim_aux array +type prim_aux = + | PAprim of string * pconstant * CPrimitives.t * prim_aux array | PAml of mllambda let add_check cond args = @@ -962,97 +959,67 @@ let add_check cond args = | _ -> cond in Array.fold_left aux cond args - + let extract_prim ml_of l = let decl = ref [] in let cond = ref [] in - let rec aux l = + let rec aux l = match l with | Lprim(prefix,kn,p,args) -> - let args = Array.map aux args in - cond := add_check !cond args; - PAprim(prefix,kn,p,args) + let args = Array.map aux args in + cond := add_check !cond args; + PAprim(prefix,kn,p,args) | Lrel _ | Lvar _ | Luint _ | Lval _ | Lconst _ -> PAml (ml_of l) - | _ -> - let x = fresh_lname Anonymous in - decl := (x,ml_of l)::!decl; - PAml (MLlocal x) in + | _ -> + let x = fresh_lname Anonymous in + decl := (x,ml_of l)::!decl; + PAml (MLlocal x) in let res = aux l in (!decl, !cond, res) -let app_prim p args = MLapp(MLprimitive p, args) - -let to_int v = +let cast_to_int v = match v with - | MLapp(MLprimitive Mk_uint, t) -> - begin match t.(0) with - | MLuint i -> MLint (Uint31.to_int i) - | _ -> MLapp(MLprimitive Val_to_int, [|v|]) - end - | MLapp(MLprimitive Mk_int, t) -> t.(0) - | _ -> MLapp(MLprimitive Val_to_int, [|v|]) - -let of_int v = - match v with - | MLapp(MLprimitive Val_to_int, t) -> t.(0) - | _ -> MLapp(MLprimitive Mk_int,[|v|]) + | MLint _ -> v + | _ -> MLapp(MLprimitive Val_to_int, [|v|]) let compile_prim decl cond paux = -(* - let args_to_int args = - for i = 0 to Array.length args - 1 do - args.(i) <- to_int args.(i) - done; - args in - *) + let rec opt_prim_aux paux = match paux with | PAprim(_prefix, _kn, op, args) -> - let args = Array.map opt_prim_aux args in - app_prim (Coq_primitive(op,None)) args -(* - TODO: check if this inlining was useful - begin match op with - | Int31lt -> - if Sys.word_size = 64 then - app_prim Mk_bool [|(app_prim MLlt (args_to_int args))|] - else app_prim (Coq_primitive (CPrimitives.Int31lt,None)) args - | Int31le -> - if Sys.word_size = 64 then - app_prim Mk_bool [|(app_prim MLle (args_to_int args))|] - else app_prim (Coq_primitive (CPrimitives.Int31le, None)) args - | Int31lsl -> of_int (mk_lsl (args_to_int args)) - | Int31lsr -> of_int (mk_lsr (args_to_int args)) - | Int31land -> of_int (mk_land (args_to_int args)) - | Int31lor -> of_int (mk_lor (args_to_int args)) - | Int31lxor -> of_int (mk_lxor (args_to_int args)) - | Int31add -> of_int (mk_add (args_to_int args)) - | Int31sub -> of_int (mk_sub (args_to_int args)) - | Int31mul -> of_int (mk_mul (args_to_int args)) - | _ -> app_prim (Coq_primitive(op,None)) args - end *) - | PAml ml -> ml - and naive_prim_aux paux = + let args = Array.map opt_prim_aux args in + app_prim (Coq_primitive(op,None)) args + | PAml ml -> ml + + and naive_prim_aux paux = match paux with | PAprim(prefix, kn, op, args) -> - app_prim (Coq_primitive(op, Some (prefix, kn))) (Array.map naive_prim_aux args) - | PAml ml -> ml in + app_prim (Coq_primitive(op, Some (prefix,kn))) (Array.map naive_prim_aux args) + | PAml ml -> ml + in - let compile_cond cond paux = + let compile_cond cond paux = match cond with - | [] -> opt_prim_aux paux + | [] -> opt_prim_aux paux | [c1] -> - MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) + MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) | c1::cond -> - let cond = - List.fold_left - (fun ml c -> app_prim MLland [| ml; to_int c|]) - (app_prim MLland [|to_int c1; MLint 0 |]) cond in - let cond = app_prim MLmagic [|cond|] in - MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in + let cond = + List.fold_left + (fun ml c -> app_prim MLland [| ml; cast_to_int c|]) + (app_prim MLland [| cast_to_int c1; MLint 0 |]) cond in + let cond = app_prim MLmagic [|cond|] in + MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in + let add_decl decl body = List.fold_left (fun body (x,d) -> MLlet(x,d,body)) body decl in - add_decl decl (compile_cond cond paux) + + (* The optimizations done for checking if integer values are closed are valid + only on 64-bit architectures. So on 32-bit architectures, we fall back to less optimized checks. *) + if max_int = 1073741823 (* 32-bits *) then + add_decl decl (naive_prim_aux paux) + else + add_decl decl (compile_cond cond paux) let ml_of_instance instance u = let ml_of_level l = @@ -1089,6 +1056,11 @@ let ml_of_instance instance u = | Llam(ids,body) -> let lnames,env = push_rels env ids in MLlam(lnames, ml_of_lam env l body) + | Lrec(id,body) -> + let ids,body = decompose_Llam body in + let lname, env = push_rel env id in + let lnames, env = push_rels env ids in + MLletrec([|lname, lnames, ml_of_lam env l body|], MLlocal lname) | Llet(id,def,body) -> let def = ml_of_lam env l def in let lname, env = push_rel env id in @@ -1101,8 +1073,8 @@ let ml_of_instance instance u = mkMLapp (MLglobal(Gconstant (prefix, c))) args | Lproj (prefix, ind, i) -> MLglobal(Gproj (prefix, ind, i)) | Lprim _ -> - let decl,cond,paux = extract_prim (ml_of_lam env l) t in - compile_prim decl cond paux + let decl,cond,paux = extract_prim (ml_of_lam env l) t in + compile_prim decl cond paux | Lcase (annot,p,a,bs) -> (* let predicate_uid fv_pred = compilation of p let rec case_uid fv a_uid = @@ -1311,18 +1283,7 @@ let ml_of_instance instance u = | Lconstruct (prefix, (cn,u)) -> let uargs = ml_of_instance env.env_univ u in mkMLapp (MLglobal (Gconstruct (prefix, cn))) uargs - | Luint v -> - (match v with - | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) - | UintDigits (prefix,cn,ds) -> - let c = MLglobal (Gconstruct (prefix, cn)) in - let ds = Array.map (ml_of_lam env l) ds in - let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in - MLapp(i31, ds) - | UintDecomp (prefix,cn,t) -> - let c = MLglobal (Gconstruct (prefix, cn)) in - let t = ml_of_lam env l t in - MLapp (MLprimitive Decomp_uint, [|c;t|])) + | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i | Lsort s -> @@ -1646,7 +1607,7 @@ let pp_mllam fmt l = Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" (string_of_construct prefix c) pp_cargs args | MLint i -> pp_int fmt i - | MLuint i -> Format.fprintf fmt "(Uint31.of_int %a)" pp_int (Uint31.to_int i) + | MLuint i -> Format.fprintf fmt "(%s)" (Uint63.compile i) | MLsetref (s, body) -> Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body | MLsequence(l1,l2) -> @@ -1766,8 +1727,6 @@ let pp_mllam fmt l = | Mk_int -> Format.fprintf fmt "mk_int" | Mk_bool -> Format.fprintf fmt "mk_bool" | Val_to_int -> Format.fprintf fmt "val_to_int" - | Mk_I31_accu -> Format.fprintf fmt "mk_I31_accu" - | Decomp_uint -> Format.fprintf fmt "decomp_uint" | Mk_meta -> Format.fprintf fmt "mk_meta_accu" | Mk_evar -> Format.fprintf fmt "mk_evar_accu" | MLand -> Format.fprintf fmt "(&&)" @@ -1787,9 +1746,9 @@ let pp_mllam fmt l = | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty" | Coq_primitive (op,None) -> Format.fprintf fmt "no_check_%s" (CPrimitives.to_string op) - | Coq_primitive (op, Some (prefix,kn)) -> + | Coq_primitive (op, Some (prefix,(c,_))) -> Format.fprintf fmt "%s %a" (CPrimitives.to_string op) - pp_mllam (MLglobal (Gconstant (prefix, kn))) + pp_mllam (MLglobal (Gconstant (prefix,c))) in Format.fprintf fmt "@[%a@]" pp_mllam l @@ -1893,17 +1852,13 @@ and compile_named env sigma univ auxdefs id = Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = - let no_univs = - match cb.const_universes with - | Monomorphic_const _ -> true - | Polymorphic_const ctx -> Int.equal (Univ.AUContext.size ctx) 0 - in + let no_univs = 0 = Univ.AUContext.size (Declareops.constant_polymorphic_context cb) in begin match cb.const_body with | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); - let is_lazy = is_lazy env prefix t in + let is_lazy = is_lazy t in let code = if is_lazy then mk_lazy code else code in let name = if interactive then LinkedInteractive prefix @@ -1991,7 +1946,7 @@ let compile_mind mb mind stack = let tbl = ob.mind_reloc_tbl in (* Building info *) let ci = { ci_ind = ind; ci_npar = nparams; - ci_cstr_nargs = [|0|]; + ci_cstr_nargs = [|0|]; ci_relevance = ob.mind_relevance; ci_cstr_ndecls = [||] (*FIXME*); ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in let asw = { asw_ind = ind; asw_prefix = ""; asw_ci = ci; @@ -2014,7 +1969,7 @@ let compile_mind mb mind stack = let projs = match mb.mind_record with | NotRecord | FakeRecord -> [] | PrimRecord info -> - let _, _, pbs = info.(i) in + let _, _, _, pbs = info.(i) in Array.fold_left_i add_proj [] pbs in projs @ constructors @ gtype :: accu :: stack diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 054b6a2d17..baa290367f 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -14,7 +14,8 @@ open Nativelib open Reduction open Util open Nativevalues -open Nativecode +open Nativecode +open Environ (** This module implements the conversion test by compiling to OCaml code *) @@ -33,6 +34,8 @@ let rec conv_val env pb lvl v1 v2 cu = conv_accu env pb lvl k1 k2 cu | Vconst i1, Vconst i2 -> if Int.equal i1 i2 then cu else raise NotConvertible + | Vint64 i1, Vint64 i2 -> + if Int64.equal i1 i2 then cu else raise NotConvertible | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in @@ -46,7 +49,7 @@ let rec conv_val env pb lvl v1 v2 cu = aux lvl max b1 b2 (i+1) cu in aux lvl (n1-1) b1 b2 0 cu - | Vaccu _, _ | Vconst _, _ | Vblock _, _ -> raise NotConvertible + | Vaccu _, _ | Vconst _, _ | Vint64 _, _ | Vblock _, _ -> raise NotConvertible and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in @@ -142,7 +145,7 @@ let warn_no_native_compiler = strbrk " falling back to VM conversion test.") let native_conv_gen pb sigma env univs t1 t2 = - if not Coq_config.native_compiler then begin + if not (typing_flags env).Declarations.enable_native_compiler then begin warn_no_native_compiler (); Vconv.vm_conv_gen pb env univs t1 t2 end diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli deleted file mode 100644 index 2d8e2ba2f0..0000000000 --- a/kernel/nativeinstr.mli +++ /dev/null @@ -1,59 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -open Names -open Constr -open Nativevalues - -(** This file defines the lambda code for the native compiler. It has been -extracted from Nativelambda.ml because of the retroknowledge architecture. *) - -type prefix = string - -type uint = - | UintVal of Uint31.t - | UintDigits of prefix * constructor * lambda array - | UintDecomp of prefix * constructor * lambda - -and lambda = - | Lrel of Name.t * int - | Lvar of Id.t - | Lmeta of metavariable * lambda (* type *) - | Levar of Evar.t * lambda array (* arguments *) - | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda - | Lapp of lambda * lambda array - | Lconst of prefix * pconstant - | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) - | Lprim of prefix * Constant.t * CPrimitives.t * lambda array - | Lcase of annot_sw * lambda * lambda * lam_branches - (* annotations, term being matched, accu, branches *) - | Lif of lambda * lambda * lambda - | Lfix of (int array * (string * inductive) array * int) * fix_decl - | Lcofix of int * fix_decl (* must be in eta-expanded form *) - | Lmakeblock of prefix * pconstructor * int * lambda array - (* prefix, constructor name, constructor tag, arguments *) - (* A fully applied constructor *) - | Lconstruct of prefix * pconstructor - (* A partially applied constructor *) - | Luint of uint - | Lval of Nativevalues.t - | Lsort of Sorts.t - | Lind of prefix * pinductive - | Llazy - | Lforce - -(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation -to be correct. Otherwise, memoization of previous evaluations will be applied -again to extra arguments (see #7333). *) - -and lam_branches = (constructor * Name.t array * lambda) array - -and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 70cb8691c6..ec3a7b893d 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -14,12 +14,46 @@ open Constr open Declarations open Environ open Nativevalues -open Nativeinstr module RelDecl = Context.Rel.Declaration - -exception NotClosed +(** This file defines the lambda code generation phase of the native compiler *) +type prefix = string + +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Lmeta of metavariable * lambda (* type *) + | Levar of Evar.t * lambda array (* arguments *) + | Lprod of lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Lrec of Name.t Context.binder_annot * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of prefix * pconstant + | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) + | Lprim of prefix * pconstant * CPrimitives.t * lambda array + (* No check if None *) + | Lcase of annot_sw * lambda * lambda * lam_branches + (* annotations, term being matched, accu, branches *) + | Lif of lambda * lambda * lambda + | Lfix of (int array * (string * inductive) array * int) * fix_decl + | Lcofix of int * fix_decl + | Lmakeblock of prefix * pconstructor * int * lambda array + (* prefix, constructor Name.t, constructor tag, arguments *) + (* A fully applied constructor *) + | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) + (* A partially applied constructor *) + | Luint of Uint63.t + | Lval of Nativevalues.t + | Lsort of Sorts.t + | Lind of prefix * pinductive + | Llazy + | Lforce + +and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array + +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array type evars = { evars_val : existential -> constr option; @@ -84,9 +118,9 @@ let get_const_prefix env c = (* A generic map function *) -let rec map_lam_with_binders g f n lam = +let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ | Lconstruct _ | Llazy | Lforce | Lmeta _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in @@ -95,6 +129,9 @@ let rec map_lam_with_binders g f n lam = | Llam(ids,body) -> let body' = f (g (Array.length ids) n) body in if body == body' then lam else mkLlam ids body' + | Lrec(id,body) -> + let body' = f (g 1 n) body in + if body == body' then lam else Lrec(id,body') | Llet(id,def,body) -> let def' = f n def in let body' = f (g 1 n) body in @@ -135,23 +172,10 @@ let rec map_lam_with_binders g f n lam = | Lmakeblock(prefix,cn,tag,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(prefix,cn,tag,args') - | Luint u -> - let u' = map_uint g f n u in - if u == u' then lam else Luint u' | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') -and map_uint _g f n u = - match u with - | UintVal _ -> u - | UintDigits(prefix,c,args) -> - let args' = Array.Smart.map (f n) args in - if args == args' then u else UintDigits(prefix,c,args') - | UintDecomp(prefix,c,a) -> - let a' = f n a in - if a == a' then u else UintDecomp(prefix,c,a') - (*s Lift and substitution *) let rec lam_exlift el lam = @@ -186,7 +210,7 @@ let lam_subst_args subst args = (* [simplify subst lam] simplify the expression [lam_subst subst lam] *) (* that is : *) (* - Reduce [let] is the definition can be substituted i.e: *) -(* - a variable (rel or identifier) *) +(* - a variable (rel or Id.t) *) (* - a constant *) (* - a structured constant *) (* - a function *) @@ -298,7 +322,7 @@ let is_value lc = match lc with | Lval _ -> true | Lmakeblock(_,_,_,args) when Array.is_empty args -> true - | Luint (UintVal _) -> true + | Luint _ -> true | _ -> false let get_value lc = @@ -306,7 +330,7 @@ let get_value lc = | Lval v -> v | Lmakeblock(_,_,tag,args) when Array.is_empty args -> Nativevalues.mk_int tag - | Luint (UintVal i) -> Nativevalues.mk_uint i + | Luint i -> Nativevalues.mk_uint i | _ -> raise Not_found let make_args start _end = @@ -333,6 +357,21 @@ let rec get_alias env (kn, u as p) = | Cemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p +let prim env kn p args = + let prefix = get_const_prefix env (fst kn) in + Lprim(prefix, kn, p, args) + +let expand_prim env kn op arity = + (* primitives are always Relevant *) + let ids = Array.make arity Context.anonR in + let args = make_args arity 1 in + Llam(ids, prim env kn op args) + +let lambda_of_prim env kn op args = + let arity = CPrimitives.arity op in + if Array.length args >= arity then prim env kn op args + else mkLapp (expand_prim env kn op arity) args + (*i Global environment *) let get_names decl = @@ -357,7 +396,7 @@ module Cache = let get_construct_info cache env c : constructor_info = try ConstrTable.find cache c - with Not_found -> + with Not_found -> let ((mind,j), i) = c in let oib = lookup_mind mind env in let oip = oib.mind_packets.(j) in @@ -368,22 +407,9 @@ module Cache = r end -let is_lazy env prefix t = - match kind t with - | App (f,_args) -> - begin match kind f with - | Construct (c,_) -> - let gr = GlobRef.IndRef (fst c) in - (try - let _ = - Retroknowledge.get_native_before_match_info env.retroknowledge - gr prefix c Llazy; - in - false - with Not_found -> true) - | _ -> true - end - | LetIn _ | Case _ | Proj _ -> true +let is_lazy t = + match Constr.kind t with + | App _ | LetIn _ | Case _ | Proj _ -> true | _ -> false let evar_value sigma ev = sigma.evars_val ev @@ -482,13 +508,6 @@ let rec lambda_of_constr cache env sigma c = in (* translation of the argument *) let la = lambda_of_constr cache env sigma a in - let gr = GlobRef.IndRef ind in - let la = - try - Retroknowledge.get_native_before_match_info (env).retroknowledge - gr prefix (ind,1) la - with Not_found -> la - in (* translation of the type *) let lt = lambda_of_constr cache env sigma t in (* translation of branches *) @@ -500,8 +519,10 @@ let rec lambda_of_constr cache env sigma c = else match b with | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body) - | _ -> - let ids = Array.make arity Anonymous in + | _ -> + (** TODO relevance *) + let anon = Context.make_annot Anonymous Sorts.Relevant in + let ids = Array.make arity anon in let args = make_args arity 1 in let ll = lam_lift arity b in (cn, ids, mkLapp ll args) in @@ -519,7 +540,7 @@ let rec lambda_of_constr cache env sigma c = let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in let lbodies = lambda_of_args cache env sigma 0 rec_bodies in Lfix((pos, inds, i), (names, ltypes, lbodies)) - + | CoFix(init,(names,type_bodies,rec_bodies)) -> let rec_bodies = Array.map2 (Reduction.eta_expand env) rec_bodies type_bodies in let ltypes = lambda_of_args cache env sigma 0 type_bodies in @@ -527,27 +548,22 @@ let rec lambda_of_constr cache env sigma c = let lbodies = lambda_of_args cache env sigma 0 rec_bodies in Lcofix(init, (names, ltypes, lbodies)) + | Int i -> Luint i + and lambda_of_app cache env sigma f args = match kind f with | Const (_kn,_u as c) -> let kn,u = get_alias env c in let cb = lookup_constant kn env in - (try - let prefix = get_const_prefix env kn in - (* We delay the compilation of arguments to avoid an exponential behavior *) - let f = Retroknowledge.get_native_compiling_info - (env).retroknowledge (GlobRef.ConstRef kn) prefix in - let args = lambda_of_args cache env sigma 0 args in - f args - with Not_found -> begin match cb.const_body with + | Primitive op -> lambda_of_prim env c op (lambda_of_args cache env sigma 0 args) | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then lambda_of_app cache env sigma (Mod_subst.force_constr csubst) args else let prefix = get_const_prefix env kn in let t = - if is_lazy env prefix (Mod_subst.force_constr csubst) then + if is_lazy (Mod_subst.force_constr csubst) then mkLapp Lforce [|Lconst (prefix, (kn,u))|] else Lconst (prefix, (kn,u)) in @@ -555,34 +571,18 @@ and lambda_of_app cache env sigma f args = | OpaqueDef _ | Undef _ -> let prefix = get_const_prefix env kn in mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) - end) + end | Construct (c,u) -> let tag, nparams, arity = Cache.get_construct_info cache env c in let expected = nparams + arity in let nargs = Array.length args in let prefix = get_mind_prefix env (fst (fst c)) in - let gr = GlobRef.ConstructRef c in if Int.equal nargs expected then - try - try - Retroknowledge.get_native_constant_static_info - (env).retroknowledge - gr args - with NotClosed -> - assert (Int.equal nparams 0); (* should be fine for int31 *) - let args = lambda_of_args cache env sigma nparams args in - Retroknowledge.get_native_constant_dynamic_info - (env).retroknowledge gr prefix c args - with Not_found -> let args = lambda_of_args cache env sigma nparams args in makeblock env c u tag args else let args = lambda_of_args cache env sigma 0 args in - (try - Retroknowledge.get_native_constant_dynamic_info - (env).retroknowledge gr prefix c args - with Not_found -> - mkLapp (Lconstruct (prefix, (c,u))) args) + mkLapp (Lconstruct (prefix, (c,u))) args | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in @@ -615,45 +615,3 @@ let lambda_of_constr env sigma c = let mk_lazy c = mkLapp Llazy [|c|] - -(** Retroknowledge, to be removed once we move to primitive machine integers *) -let compile_static_int31 fc args = - if not fc then raise Not_found else - Luint (UintVal - (Uint31.of_int (Array.fold_left - (fun temp_i -> fun t -> match kind t with - | Construct ((_,d),_) -> 2*temp_i+d-1 - | _ -> raise NotClosed) - 0 args))) - -let compile_dynamic_int31 fc prefix c args = - if not fc then raise Not_found else - Luint (UintDigits (prefix,c,args)) - -(* We are relying here on the order of digits constructors *) -let digits_from_uint digits_ind prefix i = - let d0 = Lconstruct (prefix, ((digits_ind, 1), Univ.Instance.empty)) in - let d1 = Lconstruct (prefix, ((digits_ind, 2), Univ.Instance.empty)) in - let digits = Array.make 31 d0 in - for k = 0 to 30 do - if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then - digits.(30-k) <- d1 - done; - digits - -let before_match_int31 digits_ind fc prefix c t = - if not fc then - raise Not_found - else - match t with - | Luint (UintVal i) -> - let digits = digits_from_uint digits_ind prefix i in - mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) digits - | Luint (UintDigits (prefix,c,args)) -> - mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) args - | _ -> Luint (UintDecomp (prefix,c,t)) - -let compile_prim prim kn fc prefix args = - if not fc then raise Not_found - else - Lprim(prefix, kn, prim, args) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index 7b20258929..b0de257a27 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -10,19 +10,55 @@ open Names open Constr open Environ -open Nativeinstr +open Nativevalues (** This file defines the lambda code generation phase of the native compiler *) +type prefix = string + +type lambda = + | Lrel of Name.t * int + | Lvar of Id.t + | Lmeta of metavariable * lambda (* type *) + | Levar of Evar.t * lambda array (* arguments *) + | Lprod of lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Lrec of Name.t Context.binder_annot * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda + | Lapp of lambda * lambda array + | Lconst of prefix * pconstant + | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) + | Lprim of prefix * pconstant * CPrimitives.t * lambda array + | Lcase of annot_sw * lambda * lambda * lam_branches + (* annotations, term being matched, accu, branches *) + | Lif of lambda * lambda * lambda + | Lfix of (int array * (string * inductive) array * int) * fix_decl + | Lcofix of int * fix_decl + | Lmakeblock of prefix * pconstructor * int * lambda array + (* prefix, constructor Name.t, constructor tag, arguments *) + (* A fully applied constructor *) + | Lconstruct of prefix * pconstructor (* prefix, constructor Name.t *) + (* A partially applied constructor *) + | Luint of Uint63.t + | Lval of Nativevalues.t + | Lsort of Sorts.t + | Lind of prefix * pinductive + | Llazy + | Lforce + +and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array + +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array + type evars = { evars_val : existential -> constr option; evars_metas : metavariable -> types } val empty_evars : evars -val decompose_Llam : lambda -> Name.t array * lambda -val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda +val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda +val decompose_Llam_Llet : lambda -> (Name.t Context.binder_annot * lambda option) array * lambda -val is_lazy : env -> prefix -> constr -> bool +val is_lazy : constr -> bool val mk_lazy : lambda -> lambda val get_mind_prefix : env -> MutInd.t -> string @@ -30,14 +66,3 @@ val get_mind_prefix : env -> MutInd.t -> string val get_alias : env -> pconstant -> pconstant val lambda_of_constr : env -> evars -> Constr.constr -> lambda - -val compile_static_int31 : bool -> Constr.constr array -> lambda - -val compile_dynamic_int31 : bool -> prefix -> constructor -> lambda array -> - lambda - -val before_match_int31 : inductive -> bool -> prefix -> constructor -> lambda -> - lambda - -val compile_prim : CPrimitives.t -> Constant.t -> bool -> prefix -> lambda array -> - lambda diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index d294f2060e..833e4082f0 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -66,7 +66,6 @@ let warn_native_compiler_failed = CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ?profile:(profile=false) ml_filename = - let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 93e74af845..3eb51ffc59 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -117,11 +117,11 @@ let mk_ind_accu ind u = let mk_sort_accu s u = let open Sorts in match s with - | Prop | Set -> mk_accu (Asort s) + | SProp | Prop | Set -> mk_accu (Asort s) | Type s -> let u = Univ.Instance.of_array u in - let s = Univ.subst_instance_universe u s in - mk_accu (Asort (Type s)) + let s = Sorts.sort_of_univ (Univ.subst_instance_universe u s) in + mk_accu (Asort s) let mk_var_accu id = mk_accu (Avar id) @@ -196,11 +196,17 @@ let dummy_value : unit -> t = fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed.") let cast_accu v = (Obj.magic v:accumulator) +[@@ocaml.inline always] let mk_int (x : int) = (Obj.magic x : t) +[@@ocaml.inline always] + (* Coq's booleans are reversed... *) let mk_bool (b : bool) = (Obj.magic (not b) : t) -let mk_uint (x : Uint31.t) = (Obj.magic x : t) +[@@ocaml.inline always] + +let mk_uint (x : Uint63.t) = (Obj.magic x : t) +[@@ocaml.inline always] type block @@ -216,8 +222,9 @@ type kind_of_value = | Vaccu of accumulator | Vfun of (t -> t) | Vconst of int + | Vint64 of int64 | Vblock of block - + let kind_of_value (v:t) = let o = Obj.repr v in if Obj.is_int o then Vconst (Obj.magic v) @@ -225,8 +232,8 @@ let kind_of_value (v:t) = let tag = Obj.tag o in if Int.equal tag accumulate_tag then Vaccu (Obj.magic v) - else - if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) + else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) + else if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) else (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); or ??? what is 1002*) @@ -236,92 +243,105 @@ let kind_of_value (v:t) = let is_int (x:t) = let o = Obj.repr x in - Obj.is_int o + Obj.is_int o || Int.equal (Obj.tag o) Obj.custom_tag let val_to_int (x:t) = (Obj.magic x : int) +[@@ocaml.inline always] -let to_uint (x:t) = (Obj.magic x : Uint31.t) -let of_uint (x: Uint31.t) = (Obj.magic x : t) +let to_uint (x:t) = (Obj.magic x : Uint63.t) +[@@ocaml.inline always] let no_check_head0 x = - of_uint (Uint31.head0 (to_uint x)) + mk_uint (Uint63.head0 (to_uint x)) +[@@ocaml.inline always] let head0 accu x = if is_int x then no_check_head0 x else accu x let no_check_tail0 x = - of_uint (Uint31.tail0 (to_uint x)) + mk_uint (Uint63.tail0 (to_uint x)) +[@@ocaml.inline always] let tail0 accu x = if is_int x then no_check_tail0 x else accu x let no_check_add x y = - of_uint (Uint31.add (to_uint x) (to_uint y)) + mk_uint (Uint63.add (to_uint x) (to_uint y)) +[@@ocaml.inline always] let add accu x y = if is_int x && is_int y then no_check_add x y else accu x y let no_check_sub x y = - of_uint (Uint31.sub (to_uint x) (to_uint y)) + mk_uint (Uint63.sub (to_uint x) (to_uint y)) +[@@ocaml.inline always] let sub accu x y = if is_int x && is_int y then no_check_sub x y else accu x y let no_check_mul x y = - of_uint (Uint31.mul (to_uint x) (to_uint y)) + mk_uint (Uint63.mul (to_uint x) (to_uint y)) +[@@ocaml.inline always] let mul accu x y = if is_int x && is_int y then no_check_mul x y else accu x y let no_check_div x y = - of_uint (Uint31.div (to_uint x) (to_uint y)) + mk_uint (Uint63.div (to_uint x) (to_uint y)) +[@@ocaml.inline always] let div accu x y = if is_int x && is_int y then no_check_div x y else accu x y let no_check_rem x y = - of_uint (Uint31.rem (to_uint x) (to_uint y)) + mk_uint (Uint63.rem (to_uint x) (to_uint y)) +[@@ocaml.inline always] let rem accu x y = if is_int x && is_int y then no_check_rem x y else accu x y let no_check_l_sr x y = - of_uint (Uint31.l_sr (to_uint x) (to_uint y)) + mk_uint (Uint63.l_sr (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_sr accu x y = if is_int x && is_int y then no_check_l_sr x y else accu x y let no_check_l_sl x y = - of_uint (Uint31.l_sl (to_uint x) (to_uint y)) + mk_uint (Uint63.l_sl (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_sl accu x y = if is_int x && is_int y then no_check_l_sl x y else accu x y let no_check_l_and x y = - of_uint (Uint31.l_and (to_uint x) (to_uint y)) + mk_uint (Uint63.l_and (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_and accu x y = if is_int x && is_int y then no_check_l_and x y else accu x y let no_check_l_xor x y = - of_uint (Uint31.l_xor (to_uint x) (to_uint y)) + mk_uint (Uint63.l_xor (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_xor accu x y = if is_int x && is_int y then no_check_l_xor x y else accu x y let no_check_l_or x y = - of_uint (Uint31.l_or (to_uint x) (to_uint y)) + mk_uint (Uint63.l_or (to_uint x) (to_uint y)) +[@@ocaml.inline always] let l_or accu x y = if is_int x && is_int y then no_check_l_or x y @@ -337,61 +357,57 @@ type coq_pair = | Paccu of t | PPair of t * t -type coq_zn2z = - | Zaccu of t - | ZW0 - | ZWW of t * t - let mkCarry b i = - if b then (Obj.magic (C1(of_uint i)):t) - else (Obj.magic (C0(of_uint i)):t) + if b then (Obj.magic (C1(mk_uint i)):t) + else (Obj.magic (C0(mk_uint i)):t) let no_check_addc x y = - let s = Uint31.add (to_uint x) (to_uint y) in - mkCarry (Uint31.lt s (to_uint x)) s + let s = Uint63.add (to_uint x) (to_uint y) in + mkCarry (Uint63.lt s (to_uint x)) s +[@@ocaml.inline always] let addc accu x y = if is_int x && is_int y then no_check_addc x y else accu x y let no_check_subc x y = - let s = Uint31.sub (to_uint x) (to_uint y) in - mkCarry (Uint31.lt (to_uint x) (to_uint y)) s + let s = Uint63.sub (to_uint x) (to_uint y) in + mkCarry (Uint63.lt (to_uint x) (to_uint y)) s +[@@ocaml.inline always] let subc accu x y = if is_int x && is_int y then no_check_subc x y else accu x y -let no_check_addcarryc x y = +let no_check_addCarryC x y = let s = - Uint31.add (Uint31.add (to_uint x) (to_uint y)) - (Uint31.of_int 1) in - mkCarry (Uint31.le s (to_uint x)) s + Uint63.add (Uint63.add (to_uint x) (to_uint y)) + (Uint63.of_int 1) in + mkCarry (Uint63.le s (to_uint x)) s +[@@ocaml.inline always] -let addcarryc accu x y = - if is_int x && is_int y then no_check_addcarryc x y +let addCarryC accu x y = + if is_int x && is_int y then no_check_addCarryC x y else accu x y -let no_check_subcarryc x y = +let no_check_subCarryC x y = let s = - Uint31.sub (Uint31.sub (to_uint x) (to_uint y)) - (Uint31.of_int 1) in - mkCarry (Uint31.le (to_uint x) (to_uint y)) s + Uint63.sub (Uint63.sub (to_uint x) (to_uint y)) + (Uint63.of_int 1) in + mkCarry (Uint63.le (to_uint x) (to_uint y)) s +[@@ocaml.inline always] -let subcarryc accu x y = - if is_int x && is_int y then no_check_subcarryc x y +let subCarryC accu x y = + if is_int x && is_int y then no_check_subCarryC x y else accu x y let of_pair (x, y) = - (Obj.magic (PPair(of_uint x, of_uint y)):t) - -let zn2z_of_pair (x,y) = - if Uint31.equal x (Uint31.of_uint 0) && - Uint31.equal y (Uint31.of_uint 0) then Obj.magic ZW0 - else (Obj.magic (ZWW(of_uint x, of_uint y)) : t) + (Obj.magic (PPair(mk_uint x, mk_uint y)):t) +[@@ocaml.inline always] let no_check_mulc x y = - zn2z_of_pair(Uint31.mulc (to_uint x) (to_uint y)) + of_pair (Uint63.mulc (to_uint x) (to_uint y)) +[@@ocaml.inline always] let mulc accu x y = if is_int x && is_int y then no_check_mulc x y @@ -399,7 +415,8 @@ let mulc accu x y = let no_check_diveucl x y = let i1, i2 = to_uint x, to_uint y in - of_pair(Uint31.div i1 i2, Uint31.rem i1 i2) + of_pair(Uint63.div i1 i2, Uint63.rem i1 i2) +[@@ocaml.inline always] let diveucl accu x y = if is_int x && is_int y then no_check_diveucl x y @@ -407,21 +424,20 @@ let diveucl accu x y = let no_check_div21 x y z = let i1, i2, i3 = to_uint x, to_uint y, to_uint z in - of_pair (Uint31.div21 i1 i2 i3) + of_pair (Uint63.div21 i1 i2 i3) +[@@ocaml.inline always] let div21 accu x y z = if is_int x && is_int y && is_int z then no_check_div21 x y z else accu x y z -let no_check_addmuldiv x y z = +let no_check_addMulDiv x y z = let p, i, j = to_uint x, to_uint y, to_uint z in - let p' = Uint31.to_int p in - of_uint (Uint31.l_or - (Uint31.l_sl i p) - (Uint31.l_sr j (Uint31.of_int (31 - p')))) + mk_uint (Uint63.addmuldiv p i j) +[@@ocaml.inline always] -let addmuldiv accu x y z = - if is_int x && is_int y && is_int z then no_check_addmuldiv x y z +let addMulDiv accu x y z = + if is_int x && is_int y && is_int z then no_check_addMulDiv x y z else accu x y z [@@@ocaml.warning "-34"] @@ -436,29 +452,32 @@ type coq_cmp = | CmpLt | CmpGt -let no_check_eq x y = - mk_bool (Uint31.equal (to_uint x) (to_uint y)) +let no_check_eq x y = + mk_bool (Uint63.equal (to_uint x) (to_uint y)) +[@@ocaml.inline always] let eq accu x y = if is_int x && is_int y then no_check_eq x y else accu x y let no_check_lt x y = - mk_bool (Uint31.lt (to_uint x) (to_uint y)) + mk_bool (Uint63.lt (to_uint x) (to_uint y)) +[@@ocaml.inline always] let lt accu x y = if is_int x && is_int y then no_check_lt x y else accu x y let no_check_le x y = - mk_bool (Uint31.le (to_uint x) (to_uint y)) + mk_bool (Uint63.le (to_uint x) (to_uint y)) +[@@ocaml.inline always] let le accu x y = if is_int x && is_int y then no_check_le x y else accu x y let no_check_compare x y = - match Uint31.compare (to_uint x) (to_uint y) with + match Uint63.compare (to_uint x) (to_uint y) with | x when x < 0 -> (Obj.magic CmpLt:t) | 0 -> (Obj.magic CmpEq:t) | _ -> (Obj.magic CmpGt:t) @@ -467,6 +486,11 @@ let compare accu x y = if is_int x && is_int y then no_check_compare x y else accu x y +let print x = + Printf.fprintf stderr "%s" (Uint63.to_string (to_uint x)); + flush stderr; + x + let hobcnv = Array.init 256 (fun i -> Printf.sprintf "%02x" i) let bohcnv = Array.init 256 (fun i -> i - (if 0x30 <= i then 0x30 else 0) - @@ -491,63 +515,3 @@ let str_decode s = Buffer.add_char mshl_expr (bin_of_hex (Bytes.to_string buf)) done; Marshal.from_bytes (Buffer.to_bytes mshl_expr) 0 - -(** Retroknowledge, to be removed when we switch to primitive integers *) - -(* This will be unsafe with 63-bits integers *) -let digit_to_uint d = (Obj.magic d : Uint31.t) - -let mk_I31_accu c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 - x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 = - if is_int x0 && is_int x1 && is_int x2 && is_int x3 && is_int x4 && is_int x5 - && is_int x6 && is_int x7 && is_int x8 && is_int x9 && is_int x10 - && is_int x11 && is_int x12 && is_int x13 && is_int x14 && is_int x15 - && is_int x16 && is_int x17 && is_int x18 && is_int x19 && is_int x20 - && is_int x21 && is_int x22 && is_int x23 && is_int x24 && is_int x25 - && is_int x26 && is_int x27 && is_int x28 && is_int x29 && is_int x30 - then - let r = digit_to_uint x0 in - let r = Uint31.add_digit r (digit_to_uint x1) in - let r = Uint31.add_digit r (digit_to_uint x2) in - let r = Uint31.add_digit r (digit_to_uint x3) in - let r = Uint31.add_digit r (digit_to_uint x4) in - let r = Uint31.add_digit r (digit_to_uint x5) in - let r = Uint31.add_digit r (digit_to_uint x6) in - let r = Uint31.add_digit r (digit_to_uint x7) in - let r = Uint31.add_digit r (digit_to_uint x8) in - let r = Uint31.add_digit r (digit_to_uint x9) in - let r = Uint31.add_digit r (digit_to_uint x10) in - let r = Uint31.add_digit r (digit_to_uint x11) in - let r = Uint31.add_digit r (digit_to_uint x12) in - let r = Uint31.add_digit r (digit_to_uint x13) in - let r = Uint31.add_digit r (digit_to_uint x14) in - let r = Uint31.add_digit r (digit_to_uint x15) in - let r = Uint31.add_digit r (digit_to_uint x16) in - let r = Uint31.add_digit r (digit_to_uint x17) in - let r = Uint31.add_digit r (digit_to_uint x18) in - let r = Uint31.add_digit r (digit_to_uint x19) in - let r = Uint31.add_digit r (digit_to_uint x20) in - let r = Uint31.add_digit r (digit_to_uint x21) in - let r = Uint31.add_digit r (digit_to_uint x22) in - let r = Uint31.add_digit r (digit_to_uint x23) in - let r = Uint31.add_digit r (digit_to_uint x24) in - let r = Uint31.add_digit r (digit_to_uint x25) in - let r = Uint31.add_digit r (digit_to_uint x26) in - let r = Uint31.add_digit r (digit_to_uint x27) in - let r = Uint31.add_digit r (digit_to_uint x28) in - let r = Uint31.add_digit r (digit_to_uint x29) in - let r = Uint31.add_digit r (digit_to_uint x30) in - mk_uint r - else - c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 - x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 - -let decomp_uint c v = - if is_int v then - let r = ref c in - let v = val_to_int v in - for i = 30 downto 0 do - r := (!r) (mk_int ((v lsr i) land 1)); - done; - !r - else v diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 10689941e8..58cb6e2c30 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -78,8 +78,13 @@ val mk_const : tag -> t val mk_block : tag -> t array -> t val mk_bool : bool -> t +[@@ocaml.inline always] + val mk_int : int -> t -val mk_uint : Uint31.t -> t +[@@ocaml.inline always] + +val mk_uint : Uint63.t -> t +[@@ocaml.inline always] val napply : t -> t array -> t (* Functions over accumulators *) @@ -90,6 +95,8 @@ val args_of_accu : accumulator -> t array val accu_nargs : accumulator -> int val cast_accu : t -> accumulator +[@@ocaml.inline always] + (* Functions over block: i.e constructors *) type block @@ -106,6 +113,7 @@ type kind_of_value = | Vaccu of accumulator | Vfun of (t -> t) | Vconst of int + | Vint64 of int64 | Vblock of block val kind_of_value : t -> kind_of_value @@ -136,51 +144,90 @@ val l_or : t -> t -> t -> t val addc : t -> t -> t -> t val subc : t -> t -> t -> t -val addcarryc : t -> t -> t -> t -val subcarryc : t -> t -> t -> t +val addCarryC : t -> t -> t -> t +val subCarryC : t -> t -> t -> t val mulc : t -> t -> t -> t val diveucl : t -> t -> t -> t val div21 : t -> t -> t -> t -> t -val addmuldiv : t -> t -> t -> t -> t +val addMulDiv : t -> t -> t -> t -> t val eq : t -> t -> t -> t val lt : t -> t -> t -> t val le : t -> t -> t -> t val compare : t -> t -> t -> t +val print : t -> t + (* Function without check *) val no_check_head0 : t -> t +[@@ocaml.inline always] + val no_check_tail0 : t -> t +[@@ocaml.inline always] val no_check_add : t -> t -> t +[@@ocaml.inline always] + val no_check_sub : t -> t -> t +[@@ocaml.inline always] + val no_check_mul : t -> t -> t +[@@ocaml.inline always] + val no_check_div : t -> t -> t +[@@ocaml.inline always] + val no_check_rem : t -> t -> t +[@@ocaml.inline always] val no_check_l_sr : t -> t -> t +[@@ocaml.inline always] + val no_check_l_sl : t -> t -> t +[@@ocaml.inline always] + val no_check_l_and : t -> t -> t +[@@ocaml.inline always] + val no_check_l_xor : t -> t -> t +[@@ocaml.inline always] + val no_check_l_or : t -> t -> t +[@@ocaml.inline always] val no_check_addc : t -> t -> t +[@@ocaml.inline always] + val no_check_subc : t -> t -> t -val no_check_addcarryc : t -> t -> t -val no_check_subcarryc : t -> t -> t +[@@ocaml.inline always] + +val no_check_addCarryC : t -> t -> t +[@@ocaml.inline always] + +val no_check_subCarryC : t -> t -> t +[@@ocaml.inline always] val no_check_mulc : t -> t -> t +[@@ocaml.inline always] + val no_check_diveucl : t -> t -> t +[@@ocaml.inline always] val no_check_div21 : t -> t -> t -> t -val no_check_addmuldiv : t -> t -> t -> t +[@@ocaml.inline always] + +val no_check_addMulDiv : t -> t -> t -> t +[@@ocaml.inline always] val no_check_eq : t -> t -> t +[@@ocaml.inline always] + val no_check_lt : t -> t -> t +[@@ocaml.inline always] + val no_check_le : t -> t -> t -val no_check_compare : t -> t -> t +[@@ocaml.inline always] -val mk_I31_accu : t -val decomp_uint : t -> t -> t +val no_check_compare : t -> t -> t diff --git a/kernel/primred.ml b/kernel/primred.ml new file mode 100644 index 0000000000..d6d0a6143a --- /dev/null +++ b/kernel/primred.ml @@ -0,0 +1,204 @@ +(* Reduction of native operators *) +open Names +open CPrimitives +open Retroknowledge +open Environ +open CErrors + +let add_retroknowledge env action = + match action with + | Register_type(PT_int63,c) -> + let retro = env.retroknowledge in + let retro = + match retro.retro_int63 with + | None -> { retro with retro_int63 = Some c } + | Some c' -> assert (Constant.equal c c'); retro in + set_retroknowledge env retro + | Register_ind(pit,ind) -> + let retro = env.retroknowledge in + let retro = + match pit with + | PIT_bool -> + let r = + match retro.retro_bool with + | None -> ((ind,1), (ind,2)) + | Some (((ind',_),_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_bool = Some r } + | PIT_carry -> + let r = + match retro.retro_carry with + | None -> ((ind,1), (ind,2)) + | Some (((ind',_),_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_carry = Some r } + | PIT_pair -> + let r = + match retro.retro_pair with + | None -> (ind,1) + | Some ((ind',_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_pair = Some r } + | PIT_cmp -> + let r = + match retro.retro_cmp with + | None -> ((ind,1), (ind,2), (ind,3)) + | Some (((ind',_),_,_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_cmp = Some r } + in + set_retroknowledge env retro + +let get_int_type env = + match env.retroknowledge.retro_int63 with + | Some c -> c + | None -> anomaly Pp.(str"Reduction of primitive: int63 not registered") + +let get_bool_constructors env = + match env.retroknowledge.retro_bool with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: bool not registered") + +let get_carry_constructors env = + match env.retroknowledge.retro_carry with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: carry not registered") + +let get_pair_constructor env = + match env.retroknowledge.retro_pair with + | Some c -> c + | None -> anomaly Pp.(str"Reduction of primitive: pair not registered") + +let get_cmp_constructors env = + match env.retroknowledge.retro_cmp with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: cmp not registered") + +exception NativeDestKO + +module type RedNativeEntries = + sig + type elem + type args + type evd (* will be unit in kernel, evar_map outside *) + + val get : args -> int -> elem + val get_int : evd -> elem -> Uint63.t + val mkInt : env -> Uint63.t -> elem + val mkBool : env -> bool -> elem + val mkCarry : env -> bool -> elem -> elem (* true if carry *) + val mkIntPair : env -> elem -> elem -> elem + val mkLt : env -> elem + val mkEq : env -> elem + val mkGt : env -> elem + + end + +module type RedNative = + sig + type elem + type args + type evd + val red_prim : env -> evd -> CPrimitives.t -> args -> elem option + end + +module RedNative (E:RedNativeEntries) : + RedNative with type elem = E.elem + with type args = E.args + with type evd = E.evd = +struct + type elem = E.elem + type args = E.args + type evd = E.evd + + let get_int evd args i = E.get_int evd (E.get args i) + + let get_int1 evd args = get_int evd args 0 + + let get_int2 evd args = get_int evd args 0, get_int evd args 1 + + let get_int3 evd args = + get_int evd args 0, get_int evd args 1, get_int evd args 2 + + let red_prim_aux env evd op args = + let open CPrimitives in + match op with + | Int63head0 -> + let i = get_int1 evd args in E.mkInt env (Uint63.head0 i) + | Int63tail0 -> + let i = get_int1 evd args in E.mkInt env (Uint63.tail0 i) + | Int63add -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.add i1 i2) + | Int63sub -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.sub i1 i2) + | Int63mul -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.mul i1 i2) + | Int63div -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.div i1 i2) + | Int63mod -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.rem i1 i2) + | Int63lsr -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sr i1 i2) + | Int63lsl -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sl i1 i2) + | Int63land -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_and i1 i2) + | Int63lor -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_or i1 i2) + | Int63lxor -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_xor i1 i2) + | Int63addc -> + let i1, i2 = get_int2 evd args in + let s = Uint63.add i1 i2 in + E.mkCarry env (Uint63.lt s i1) (E.mkInt env s) + | Int63subc -> + let i1, i2 = get_int2 evd args in + let s = Uint63.sub i1 i2 in + E.mkCarry env (Uint63.lt i1 i2) (E.mkInt env s) + | Int63addCarryC -> + let i1, i2 = get_int2 evd args in + let s = Uint63.add (Uint63.add i1 i2) (Uint63.of_int 1) in + E.mkCarry env (Uint63.le s i1) (E.mkInt env s) + | Int63subCarryC -> + let i1, i2 = get_int2 evd args in + let s = Uint63.sub (Uint63.sub i1 i2) (Uint63.of_int 1) in + E.mkCarry env (Uint63.le i1 i2) (E.mkInt env s) + | Int63mulc -> + let i1, i2 = get_int2 evd args in + let (h, l) = Uint63.mulc i1 i2 in + E.mkIntPair env (E.mkInt env h) (E.mkInt env l) + | Int63diveucl -> + let i1, i2 = get_int2 evd args in + let q,r = Uint63.div i1 i2, Uint63.rem i1 i2 in + E.mkIntPair env (E.mkInt env q) (E.mkInt env r) + | Int63div21 -> + let i1, i2, i3 = get_int3 evd args in + let q,r = Uint63.div21 i1 i2 i3 in + E.mkIntPair env (E.mkInt env q) (E.mkInt env r) + | Int63addMulDiv -> + let p, i, j = get_int3 evd args in + E.mkInt env + (Uint63.l_or + (Uint63.l_sl i p) + (Uint63.l_sr j (Uint63.sub (Uint63.of_int Uint63.uint_size) p))) + | Int63eq -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.equal i1 i2) + | Int63lt -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.lt i1 i2) + | Int63le -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.le i1 i2) + | Int63compare -> + let i1, i2 = get_int2 evd args in + begin match Uint63.compare i1 i2 with + | x when x < 0 -> E.mkLt env + | 0 -> E.mkEq env + | _ -> E.mkGt env + end + + let red_prim env evd p args = + try + let r = + red_prim_aux env evd p args + in Some r + with NativeDestKO -> None + +end diff --git a/kernel/primred.mli b/kernel/primred.mli new file mode 100644 index 0000000000..f5998982d7 --- /dev/null +++ b/kernel/primred.mli @@ -0,0 +1,44 @@ +open Names +open Environ + +(** {5 Reduction of primitives} *) +val add_retroknowledge : env -> Retroknowledge.action -> env + +val get_int_type : env -> Constant.t +val get_bool_constructors : env -> constructor * constructor +val get_carry_constructors : env -> constructor * constructor +val get_pair_constructor : env -> constructor +val get_cmp_constructors : env -> constructor * constructor * constructor + +exception NativeDestKO (* Should be raised by get_* functions on failure *) + +module type RedNativeEntries = + sig + type elem + type args + type evd (* will be unit in kernel, evar_map outside *) + + val get : args -> int -> elem + val get_int : evd -> elem -> Uint63.t + val mkInt : env -> Uint63.t -> elem + val mkBool : env -> bool -> elem + val mkCarry : env -> bool -> elem -> elem (* true if carry *) + val mkIntPair : env -> elem -> elem -> elem + val mkLt : env -> elem + val mkEq : env -> elem + val mkGt : env -> elem + end + +module type RedNative = + sig + type elem + type args + type evd + val red_prim : env -> evd -> CPrimitives.t -> args -> elem option + end + +module RedNative : + functor (E:RedNativeEntries) -> + RedNative with type elem = E.elem + with type args = E.args + with type evd = E.evd diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 00576476ab..2f11f3dd6b 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -21,6 +21,7 @@ open CErrors open Util open Names open Constr +open Declarations open Vars open Environ open CClosure @@ -59,16 +60,23 @@ let compare_stack_shape stk1 stk2 = Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 + | Zprimitive(op1,_,rargs1, _kargs1)::s1, Zprimitive(op2,_,rargs2, _kargs2)::s2 -> + bal=0 && op1=op2 && List.length rargs1=List.length rargs2 && + compare_rec 0 s1 s2 | [], _ :: _ - | (Zproj _ | ZcaseT _ | Zfix _) :: _, _ -> false + | (Zproj _ | ZcaseT _ | Zfix _ | Zprimitive _) :: _, _ -> false in compare_rec 0 stk1 stk2 +type lft_fconstr = lift * fconstr + type lft_constr_stack_elt = Zlapp of (lift * fconstr) array | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack - | Zlcase of case_info * lift * fconstr * fconstr array + | Zlcase of case_info * lift * constr * constr array * fconstr subs + | Zlprimitive of + CPrimitives.t * pconstant * lft_fconstr list * lft_fconstr next_native_args and lft_constr_stack = lft_constr_stack_elt list let rec zlapp v = function @@ -102,7 +110,10 @@ let pure_stack lfts stk = let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,e),(l,pstk)) -> - (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk)) + (l,Zlcase(ci,l,p,br,e)::pstk) + | (Zprimitive(op,c,rargs,kargs),(l,pstk)) -> + (l,Zlprimitive(op,c,List.map (fun t -> (l,t)) rargs, + List.map (fun (k,t) -> (k,(l,t))) kargs)::pstk)) in snd (pure_rec lfts stk) @@ -127,10 +138,10 @@ let nf_betaiota env t = let whd_betaiotazeta env x = match kind x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _) -> x + Prod _|Lambda _|Fix _|CoFix _|Int _) -> x | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | Const _ -> x + | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | Int _ -> x | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos betaiotazeta env) (create_tab ()) (inject x) @@ -141,10 +152,10 @@ let whd_betaiotazeta env x = let whd_all env t = match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _) -> t + Prod _|Lambda _|Fix _|CoFix _|Int _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | Int _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Const _ |Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos all env) (create_tab ()) (inject t) @@ -155,10 +166,10 @@ let whd_all env t = let whd_allnolet env t = match kind t with | (Sort _|Meta _|Evar _|Ind _|Construct _| - Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t + Prod _|Lambda _|Fix _|CoFix _|LetIn _|Int _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ | Int _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | App _ | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos allnolet env) (create_tab ()) (inject t) @@ -177,13 +188,11 @@ type 'a kernel_conversion_function = env -> 'a -> 'a -> unit (* functions of this type can be called from outside the kernel *) type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit exception NotConvertible -exception NotConvertibleVect of int - (* Convertibility of sorts *) @@ -233,18 +242,14 @@ let inductive_cumulativity_arguments (mind,ind) = mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs let convert_inductives_gen cmp_instances cmp_cumul cv_pb (mind,ind) nargs u1 u2 s = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); - s - | Declarations.Polymorphic_ind _ -> - cmp_instances u1 u2 s - | Declarations.Cumulative_ind cumi -> + match mind.Declarations.mind_variance with + | None -> cmp_instances u1 u2 s + | Some variances -> let num_param_arity = inductive_cumulativity_arguments (mind,ind) in if not (Int.equal num_param_arity nargs) then cmp_instances u1 u2 s else - cmp_cumul cv_pb (Univ.ACumulativityInfo.variance cumi) u1 u2 s + cmp_cumul cv_pb variances u1 u2 s let convert_inductives cv_pb ind nargs u1 u2 (s, check) = convert_inductives_gen (check.compare_instances ~flex:false) check.compare_cumul_instances @@ -255,13 +260,9 @@ let constructor_cumulativity_arguments (mind, ind, ctor) = mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(ctor - 1) let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u2 s = - match mind.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); - s - | Declarations.Polymorphic_ind _ -> - cmp_instances u1 u2 s - | Declarations.Cumulative_ind _cumi -> + match mind.Declarations.mind_variance with + | None -> cmp_instances u1 u2 s + | Some _ -> let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in if not (Int.equal num_cnstr_args nargs) then cmp_instances u1 u2 s @@ -288,36 +289,22 @@ let conv_table_key infos k1 k2 cuniv = | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible -let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = - let rec cmp_rec pstk1 pstk2 cuniv = - match (pstk1,pstk2) with - | (z1::s1, z2::s2) -> - let cu1 = cmp_rec s1 s2 cuniv in - (match (z1,z2) with - | (Zlapp a1,Zlapp a2) -> - Array.fold_right2 f a1 a2 cu1 - | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> - if not (Projection.Repr.equal c1 c2) then - raise NotConvertible - else cu1 - | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> - let cu2 = f fx1 fx2 cu1 in - cmp_rec a1 a2 cu2 - | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> - if not (fmind ci1.ci_ind ci2.ci_ind) then - raise NotConvertible; - let cu2 = f (l1,p1) (l2,p2) cu1 in - Array.fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2 - | _ -> assert false) - | _ -> cuniv in - if compare_stack_shape stk1 stk2 then - cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv - else raise NotConvertible +exception IrregularPatternShape + +let unfold_ref_with_args infos tab fl v = + match unfold_reference infos tab fl with + | Def def -> Some (def, v) + | Primitive op when check_native_args op v -> + let c = match fl with ConstKey c -> c | _ -> assert false in + let rargs, a, nargs, v = get_native_args1 op c v in + Some (whd_stack infos tab a (Zupdate a::(Zprimitive(op,c,rargs,nargs)::v))) + | Undef _ | OpaqueDef _ | Primitive _ -> None type conv_tab = { cnv_inf : clos_infos; - lft_tab : fconstr infos_tab; - rgt_tab : fconstr infos_tab; + relevances : Sorts.relevance list; + lft_tab : clos_tab; + rgt_tab : clos_tab; } (** Invariant: for any tl ∈ lft_tab and tr ∈ rgt_tab, there is no mutable memory location contained both in tl and in tr. *) @@ -325,9 +312,23 @@ type conv_tab = { (** The same heap separation invariant must hold for the fconstr arguments passed to each respective side of the conversion function below. *) +let push_relevance infos r = + { infos with relevances = r.Context.binder_relevance :: infos.relevances } + +let rec skip_pattern infos n c1 c2 = + if Int.equal n 0 then infos, c1, c2 + else match kind c1, kind c2 with + | Lambda (x, _, c1), Lambda (_, _, c2) -> skip_pattern (push_relevance infos x) (pred n) c1 c2 + | _ -> raise IrregularPatternShape + +let is_irrelevant infos lft c = + let env = info_env infos.cnv_inf in + try Retypeops.relevance_of_fterm env infos.relevances lft c == Sorts.Irrelevant with _ -> false + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = - eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv + try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv + with NotConvertible when is_irrelevant infos lft1 term1 && is_irrelevant infos lft2 term2 -> cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = @@ -346,7 +347,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); - sort_cmp_universes (env_of_infos infos.cnv_inf) cv_pb s1 s2 cuniv + sort_cmp_universes (info_env infos.cnv_inf) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -373,28 +374,26 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try - let cuniv = conv_table_key infos.cnv_inf fl1 fl2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + let cuniv = conv_table_key infos.cnv_inf fl1 fl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with NotConvertible | Univ.UniverseInconsistency _ -> - (* else the oracle tells which constant is to be expanded *) + (* else the oracle tells which constant is to be expanded *) let oracle = CClosure.oracle_of_infos infos.cnv_inf in let (app1,app2) = + let aux appr1 lft1 fl1 tab1 v1 appr2 lft2 fl2 tab2 v2 = + match unfold_ref_with_args infos.cnv_inf tab1 fl1 v1 with + | Some t1 -> ((lft1, t1), appr2) + | None -> match unfold_ref_with_args infos.cnv_inf tab2 fl2 v2 with + | Some t2 -> (appr1, (lft2, t2)) + | None -> raise NotConvertible + in if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then - match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> ((lft1, (def1, v1)), appr2) - | None -> - (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> (appr1, (lft2, (def2, v2))) - | None -> raise NotConvertible) + aux appr1 lft1 fl1 infos.lft_tab v1 appr2 lft2 fl2 infos.rgt_tab v2 else - match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> (appr1, (lft2, (def2, v2))) - | None -> - (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> ((lft1, (def1, v1)), appr2) - | None -> raise NotConvertible) - in - eqappr cv_pb l2r infos app1 app2 cuniv) + let (app2,app1) = aux appr2 lft2 fl2 infos.rgt_tab v2 appr1 lft1 fl1 infos.lft_tab v1 in + (app1,app2) + in + eqappr cv_pb l2r infos app1 app2 cuniv) | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, @@ -407,63 +406,69 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = match unfold_projection infos.cnv_inf p2 with | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv - | None -> + | None -> if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) - && compare_stack_shape v1 v2 then + && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 u1 - else (* Two projections in WHNF: unfold *) + else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> - (match unfold_projection infos.cnv_inf p1 with - | Some s1 -> + begin match unfold_projection infos.cnv_inf p1 with + | Some s1 -> eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv - | None -> - (match t2 with - | FFlex fl2 -> - (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv - | None -> raise NotConvertible) - | _ -> raise NotConvertible)) - + | None -> + begin match t2 with + | FFlex fl2 -> + begin match unfold_ref_with_args infos.cnv_inf infos.rgt_tab fl2 v2 with + | Some t2 -> + eqappr cv_pb l2r infos appr1 (lft2, t2) cuniv + | None -> raise NotConvertible + end + | _ -> raise NotConvertible + end + end + | (t1, FProj (p2,c2)) -> - (match unfold_projection infos.cnv_inf p2 with - | Some s2 -> + begin match unfold_projection infos.cnv_inf p2 with + | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv - | None -> - (match t1 with - | FFlex fl1 -> - (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> - eqappr cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv - | None -> raise NotConvertible) - | _ -> raise NotConvertible)) - + | None -> + begin match t1 with + | FFlex fl1 -> + begin match unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 with + | Some t1 -> + eqappr cv_pb l2r infos (lft1, t1) appr2 cuniv + | None -> raise NotConvertible + end + | _ -> raise NotConvertible + end + end + (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); - let (_,ty1,bd1) = destFLambda mk_clos hd1 in + anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); + let (x1,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv + ccnv CONV l2r (push_relevance infos x1) (el_lift el1) (el_lift el2) bd1 bd2 cuniv - | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> + | (FProd (x1, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv + ccnv cv_pb l2r (push_relevance infos x1) (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -472,23 +477,25 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda).") in - let (_,_ty1,bd1) = destFLambda mk_clos hd1 in + let (x1,_ty1,bd1) = destFLambda mk_clos hd1 in + let infos = push_relevance infos x1 in eqappr CONV l2r infos - (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv + (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> let () = match v2 with | [] -> () | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda).") in - let (_,_ty2,bd2) = destFLambda mk_clos hd2 in + let (x2,_ty2,bd2) = destFLambda mk_clos hd2 in + let infos = push_relevance infos x2 in eqappr CONV l2r infos - (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv - + (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv + (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> - (match unfold_reference infos.cnv_inf infos.lft_tab fl1 with - | Some def1 -> + begin match unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 with + | Some (def1,v1) -> (** By virtue of the previous case analyses, we know [c2] is rigid. Conversion check to rigid terms eventually implies full weak-head reduction, so instead of repeatedly performing small-step @@ -496,32 +503,34 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in let r1 = whd_stack (infos_with_reds infos.cnv_inf all) infos.lft_tab def1 v1 in eqappr cv_pb l2r infos (lft1, r1) appr2 cuniv - | None -> - match c2 with + | None -> + (match c2 with | FConstruct ((ind2,_j2),_u2) -> - (try - let v2, v1 = - eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - with Not_found -> raise NotConvertible) - | _ -> raise NotConvertible) - + (try + let v2, v1 = + eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + end + | (c1, FFlex fl2) -> - (match unfold_reference infos.cnv_inf infos.rgt_tab fl2 with - | Some def2 -> + begin match unfold_ref_with_args infos.cnv_inf infos.rgt_tab fl2 v2 with + | Some (def2, v2) -> (** Symmetrical case of above. *) let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in let r2 = whd_stack (infos_with_reds infos.cnv_inf all) infos.rgt_tab def2 v2 in eqappr cv_pb l2r infos appr1 (lft2, r2) cuniv - | None -> - match c1 with - | FConstruct ((ind1,_j1),_u1) -> - (try let v1, v2 = - eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - with Not_found -> raise NotConvertible) - | _ -> raise NotConvertible) - + | None -> + match c1 with + | FConstruct ((ind1,_j1),_u1) -> + (try let v1, v2 = + eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible + end + (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1), FInd (ind2,u2)) -> if eq_ind ind1 ind2 then @@ -568,8 +577,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) - | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> - if Int.equal i1 i2 && Array.equal Int.equal op1 op2 + | (FFix (((op1, i1),(na1,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> + if Int.equal i1 i2 && Array.equal Int.equal op1 op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in @@ -580,12 +589,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = + let infos = Array.fold_left push_relevance infos na1 in convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> + | (FCoFix ((op1,(na1,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if Int.equal op1 op2 then let n = Array.length cl1 in @@ -597,24 +608,56 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = + let infos = Array.fold_left push_relevance infos na1 in convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible + | FInt i1, FInt i2 -> + if Uint63.equal i1 i2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ - | FProd _ | FEvar _), _ -> raise NotConvertible + | FProd _ | FEvar _ | FInt _), _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = - compare_stacks - (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) - (eq_ind) - lft1 stk1 lft2 stk2 cuniv + let f (l1, t1) (l2, t2) cuniv = ccnv CONV l2r infos l1 l2 t1 t2 cuniv in + let rec cmp_rec pstk1 pstk2 cuniv = + match (pstk1,pstk2) with + | (z1::s1, z2::s2) -> + let cu1 = cmp_rec s1 s2 cuniv in + (match (z1,z2) with + | (Zlapp a1,Zlapp a2) -> + Array.fold_right2 f a1 a2 cu1 + | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> + if not (Projection.Repr.equal c1 c2) then + raise NotConvertible + else cu1 + | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> + let cu2 = f fx1 fx2 cu1 in + cmp_rec a1 a2 cu2 + | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> + if not (eq_ind ci1.ci_ind ci2.ci_ind) then + raise NotConvertible; + let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in + convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 + | (Zlprimitive(op1,_,rargs1,kargs1),Zlprimitive(op2,_,rargs2,kargs2)) -> + if not (CPrimitives.equal op1 op2) then raise NotConvertible else + let cu2 = List.fold_right2 f rargs1 rargs2 cu1 in + let fk (_,a1) (_,a2) cu = f a1 a2 cu in + List.fold_right2 fk kargs1 kargs2 cu2 + | ((Zlapp _ | Zlproj _ | Zlfix _| Zlcase _| Zlprimitive _), _) -> assert false) + | _ -> cuniv in + if compare_stack_shape stk1 stk2 then + cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv + else raise NotConvertible and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in @@ -629,11 +672,28 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible +and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = + (** Skip comparison of the pattern types. We know that the two terms are + living in a common type, thus this check is useless. *) + let fold n c1 c2 cuniv = match skip_pattern infos n c1 c2 with + | (infos, c1, c2) -> + let lft1 = el_liftn n lft1 in + let lft2 = el_liftn n lft2 in + let e1 = subs_liftn n e1 in + let e2 = subs_liftn n e2 in + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + | exception IrregularPatternShape -> + (** Might happen due to a shape invariant that is not enforced *) + ccnv CONV l2r infos lft1 lft2 (mk_clos e1 c1) (mk_clos e2 c2) cuniv + in + Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv + let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in let infos = { cnv_inf = infos; + relevances = List.map Context.Rel.Declaration.get_relevance (rel_context env); lft_tab = create_tab (); rgt_tab = create_tab (); } in @@ -655,7 +715,8 @@ let check_sort_cmp_universes env pb s0 s1 univs = | CONV -> check_eq univs u0 u1 in match (s0,s1) with - | Prop, Prop | Set, Set -> () + | SProp, SProp | Prop, Prop | Set, Set -> () + | SProp, _ | _, SProp -> raise NotConvertible | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible | Set, Prop -> raise NotConvertible | Set, Type u -> check_pb Univ.type0_univ u @@ -703,7 +764,8 @@ let infer_cmp_universes env pb s0 s1 univs = | CONV -> infer_eq univs u0 u1 in match (s0,s1) with - | Prop, Prop | Set, Set -> univs + | SProp, SProp | Prop, Prop | Set, Set -> univs + | SProp, _ | _, SProp -> raise NotConvertible | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs | Set, Prop -> raise NotConvertible | Set, Type u -> infer_pb Univ.type0_univ u @@ -739,7 +801,7 @@ let gen_conv cv_pb l2r reds env evars univs t1 t2 = () (* Profiling *) -let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = +let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _->None), universes env) = let evars, univs = evars in if Flags.profile then let fconv_universes_key = CProfile.declare_profile "trans_fconv_universes" in @@ -773,11 +835,11 @@ let infer_conv_universes = CProfile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes -let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) +let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env univs t1 t2 = infer_conv_universes CONV l2r evars ts env univs t1 t2 -let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) +let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 @@ -848,7 +910,7 @@ let dest_prod env = let t = whd_all env c in match kind t with | Prod (n,a,c0) -> - let d = LocalAssum (n,a) in + let d = LocalAssum (n,a) in decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 581e8bd88a..7dcafb7d7b 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -27,11 +27,10 @@ val nf_betaiota : env -> constr -> constr s conversion functions *) exception NotConvertible -exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = - ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit @@ -77,15 +76,15 @@ val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> - ?ts:Names.transparent_state -> constr infer_conversion_function + ?ts:TransparentState.t -> constr infer_conversion_function val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> - ?ts:Names.transparent_state -> types infer_conversion_function + ?ts:TransparentState.t -> types infer_conversion_function (** Depending on the universe state functions, this might raise [UniverseInconsistency] in addition to [NotConvertible] (for better error messages). *) val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> - Names.transparent_state -> (constr,'a) generic_conversion_function + TransparentState.t -> (constr,'a) generic_conversion_function val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function val default_conv_leq : ?l2r:bool -> types kernel_conversion_function diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index e51c25c06b..e1c4cec5b5 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -12,249 +12,29 @@ (* Addition of native Head (nb of heading 0) and Tail (nb of trailing 0) by Benjamin Grégoire, Jun 2007 *) -(* This file defines the knowledge that the kernel is able to optimize - for evaluation in the bytecode virtual machine *) +(* This file defines the knowledge that the kernel is able to optimize. *) open Names -open Constr - -(* The retroknowledge defines a bijective correspondance between some - [entry]-s (which are, in fact, merely names) and [field]-s which - are roles assigned to these entries. *) - -type int31_field = - | Int31Bits - | Int31Type - | Int31Constructor - | Int31Twice - | Int31TwicePlusOne - | Int31Phi - | Int31PhiInv - | Int31Plus - | Int31PlusC - | Int31PlusCarryC - | Int31Minus - | Int31MinusC - | Int31MinusCarryC - | Int31Times - | Int31TimesC - | Int31Div21 - | Int31Div - | Int31Diveucl - | Int31AddMulDiv - | Int31Compare - | Int31Head0 - | Int31Tail0 - | Int31Lor - | Int31Land - | Int31Lxor - -type field = - | KInt31 of int31_field - -let int31_field_of_string = - function - | "bits" -> Int31Bits - | "type" -> Int31Type - | "twice" -> Int31Twice - | "twice_plus_one" -> Int31TwicePlusOne - | "phi" -> Int31Phi - | "phi_inv" -> Int31PhiInv - | "plus" -> Int31Plus - | "plusc" -> Int31PlusC - | "pluscarryc" -> Int31PlusCarryC - | "minus" -> Int31Minus - | "minusc" -> Int31MinusC - | "minuscarryc" -> Int31MinusCarryC - | "times" -> Int31Times - | "timesc" -> Int31TimesC - | "div21" -> Int31Div21 - | "div" -> Int31Div - | "diveucl" -> Int31Diveucl - | "addmuldiv" -> Int31AddMulDiv - | "compare" -> Int31Compare - | "head0" -> Int31Head0 - | "tail0" -> Int31Tail0 - | "lor" -> Int31Lor - | "land" -> Int31Land - | "lxor" -> Int31Lxor - | s -> CErrors.user_err Pp.(str "Registering unknown int31 operator " ++ str s) - -let int31_path = DirPath.make [ Id.of_string "int31" ] - -(* record representing all the flags of the internal state of the kernel *) -type flags = {fastcomputation : bool} - - - - - -(* The [proactive] knowledge contains the mapping [field->entry]. *) - -module Proactive = - Map.Make (struct type t = field let compare = Pervasives.compare end) - -type proactive = GlobRef.t Proactive.t - -(* The [reactive] knowledge contains the mapping - [entry->field]. Fields are later to be interpreted as a - [reactive_info]. *) - -module Reactive = GlobRef.Map - -type reactive_info = {(*information required by the compiler of the VM *) - vm_compiling : - (*fastcomputation flag -> continuation -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - vm_constant_static : - (*fastcomputation flag -> constructor -> args -> result*) - (bool -> constr array -> Cinstr.lambda) - option; - vm_constant_dynamic : - (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - (* fastcomputation flag -> cont -> result *) - vm_before_match : (bool -> Cinstr.lambda -> Cinstr.lambda) option; - (* tag (= compiled int for instance) -> result *) - vm_decompile_const : (int -> constr) option; - - native_compiling : - (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> - Nativeinstr.lambda) option; - - native_constant_static : - (bool -> constr array -> Nativeinstr.lambda) option; - - native_constant_dynamic : - (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda array -> Nativeinstr.lambda) option; - - native_before_match : (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda -> Nativeinstr.lambda) option +type retroknowledge = { + retro_int63 : Constant.t option; + retro_bool : (constructor * constructor) option; (* true, false *) + retro_carry : (constructor * constructor) option; (* C0, C1 *) + retro_pair : constructor option; + retro_cmp : (constructor * constructor * constructor) option; + (* Eq, Lt, Gt *) + retro_refl : constructor option; } +let empty = { + retro_int63 = None; + retro_bool = None; + retro_carry = None; + retro_pair = None; + retro_cmp = None; + retro_refl = None; +} - -and reactive = field Reactive.t - -and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive} - -(* This type represent an atomic action of the retroknowledge. It - is stored in the compiled libraries *) -(* As per now, there is only the possibility of registering things - the possibility of unregistering or changing the flag is under study *) type action = - | RKRegister of field * GlobRef.t - - -(*initialisation*) -let initial_flags = - {fastcomputation = true;} - -let initial_proactive = - (Proactive.empty:proactive) - -let initial_reactive = - (Reactive.empty:reactive) - -let initial_retroknowledge = - {flags = initial_flags; - proactive = initial_proactive; - reactive = initial_reactive } - -let empty_reactive_info = - { vm_compiling = None ; - vm_constant_static = None; - vm_constant_dynamic = None; - vm_before_match = None; - vm_decompile_const = None; - native_compiling = None; - native_constant_static = None; - native_constant_dynamic = None; - native_before_match = None; - } - - - -(* adds a binding [entry<->field]. *) -let add_field knowledge field entry = - {knowledge with - proactive = Proactive.add field entry knowledge.proactive; - reactive = Reactive.add entry field knowledge.reactive} - -(* acces functions for proactive retroknowledge *) -let mem knowledge field = - Proactive.mem field knowledge.proactive - -let find knowledge field = - Proactive.find field knowledge.proactive - - -let (dispatch,dispatch_hook) = Hook.make () - -let dispatch_reactive entry retroknowledge = - Hook.get dispatch retroknowledge entry (Reactive.find entry retroknowledge.reactive) - -(*access functions for reactive retroknowledge*) - -(* used for compiling of functions (add, mult, etc..) *) -let get_vm_compiling_info knowledge key = - match (dispatch_reactive key knowledge).vm_compiling - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of fully applied constructors *) -let get_vm_constant_static_info knowledge key = - match (dispatch_reactive key knowledge).vm_constant_static - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of partially applied constructors *) -let get_vm_constant_dynamic_info knowledge key = - match (dispatch_reactive key knowledge).vm_constant_dynamic - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -let get_vm_before_match_info knowledge key = - match (dispatch_reactive key knowledge).vm_before_match - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -let get_vm_decompile_constant_info knowledge key = - match (dispatch_reactive key knowledge).vm_decompile_const - with - | None -> raise Not_found - | Some f -> f - -let get_native_compiling_info knowledge key = - match (dispatch_reactive key knowledge).native_compiling - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of fully applied constructors *) -let get_native_constant_static_info knowledge key = - match (dispatch_reactive key knowledge).native_constant_static - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -(* used for compilation of partially applied constructors *) -let get_native_constant_dynamic_info knowledge key = - match (dispatch_reactive key knowledge).native_constant_dynamic - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation - -let get_native_before_match_info knowledge key = - match (dispatch_reactive key knowledge).native_before_match - with - | None -> raise Not_found - | Some f -> f knowledge.flags.fastcomputation + | Register_ind of CPrimitives.prim_ind * inductive + | Register_type of CPrimitives.prim_type * Constant.t diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 0a2ef5300e..09e8140308 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -9,157 +9,19 @@ (************************************************************************) open Names -open Constr - -type retroknowledge - -(** the following types correspond to the different "things" - the kernel can learn about.*) -type int31_field = - | Int31Bits - | Int31Type - | Int31Constructor - | Int31Twice - | Int31TwicePlusOne - | Int31Phi - | Int31PhiInv - | Int31Plus - | Int31PlusC - | Int31PlusCarryC - | Int31Minus - | Int31MinusC - | Int31MinusCarryC - | Int31Times - | Int31TimesC - | Int31Div21 - | Int31Div - | Int31Diveucl - | Int31AddMulDiv - | Int31Compare - | Int31Head0 - | Int31Tail0 - | Int31Lor - | Int31Land - | Int31Lxor - -type field = - | KInt31 of int31_field - -val int31_field_of_string : string -> int31_field - -val int31_path : DirPath.t - -(** This type represent an atomic action of the retroknowledge. It - is stored in the compiled libraries - As per now, there is only the possibility of registering things - the possibility of unregistering or changing the flag is under study *) -type action = - | RKRegister of field * GlobRef.t - - -(** initial value for retroknowledge *) -val initial_retroknowledge : retroknowledge - - -(** Given an identifier id (usually Const _) - and the continuation cont of the bytecode compilation - returns the compilation of id in cont if it has a specific treatment - or raises Not_found if id should be compiled as usual *) -val get_vm_compiling_info : retroknowledge -> GlobRef.t -> - Cinstr.lambda array -> Cinstr.lambda -(*Given an identifier id (usually Construct _) - and its argument array, returns a function that tries an ad-hoc optimisated - compilation (in the case of the 31-bit integers it means compiling them - directly into an integer) - raises Not_found if id should be compiled as usual, and expectingly - CBytecodes.NotClosed if the term is not a closed constructor pattern - (a constant for the compiler) *) -val get_vm_constant_static_info : retroknowledge -> GlobRef.t -> - constr array -> Cinstr.lambda - -(*Given an identifier id (usually Construct _ ) - its argument array and a continuation, returns the compiled version - of id+args+cont when id has a specific treatment (in the case of - 31-bit integers, that would be the dynamic compilation into integers) - or raises Not_found if id should be compiled as usual *) -val get_vm_constant_dynamic_info : retroknowledge -> GlobRef.t -> - Cinstr.lambda array -> Cinstr.lambda - -(** Given a type identifier, this function is used before compiling a match - over this type. In the case of 31-bit integers for instance, it is used - to add the instruction sequence which would perform a dynamic decompilation - in case the argument of the match is not in coq representation *) -val get_vm_before_match_info : retroknowledge -> GlobRef.t -> Cinstr.lambda - -> Cinstr.lambda - -(** Given a type identifier, this function is used by pretyping/vnorm.ml to - recover the elements of that type from their compiled form if it's non - standard (it is used (and can be used) only when the compiled form - is not a block *) -val get_vm_decompile_constant_info : retroknowledge -> GlobRef.t -> int -> constr - - -val get_native_compiling_info : retroknowledge -> GlobRef.t -> Nativeinstr.prefix -> - Nativeinstr.lambda array -> Nativeinstr.lambda - -val get_native_constant_static_info : retroknowledge -> GlobRef.t -> - constr array -> Nativeinstr.lambda - -val get_native_constant_dynamic_info : retroknowledge -> GlobRef.t -> - Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda array -> - Nativeinstr.lambda - -val get_native_before_match_info : retroknowledge -> GlobRef.t -> - Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda -> Nativeinstr.lambda - - -(** the following functions are solely used in Environ and Safe_typing to implement - the functions register and unregister (and mem) of Environ *) -val add_field : retroknowledge -> field -> GlobRef.t -> retroknowledge -val mem : retroknowledge -> field -> bool -(* val remove : retroknowledge -> field -> retroknowledge *) -val find : retroknowledge -> field -> GlobRef.t - - -(** Dispatching type for the above [get_*] functions. *) -type reactive_info = {(*information required by the compiler of the VM *) - vm_compiling : - (*fastcomputation flag -> continuation -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - vm_constant_static : - (*fastcomputation flag -> constructor -> args -> result*) - (bool -> constr array -> Cinstr.lambda) - option; - vm_constant_dynamic : - (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) - (bool -> Cinstr.lambda array -> Cinstr.lambda) - option; - (* fastcomputation flag -> cont -> result *) - vm_before_match : (bool -> Cinstr.lambda -> Cinstr.lambda) option; - (* tag (= compiled int for instance) -> result *) - vm_decompile_const : (int -> constr) option; - - native_compiling : - (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array -> - Nativeinstr.lambda) option; - - native_constant_static : - (bool -> constr array -> Nativeinstr.lambda) option; - - native_constant_dynamic : - (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda array -> Nativeinstr.lambda) option; - - native_before_match : (bool -> Nativeinstr.prefix -> constructor -> - Nativeinstr.lambda -> Nativeinstr.lambda) option +type retroknowledge = { + retro_int63 : Constant.t option; + retro_bool : (constructor * constructor) option; (* true, false *) + retro_carry : (constructor * constructor) option; (* C0, C1 *) + retro_pair : constructor option; + retro_cmp : (constructor * constructor * constructor) option; + (* Eq, Lt, Gt *) + retro_refl : constructor option; } -val empty_reactive_info : reactive_info +val empty : retroknowledge -(** Hook to be set after the compiler are installed to dispatch fields - into the above [get_*] functions. *) -val dispatch_hook : (retroknowledge -> GlobRef.t -> field -> reactive_info) Hook.t +type action = + | Register_ind of CPrimitives.prim_ind * inductive + | Register_type of CPrimitives.prim_type * Constant.t diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml new file mode 100644 index 0000000000..204dec3eda --- /dev/null +++ b/kernel/retypeops.ml @@ -0,0 +1,116 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Constr +open Declarations +open Environ +open Context + +module RelDecl = Context.Rel.Declaration + +let relevance_of_rel env n = + let decl = lookup_rel n env in + RelDecl.get_relevance decl + +let relevance_of_var env x = + let decl = lookup_named x env in + Context.Named.Declaration.get_relevance decl + +let relevance_of_constant env c = + let decl = lookup_constant c env in + decl.const_relevance + +let relevance_of_constructor env ((mi,i),_) = + let decl = lookup_mind mi env in + let packet = decl.mind_packets.(i) in + packet.mind_relevance + +let relevance_of_projection env p = + let mind = Projection.mind p in + let mib = lookup_mind mind env in + Declareops.relevance_of_projection_repr mib (Projection.repr p) + +let rec relevance_of_rel_extra env extra n = + match extra with + | [] -> relevance_of_rel env n + | r :: _ when Int.equal n 1 -> r + | _ :: extra -> relevance_of_rel_extra env extra (n-1) + +let relevance_of_flex env extra lft = function + | ConstKey (c,_) -> relevance_of_constant env c + | VarKey x -> relevance_of_var env x + | RelKey p -> relevance_of_rel_extra env extra (Esubst.reloc_rel p lft) + +let rec relevance_of_fterm env extra lft f = + let open CClosure in + match CClosure.relevance_of f with + | KnownR -> Sorts.Relevant + | KnownI -> Sorts.Irrelevant + | Unknown -> + let r = match fterm_of f with + | FRel n -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft) + | FAtom c -> relevance_of_term_extra env extra lft (Esubst.subs_id 0) c + | FFlex key -> relevance_of_flex env extra lft key + | FInt _ -> Sorts.Relevant + | FInd _ | FProd _ -> Sorts.Relevant (* types are always relevant *) + | FConstruct (c,_) -> relevance_of_constructor env c + | FApp (f, _) -> relevance_of_fterm env extra lft f + | FProj (p, _) -> relevance_of_projection env p + | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance + | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance + | FCaseT (ci, _, _, _, _) -> ci.ci_relevance + | FLambda (len, tys, bdy, e) -> + let extra = List.rev_append (List.map (fun (x,_) -> binder_relevance x) tys) extra in + let lft = Esubst.el_liftn len lft in + relevance_of_term_extra env extra lft e bdy + | FLetIn (x, _, _, bdy, e) -> + relevance_of_term_extra env (x.binder_relevance :: extra) + (Esubst.el_lift lft) (Esubst.subs_lift e) bdy + | FLIFT (k, f) -> relevance_of_fterm env extra (Esubst.el_shft k lft) f + | FCLOS (c, e) -> relevance_of_term_extra env extra lft e c + + | FEvar (_, _) -> Sorts.Relevant (* let's assume evars are relevant for now *) + | FLOCKED -> assert false + in + CClosure.set_relevance r f; + r + +and relevance_of_term_extra env extra lft subs c = + match kind c with + | Rel n -> + (match Esubst.expand_rel n subs with + | Inl (k, f) -> relevance_of_fterm env extra (Esubst.el_liftn k lft) f + | Inr (n, _) -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft)) + | Var x -> relevance_of_var env x + | Sort _ | Ind _ | Prod _ -> Sorts.Relevant (* types are always relevant *) + | Cast (c, _, _) -> relevance_of_term_extra env extra lft subs c + | Lambda ({binder_relevance=r;_}, _, bdy) -> + relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + | LetIn ({binder_relevance=r;_}, _, _, bdy) -> + relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + | App (c, _) -> relevance_of_term_extra env extra lft subs c + | Const (c,_) -> relevance_of_constant env c + | Construct (c,_) -> relevance_of_constructor env c + | Case (ci, _, _, _) -> ci.ci_relevance + | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance + | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance + | Proj (p, _) -> relevance_of_projection env p + | Int _ -> Sorts.Relevant + + | Meta _ | Evar _ -> Sorts.Relevant (* let's assume metas and evars are relevant for now *) + +let relevance_of_fterm env extra lft c = + if Environ.sprop_allowed env then relevance_of_fterm env extra lft c + else Sorts.Relevant + +let relevance_of_term env c = + if Environ.sprop_allowed env + then relevance_of_term_extra env [] Esubst.el_id (Esubst.subs_id 0) c + else Sorts.Relevant diff --git a/kernel/retypeops.mli b/kernel/retypeops.mli new file mode 100644 index 0000000000..f30c541c3f --- /dev/null +++ b/kernel/retypeops.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** We can take advantage of non-cumulativity of SProp to avoid fully + retyping terms when we just want to know if they inhabit some + proof-irrelevant type. *) + +val relevance_of_term : Environ.env -> Constr.constr -> Sorts.relevance + +val relevance_of_fterm : Environ.env -> Sorts.relevance list -> + Esubst.lift -> CClosure.fconstr -> + Sorts.relevance + + +(** Helpers *) +open Names +val relevance_of_rel_extra : Environ.env -> Sorts.relevance list -> int -> Sorts.relevance +val relevance_of_var : Environ.env -> Id.t -> Sorts.relevance +val relevance_of_constant : Environ.env -> Constant.t -> Sorts.relevance +val relevance_of_constructor : Environ.env -> constructor -> Sorts.relevance +val relevance_of_projection : Environ.env -> Projection.t -> Sorts.relevance diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 820c5b3a2b..673f025c75 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -59,10 +59,10 @@ etc. *) -open CErrors open Util open Names open Declarations +open Constr open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -168,6 +168,12 @@ let is_initial senv = let delta_of_senv senv = senv.modresolver,senv.paramresolver +let constant_of_delta_kn_senv senv kn = + Mod_subst.constant_of_deltas_kn senv.paramresolver senv.modresolver kn + +let mind_of_delta_kn_senv senv kn = + Mod_subst.mind_of_deltas_kn senv.paramresolver senv.modresolver kn + (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment @@ -186,7 +192,28 @@ let set_engagement c senv = engagement = Some c } let set_typing_flags c senv = - { senv with env = Environ.set_typing_flags c senv.env } + let env = Environ.set_typing_flags c senv.env in + if env == senv.env then senv + else { senv with env } + +let set_indices_matter indices_matter senv = + set_typing_flags { (Environ.typing_flags senv.env) with indices_matter } senv + +let set_share_reduction b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with share_reduction = b } senv + +let set_VM b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with enable_VM = b } senv + +let set_native_compiler b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with enable_native_compiler = b } senv + +let make_sprop_cumulative senv = { senv with env = Environ.make_sprop_cumulative senv.env } + +let set_allow_sprop b senv = { senv with env = Environ.set_allow_sprop b senv.env } (** Check that the engagement [c] expected by a library matches the current (initial) one *) @@ -204,21 +231,62 @@ let check_engagement env expected_impredicative_set = let get_opaque_body env cbo = match cbo.const_body with | Undef _ -> assert false + | Primitive _ -> assert false | Def _ -> `Nothing | OpaqueDef opaque -> `Opaque (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) -type private_constants = Term_typing.side_effects +type side_effect = { + from_env : Declarations.structure_body CEphemeron.key; + eff : Entries.side_eff list; +} -let empty_private_constants = Term_typing.empty_seff -let add_private = Term_typing.add_seff -let concat_private = Term_typing.concat_seff -let mk_pure_proof = Term_typing.mk_pure_proof -let inline_private_constants_in_constr = Term_typing.inline_side_effects -let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects -let side_effects_of_private_constants = Term_typing.uniq_seff +module SideEffects : +sig + type t + val repr : t -> side_effect list + val empty : t + val add : side_effect -> t -> t + val concat : t -> t -> t +end = +struct + +module SeffOrd = struct +open Entries +type t = side_effect +let compare e1 e2 = + let cmp e1 e2 = Constant.CanOrd.compare e1.seff_constant e2.seff_constant in + List.compare cmp e1.eff e2.eff +end + +module SeffSet = Set.Make(SeffOrd) + +type t = { seff : side_effect list; elts : SeffSet.t } +(** Invariant: [seff] is a permutation of the elements of [elts] *) + +let repr eff = eff.seff +let empty = { seff = []; elts = SeffSet.empty } +let add x es = + if SeffSet.mem x es.elts then es + else { seff = x :: es.seff; elts = SeffSet.add x es.elts } +let concat xes yes = + List.fold_right add xes.seff yes + +end + +type private_constants = SideEffects.t + +let side_effects_of_private_constants l = + let ans = List.rev (SideEffects.repr l) in + List.map_append (fun { eff; _ } -> eff) ans + +let empty_private_constants = SideEffects.empty +let add_private mb eff effs = + let from_env = CEphemeron.create mb in + SideEffects.add { eff; from_env } effs +let concat_private = SideEffects.concat let make_eff env cst r = let open Entries in @@ -248,10 +316,10 @@ let universes_of_private eff = | `Opaque (_, ctx) -> ctx :: acc in match eff.seff_body.const_universes with - | Monomorphic_const ctx -> ctx :: acc - | Polymorphic_const _ -> acc + | Monomorphic ctx -> ctx :: acc + | Polymorphic _ -> acc in - List.fold_left fold [] (Term_typing.uniq_seff eff) + List.fold_left fold [] (side_effects_of_private_constants eff) let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env @@ -373,14 +441,16 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let c, typ = Term_typing.translate_local_def senv.env id de in - let env'' = safe_push_named (LocalDef (id, c, typ)) senv.env in + let c, r, typ = Term_typing.translate_local_def senv.env id de in + let x = Context.make_annot id r in + let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in { senv with env = env'' } let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in - let t = Term_typing.translate_local_assum senv'.env t in - let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in + let t, r = Term_typing.translate_local_assum senv'.env t in + let x = Context.make_annot id r in + let env'' = safe_push_named (LocalAssum (x,t)) senv'.env in {senv' with env=env''} @@ -401,10 +471,10 @@ let labels_of_mib mib = let globalize_constant_universes env cb = match cb.const_universes with - | Monomorphic_const cstrs -> + | Monomorphic cstrs -> Now (false, cstrs) :: (match cb.const_body with - | (Undef _ | Def _) -> [] + | (Undef _ | Def _ | Primitive _) -> [] | OpaqueDef lc -> match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with | None -> [] @@ -412,15 +482,14 @@ let globalize_constant_universes env cb = match Future.peek_val fc with | None -> [Later fc] | Some c -> [Now (false, c)]) - | Polymorphic_const _ -> + | Polymorphic _ -> [Now (true, Univ.ContextSet.empty)] let globalize_mind_universes mb = match mb.mind_universes with - | Monomorphic_ind ctx -> + | Monomorphic ctx -> [Now (false, ctx)] - | Polymorphic_ind _ -> [Now (true, Univ.ContextSet.empty)] - | Cumulative_ind _ -> [Now (true, Univ.ContextSet.empty)] + | Polymorphic _ -> [Now (true, Univ.ContextSet.empty)] let constraints_of_sfb env sfb = match sfb with @@ -429,6 +498,11 @@ let constraints_of_sfb env sfb = | SFBmodtype mtb -> [Now (false, mtb.mod_constraints)] | SFBmodule mb -> [Now (false, mb.mod_constraints)] +let add_retroknowledge pttc senv = + { senv with + env = Primred.add_retroknowledge senv.env pttc; + local_retroknowledge = pttc::senv.local_retroknowledge } + (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -438,7 +512,7 @@ type generic_name = | M (** name already known, cf the mod_mp field *) | MT (** name already known, cf the mod_mp field *) -let add_field ((l,sfb) as field) gn senv = +let add_field ?(is_include=false) ((l,sfb) as field) gn senv = let mlabs,olabs = match sfb with | SFBmind mib -> let l = labels_of_mib mib in @@ -448,8 +522,18 @@ let add_field ((l,sfb) as field) gn senv = | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in - let cst = constraints_of_sfb senv.env sfb in - let senv = add_constraints_list cst senv in + let senv = + if is_include then + (* Universes and constraints were added when the included module + was defined eg in [Include F X.] (one of the trickier + versions of Include) the constraints on the fields are + exactly those of the fields of F which was defined + separately. *) + senv + else + let cst = constraints_of_sfb senv.env sfb in + add_constraints_list cst senv + in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env @@ -501,8 +585,218 @@ let add_constant_aux ~in_section senv (kn, cb) = in senv'' +let mk_pure_proof c = (c, Univ.ContextSet.empty), SideEffects.empty + +let inline_side_effects env body side_eff = + let open Entries in + let open Constr in + (** First step: remove the constants that are still in the environment *) + let filter { eff = se; from_env = mb } = + let map e = (e.seff_constant, e.seff_body, e.seff_env) in + let cbl = List.map map se in + let not_exists (c,_,_) = + try ignore(Environ.lookup_constant c env); false + with Not_found -> true in + let cbl = List.filter not_exists cbl in + (cbl, mb) + in + (* CAVEAT: we assure that most recent effects come first *) + let side_eff = List.map filter (SideEffects.repr side_eff) in + let sigs = List.rev_map (fun (cbl, mb) -> mb, List.length cbl) side_eff in + let side_eff = List.fold_left (fun accu (cbl, _) -> cbl @ accu) [] side_eff in + let side_eff = List.rev side_eff in + (** Most recent side-effects first in side_eff *) + if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs) + else + (** Second step: compute the lifts and substitutions to apply *) + let cname c r = Context.make_annot (Name (Label.to_id (Constant.label c))) r in + let fold (subst, var, ctx, args) (c, cb, b) = + let (b, opaque) = match cb.const_body, b with + | Def b, _ -> (Mod_subst.force_constr b, false) + | OpaqueDef _, `Opaque (b,_) -> (b, true) + | _ -> assert false + in + match cb.const_universes with + | Monomorphic univs -> + (** Abstract over the term at the top of the proof *) + let ty = cb.const_type in + let subst = Cmap_env.add c (Inr var) subst in + let ctx = Univ.ContextSet.union ctx univs in + (subst, var + 1, ctx, (cname c cb.const_relevance, b, ty, opaque) :: args) + | Polymorphic _ -> + (** Inline the term to emulate universe polymorphism *) + let subst = Cmap_env.add c (Inl b) subst in + (subst, var, ctx, args) + in + let (subst, len, ctx, args) = List.fold_left fold (Cmap_env.empty, 1, Univ.ContextSet.empty, []) side_eff in + (** Third step: inline the definitions *) + let rec subst_const i k t = match Constr.kind t with + | Const (c, u) -> + let data = try Some (Cmap_env.find c subst) with Not_found -> None in + begin match data with + | None -> t + | Some (Inl b) -> + (** [b] is closed but may refer to other constants *) + subst_const i k (Vars.subst_instance_constr u b) + | Some (Inr n) -> + mkRel (k + n - i) + end + | Rel n -> + (** Lift free rel variables *) + if n <= k then t + else mkRel (n + len - i - 1) + | _ -> Constr.map_with_binders ((+) 1) (fun k t -> subst_const i k t) k t + in + let map_args i (na, b, ty, opaque) = + (** Both the type and the body may mention other constants *) + let ty = subst_const (len - i - 1) 0 ty in + let b = subst_const (len - i - 1) 0 b in + (na, b, ty, opaque) + in + let args = List.mapi map_args args in + let body = subst_const 0 0 body in + let fold_arg (na, b, ty, opaque) accu = + if opaque then mkApp (mkLambda (na, ty, accu), [|b|]) + else mkLetIn (na, b, ty, accu) + in + let body = List.fold_right fold_arg args body in + (body, ctx, sigs) + +let inline_private_constants_in_definition_entry env ce = + let open Entries in + { ce with + const_entry_body = Future.chain + ce.const_entry_body (fun ((body, ctx), side_eff) -> + let body, ctx',_ = inline_side_effects env body side_eff in + let ctx' = Univ.ContextSet.union ctx ctx' in + (body, ctx'), ()); + } + +let inline_private_constants_in_constr env body side_eff = + pi1 (inline_side_effects env body side_eff) + +let rec is_nth_suffix n l suf = + if Int.equal n 0 then l == suf + else match l with + | [] -> false + | _ :: l -> is_nth_suffix (pred n) l suf + +(* Given the list of signatures of side effects, checks if they match. + * I.e. if they are ordered descendants of the current revstruct. + Returns the number of effects that can be trusted. *) +let check_signatures curmb sl = + let is_direct_ancestor accu (mb, how_many) = + match accu with + | None -> None + | Some (n, curmb) -> + try + let mb = CEphemeron.get mb in + if is_nth_suffix how_many mb curmb + then Some (n + how_many, mb) + else None + with CEphemeron.InvalidKey -> None in + let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in + match sl with + | None -> 0 + | Some (n, _) -> n + + +let constant_entry_of_side_effect cb u = + let open Entries in + let univs = + match cb.const_universes with + | Monomorphic uctx -> + Monomorphic_entry uctx + | Polymorphic auctx -> + Polymorphic_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) + in + let pt = + match cb.const_body, u with + | OpaqueDef _, `Opaque (b, c) -> b, c + | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty + | _ -> assert false in + DefinitionEntry { + const_entry_body = Future.from_val (pt, ()); + const_entry_secctx = None; + const_entry_feedback = None; + const_entry_type = Some cb.const_type; + const_entry_universes = univs; + const_entry_opaque = Declareops.is_opaque cb; + const_entry_inline_code = cb.const_inline_code } + +let turn_direct orig = + let open Entries in + let cb = orig.seff_body in + if Declareops.is_opaque cb then + let p = match orig.seff_env with + | `Opaque (b, c) -> (b, c) + | _ -> assert false + in + let const_body = OpaqueDef (Opaqueproof.create (Future.from_val p)) in + let cb = { cb with const_body } in + { orig with seff_body = cb } + else orig + +let export_eff eff = + let open Entries in + (eff.seff_constant, eff.seff_body, eff.seff_role) + +let export_side_effects mb env c = + let open Entries in + let body = c.const_entry_body in + let _, eff = Future.force body in + let ce = { c with + Entries.const_entry_body = Future.chain body + (fun (b_ctx, _) -> b_ctx, ()) } in + let not_exists e = + try ignore(Environ.lookup_constant e.seff_constant env); false + with Not_found -> true in + let aux (acc,sl) { eff = se; from_env = mb } = + let cbl = List.filter not_exists se in + if List.is_empty cbl then acc, sl + else cbl :: acc, (mb,List.length cbl) :: sl in + let seff, signatures = List.fold_left aux ([],[]) (SideEffects.repr eff) in + let trusted = check_signatures mb signatures in + let push_seff env eff = + let { seff_constant = kn; seff_body = cb ; _ } = eff in + let env = Environ.add_constant kn cb env in + match cb.const_universes with + | Polymorphic _ -> env + | Monomorphic ctx -> + let ctx = match eff.seff_env with + | `Nothing -> ctx + | `Opaque(_, ctx') -> Univ.ContextSet.union ctx' ctx + in + Environ.push_context_set ~strict:true ctx env + in + let rec translate_seff sl seff acc env = + match seff with + | [] -> List.rev acc, ce + | cbs :: rest -> + if Int.equal sl 0 then + let env, cbs = + List.fold_left (fun (env,cbs) eff -> + let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in + let ce = constant_entry_of_side_effect ocb u in + let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in + let eff = { eff with + seff_body = cb; + seff_env = `Nothing; + } in + (push_seff env eff, export_eff eff :: cbs)) + (env,[]) cbs in + translate_seff 0 rest (cbs @ acc) env + else + let cbs_len = List.length cbs in + let cbs = List.map turn_direct cbs in + let env = List.fold_left push_seff env cbs in + let ecbs = List.map export_eff cbs in + translate_seff (sl - cbs_len) rest (ecbs @ acc) env + in + translate_seff trusted seff [] env + let export_private_constants ~in_section ce senv = - let exported, ce = Term_typing.export_side_effects senv.revstruct senv.env ce in + let exported, ce = export_side_effects senv.revstruct senv.env ce in let bodies = List.map (fun (kn, cb, _) -> (kn, cb)) exported in let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in @@ -514,13 +808,25 @@ let add_constant ~in_section l decl senv = let cb = match decl with | ConstantEntry (EffectEntry, ce) -> - Term_typing.translate_constant (Term_typing.SideEffects senv.revstruct) senv.env kn ce + let handle env body eff = + let body, uctx, signatures = inline_side_effects env body eff in + let trusted = check_signatures senv.revstruct signatures in + body, uctx, trusted + in + Term_typing.translate_constant (Term_typing.SideEffects handle) senv.env kn ce | ConstantEntry (PureEntry, ce) -> Term_typing.translate_constant Term_typing.Pure senv.env kn ce | GlobalRecipe r -> let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in if in_section then cb else Declareops.hcons_const_body cb in add_constant_aux ~in_section senv (kn, cb) in + let senv = + match decl with + | ConstantEntry (_,(Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ })) -> + if in_section then CErrors.anomaly (Pp.str "Primitive type not allowed in sections"); + add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv + | _ -> senv + in kn, senv (** Insertion of inductive types *) @@ -536,7 +842,7 @@ let check_mind mie lab = let add_mind l mie senv = let () = check_mind mie l in let kn = MutInd.make2 senv.modpath l in - let mib = Term_typing.translate_mind senv.env kn mie in + let mib = Indtypes.check_inductive senv.env kn mie in let mib = match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib in @@ -774,7 +1080,7 @@ let add_include me is_module inl senv = | SFBmodule _ -> M | SFBmodtype _ -> MT in - add_field field new_name senv + add_field ~is_include:true field new_name senv in resolver, List.fold_left add senv str @@ -788,6 +1094,8 @@ type compiled_library = { comp_natsymbs : Nativecode.symbols } +let module_of_library lib = lib.comp_mod + type native_library = Nativecode.global list let get_library_native_symbols senv dir = @@ -811,7 +1119,7 @@ let start_library dir senv = modvariant = LIBRARY; required = senv.required } -let export ?except senv dir = +let export ?except ~output_native_objects senv dir = let senv = try join_safe_environment ?except senv with e -> @@ -833,7 +1141,7 @@ let export ?except senv dir = } in let ast, symbols = - if !Flags.output_native_objects then + if output_native_objects then Nativelibrary.dump_library mp dir senv.env str else [], Nativecode.empty_symbols in @@ -883,18 +1191,6 @@ let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) -let register field value senv = - (* todo : value closed *) - (* spiwack : updates the safe_env with the information that the register - action has to be performed (again) when the environment is imported *) - { senv with - env = Environ.register senv.env field value; - local_retroknowledge = - Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge - } - -(* This function serves only for inlining constants in native compiler for now, -but it is meant to become a replacement for environ.register *) let register_inline kn senv = let open Environ in if not (evaluable_constant kn senv.env) then @@ -904,6 +1200,88 @@ let register_inline kn senv = let cb = {cb with const_inline_code = true} in let env = add_constant kn cb env in { senv with env} +let check_register_ind ind r env = + let (mb,ob as spec) = Inductive.lookup_mind_specif env ind in + let check_if b msg = + if not b then + CErrors.user_err ~hdr:"check_register_ind" msg in + check_if (Int.equal (Array.length mb.mind_packets) 1) Pp.(str "A non mutual inductive is expected"); + let is_monomorphic = function Monomorphic _ -> true | Polymorphic _ -> false in + check_if (is_monomorphic mb.mind_universes) Pp.(str "A universe monomorphic inductive type is expected"); + check_if (not @@ Inductive.is_private spec) Pp.(str "A non-private inductive type is expected"); + let check_nparams n = + check_if (Int.equal mb.mind_nparams n) Pp.(str "An inductive type with " ++ int n ++ str " parameters is expected") + in + let check_nconstr n = + check_if (Int.equal (Array.length ob.mind_consnames) n) + Pp.(str "an inductive type with " ++ int n ++ str " constructors is expected") + in + let check_name pos s = + check_if (Id.equal ob.mind_consnames.(pos) (Id.of_string s)) + Pp.(str"the " ++ int (pos + 1) ++ str + "th constructor does not have the expected name: " ++ str s) in + let check_type pos t = + check_if (Constr.equal t ob.mind_user_lc.(pos)) + Pp.(str"the " ++ int (pos + 1) ++ str + "th constructor does not have the expected type") in + let check_type_cte pos = check_type pos (Constr.mkRel 1) in + match r with + | CPrimitives.PIT_bool -> + check_nparams 0; + check_nconstr 2; + check_name 0 "true"; + check_type_cte 0; + check_name 1 "false"; + check_type_cte 1 + | CPrimitives.PIT_carry -> + check_nparams 1; + check_nconstr 2; + let test_type pos = + let c = ob.mind_user_lc.(pos) in + let s = Pp.(str"the " ++ int (pos + 1) ++ str + "th constructor does not have the expected type") in + check_if (Constr.isProd c) s; + let (_,d,cd) = Constr.destProd c in + check_if (Constr.is_Type d) s; + check_if + (Constr.equal + (mkProd (Context.anonR,mkRel 1, mkApp (mkRel 3,[|mkRel 2|]))) + cd) + s in + check_name 0 "C0"; + test_type 0; + check_name 1 "C1"; + test_type 1; + | CPrimitives.PIT_pair -> + check_nparams 2; + check_nconstr 1; + check_name 0 "pair"; + let c = ob.mind_user_lc.(0) in + let s = Pp.str "the constructor does not have the expected type" in + begin match Term.decompose_prod c with + | ([_,b;_,a;_,_B;_,_A], codom) -> + check_if (is_Type _A) s; + check_if (is_Type _B) s; + check_if (Constr.equal a (mkRel 2)) s; + check_if (Constr.equal b (mkRel 2)) s; + check_if (Constr.equal codom (mkApp (mkRel 5,[|mkRel 4; mkRel 3|]))) s + | _ -> check_if false s + end + | CPrimitives.PIT_cmp -> + check_nparams 0; + check_nconstr 3; + check_name 0 "Eq"; + check_type_cte 0; + check_name 1 "Lt"; + check_type_cte 1; + check_name 2 "Gt"; + check_type_cte 2 + +let register_inductive ind prim senv = + check_register_ind ind prim senv.env; + let action = Retroknowledge.Register_ind(prim,ind) in + add_retroknowledge action senv + let add_constraints c = add_constraints (Now (false, Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) @@ -929,128 +1307,6 @@ loaded by side-effect once and for all (like it is done in OCaml). Would this be correct with respect to undo's and stuff ? *) -let set_strategy e k l = { e with env = +let set_strategy k l e = { e with env = (Environ.set_oracle e.env (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) } - -(** Register retroknowledge hooks *) - -open Retroknowledge - -(* the Environ.register function synchronizes the proactive and reactive - retroknowledge. *) -let dispatch = - - (* subfunction used for static decompilation of int31 (after a vm_compute, - see pretyping/vnorm.ml for more information) *) - let constr_of_int31 = - let nth_digit_plus_one i n = (* calculates the nth (starting with 0) - digit of i and adds 1 to it - (nth_digit_plus_one 1 3 = 2) *) - if Int.equal (i land (1 lsl n)) 0 then - 1 - else - 2 - in - fun ind -> fun digit_ind -> fun tag -> - let array_of_int i = - Array.init 31 (fun n -> Constr.mkConstruct - (digit_ind, nth_digit_plus_one i (30-n))) - in - (* We check that no bit above 31 is set to one. This assertion used to - fail in the VM, and led to conversion tests failing at Qed. *) - assert (Int.equal (tag lsr 31) 0); - Constr.mkApp(Constr.mkConstruct(ind, 1), array_of_int tag) - in - - (* subfunction which dispatches the compiling information of an - int31 operation which has a specific vm instruction (associates - it to the name of the coq definition in the reactive retroknowledge) *) - let int31_op n op prim kn = - { empty_reactive_info with - vm_compiling = Some (Clambda.compile_prim n op (kn, Univ.Instance.empty)); (*XXX: FIXME universes? *) - native_compiling = Some (Nativelambda.compile_prim prim kn); - } - in - -fun rk value field -> - (* subfunction which shortens the (very common) dispatch of operations *) - let int31_op_from_const n op prim = - match value with - | GlobRef.ConstRef kn -> int31_op n op prim kn - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") - in - let int31_binop_from_const op prim = int31_op_from_const 2 op prim in - let int31_unop_from_const op prim = int31_op_from_const 1 op prim in - match field with - | KInt31 Int31Type -> - let int31bit = - (* invariant : the type of bits is registered, otherwise the function - would raise Not_found. The invariant is enforced in safe_typing.ml *) - match field with - | KInt31 Int31Type -> Retroknowledge.find rk (KInt31 Int31Bits) - | _ -> anomaly ~label:"Environ.register" - (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") - in - let i31bit_type = - match int31bit with - | GlobRef.IndRef i31bit_type -> i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "Int31Bits should be an inductive type.") - in - let int31_decompilation = - match value with - | GlobRef.IndRef i31t -> - constr_of_int31 i31t i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "should be an inductive type.") - in - { empty_reactive_info with - vm_decompile_const = Some int31_decompilation; - vm_before_match = Some Clambda.int31_escape_before_match; - native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); - } - | KInt31 Int31Constructor -> - { empty_reactive_info with - vm_constant_static = Some Clambda.compile_structured_int31; - vm_constant_dynamic = Some Clambda.dynamic_int31_compilation; - native_constant_static = Some Nativelambda.compile_static_int31; - native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; - } - | KInt31 Int31Plus -> int31_binop_from_const Cbytecodes.Kaddint31 - CPrimitives.Int31add - | KInt31 Int31PlusC -> int31_binop_from_const Cbytecodes.Kaddcint31 - CPrimitives.Int31addc - | KInt31 Int31PlusCarryC -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 - CPrimitives.Int31addcarryc - | KInt31 Int31Minus -> int31_binop_from_const Cbytecodes.Ksubint31 - CPrimitives.Int31sub - | KInt31 Int31MinusC -> int31_binop_from_const Cbytecodes.Ksubcint31 - CPrimitives.Int31subc - | KInt31 Int31MinusCarryC -> int31_binop_from_const - Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc - | KInt31 Int31Times -> int31_binop_from_const Cbytecodes.Kmulint31 - CPrimitives.Int31mul - | KInt31 Int31TimesC -> int31_binop_from_const Cbytecodes.Kmulcint31 - CPrimitives.Int31mulc - | KInt31 Int31Div21 -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 - CPrimitives.Int31div21 - | KInt31 Int31Diveucl -> int31_binop_from_const Cbytecodes.Kdivint31 - CPrimitives.Int31diveucl - | KInt31 Int31AddMulDiv -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 - CPrimitives.Int31addmuldiv - | KInt31 Int31Compare -> int31_binop_from_const Cbytecodes.Kcompareint31 - CPrimitives.Int31compare - | KInt31 Int31Head0 -> int31_unop_from_const Cbytecodes.Khead0int31 - CPrimitives.Int31head0 - | KInt31 Int31Tail0 -> int31_unop_from_const Cbytecodes.Ktail0int31 - CPrimitives.Int31tail0 - | KInt31 Int31Lor -> int31_binop_from_const Cbytecodes.Klorint31 - CPrimitives.Int31lor - | KInt31 Int31Land -> int31_binop_from_const Cbytecodes.Klandint31 - CPrimitives.Int31land - | KInt31 Int31Lxor -> int31_binop_from_const Cbytecodes.Klxorint31 - CPrimitives.Int31lxor - | _ -> empty_reactive_info - -let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 0f150ea971..46c97c1fb8 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -136,7 +136,15 @@ val add_constraints : (** Setting the type theory flavor *) val set_engagement : Declarations.engagement -> safe_transformer0 +val set_indices_matter : bool -> safe_transformer0 val set_typing_flags : Declarations.typing_flags -> safe_transformer0 +val set_share_reduction : bool -> safe_transformer0 +val set_VM : bool -> safe_transformer0 +val set_native_compiler : bool -> safe_transformer0 +val make_sprop_cumulative : safe_transformer0 +val set_allow_sprop : bool -> safe_transformer0 + +val check_engagement : Environ.env -> Declarations.set_predicativity -> unit (** {6 Interactive module functions } *) @@ -174,12 +182,14 @@ type compiled_library type native_library = Nativecode.global list +val module_of_library : compiled_library -> Declarations.module_body + val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.symbols val start_library : DirPath.t -> ModPath.t safe_transformer val export : - ?except:Future.UUIDSet.t -> + ?except:Future.UUIDSet.t -> output_native_objects:bool -> safe_environment -> DirPath.t -> ModPath.t * compiled_library * native_library @@ -204,14 +214,13 @@ val exists_objlabel : Label.t -> safe_environment -> bool val delta_of_senv : safe_environment -> Mod_subst.delta_resolver * Mod_subst.delta_resolver -(** {6 Retroknowledge / Native compiler } *) +val constant_of_delta_kn_senv : safe_environment -> KerName.t -> Constant.t +val mind_of_delta_kn_senv : safe_environment -> KerName.t -> MutInd.t -open Retroknowledge - -val register : - field -> GlobRef.t -> safe_transformer0 +(** {6 Retroknowledge / Native compiler } *) val register_inline : Constant.t -> safe_transformer0 +val register_inductive : inductive -> CPrimitives.prim_ind -> safe_transformer0 val set_strategy : - safe_environment -> Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_environment + Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_transformer0 diff --git a/kernel/sorts.ml b/kernel/sorts.ml index a7bb08f5b6..09c98ca1bc 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -10,13 +10,15 @@ open Univ -type family = InProp | InSet | InType +type family = InSProp | InProp | InSet | InType type t = + | SProp | Prop | Set | Type of Universe.t +let sprop = SProp let prop = Prop let set = Set let type1 = Type type1_univ @@ -25,15 +27,20 @@ let univ_of_sort = function | Type u -> u | Set -> Universe.type0 | Prop -> Universe.type0m + | SProp -> Universe.sprop let sort_of_univ u = - if is_type0m_univ u then prop + if Universe.is_sprop u then sprop + else if is_type0m_univ u then prop else if is_type0_univ u then set else Type u let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with + | SProp, SProp -> 0 + | SProp, _ -> -1 + | _, SProp -> 1 | Prop, Prop -> 0 | Prop, _ -> -1 | Set, Prop -> 1 @@ -44,34 +51,52 @@ let compare s1 s2 = let equal s1 s2 = Int.equal (compare s1 s2) 0 +let super = function + | SProp | Prop | Set -> Type (Universe.type1) + | Type u -> Type (Universe.super u) + +let is_sprop = function + | SProp -> true + | Prop | Set | Type _ -> false + let is_prop = function | Prop -> true - | Type u when Universe.equal Universe.type0m u -> true - | _ -> false + | SProp | Set | Type _ -> false let is_set = function | Set -> true - | Type u when Universe.equal Universe.type0 u -> true - | _ -> false + | SProp | Prop | Type _ -> false let is_small = function - | Prop | Set -> true - | Type u -> is_small_univ u + | SProp | Prop | Set -> true + | Type _ -> false let family = function + | SProp -> InSProp | Prop -> InProp | Set -> InSet - | Type u when is_type0m_univ u -> InProp - | Type u when is_type0_univ u -> InSet | Type _ -> InType +let family_compare a b = match a,b with + | InSProp, InSProp -> 0 + | InSProp, _ -> -1 + | _, InSProp -> 1 + | InProp, InProp -> 0 + | InProp, _ -> -1 + | _, InProp -> 1 + | InSet, InSet -> 0 + | InSet, _ -> -1 + | _, InSet -> 1 + | InType, InType -> 0 + let family_equal = (==) open Hashset.Combine let hash = function - | Prop -> combinesmall 1 0 - | Set -> combinesmall 1 1 + | SProp -> combinesmall 1 0 + | Prop -> combinesmall 1 1 + | Set -> combinesmall 1 2 | Type u -> let h = Univ.Universe.hash u in combinesmall 2 h @@ -102,3 +127,34 @@ module Hsorts = end) let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ + +(** On binders: is this variable proof relevant *) +type relevance = Relevant | Irrelevant + +let relevance_equal r1 r2 = match r1,r2 with + | Relevant, Relevant | Irrelevant, Irrelevant -> true + | (Relevant | Irrelevant), _ -> false + +let relevance_of_sort_family = function + | InSProp -> Irrelevant + | _ -> Relevant + +let relevance_hash = function + | Relevant -> 0 + | Irrelevant -> 1 + +let relevance_of_sort = function + | SProp -> Irrelevant + | _ -> Relevant + +let debug_print = function + | SProp -> Pp.(str "SProp") + | Prop -> Pp.(str "Prop") + | Set -> Pp.(str "Set") + | Type u -> Pp.(str "Type(" ++ Univ.Universe.pr u ++ str ")") + +let pr_sort_family = function + | InSProp -> Pp.(str "SProp") + | InProp -> Pp.(str "Prop") + | InSet -> Pp.(str "Set") + | InType -> Pp.(str "Type") diff --git a/kernel/sorts.mli b/kernel/sorts.mli index cac6229b91..c49728b146 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -10,13 +10,15 @@ (** {6 The sorts of CCI. } *) -type family = InProp | InSet | InType +type family = InSProp | InProp | InSet | InType -type t = +type t = private + | SProp | Prop | Set | Type of Univ.Universe.t +val sprop : t val set : t val prop : t val type1 : t @@ -25,6 +27,7 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val is_sprop : t -> bool val is_set : t -> bool val is_prop : t -> bool val is_small : t -> bool @@ -32,6 +35,7 @@ val family : t -> family val hcons : t -> t +val family_compare : family -> family -> int val family_equal : family -> family -> bool module List : sig @@ -41,3 +45,19 @@ end val univ_of_sort : t -> Univ.Universe.t val sort_of_univ : Univ.Universe.t -> t + +val super : t -> t + +(** On binders: is this variable proof relevant *) +type relevance = Relevant | Irrelevant + +val relevance_hash : relevance -> int + +val relevance_equal : relevance -> relevance -> bool + +val relevance_of_sort : t -> relevance +val relevance_of_sort_family : family -> relevance + +val debug_print : t -> Pp.t + +val pr_sort_family : family -> Pp.t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d64342dbb0..1857ea3329 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -23,6 +23,7 @@ open Declareops open Reduction open Inductive open Modops +open Context open Mod_subst (*i*) @@ -92,13 +93,25 @@ let check_conv_error error why cst poly f env a1 a2 = with NotConvertible -> error why | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) -let check_polymorphic_instance error env auctx1 auctx2 = - if not (Univ.AUContext.size auctx1 == Univ.AUContext.size auctx2) then - error IncompatibleInstances - else if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then - error (IncompatibleConstraints auctx1) - else - Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env +let check_universes error env u1 u2 = + match u1, u2 with + | Monomorphic _, Monomorphic _ -> env + | Polymorphic auctx1, Polymorphic auctx2 -> + if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) + else + Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env + | Monomorphic _, Polymorphic _ -> error (PolymorphicStatusExpected true) + | Polymorphic _, Monomorphic _ -> error (PolymorphicStatusExpected false) + +let check_variance error v1 v2 = + match v1, v2 with + | None, None -> () + | Some v1, Some v2 -> + if not (Array.for_all2 Variance.check_subtype v2 v1) then + error IncompatibleVariance + | None, Some _ -> error (CumulativeStatusExpected true) + | Some _, None -> error (CumulativeStatusExpected false) (* for now we do not allow reorderings *) @@ -112,29 +125,9 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let env, inst = - match mib1.mind_universes, mib2.mind_universes with - | Monomorphic_ind _, Monomorphic_ind _ -> env, Univ.Instance.empty - | Polymorphic_ind auctx, Polymorphic_ind auctx' -> - let env = check_polymorphic_instance error env auctx auctx' in - env, Univ.make_abstract_instance auctx' - | Cumulative_ind cumi, Cumulative_ind cumi' -> - (** Currently there is no way to control variance of inductive types, but - just in case we require that they are in a subtyping relation. *) - let () = - let v = ACumulativityInfo.variance cumi in - let v' = ACumulativityInfo.variance cumi' in - if not (Array.for_all2 Variance.check_subtype v' v) then - CErrors.anomaly Pp.(str "Variance of " ++ KerName.print kn1 ++ - str " is not compatible with the one of " ++ KerName.print kn2) - in - let auctx = Univ.ACumulativityInfo.univ_context cumi in - let auctx' = Univ.ACumulativityInfo.univ_context cumi' in - let env = check_polymorphic_instance error env auctx auctx' in - env, Univ.make_abstract_instance auctx' - | _ -> error - (CumulativeStatusExpected (Declareops.inductive_is_cumulative mib2)) - in + let env = check_universes error env mib1.mind_universes mib2.mind_universes in + let () = check_variance error mib1.mind_variance mib2.mind_variance in + let inst = make_abstract_instance (Declareops.inductive_polymorphic_context mib1) in let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name t1 t2 = check_conv (NotConvertibleInductiveField name) @@ -198,8 +191,8 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 check (fun mib -> mib.mind_record <> NotRecord) (==) (fun x -> RecordFieldExpected x); if mib1.mind_record <> NotRecord then begin let rec names_prod_letin t = match kind t with - | Prod(n,_,t) -> n::(names_prod_letin t) - | LetIn(n,_,_,t) -> n::(names_prod_letin t) + | Prod(n,_,t) -> n.binder_name::(names_prod_letin t) + | LetIn(n,_,_,t) -> n.binder_name::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in @@ -237,17 +230,8 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking universes *) - let poly, env = - match cb1.const_universes, cb2.const_universes with - | Monomorphic_const _, Monomorphic_const _ -> - false, env - | Polymorphic_const auctx1, Polymorphic_const auctx2 -> - true, check_polymorphic_instance error env auctx1 auctx2 - | Monomorphic_const _, Polymorphic_const _ -> - error (PolymorphicStatusExpected true) - | Polymorphic_const _, Monomorphic_const _ -> - error (PolymorphicStatusExpected false) - in + let env = check_universes error env cb1.const_universes cb2.const_universes in + let poly = Declareops.constant_is_polymorphic cb1 in (* Now check types *) let typ1 = cb1.const_type in let typ2 = cb2.const_type in @@ -259,10 +243,10 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with - | Undef _ | OpaqueDef _ -> cst + | Primitive _ | Undef _ | OpaqueDef _ -> cst | Def lc2 -> (match cb1.const_body with - | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField + | Primitive _ | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField | Def lc1 -> (* NB: cb1 might have been strengthened and appear as transparent. Anyway [check_conv] will handle that afterwards. *) diff --git a/kernel/term.ml b/kernel/term.ml index 795cdeb040..f09c45715f 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -14,13 +14,14 @@ open CErrors open Names open Vars open Constr +open Context (* Deprecated *) -type sorts_family = Sorts.family = InProp | InSet | InType +type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type sorts = Sorts.t = - | Prop | Set +type sorts = Sorts.t = private + | SProp | Prop | Set | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] @@ -32,9 +33,11 @@ type sorts = Sorts.t = (* Other term constructors *) (***************************) -let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) -let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) -let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) +let name_annot = map_annot Name.mk_name + +let mkNamedProd id typ c = mkProd (name_annot id, typ, subst_var id.binder_name c) +let mkNamedLambda id typ c = mkLambda (name_annot id, typ, subst_var id.binder_name c) +let mkNamedLetIn id c1 t c2 = mkLetIn (name_annot id, c1, t, subst_var id.binder_name c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn decl c = @@ -60,10 +63,11 @@ let mkNamedProd_wo_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedProd id t c - | LocalDef (id,b,_t) -> subst1 b (subst_var id c) + | LocalDef (id,b,_) -> subst1 b (subst_var id.binder_name c) (* non-dependent product t1 -> t2 *) -let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) +let mkArrow t1 r t2 = mkProd (make_annot Anonymous r, t1, t2) +let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2 (* Constructs either [[x:t]c] or [[x=b:t]c] *) let mkLambda_or_LetIn decl c = @@ -366,8 +370,8 @@ let rec isArity c = type ('constr, 'types) kind_of_type = | SortType of Sorts.t | CastType of 'types * 'types - | ProdType of Name.t * 'types * 'types - | LetInType of Name.t * 'constr * 'types * 'types + | ProdType of Name.t Context.binder_annot * 'types * 'types + | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array let kind_of_type t = match kind t with @@ -379,4 +383,4 @@ let kind_of_type t = match kind t with | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) - | (Lambda _ | Construct _) -> failwith "Not a type" + | (Lambda _ | Construct _ | Int _) -> failwith "Not a type" diff --git a/kernel/term.mli b/kernel/term.mli index 181d714ed7..4265324693 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -17,12 +17,15 @@ open Constr [forall (_:t1), t2]. Beware [t_2] is NOT lifted. Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))] *) -val mkArrow : types -> types -> constr +val mkArrow : types -> Sorts.relevance -> types -> constr + +val mkArrowR : types -> types -> constr +(** For an always-relevant domain *) (** Named version of the functions from [Term]. *) -val mkNamedLambda : Id.t -> types -> constr -> constr -val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr -val mkNamedProd : Id.t -> types -> types -> types +val mkNamedLambda : Id.t Context.binder_annot -> types -> constr -> constr +val mkNamedLetIn : Id.t Context.binder_annot -> constr -> types -> constr -> constr +val mkNamedProd : Id.t Context.binder_annot -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) val mkProd_or_LetIn : Constr.rel_declaration -> types -> types @@ -45,24 +48,24 @@ val appvectc : constr -> constr array -> constr (** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) -val prodn : int -> (Name.t * constr) list -> constr -> constr +val prodn : int -> (Name.t Context.binder_annot * constr) list -> constr -> constr (** [compose_prod l b] @return [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [decompose_prod]. *) -val compose_prod : (Name.t * constr) list -> constr -> constr +val compose_prod : (Name.t Context.binder_annot * constr) list -> constr -> constr (** [lamn n l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) -val lamn : int -> (Name.t * constr) list -> constr -> constr +val lamn : int -> (Name.t Context.binder_annot * constr) list -> constr -> constr (** [compose_lam l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [it_destLam] *) -val compose_lam : (Name.t * constr) list -> constr -> constr +val compose_lam : (Name.t Context.binder_annot * constr) list -> constr -> constr (** [to_lambda n l] @return [fun (x_1:T_1)...(x_n:T_n) => T] @@ -107,22 +110,22 @@ val prod_applist_assum : int -> types -> constr list -> types (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *) -val decompose_prod : constr -> (Name.t*constr) list * constr +val decompose_prod : constr -> (Name.t Context.binder_annot * constr) list * constr (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) -val decompose_lam : constr -> (Name.t*constr) list * constr +val decompose_lam : constr -> (Name.t Context.binder_annot * constr) list * constr (** Given a positive integer n, decompose a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. Raise a user error if not enough products. *) -val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr +val decompose_prod_n : int -> constr -> (Name.t Context.binder_annot * constr) list * constr (** Given a positive integer {% $ %}n{% $ %}, decompose a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}. Raise a user error if not enough lambdas. *) -val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr +val decompose_lam_n : int -> constr -> (Name.t Context.binder_annot * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) @@ -183,17 +186,17 @@ val isArity : types -> bool type ('constr, 'types) kind_of_type = | SortType of Sorts.t | CastType of 'types * 'types - | ProdType of Name.t * 'types * 'types - | LetInType of Name.t * 'constr * 'types * 'types + | ProdType of Name.t Context.binder_annot * 'types * 'types + | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array val kind_of_type : types -> (constr, types) kind_of_type (* Deprecated *) -type sorts_family = Sorts.family = InProp | InSet | InType +type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type sorts = Sorts.t = - | Prop | Set +type sorts = Sorts.t = private + | SProp | Prop | Set | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 5ccc23eefc..faa4411e92 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -21,165 +21,17 @@ open Constr open Declarations open Environ open Entries -open Typeops module NamedDecl = Context.Named.Declaration (* Insertion of constants and parameters in environment. *) -type side_effect = { - from_env : Declarations.structure_body CEphemeron.key; - eff : side_eff list; -} - -module SideEffects : -sig - type t - val repr : t -> side_effect list - val empty : t - val add : side_effect -> t -> t - val concat : t -> t -> t -end = -struct - -module SeffOrd = struct -type t = side_effect -let compare e1 e2 = - let cmp e1 e2 = Constant.CanOrd.compare e1.seff_constant e2.seff_constant in - List.compare cmp e1.eff e2.eff -end - -module SeffSet = Set.Make(SeffOrd) - -type t = { seff : side_effect list; elts : SeffSet.t } -(** Invariant: [seff] is a permutation of the elements of [elts] *) - -let repr eff = eff.seff -let empty = { seff = []; elts = SeffSet.empty } -let add x es = - if SeffSet.mem x es.elts then es - else { seff = x :: es.seff; elts = SeffSet.add x es.elts } -let concat xes yes = - List.fold_right add xes.seff yes - -end - -type side_effects = SideEffects.t +type 'a effect_handler = + env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) type _ trust = | Pure : unit trust -| SideEffects : structure_body -> side_effects trust - -let uniq_seff_rev = SideEffects.repr -let uniq_seff l = - let ans = List.rev (SideEffects.repr l) in - List.map_append (fun { eff ; _ } -> eff) ans - -let empty_seff = SideEffects.empty -let add_seff mb eff effs = - let from_env = CEphemeron.create mb in - SideEffects.add { eff; from_env } effs -let concat_seff = SideEffects.concat - -let mk_pure_proof c = (c, Univ.ContextSet.empty), empty_seff - -let inline_side_effects env body ctx side_eff = - (** First step: remove the constants that are still in the environment *) - let filter { eff = se; from_env = mb } = - let map e = (e.seff_constant, e.seff_body, e.seff_env) in - let cbl = List.map map se in - let not_exists (c,_,_) = - try ignore(Environ.lookup_constant c env); false - with Not_found -> true in - let cbl = List.filter not_exists cbl in - (cbl, mb) - in - (* CAVEAT: we assure that most recent effects come first *) - let side_eff = List.map filter (uniq_seff_rev side_eff) in - let sigs = List.rev_map (fun (cbl, mb) -> mb, List.length cbl) side_eff in - let side_eff = List.fold_left (fun accu (cbl, _) -> cbl @ accu) [] side_eff in - let side_eff = List.rev side_eff in - (** Most recent side-effects first in side_eff *) - if List.is_empty side_eff then (body, ctx, sigs) - else - (** Second step: compute the lifts and substitutions to apply *) - let cname c = Name (Label.to_id (Constant.label c)) in - let fold (subst, var, ctx, args) (c, cb, b) = - let (b, opaque) = match cb.const_body, b with - | Def b, _ -> (Mod_subst.force_constr b, false) - | OpaqueDef _, `Opaque (b,_) -> (b, true) - | _ -> assert false - in - match cb.const_universes with - | Monomorphic_const univs -> - (** Abstract over the term at the top of the proof *) - let ty = cb.const_type in - let subst = Cmap_env.add c (Inr var) subst in - let ctx = Univ.ContextSet.union ctx univs in - (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) - | Polymorphic_const _auctx -> - (** Inline the term to emulate universe polymorphism *) - let subst = Cmap_env.add c (Inl b) subst in - (subst, var, ctx, args) - in - let (subst, len, ctx, args) = List.fold_left fold (Cmap_env.empty, 1, ctx, []) side_eff in - (** Third step: inline the definitions *) - let rec subst_const i k t = match Constr.kind t with - | Const (c, u) -> - let data = try Some (Cmap_env.find c subst) with Not_found -> None in - begin match data with - | None -> t - | Some (Inl b) -> - (** [b] is closed but may refer to other constants *) - subst_const i k (Vars.subst_instance_constr u b) - | Some (Inr n) -> - mkRel (k + n - i) - end - | Rel n -> - (** Lift free rel variables *) - if n <= k then t - else mkRel (n + len - i - 1) - | _ -> Constr.map_with_binders ((+) 1) (fun k t -> subst_const i k t) k t - in - let map_args i (na, b, ty, opaque) = - (** Both the type and the body may mention other constants *) - let ty = subst_const (len - i - 1) 0 ty in - let b = subst_const (len - i - 1) 0 b in - (na, b, ty, opaque) - in - let args = List.mapi map_args args in - let body = subst_const 0 0 body in - let fold_arg (na, b, ty, opaque) accu = - if opaque then mkApp (mkLambda (na, ty, accu), [|b|]) - else mkLetIn (na, b, ty, accu) - in - let body = List.fold_right fold_arg args body in - (body, ctx, sigs) - -let rec is_nth_suffix n l suf = - if Int.equal n 0 then l == suf - else match l with - | [] -> false - | _ :: l -> is_nth_suffix (pred n) l suf - -(* Given the list of signatures of side effects, checks if they match. - * I.e. if they are ordered descendants of the current revstruct. - Returns the number of effects that can be trusted. *) -let check_signatures curmb sl = - let is_direct_ancestor accu (mb, how_many) = - match accu with - | None -> None - | Some (n, curmb) -> - try - let mb = CEphemeron.get mb in - if is_nth_suffix how_many mb curmb - then Some (n + how_many, mb) - else None - with CEphemeron.InvalidKey -> None in - let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in - match sl with - | None -> 0 - | Some (n, _) -> n +| SideEffects : 'a effect_handler -> 'a trust let skip_trusted_seff sl b e = let rec aux sl b e acc = @@ -212,43 +64,73 @@ let feedback_completion_typecheck = Option.iter (fun state_id -> Feedback.feedback ~id:state_id Feedback.Complete) -let abstract_constant_universes = function - | Monomorphic_const_entry uctx -> - Univ.empty_level_subst, Monomorphic_const uctx - | Polymorphic_const_entry uctx -> - let sbst, auctx = Univ.abstract_universes uctx in - let sbst = Univ.make_instance_subst sbst in - sbst, Polymorphic_const auctx - let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = match dcl with | ParameterEntry (ctx,(t,uctx),nl) -> let env = match uctx with - | Monomorphic_const_entry uctx -> push_context_set ~strict:true uctx env - | Polymorphic_const_entry uctx -> push_context ~strict:false uctx env + | Monomorphic_entry uctx -> push_context_set ~strict:true uctx env + | Polymorphic_entry (_, uctx) -> push_context ~strict:false uctx env in - let j = infer env t in - let usubst, univs = abstract_constant_universes uctx in - let c = Typeops.assumption_of_judgment env j in - let t = Constr.hcons (Vars.subst_univs_level_constr usubst c) in + let j = Typeops.infer env t in + let usubst, univs = Declareops.abstract_universes uctx in + let r = Typeops.assumption_of_judgment env j in + let t = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in { Cooking.cook_body = Undef nl; cook_type = t; cook_universes = univs; + cook_private_univs = None; + cook_relevance = r; cook_inline = false; cook_context = ctx; } + (** Primitives cannot be universe polymorphic *) + | PrimitiveEntry ({ prim_entry_type = otyp; + prim_entry_univs = uctxt; + prim_entry_content = op_t; + }) -> + let env = push_context_set ~strict:true uctxt env in + let ty = match otyp with + | Some typ -> + let typ = Typeops.infer_type env typ in + Typeops.check_primitive_type env op_t typ.utj_val; + Constr.hcons typ.utj_val + | None -> + match op_t with + | CPrimitives.OT_op op -> Typeops.type_of_prim env op + | CPrimitives.OT_type _ -> mkSet + in + let cd = + match op_t with + | CPrimitives.OT_op op -> Declarations.Primitive op + | CPrimitives.OT_type _ -> Undef None in + { Cooking.cook_body = cd; + cook_type = ty; + cook_universes = Monomorphic uctxt; + cook_private_univs = None; + cook_inline = false; + cook_context = None; + cook_relevance = Sorts.Relevant; + } + (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, so we delay the typing and hash consing of its body. Remark: when the universe quantification is given explicitly, we could delay even in the polymorphic case. *) + +(** Definition is opaque (Qed) and non polymorphic with known type, so we delay +the typing and hash consing of its body. + +TODO: if the universe quantification is given explicitly, we could delay even in +the polymorphic case + *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; - const_entry_universes = Monomorphic_const_entry univs; _ } as c) -> + const_entry_universes = Monomorphic_entry univs; _ } as c) -> let env = push_context_set ~strict:true univs env in - let { const_entry_body = body; const_entry_feedback = feedback_id ; _ } = c in - let tyj = infer_type env typ in + let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in + let tyj = Typeops.infer_type env typ in let proofterm = Future.chain body (fun ((body,uctx),side_eff) -> (* don't redeclare universes which are declared for the type *) @@ -256,17 +138,17 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let j, uctx = match trust with | Pure -> let env = push_context_set uctx env in - let j = infer env body in - let _ = judge_of_cast env j DEFAULTcast tyj in + let j = Typeops.infer env body in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx - | SideEffects mb -> - let (body, uctx, signatures) = inline_side_effects env body uctx side_eff in - let valid_signatures = check_signatures mb signatures in + | SideEffects handle -> + let (body, uctx', valid_signatures) = handle env body side_eff in + let uctx = Univ.ContextSet.union uctx uctx' in let env = push_context_set uctx env in let body,env,ectx = skip_trusted_seff valid_signatures body env in - let j = infer env body in + let j = Typeops.infer env body in let j = unzip ectx j in - let _ = judge_of_cast env j DEFAULTcast tyj in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx in let c = Constr.hcons j.uj_val in @@ -275,8 +157,10 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let def = OpaqueDef (Opaqueproof.create proofterm) in { Cooking.cook_body = def; - cook_type = typ; - cook_universes = Monomorphic_const univs; + cook_type = tyj.utj_val; + cook_universes = Monomorphic univs; + cook_private_univs = None; + cook_relevance = Sorts.relevance_of_sort tyj.utj_type; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -286,37 +170,40 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let { const_entry_type = typ; const_entry_opaque = opaque ; _ } = c in let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in let (body, ctx), side_eff = Future.join body in - let body, ctx, _ = match trust with - | Pure -> body, ctx, [] - | SideEffects _ -> inline_side_effects env body ctx side_eff + let body, ctx = match trust with + | Pure -> body, ctx + | SideEffects handle -> + let body, ctx', _ = handle env body side_eff in + body, Univ.ContextSet.union ctx ctx' in - let env, usubst, univs = match c.const_entry_universes with - | Monomorphic_const_entry univs -> + let env, usubst, univs, private_univs = match c.const_entry_universes with + | Monomorphic_entry univs -> let ctx = Univ.ContextSet.union univs ctx in let env = push_context_set ~strict:true ctx env in - env, Univ.empty_level_subst, Monomorphic_const ctx - | Polymorphic_const_entry uctx -> - (** Ensure not to generate internal constraints in polymorphic mode. - The only way for this to happen would be that either the body - contained deferred universes, or that it contains monomorphic - side-effects. The first property is ruled out by upper layers, - and the second one is ensured by the fact we currently - unconditionally export side-effects from polymorphic definitions, - i.e. [trust] is always [Pure]. *) - let () = assert (Univ.ContextSet.is_empty ctx) in + env, Univ.empty_level_subst, Monomorphic ctx, None + | Polymorphic_entry (nas, uctx) -> + (** [ctx] must contain local universes, such that it has no impact + on the rest of the graph (up to transitivity). *) let env = push_context ~strict:false uctx env in - let sbst, auctx = Univ.abstract_universes uctx in + let sbst, auctx = Univ.abstract_universes nas uctx in let sbst = Univ.make_instance_subst sbst in - env, sbst, Polymorphic_const auctx + let env, local = + if opaque then + push_subgraph ctx env, Some (on_snd (Univ.subst_univs_level_constraints sbst) ctx) + else + if Univ.ContextSet.is_empty ctx then env, None + else CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition.") + in + env, sbst, Polymorphic auctx, local in - let j = infer env body in + let j = Typeops.infer env body in let typ = match typ with | None -> Vars.subst_univs_level_constr usubst j.uj_type | Some t -> - let tj = infer_type env t in - let _ = judge_of_cast env j DEFAULTcast tj in - Vars.subst_univs_level_constr usubst t + let tj = Typeops.infer_type env t in + let _ = Typeops.judge_of_cast env j DEFAULTcast tj in + Vars.subst_univs_level_constr usubst tj.utj_val in let def = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in let def = @@ -328,6 +215,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = Cooking.cook_body = def; cook_type = typ; cook_universes = univs; + cook_private_univs = private_univs; + cook_relevance = Retypeops.relevance_of_term env j.uj_val; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -379,7 +268,7 @@ let build_constant_declaration _kn env result = we must look at the body NOW, if any *) let ids_typ = global_vars_set env typ in let ids_def = match def with - | Undef _ -> Id.Set.empty + | Undef _ | Primitive _ -> Id.Set.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = @@ -399,7 +288,7 @@ let build_constant_declaration _kn env result = (* We use the declared set and chain a check of correctness *) sort declared, match def with - | Undef _ as x -> x (* nothing to check *) + | Undef _ | Primitive _ as x -> x (* nothing to check *) | Def cs as x -> let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in @@ -422,6 +311,8 @@ let build_constant_declaration _kn env result = const_type = typ; const_body_code = tps; const_universes = univs; + const_private_poly_univs = result.cook_private_univs; + const_relevance = result.cook_relevance; const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } @@ -431,105 +322,10 @@ let translate_constant mb env kn ce = build_constant_declaration kn env (infer_declaration ~trust:mb env ce) -let constant_entry_of_side_effect cb u = - let univs = - match cb.const_universes with - | Monomorphic_const uctx -> - Monomorphic_const_entry uctx - | Polymorphic_const auctx -> - Polymorphic_const_entry (Univ.AUContext.repr auctx) - in - let pt = - match cb.const_body, u with - | OpaqueDef _, `Opaque (b, c) -> b, c - | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty - | _ -> assert false in - DefinitionEntry { - const_entry_body = Future.from_val (pt, ()); - const_entry_secctx = None; - const_entry_feedback = None; - const_entry_type = Some cb.const_type; - const_entry_universes = univs; - const_entry_opaque = Declareops.is_opaque cb; - const_entry_inline_code = cb.const_inline_code } -;; - -let turn_direct orig = - let cb = orig.seff_body in - if Declareops.is_opaque cb then - let p = match orig.seff_env with - | `Opaque (b, c) -> (b, c) - | _ -> assert false - in - let const_body = OpaqueDef (Opaqueproof.create (Future.from_val p)) in - let cb = { cb with const_body } in - { orig with seff_body = cb } - else orig - -type exported_side_effect = - Constant.t * constant_body * side_effect_role - -let export_eff eff = - (eff.seff_constant, eff.seff_body, eff.seff_role) - -let export_side_effects mb env c = - let { const_entry_body = body; _ } = c in - let _, eff = Future.force body in - let ce = { c with - const_entry_body = Future.chain body - (fun (b_ctx, _) -> b_ctx, ()) } in - let not_exists e = - try ignore(Environ.lookup_constant e.seff_constant env); false - with Not_found -> true in - let aux (acc,sl) { eff = se; from_env = mb } = - let cbl = List.filter not_exists se in - if List.is_empty cbl then acc, sl - else cbl :: acc, (mb,List.length cbl) :: sl in - let seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in - let trusted = check_signatures mb signatures in - let push_seff env eff = - let { seff_constant = kn; seff_body = cb ; _ } = eff in - let env = Environ.add_constant kn cb env in - match cb.const_universes with - | Polymorphic_const _ -> env - | Monomorphic_const ctx -> - let ctx = match eff.seff_env with - | `Nothing -> ctx - | `Opaque(_, ctx') -> Univ.ContextSet.union ctx' ctx - in - Environ.push_context_set ~strict:true ctx env - in - let rec translate_seff sl seff acc env = - match seff with - | [] -> List.rev acc, ce - | cbs :: rest -> - if Int.equal sl 0 then - let env, cbs = - List.fold_left (fun (env,cbs) eff -> - let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in - let ce = constant_entry_of_side_effect ocb u in - let cb = translate_constant Pure env kn ce in - let eff = { eff with - seff_body = cb; - seff_env = `Nothing; - } in - (push_seff env eff, export_eff eff :: cbs)) - (env,[]) cbs in - translate_seff 0 rest (cbs @ acc) env - else - let cbs_len = List.length cbs in - let cbs = List.map turn_direct cbs in - let env = List.fold_left push_seff env cbs in - let ecbs = List.map export_eff cbs in - translate_seff (sl - cbs_len) rest (ecbs @ acc) env - in - translate_seff trusted seff [] env -;; - let translate_local_assum env t = - let j = infer env t in + let j = Typeops.infer env t in let t = Typeops.assumption_of_judgment env j in - t + j.uj_val, t let translate_recipe ~hcons env kn r = build_constant_declaration kn env (Cooking.cook_constant ~hcons r) @@ -542,7 +338,7 @@ let translate_local_def env _id centry = const_entry_secctx = centry.secdef_secctx; const_entry_feedback = centry.secdef_feedback; const_entry_type = centry.secdef_type; - const_entry_universes = Monomorphic_const_entry Univ.ContextSet.empty; + const_entry_universes = Monomorphic_entry Univ.ContextSet.empty; const_entry_opaque = false; const_entry_inline_code = false; } in @@ -551,6 +347,7 @@ let translate_local_def env _id centry = if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin match decl.cook_body with | Undef _ -> () + | Primitive _ -> () | Def _ -> () | OpaqueDef lc -> let ids_typ = global_vars_set env typ in @@ -559,8 +356,8 @@ let translate_local_def env _id centry = record_aux env ids_typ ids_def end; let () = match decl.cook_universes with - | Monomorphic_const ctx -> assert (Univ.ContextSet.is_empty ctx) - | Polymorphic_const _ -> assert false + | Monomorphic ctx -> assert (Univ.ContextSet.is_empty ctx) + | Polymorphic _ -> assert false in let c = match decl.cook_body with | Def c -> Mod_subst.force_constr c @@ -571,20 +368,6 @@ let translate_local_def env _id centry = the body by virtue of the typing of [Entries.section_def_entry]. *) let () = assert (Univ.ContextSet.is_empty cst) in p - | Undef _ -> assert false + | Undef _ | Primitive _ -> assert false in - c, typ - -(* Insertion of inductive types. *) - -let translate_mind env kn mie = Indtypes.check_inductive env kn mie - -let inline_entry_side_effects env ce = { ce with - const_entry_body = Future.chain - ce.const_entry_body (fun ((body, ctx), side_eff) -> - let body, ctx',_ = inline_side_effects env body ctx side_eff in - (body, ctx'), ()); -} - -let inline_side_effects env body side_eff = - pi1 (inline_side_effects env body Univ.ContextSet.empty side_eff) + c, decl.cook_relevance, typ diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index ab25090b00..1fa5eca2e3 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -14,56 +14,27 @@ open Environ open Declarations open Entries -type side_effects +(** Handlers are used to manage side-effects. The ['a] type stands for the type + of side-effects, and it is parametric because they are only defined later + on. Handlers inline the provided side-effects into the term, and return + the set of additional global constraints that need to be added for the term + to be well typed. *) +type 'a effect_handler = + env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) type _ trust = | Pure : unit trust -| SideEffects : structure_body -> side_effects trust +| SideEffects : 'a effect_handler -> 'a trust val translate_local_def : env -> Id.t -> section_def_entry -> - constr * types + constr * Sorts.relevance * types -val translate_local_assum : env -> types -> types - -val mk_pure_proof : constr -> side_effects proof_output - -val inline_side_effects : env -> constr -> side_effects -> constr -(** Returns the term where side effects have been turned into let-ins or beta - redexes. *) - -val inline_entry_side_effects : - env -> side_effects definition_entry -> unit definition_entry -(** Same as {!inline_side_effects} but applied to entries. Only modifies the - {!Entries.const_entry_body} field. It is meant to get a term out of a not - yet type checked proof. *) - -val empty_seff : side_effects -val add_seff : Declarations.structure_body -> Entries.side_eff list -> side_effects -> side_effects -val concat_seff : side_effects -> side_effects -> side_effects -(** [concat_seff e1 e2] adds the side-effects of [e1] to [e2], i.e. effects in - [e1] must be more recent than those of [e2]. *) -val uniq_seff : side_effects -> side_eff list -(** Return the list of individual side-effects in the order of their - creation. *) +val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> constant_body -type exported_side_effect = - Constant.t * constant_body * side_effect_role - -(* Given a constant entry containing side effects it exports them (either - * by re-checking them or trusting them). Returns the constant bodies to - * be pushed in the safe_env by safe typing. The main constant entry - * needs to be translated as usual after this step. *) -val export_side_effects : - structure_body -> env -> side_effects definition_entry -> - exported_side_effect list * unit definition_entry - -val translate_mind : - env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) diff --git a/kernel/transparentState.ml b/kernel/transparentState.ml new file mode 100644 index 0000000000..9661dace6a --- /dev/null +++ b/kernel/transparentState.ml @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +type t = { + tr_var : Id.Pred.t; + tr_cst : Cpred.t; +} + +let empty = { + tr_var = Id.Pred.empty; + tr_cst = Cpred.empty; +} + +let full = { + tr_var = Id.Pred.full; + tr_cst = Cpred.full; +} + +let var_full = { + tr_var = Id.Pred.full; + tr_cst = Cpred.empty; +} + +let cst_full = { + tr_var = Id.Pred.empty; + tr_cst = Cpred.full; +} + +let is_empty ts = + Id.Pred.is_empty ts.tr_var && Cpred.is_empty ts.tr_cst + +let is_transparent_variable ts id = + Id.Pred.mem id ts.tr_var + +let is_transparent_constant ts cst = + Cpred.mem cst ts.tr_cst diff --git a/kernel/transparentState.mli b/kernel/transparentState.mli new file mode 100644 index 0000000000..f2999c6869 --- /dev/null +++ b/kernel/transparentState.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** Sets of names *) +type t = { + tr_var : Id.Pred.t; + tr_cst : Cpred.t; +} + +val empty : t +(** Everything opaque *) + +val full : t +(** Everything transparent *) + +val var_full : t +(** All variables transparent *) + +val cst_full : t +(** All constant transparent *) + +val is_empty : t -> bool + +val is_transparent_variable : t -> Id.t -> bool +val is_transparent_constant : t -> Constant.t -> bool diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 60293fe864..c45fe1cf00 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -33,6 +33,7 @@ type 'constr pguard_error = | RecCallInCasePred of 'constr | NotGuardedForm of 'constr | ReturnPredicateNotCoInductive of 'constr + | FixpointOnIrrelevantInductive type guard_error = constr pguard_error @@ -47,27 +48,45 @@ type ('constr, 'types) ptype_error = | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option + | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment | ActualType of ('constr, 'types) punsafe_judgment * 'types + | IncorrectPrimitive of (CPrimitives.op_or_type,'types) punsafe_judgment * 'types | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array | UnsatisfiedConstraints of Univ.Constraint.t | UndeclaredUniverse of Univ.Level.t + | DisallowedSProp + | BadRelevance type type_error = (constr, types) ptype_error exception TypeError of env * type_error +type inductive_error = + | NonPos of env * constr * constr + | NotEnoughArgs of env * constr * constr + | NotConstructor of env * Id.t * constr * constr * int * int + | NonPar of env * constr * int * constr * constr + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of env * constr + | BadEntry + | LargeNonPropInductiveNotInType + | BadUnivs + +exception InductiveError of inductive_error + let nfj env {uj_val=c;uj_type=ct} = {uj_val=c;uj_type=nf_betaiota env ct} @@ -86,8 +105,8 @@ let error_assumption env j = let error_reference_variables env id c = raise (TypeError (env, ReferenceVariables (id,c))) -let error_elim_arity env ind aritylst c pj okinds = - raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) +let error_elim_arity env ind c pj okinds = + raise (TypeError (env, ElimArity (ind,c,pj,okinds))) let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) @@ -105,6 +124,9 @@ let error_generalization env nvar c = let error_actual_type env j expty = raise (TypeError (env, ActualType (j,expty))) +let error_incorrect_primitive env p t = + raise (TypeError (env, IncorrectPrimitive (p, t))) + let error_cant_apply_not_functional env rator randl = raise (TypeError (env, CantApplyNonFunctional (rator,randl))) @@ -129,3 +151,53 @@ let error_unsatisfied_constraints env c = let error_undeclared_universe env l = raise (TypeError (env, UndeclaredUniverse l)) + +let error_disallowed_sprop env = + raise (TypeError (env, DisallowedSProp)) + +let error_bad_relevance env = + raise (TypeError (env, BadRelevance)) + +let map_pguard_error f = function +| NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody +| RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) +| RecursionOnIllegalTerm (n, (env, c), l1, l2) -> RecursionOnIllegalTerm (n, (env, f c), l1, l2) +| NotEnoughArgumentsForFixCall n -> NotEnoughArgumentsForFixCall n +| CodomainNotInductiveType c -> CodomainNotInductiveType (f c) +| NestedRecursiveOccurrences -> NestedRecursiveOccurrences +| UnguardedRecursiveCall c -> UnguardedRecursiveCall (f c) +| RecCallInTypeOfAbstraction c -> RecCallInTypeOfAbstraction (f c) +| RecCallInNonRecArgOfConstructor c -> RecCallInNonRecArgOfConstructor (f c) +| RecCallInTypeOfDef c -> RecCallInTypeOfDef (f c) +| RecCallInCaseFun c -> RecCallInCaseFun (f c) +| RecCallInCaseArg c -> RecCallInCaseArg (f c) +| RecCallInCasePred c -> RecCallInCasePred (f c) +| NotGuardedForm c -> NotGuardedForm (f c) +| ReturnPredicateNotCoInductive c -> ReturnPredicateNotCoInductive (f c) +| FixpointOnIrrelevantInductive -> FixpointOnIrrelevantInductive + +let map_ptype_error f = function +| UnboundRel n -> UnboundRel n +| UnboundVar id -> UnboundVar id +| NotAType j -> NotAType (on_judgment f j) +| BadAssumption j -> BadAssumption (on_judgment f j) +| ReferenceVariables (id, c) -> ReferenceVariables (id, f c) +| ElimArity (pi, c, j, ar) -> ElimArity (pi, f c, on_judgment f j, ar) +| CaseNotInductive j -> CaseNotInductive (on_judgment f j) +| WrongCaseInfo (pi, ci) -> WrongCaseInfo (pi, ci) +| NumberBranches (j, n) -> NumberBranches (on_judgment f j, n) +| IllFormedBranch (c, pc, t1, t2) -> IllFormedBranch (f c, pc, f t1, f t2) +| Generalization ((na, t), j) -> Generalization ((na, f t), on_judgment f j) +| ActualType (j, t) -> ActualType (on_judgment f j, f t) +| IncorrectPrimitive (p, t) -> IncorrectPrimitive ({p with uj_type=f p.uj_type}, f t) +| CantApplyBadType ((n, c1, c2), j, vj) -> + CantApplyBadType ((n, f c1, f c2), on_judgment f j, Array.map (on_judgment f) vj) +| CantApplyNonFunctional (j, jv) -> CantApplyNonFunctional (on_judgment f j, Array.map (on_judgment f) jv) +| IllFormedRecBody (ge, na, n, env, jv) -> + IllFormedRecBody (map_pguard_error f ge, na, n, env, Array.map (on_judgment f) jv) +| IllTypedRecBody (n, na, jv, t) -> + IllTypedRecBody (n, na, Array.map (on_judgment f) jv, Array.map f t) +| UnsatisfiedConstraints g -> UnsatisfiedConstraints g +| UndeclaredUniverse l -> UndeclaredUniverse l +| DisallowedSProp -> DisallowedSProp +| BadRelevance -> BadRelevance diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 3fd40a7f42..88165a4f07 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -34,6 +34,7 @@ type 'constr pguard_error = | RecCallInCasePred of 'constr | NotGuardedForm of 'constr | ReturnPredicateNotCoInductive of 'constr + | FixpointOnIrrelevantInductive type guard_error = constr pguard_error @@ -48,27 +49,49 @@ type ('constr, 'types) ptype_error = | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option + | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int | IllFormedBranch of 'constr * pconstructor * 'constr * 'constr | Generalization of (Name.t * 'types) * ('constr, 'types) punsafe_judgment | ActualType of ('constr, 'types) punsafe_judgment * 'types + | IncorrectPrimitive of (CPrimitives.op_or_type,'types) punsafe_judgment * 'types | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array | UnsatisfiedConstraints of Univ.Constraint.t | UndeclaredUniverse of Univ.Level.t + | DisallowedSProp + | BadRelevance type type_error = (constr, types) ptype_error exception TypeError of env * type_error +(** The different kinds of errors that may result of a malformed inductive + definition. *) +type inductive_error = + | NonPos of env * constr * constr + | NotEnoughArgs of env * constr * constr + | NotConstructor of env * Id.t * constr * constr * int * int + | NonPar of env * constr * int * constr * constr + | SameNamesTypes of Id.t + | SameNamesConstructors of Id.t + | SameNamesOverlap of Id.t list + | NotAnArity of env * constr + | BadEntry + | LargeNonPropInductiveNotInType + | BadUnivs + +exception InductiveError of inductive_error + +(** Raising functions *) + val error_unbound_rel : env -> int -> 'a val error_unbound_var : env -> variable -> 'a @@ -80,8 +103,8 @@ val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> Id.t -> constr -> 'a val error_elim_arity : - env -> pinductive -> Sorts.family list -> constr -> unsafe_judgment -> - (Sorts.family * Sorts.family * arity_error) option -> 'a + env -> pinductive -> constr -> unsafe_judgment -> + (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -93,6 +116,8 @@ val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a +val error_incorrect_primitive : env -> (CPrimitives.op_or_type,types) punsafe_judgment -> types -> 'a + val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a @@ -101,13 +126,20 @@ val error_cant_apply_bad_type : unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : - env -> guard_error -> Name.t array -> int -> env -> unsafe_judgment array -> 'a + env -> guard_error -> Name.t Context.binder_annot array -> int -> env -> unsafe_judgment array -> 'a val error_ill_typed_rec_body : - env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a + env -> int -> Name.t Context.binder_annot array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : Sorts.family -> Sorts.family -> arity_error val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a val error_undeclared_universe : env -> Univ.Level.t -> 'a + +val error_disallowed_sprop : env -> 'a + +val error_bad_relevance : env -> 'a + +val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error +val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 7456ecea56..12ffbf4357 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -13,7 +13,9 @@ open Util open Names open Univ open Sorts +open Term open Constr +open Context open Vars open Declarations open Environ @@ -24,6 +26,8 @@ open Type_errors module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +exception NotConvertibleVect of int + let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = @@ -47,11 +51,32 @@ let check_type env c t = (* This should be a type intended to be assumed. The error message is not as useful as for [type_judgment]. *) -let check_assumption env t ty = - try let _ = check_type env t ty in t +let infer_assumption env t ty = + try + let s = check_type env t ty in + (match s with Sorts.SProp -> Irrelevant | _ -> Relevant) with TypeError _ -> error_assumption env (make_judge t ty) +let warn_bad_relevance_name = "bad-relevance" +let warn_bad_relevance = + CWarnings.create ~name:warn_bad_relevance_name ~category:"debug" ~default:CWarnings.Disabled + Pp.(function + | None -> str "Bad relevance in case annotation." + | Some x -> str "Bad relevance for binder " ++ Name.print x.binder_name ++ str ".") + +let warn_bad_relevance_ci ?loc () = warn_bad_relevance ?loc None +let warn_bad_relevance ?loc x = warn_bad_relevance ?loc (Some x) + +let check_assumption env x t ty = + let r = x.binder_relevance in + let r' = infer_assumption env t ty in + let x = if Sorts.relevance_equal r r' + then x + else (warn_bad_relevance x; {x with binder_relevance = r'}) + in + x + (************************************************) (* Incremental typing rules: builds a typing judgment given the *) (* judgments for the subterms. *) @@ -69,7 +94,7 @@ let type_of_type u = mkType uu let type_of_sort = function - | Prop | Set -> type1 + | SProp | Prop | Set -> type1 | Type u -> type_of_type u (*s Type of a de Bruijn index. *) @@ -91,7 +116,8 @@ let type_of_variable env id = (* Checks if a context of variables can be instantiated by the variables of the current env. Order does not have to be checked assuming that all names are distinct *) -let check_hyps_inclusion env f c sign = +let check_hyps_inclusion env ?evars f c sign = + let conv env a b = conv env ?evars a b in Context.Named.fold_outside (fun d1 () -> let open Context.Named.Declaration in @@ -150,33 +176,120 @@ let type_of_abstraction _env name var ty = let make_judgev c t = Array.map2 make_judge c t +let rec check_empty_stack = function +| [] -> true +| CClosure.Zupdate _ :: s -> check_empty_stack s +| _ -> false + let type_of_apply env func funt argsv argstv = + let open CClosure in let len = Array.length argsv in - let rec apply_rec i typ = - if Int.equal i len then typ - else - (match kind (whd_all env typ) with - | Prod (_,c1,c2) -> - let arg = argsv.(i) and argt = argstv.(i) in - (try - let () = conv_leq false env argt c1 in - apply_rec (i+1) (subst1 arg c2) - with NotConvertible -> - error_cant_apply_bad_type env - (i+1,c1,argt) - (make_judge func funt) - (make_judgev argsv argstv)) - + let infos = create_clos_infos all env in + let tab = create_tab () in + let rec apply_rec i typ = + if Int.equal i len then term_of_fconstr typ + else + let typ, stk = whd_stack infos tab typ [] in + (** The return stack is known to be empty *) + let () = assert (check_empty_stack stk) in + match fterm_of typ with + | FProd (_, c1, c2, e) -> + let arg = argsv.(i) in + let argt = argstv.(i) in + let c1 = term_of_fconstr c1 in + begin match conv_leq false env argt c1 with + | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons ([| inject arg |], e)) c2) + | exception NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv) + end | _ -> - error_cant_apply_not_functional env - (make_judge func funt) - (make_judgev argsv argstv)) - in apply_rec 0 funt + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv) + in + apply_rec 0 (inject funt) + +(* Type of primitive constructs *) +let type_of_prim_type _env = function + | CPrimitives.PT_int63 -> Constr.mkSet + +let type_of_int env = + match env.retroknowledge.Retroknowledge.retro_int63 with + | Some c -> mkConst c + | None -> CErrors.user_err Pp.(str"The type int must be registered before this construction can be typechecked.") + +let type_of_prim env t = + let int_ty = type_of_int env in + let bool_ty () = + match env.retroknowledge.Retroknowledge.retro_bool with + | Some ((ind,_),_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type bool must be registered before this primitive.") + in + let compare_ty () = + match env.retroknowledge.Retroknowledge.retro_cmp with + | Some ((ind,_),_,_) -> Constr.mkInd ind + | None -> CErrors.user_err Pp.(str"The type compare must be registered before this primitive.") + in + let pair_ty fst_ty snd_ty = + match env.retroknowledge.Retroknowledge.retro_pair with + | Some (ind,_) -> Constr.mkApp(Constr.mkInd ind, [|fst_ty;snd_ty|]) + | None -> CErrors.user_err Pp.(str"The type pair must be registered before this primitive.") + in + let carry_ty int_ty = + match env.retroknowledge.Retroknowledge.retro_carry with + | Some ((ind,_),_) -> Constr.mkApp(Constr.mkInd ind, [|int_ty|]) + | None -> CErrors.user_err Pp.(str"The type carry must be registered before this primitive.") + in + let rec nary_int63_op arity ty = + if Int.equal arity 0 then ty + else Constr.mkProd(Context.nameR (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) + in + let return_ty = + let open CPrimitives in + match t with + | Int63head0 + | Int63tail0 + | Int63add + | Int63sub + | Int63mul + | Int63div + | Int63mod + | Int63lsr + | Int63lsl + | Int63land + | Int63lor + | Int63lxor + | Int63addMulDiv -> int_ty + | Int63eq + | Int63lt + | Int63le -> bool_ty () + | Int63mulc + | Int63div21 + | Int63diveucl -> pair_ty int_ty int_ty + | Int63addc + | Int63subc + | Int63addCarryC + | Int63subCarryC -> carry_ty int_ty + | Int63compare -> compare_ty () + in + nary_int63_op (CPrimitives.arity t) return_ty + +let type_of_prim_or_type env = let open CPrimitives in + function + | OT_type t -> type_of_prim_type env t + | OT_op op -> type_of_prim env op + +let judge_of_int env i = + make_judge (Constr.mkInt i) (type_of_int env) (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with + | (_, SProp) | (SProp, _) -> rangsort (* Product rule (s,Prop,Prop) *) | (_, Prop) -> rangsort (* Product rule (Prop/Set,Set,Set) *) @@ -188,13 +301,13 @@ let sort_of_product env domsort rangsort = rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (Universe.sup Universe.type0 u1) + Sorts.sort_of_univ (Universe.sup Universe.type0 u1) (* Product rule (Prop,Type_i,Type_i) *) - | (Set, Type u2) -> Type (Universe.sup Universe.type0 u2) + | (Set, Type u2) -> Sorts.sort_of_univ (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (Universe.sup u1 u2) + | (Type u1, Type u2) -> Sorts.sort_of_univ (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -289,11 +402,17 @@ let type_of_case env ci p pt c ct _lf lft = let (pind, _ as indspec) = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - let () = check_case_info env pind ci in + let _, sp = try dest_arity env pt + with NotArity -> error_elim_arity env pind c (make_judge p pt) None in + let rp = Sorts.relevance_of_sort sp in + let ci = if ci.ci_relevance == rp then ci + else (warn_bad_relevance_ci (); {ci with ci_relevance=rp}) + in + let () = check_case_info env pind rp ci in let (bty,rslty) = type_case_branches env indspec (make_judge p pt) c in let () = check_branch_types env pind c ct lft bty in - rslty + ci, rslty let type_of_projection env p c ct = let pty = lookup_projection p env in @@ -319,9 +438,62 @@ let check_fixpoint env lna lar vdef vdeft = with NotConvertibleVect i -> error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar +(* Global references *) + +let type_of_global_in_context env r = + let open Names.GlobRef in + match r with + | VarRef id -> Environ.named_type id env, Univ.AUContext.empty + | ConstRef c -> + let cb = Environ.lookup_constant c env in + let univs = Declareops.constant_polymorphic_context cb in + cb.Declarations.const_type, univs + | IndRef ind -> + let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in + let univs = Declareops.inductive_polymorphic_context mib in + let inst = Univ.make_abstract_instance univs in + let env = Environ.push_context ~strict:false (Univ.AUContext.repr univs) env in + Inductive.type_of_inductive env (specif, inst), univs + | ConstructRef cstr -> + let (mib,_ as specif) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) + in + let univs = Declareops.inductive_polymorphic_context mib in + let inst = Univ.make_abstract_instance univs in + Inductive.type_of_constructor (cstr,inst) specif, univs + +(* Build a fresh instance for a given context, its associated substitution and + the instantiated constraints. *) + +let constr_of_global_in_context env r = + let open GlobRef in + match r with + | VarRef id -> mkVar id, Univ.AUContext.empty + | ConstRef c -> + let cb = lookup_constant c env in + let univs = Declareops.constant_polymorphic_context cb in + mkConstU (c, Univ.make_abstract_instance univs), univs + | IndRef ind -> + let (mib,_) = Inductive.lookup_mind_specif env ind in + let univs = Declareops.inductive_polymorphic_context mib in + mkIndU (ind, Univ.make_abstract_instance univs), univs + | ConstructRef cstr -> + let (mib,_) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) + in + let univs = Declareops.inductive_polymorphic_context mib in + mkConstructU (cstr, Univ.make_abstract_instance univs), univs + (************************************************************************) (************************************************************************) +let check_binder_annot s x = + let r = x.binder_relevance in + let r' = Sorts.relevance_of_sort s in + if r' == r + then x + else (warn_bad_relevance x; {x with binder_relevance = r'}) + (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions @@ -330,85 +502,110 @@ let rec execute env cstr = let open Context.Rel.Declaration in match kind cstr with (* Atomic terms *) - | Sort s -> type_of_sort s + | Sort s -> + (match s with + | SProp -> if not (Environ.sprop_allowed env) then error_disallowed_sprop env + | _ -> ()); + cstr, type_of_sort s | Rel n -> - type_of_relative env n + cstr, type_of_relative env n | Var id -> - type_of_variable env id + cstr, type_of_variable env id | Const c -> - type_of_constant env c + cstr, type_of_constant env c | Proj (p, c) -> - let ct = execute env c in - type_of_projection env p c ct + let c', ct = execute env c in + let cstr = if c == c' then cstr else mkProj (p,c') in + cstr, type_of_projection env p c' ct (* Lambda calculus operators *) | App (f,args) -> - let argst = execute_array env args in - let ft = + let args', argst = execute_array env args in + let f', ft = match kind f with | Ind ind when Environ.template_polymorphic_pind ind env -> let args = Array.map (fun t -> lazy t) argst in - type_of_inductive_knowing_parameters env ind args + f, type_of_inductive_knowing_parameters env ind args | _ -> (* No template polymorphism *) execute env f in - - type_of_apply env f ft args argst + let cstr = if f == f' && args == args' then cstr else mkApp (f',args') in + cstr, type_of_apply env f' ft args' argst | Lambda (name,c1,c2) -> - let _ = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let c2t = execute env1 c2 in - type_of_abstraction env name c1 c2t + let c1', s = execute_is_type env c1 in + let name' = check_binder_annot s name in + let env1 = push_rel (LocalAssum (name',c1')) env in + let c2', c2t = execute env1 c2 in + let cstr = if name == name' && c1 == c1' && c2 == c2' then cstr else mkLambda(name',c1',c2') in + cstr, type_of_abstraction env name' c1 c2t | Prod (name,c1,c2) -> - let vars = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let vars' = execute_is_type env1 c2 in - type_of_product env name vars vars' + let c1', vars = execute_is_type env c1 in + let name' = check_binder_annot vars name in + let env1 = push_rel (LocalAssum (name',c1')) env in + let c2', vars' = execute_is_type env1 c2 in + let cstr = if name == name' && c1 == c1' && c2 == c2' then cstr else mkProd(name',c1',c2') in + cstr, type_of_product env name' vars vars' | LetIn (name,c1,c2,c3) -> - let c1t = execute env c1 in - let _c2s = execute_is_type env c2 in - let () = check_cast env c1 c1t DEFAULTcast c2 in - let env1 = push_rel (LocalDef (name,c1,c2)) env in - let c3t = execute env1 c3 in - subst1 c1 c3t + let c1', c1t = execute env c1 in + let c2', c2s = execute_is_type env c2 in + let name' = check_binder_annot c2s name in + let () = check_cast env c1' c1t DEFAULTcast c2' in + let env1 = push_rel (LocalDef (name',c1',c2')) env in + let c3', c3t = execute env1 c3 in + let cstr = if name == name' && c1 == c1' && c2 == c2' && c3 == c3' then cstr + else mkLetIn(name',c1',c2',c3') + in + cstr, subst1 c1 c3t | Cast (c,k,t) -> - let ct = execute env c in - let _ts = (check_type env t (execute env t)) in - let () = check_cast env c ct k t in - t + let c', ct = execute env c in + let t', _ts = execute_is_type env t in + let () = check_cast env c' ct k t' in + let cstr = if c == c' && t == t' then cstr else mkCast(c',k,t') in + cstr, t' (* Inductive types *) | Ind ind -> - type_of_inductive env ind + cstr, type_of_inductive env ind | Construct c -> - type_of_constructor env c + cstr, type_of_constructor env c | Case (ci,p,c,lf) -> - let ct = execute env c in - let pt = execute env p in - let lft = execute_array env lf in - type_of_case env ci p pt c ct lf lft - - | Fix ((_vn,i as vni),recdef) -> + let c', ct = execute env c in + let p', pt = execute env p in + let lf', lft = execute_array env lf in + let ci', t = type_of_case env ci p' pt c' ct lf' lft in + let cstr = if ci == ci' && c == c' && p == p' && lf == lf' then cstr + else mkCase(ci',p',c',lf') + in + cstr, t + + | Fix ((_vn,i as vni),recdef as fix) -> let (fix_ty,recdef') = execute_recdef env recdef i in - let fix = (vni,recdef') in - check_fix env fix; fix_ty + let cstr, fix = if recdef == recdef' then cstr, fix else + let fix = (vni,recdef') in mkFix fix, fix + in + check_fix env fix; cstr, fix_ty - | CoFix (i,recdef) -> + | CoFix (i,recdef as cofix) -> let (fix_ty,recdef') = execute_recdef env recdef i in - let cofix = (i,recdef') in - check_cofix env cofix; fix_ty - + let cstr, cofix = if recdef == recdef' then cstr, cofix else + let cofix = (i,recdef') in mkCoFix cofix, cofix + in + check_cofix env cofix; cstr, fix_ty + + (* Primitive types *) + | Int _ -> cstr, type_of_int env + (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables.") @@ -417,44 +614,35 @@ let rec execute env cstr = anomaly (Pp.str "the kernel does not support existential variables.") and execute_is_type env constr = - let t = execute env constr in - check_type env constr t - -and execute_recdef env (names,lar,vdef) i = - let lart = execute_array env lar in - let lara = Array.map2 (check_assumption env) lar lart in - let env1 = push_rec_types (names,lara,vdef) env in - let vdeft = execute_array env1 vdef in - let () = check_fixpoint env1 names lara vdef vdeft in - (lara.(i),(names,lara,vdef)) - -and execute_array env = Array.map (execute env) + let c, t = execute env constr in + c, check_type env constr t + +and execute_recdef env (names,lar,vdef as recdef) i = + let lar', lart = execute_array env lar in + let names' = Array.Smart.map_i (fun i na -> check_assumption env na lar'.(i) lart.(i)) names in + let env1 = push_rec_types (names',lar',vdef) env in (* vdef is ignored *) + let vdef', vdeft = execute_array env1 vdef in + let () = check_fixpoint env1 names' lar' vdef' vdeft in + let recdef = if names == names' && lar == lar' && vdef == vdef' then recdef else (names',lar',vdef') in + (lar'.(i),recdef) + +and execute_array env cs = + let tys = Array.make (Array.length cs) mkProp in + let cs = Array.Smart.map_i (fun i c -> let c, ty = execute env c in tys.(i) <- ty; c) cs in + cs, tys (* Derived functions *) -let universe_levels_of_constr _env c = - let rec aux s c = - match kind c with - | Const (_c, u) -> - LSet.fold LSet.add (Instance.levels u) s - | Ind ((_mind,_), u) | Construct (((_mind,_),_), u) -> - LSet.fold LSet.add (Instance.levels u) s - | Sort u when not (Sorts.is_small u) -> - let u = Sorts.univ_of_sort u in - LSet.fold LSet.add (Universe.levels u) s - | _ -> Constr.fold aux s c - in aux LSet.empty c - let check_wellformed_universes env c = - let univs = universe_levels_of_constr env c in + let univs = universes_of_constr c in try UGraph.check_declared_universes (universes env) univs with UGraph.UndeclaredLevel u -> error_undeclared_universe env u let infer env constr = let () = check_wellformed_universes env constr in - let t = execute env constr in - make_judge constr t + let constr, t = execute env constr in + make_judge constr t let infer = if Flags.profile then @@ -463,7 +651,7 @@ let infer = else (fun b c -> infer b c) let assumption_of_judgment env {uj_val=c; uj_type=t} = - check_assumption env c t + infer_assumption env c t let type_judgment env {uj_val=c; uj_type=t} = let s = check_type env c t in @@ -471,36 +659,27 @@ let type_judgment env {uj_val=c; uj_type=t} = let infer_type env constr = let () = check_wellformed_universes env constr in - let t = execute env constr in + let constr, t = execute env constr in let s = check_type env constr t in {utj_val = constr; utj_type = s} -let infer_v env cv = - let () = Array.iter (check_wellformed_universes env) cv in - let jv = execute_array env cv in - make_judgev cv jv - (* Typing of several terms. *) -let infer_local_decl env id = function - | Entries.LocalDefEntry c -> - let () = check_wellformed_universes env c in - let t = execute env c in - RelDecl.LocalDef (Name id, c, t) - | Entries.LocalAssumEntry c -> - let () = check_wellformed_universes env c in - let t = execute env c in - RelDecl.LocalAssum (Name id, check_assumption env c t) - -let infer_local_decls env decls = - let rec inferec env = function - | (id, d) :: l -> - let (env, l) = inferec env l in - let d = infer_local_decl env id d in - (push_rel d env, Context.Rel.add d l) - | [] -> (env, Context.Rel.empty) - in - inferec env decls +let check_context env rels = + let open Context.Rel.Declaration in + Context.Rel.fold_outside (fun d (env,rels) -> + match d with + | LocalAssum (x,ty) -> + let jty = infer_type env ty in + let x = check_binder_annot jty.utj_type x in + push_rel d env, LocalAssum (x,jty.utj_val) :: rels + | LocalDef (x,bd,ty) -> + let j1 = infer env bd in + let jty = infer_type env ty in + conv_leq false env j1.uj_type ty; + let x = check_binder_annot jty.utj_type x in + push_rel d env, LocalDef (x,j1.uj_val,jty.utj_val) :: rels) + rels ~init:(env,[]) let judge_of_prop = make_judge mkProp type1 let judge_of_set = make_judge mkSet type1 @@ -522,17 +701,17 @@ let judge_of_apply env funj argjv = let args, argtys = dest_judgev argjv in make_judge (mkApp (funj.uj_val, args)) (type_of_apply env funj.uj_val funj.uj_type args argtys) -let judge_of_abstraction env x varj bodyj = - make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) - (type_of_abstraction env x varj.utj_val bodyj.uj_type) +(* let judge_of_abstraction env x varj bodyj = *) +(* make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) *) +(* (type_of_abstraction env x varj.utj_val bodyj.uj_type) *) -let judge_of_product env x varj outj = - make_judge (mkProd (x, varj.utj_val, outj.utj_val)) - (mkSort (sort_of_product env varj.utj_type outj.utj_type)) +(* let judge_of_product env x varj outj = *) +(* make_judge (mkProd (x, varj.utj_val, outj.utj_val)) *) +(* (mkSort (sort_of_product env varj.utj_type outj.utj_type)) *) -let judge_of_letin _env name defj typj j = - make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) - (subst1 defj.uj_val j.uj_type) +(* let judge_of_letin env name defj typj j = *) +(* make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) *) +(* (subst1 defj.uj_val j.uj_type) *) let judge_of_cast env cj k tj = let () = check_cast env cj.uj_val cj.uj_type k tj.utj_val in @@ -547,5 +726,12 @@ let judge_of_constructor env cu = let judge_of_case env ci pj cj lfj = let lf, lft = dest_judgev lfj in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) - (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft) + let ci, t = type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft in + make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) t + +(* Building type of primitive operators and type *) + +let check_primitive_type env op_t t = + let inft = type_of_prim_or_type env op_t in + try default_conv ~l2r:false CUMUL env inft t + with NotConvertible -> error_incorrect_primitive env (make_judge op_t inft) t diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 57acdfe4b5..cc1885f42d 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -12,32 +12,33 @@ open Names open Constr open Univ open Environ -open Entries (** {6 Typing functions (not yet tagged as safe) } They return unsafe judgments that are "in context" of a set of - (local) universe variables (the ones that appear in the term) - and associated constraints. In case of polymorphic definitions, - these variables and constraints will be generalized. - *) + (local) universe variables (the ones that appear in the term) and + associated constraints. In case of polymorphic definitions, these + variables and constraints will be generalized. + When typechecking a term it may be updated to fix relevance marks. + Do not discard the result. *) val infer : env -> constr -> unsafe_judgment -val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment -val infer_local_decls : - env -> (Id.t * local_entry) list -> (env * Constr.rel_context) +val check_context : + env -> Constr.rel_context -> env * Constr.rel_context (** {6 Basic operations of the typing machine. } *) (** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j] returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *) -val assumption_of_judgment : env -> unsafe_judgment -> types +val assumption_of_judgment : env -> unsafe_judgment -> Sorts.relevance val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment +val check_binder_annot : Sorts.t -> Name.t Context.binder_annot -> Name.t Context.binder_annot + (** {6 Type of sorts. } *) val type1 : types val type_of_sort : Sorts.t -> types @@ -54,11 +55,10 @@ val type_of_variable : env -> variable -> types val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) - +val type_of_constant_in : env -> pconstant -> types val judge_of_constant : env -> pconstant -> unsafe_judgment (** {6 type of an applied projection } *) - val judge_of_projection : env -> Projection.t -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) @@ -67,21 +67,21 @@ val judge_of_apply : -> unsafe_judgment (** {6 Type of an abstraction. } *) -val judge_of_abstraction : - env -> Name.t -> unsafe_type_judgment -> unsafe_judgment - -> unsafe_judgment +(* val judge_of_abstraction : *) +(* env -> Name.t -> unsafe_type_judgment -> unsafe_judgment *) +(* -> unsafe_judgment *) (** {6 Type of a product. } *) val sort_of_product : env -> Sorts.t -> Sorts.t -> Sorts.t -val type_of_product : env -> Name.t -> Sorts.t -> Sorts.t -> types -val judge_of_product : - env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment - -> unsafe_judgment +val type_of_product : env -> Name.t Context.binder_annot -> Sorts.t -> Sorts.t -> types +(* val judge_of_product : *) +(* env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment *) +(* -> unsafe_judgment *) (** s Type of a let in. *) -val judge_of_letin : - env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment - -> unsafe_judgment +(* val judge_of_letin : *) +(* env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment *) +(* -> unsafe_judgment *) (** {6 Type of a cast. } *) val judge_of_cast : @@ -89,9 +89,7 @@ val judge_of_cast : unsafe_judgment (** {6 Inductive types. } *) - val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment - val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) @@ -99,7 +97,39 @@ val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment -val type_of_constant_in : env -> pconstant -> types +(** {6 Type of global references. } *) + +val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t +(** Returns the type of the global reference, by creating a fresh + instance of polymorphic references and computing their + instantiated universe context. The type should not be used + without pushing it's universe context in the environmnent of + usage. For non-universe-polymorphic constants, it does not + matter. *) + +(** {6 Building a term from a global reference *) + +(** Map a global reference to a term in its local universe + context. The term should not be used without pushing it's universe + context in the environmnent of usage. For non-universe-polymorphic + constants, it does not matter. *) +val constr_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t + +(** {6 Miscellaneous. } *) (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Constr.named_context -> unit +val check_hyps_inclusion : env -> ?evars:((existential->constr option) * UGraph.t) -> + ('a -> constr) -> 'a -> Constr.named_context -> unit + +val check_primitive_type : env -> CPrimitives.op_or_type -> types -> unit + +(** Types for primitives *) + +val type_of_int : env -> types +val judge_of_int : env -> Uint63.t -> unsafe_judgment + +val type_of_prim_type : env -> CPrimitives.prim_type -> types +val type_of_prim : env -> CPrimitives.t -> types + +val warn_bad_relevance_name : string +(** Allow the checker to make this warning into an error. *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 9ff51fca55..0d5b55ca1b 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -8,749 +8,105 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Pp -open Util open Univ -(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *) -(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *) -(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *) -(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) -(* Support for universe polymorphism by MS [2014] *) +module G = AcyclicGraph.Make(struct + type t = Level.t + module Set = LSet + module Map = LMap + module Constraint = Constraint -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu - Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) + let equal = Level.equal + let compare = Level.compare -let error_inconsistency o u v p = - raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) + type explanation = Univ.explanation + let error_inconsistency d u v p = + raise (UniverseInconsistency (d,Universe.make u, Universe.make v, p)) -(* 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 $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + let pr = Level.pr + end) [@@inlined] (* without inline, +1% ish on HoTT, compcert. See jenkins 594 vs 596 *) +(* Do not include G to make it easier to control universe specific + code (eg add_universe with a constraint vs G.add with no + constraint) *) - At every moment, we have a finite number of universes, and we - maintain the ordering in the presence of assertions $U<V$ and $U\le V$. +type t = { graph: G.t; sprop_cumulative : bool } +type 'a check_function = t -> 'a -> 'a -> bool - The equivalence $\~{}$ is represented by a tree structure, as in the - union-find algorithm. The assertions $<$ and $\le$ are represented by - adjacency lists. +let g_map f g = + let g' = f g.graph in + if g.graph == g' then g + else {g with graph=g'} - We use the algorithm described in the paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - *) - -open Universe - -module UMap = LMap - -type status = NoMark | Visited | WeakVisited | ToMerge - -(* Comparison on this type is pointer equality *) -type canonical_node = - { univ: Level.t; - ltle: bool UMap.t; (* true: strict (lt) constraint. - false: weak (le) constraint. *) - gtge: LSet.t; - rank : int; - klvl: int; - ilvl: int; - mutable status: status - } - -let big_rank = 1000000 - -(* A Level.t is either an alias for another one, or a canonical one, - for which we know the universes that are above *) - -type univ_entry = - Canonical of canonical_node - | Equiv of Level.t - -type universes = - { entries : univ_entry UMap.t; - index : int; - n_nodes : int; n_edges : int } - -type t = universes - -(** Used to cleanup universes if a traversal function is interrupted before it - has the opportunity to do it itself. *) -let unsafe_cleanup_universes g = - let iter _ n = match n with - | Equiv _ -> () - | Canonical n -> n.status <- NoMark - in - UMap.iter iter g.entries - -let rec cleanup_universes g = - try unsafe_cleanup_universes g - with e -> - (** The only way unsafe_cleanup_universes may raise an exception is when - a serious error (stack overflow, out of memory) occurs, or a signal is - sent. In this unlikely event, we relaunch the cleanup until we finally - succeed. *) - cleanup_universes g; raise e - -(* Every Level.t has a unique canonical arc representative *) - -(* Low-level function : makes u an alias for v. - Does not removes edges from n_edges, but decrements n_nodes. - u should be entered as canonical before. *) -let enter_equiv g u v = - { entries = - UMap.modify u (fun _ a -> - match a with - | Canonical n -> - n.status <- NoMark; - Equiv v - | _ -> assert false) g.entries; - index = g.index; - n_nodes = g.n_nodes - 1; - n_edges = g.n_edges } - -(* Low-level function : changes data associated with a canonical node. - Resets the mutable fields in the old record, in order to avoid breaking - invariants for other users of this record. - n.univ should already been inserted as a canonical node. *) -let change_node g n = - { g with entries = - UMap.modify n.univ - (fun _ a -> - match a with - | Canonical n' -> - n'.status <- NoMark; - Canonical n - | _ -> assert false) - g.entries } - -(* repr : universes -> Level.t -> canonical_node *) -(* canonical representative : we follow the Equiv links *) -let rec repr g u = - let a = - try UMap.find u g.entries - with Not_found -> CErrors.anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined.") - in - match a with - | Equiv v -> repr g v - | Canonical arc -> arc - -let get_set_arc g = repr g Level.set -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ - -exception AlreadyDeclared - -(* Reindexes the given universe, using the next available index. *) -let use_index g u = - let u = repr g u in - let g = change_node g { u with ilvl = g.index } in - assert (g.index > min_int); - { g with index = g.index - 1 } - -(* [safe_repr] is like [repr] but if the graph doesn't contain the - searched universe, we add it. *) -let safe_repr g u = - let rec safe_repr_rec entries u = - match UMap.find u entries with - | Equiv v -> safe_repr_rec entries v - | Canonical arc -> arc - in - try g, safe_repr_rec g.entries u - with Not_found -> - let can = - { univ = u; - ltle = UMap.empty; gtge = LSet.empty; - rank = if Level.is_small u then big_rank else 0; - klvl = 0; ilvl = 0; - status = NoMark } - in - let g = { g with - entries = UMap.add u (Canonical can) g.entries; - n_nodes = g.n_nodes + 1 } - in - let g = use_index g u in - g, repr g u - -(* Returns 1 if u is higher than v in topological order. - -1 lower - 0 if u = v *) -let topo_compare u v = - if u.klvl > v.klvl then 1 - else if u.klvl < v.klvl then -1 - else if u.ilvl > v.ilvl then 1 - else if u.ilvl < v.ilvl then -1 - else (assert (u==v); 0) - -(* Checks most of the invariants of the graph. For debugging purposes. *) -let check_universes_invariants g = - let n_edges = ref 0 in - let n_nodes = ref 0 in - UMap.iter (fun l u -> - match u with - | Canonical u -> - UMap.iter (fun v _strict -> - incr n_edges; - let v = repr g v in - assert (topo_compare u v = -1); - if u.klvl = v.klvl then - assert (LSet.mem u.univ v.gtge || - LSet.exists (fun l -> u == repr g l) v.gtge)) - u.ltle; - LSet.iter (fun v -> - let v = repr g v in - assert (v.klvl = u.klvl && - (UMap.mem u.univ v.ltle || - UMap.exists (fun l _ -> u == repr g l) v.ltle)) - ) u.gtge; - assert (u.status = NoMark); - assert (Level.equal l u.univ); - assert (u.ilvl > g.index); - assert (not (UMap.mem u.univ u.ltle)); - incr n_nodes - | Equiv _ -> assert (not (Level.is_small l))) - g.entries; - assert (!n_edges = g.n_edges); - assert (!n_nodes = g.n_nodes) - -let clean_ltle g ltle = - UMap.fold (fun u strict acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else ( - let acc = UMap.remove u (fst acc) in - if not strict && UMap.mem uu acc then (acc, true) - else (UMap.add uu strict acc, true))) - ltle (ltle, false) - -let clean_gtge g gtge = - LSet.fold (fun u acc -> - let uu = (repr g u).univ in - if Level.equal uu u then acc - else LSet.add uu (LSet.remove u (fst acc)), true) - gtge (gtge, false) - -(* [get_ltle] and [get_gtge] return ltle and gtge arcs. - Moreover, if one of these lists is dirty (e.g. points to a - non-canonical node), these functions clean this node in the - graph by removing some duplicate edges *) -let get_ltle g u = - let ltle, chgt_ltle = clean_ltle g u.ltle in - if not chgt_ltle then u.ltle, u, g - else - let sz = UMap.cardinal u.ltle in - let sz2 = UMap.cardinal ltle in - let u = { u with ltle } in - let g = change_node g u in - let g = { g with n_edges = g.n_edges + sz2 - sz } in - u.ltle, u, g - -let get_gtge g u = - let gtge, chgt_gtge = clean_gtge g u.gtge in - if not chgt_gtge then u.gtge, u, g - else - let u = { u with gtge } in - let g = change_node g u in - u.gtge, u, g - -(* [revert_graph] rollbacks the changes made to mutable fields in - nodes in the graph. - [to_revert] contains the touched nodes. *) -let revert_graph to_revert g = - List.iter (fun t -> - match UMap.find t g.entries with - | Equiv _ -> () - | Canonical t -> - t.status <- NoMark) to_revert - -exception AbortBackward of universes -exception CycleDetected - -(* Implementation of the algorithm described in § 5.1 of the following paper: - - Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A - new approach to incremental cycle detection and related - problems. arXiv preprint arXiv:1112.0784. - - The "STEP X" comments contained in this file refers to the - corresponding step numbers of the algorithm described in Section - 5.1 of this paper. *) - -(* [delta] is the timeout for backward search. It might be - useful to tune a multiplicative constant. *) -let get_delta g = - int_of_float - (min (float_of_int g.n_edges ** 0.5) - (float_of_int g.n_nodes ** (2./.3.))) - -let rec backward_traverse to_revert b_traversed count g x = - let x = repr g x in - let count = count - 1 in - if count < 0 then begin - revert_graph to_revert g; - raise (AbortBackward g) - end; - if x.status = NoMark then begin - x.status <- Visited; - let to_revert = x.univ::to_revert in - let gtge, x, g = get_gtge g x in - let to_revert, b_traversed, count, g = - LSet.fold (fun y (to_revert, b_traversed, count, g) -> - backward_traverse to_revert b_traversed count g y) - gtge (to_revert, b_traversed, count, g) - in - to_revert, x.univ::b_traversed, count, g - end - else to_revert, b_traversed, count, g - -let rec forward_traverse f_traversed g v_klvl x y = - let y = repr g y in - if y.klvl < v_klvl then begin - let y = { y with klvl = v_klvl; - gtge = if x == y then LSet.empty - else LSet.singleton x.univ } - in - let g = change_node g y in - let ltle, y, g = get_ltle g y in - let f_traversed, g = - UMap.fold (fun z _ (f_traversed, g) -> - forward_traverse f_traversed g v_klvl y z) - ltle (f_traversed, g) - in - y.univ::f_traversed, g - end else if y.klvl = v_klvl && x != y then - let g = change_node g - { y with gtge = LSet.add x.univ y.gtge } in - f_traversed, g - else f_traversed, g - -let rec find_to_merge to_revert g x v = - let x = repr g x in - match x.status with - | Visited -> false, to_revert | ToMerge -> true, to_revert - | NoMark -> - let to_revert = x::to_revert in - if Level.equal x.univ v then - begin x.status <- ToMerge; true, to_revert end - else - begin - let merge, to_revert = LSet.fold - (fun y (merge, to_revert) -> - let merge', to_revert = find_to_merge to_revert g y v in - merge' || merge, to_revert) x.gtge (false, to_revert) - in - x.status <- if merge then ToMerge else Visited; - merge, to_revert - end - | _ -> assert false - -let get_new_edges g to_merge = - (* Computing edge sets. *) - let to_merge_lvl = - List.fold_left (fun acc u -> UMap.add u.univ u acc) - UMap.empty to_merge - in - let ltle = - let fold _ n acc = - let fold u strict acc = - if strict then UMap.add u strict acc - else if UMap.mem u acc then acc - else UMap.add u false acc - in - UMap.fold fold n.ltle acc - in - UMap.fold fold to_merge_lvl UMap.empty - in - let ltle, _ = clean_ltle g ltle in - let ltle = - UMap.merge (fun _ a strict -> - match a, strict with - | Some _, Some true -> - (* There is a lt edge inside the new component. This is a - "bad cycle". *) - raise CycleDetected - | Some _, Some false -> None - | _, _ -> strict - ) to_merge_lvl ltle - in - let gtge = - UMap.fold (fun _ n acc -> LSet.union acc n.gtge) - to_merge_lvl LSet.empty - in - let gtge, _ = clean_gtge g gtge in - let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in - (ltle, gtge) - - -let reorder g u v = - (* STEP 2: backward search in the k-level of u. *) - let delta = get_delta g in - - (* [v_klvl] is the chosen future level for u, v and all - traversed nodes. *) - let b_traversed, v_klvl, g = - try - let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in - revert_graph to_revert g; - let v_klvl = (repr g u).klvl in - b_traversed, v_klvl, g - with AbortBackward g -> - (* Backward search was too long, use the next k-level. *) - let v_klvl = (repr g u).klvl + 1 in - [], v_klvl, g - in - let f_traversed, g = - (* STEP 3: forward search. Contrary to what is described in - the paper, we do not test whether v_klvl = u.klvl nor we assign - v_klvl to v.klvl. Indeed, the first call to forward_traverse - will do all that. *) - forward_traverse [] g v_klvl (repr g v) v - in - - (* STEP 4: merge nodes if needed. *) - let to_merge, b_reindex, f_reindex = - if (repr g u).klvl = v_klvl then - begin - let merge, to_revert = find_to_merge [] g u v in - let r = - if merge then - List.filter (fun u -> u.status = ToMerge) to_revert, - List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, - List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed - else [], b_traversed, f_traversed - in - List.iter (fun u -> u.status <- NoMark) to_revert; - r - end - else [], b_traversed, f_traversed - in - let to_reindex, g = - match to_merge with - | [] -> List.rev_append f_reindex b_reindex, g - | n0::q0 -> - (* Computing new root. *) - let root, rank_rest = - List.fold_left (fun ((best, _rank_rest) as acc) n -> - if n.rank >= best.rank then n, best.rank else acc) - (n0, min_int) q0 - in - let ltle, gtge = get_new_edges g to_merge in - (* Inserting the new root. *) - let g = change_node g - { root with ltle; gtge; - rank = max root.rank (rank_rest + 1); } - in - - (* Inserting shortcuts for old nodes. *) - let g = List.fold_left (fun g n -> - if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) - g to_merge - in - - (* Updating g.n_edges *) - let oldsz = - List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) - 0 to_merge - in - let sz = UMap.cardinal ltle in - let g = { g with n_edges = g.n_edges + sz - oldsz } in - - (* Not clear in the paper: we have to put the newly - created component just between B and F. *) - List.rev_append f_reindex (root.univ::b_reindex), g - - in - - (* STEP 5: reindex traversed nodes. *) - List.fold_left use_index g to_reindex - -(* Assumes [u] and [v] are already in the graph. *) -(* Does NOT assume that ucan != vcan. *) -let insert_edge strict ucan vcan g = - try - let u = ucan.univ and v = vcan.univ in - (* STEP 1: do we need to reorder nodes ? *) - let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in - - (* STEP 6: insert the new edge in the graph. *) - let u = repr g u in - let v = repr g v in - if u == v then - if strict then raise CycleDetected else g - else - let g = - try let oldstrict = UMap.find v.univ u.ltle in - if strict && not oldstrict then - change_node g { u with ltle = UMap.add v.univ true u.ltle } - else g - with Not_found -> - { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) - with n_edges = g.n_edges + 1 } - in - if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g - else - let v = { v with gtge = LSet.add u.univ v.gtge } in - change_node g v - with - | CycleDetected as e -> raise e - | e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -let add_universe_gen vlev g = - try - let _arcv = UMap.find vlev g.entries in - raise AlreadyDeclared - with Not_found -> - assert (g.index > min_int); - let v = { - univ = vlev; - ltle = LMap.empty; - gtge = LSet.empty; - rank = 0; - klvl = 0; - ilvl = g.index; - status = NoMark; - } - in - let entries = UMap.add vlev (Canonical v) g.entries in - { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v - -let add_universe vlev strict g = - let g, v = add_universe_gen vlev g in - insert_edge strict (get_set_arc g) v g - -let add_universe_unconstrained vlev g = - fst (add_universe_gen vlev g) - -exception UndeclaredLevel of Univ.Level.t -let check_declared_universes g us = - let check l = if not (UMap.mem l g.entries) then raise (UndeclaredLevel l) in - Univ.LSet.iter check us - -exception Found_explanation of explanation - -let get_explanation strict u v g = - let v = repr g v in - let visited_strict = ref UMap.empty in - let rec traverse strict u = - if u == v then - if strict then None else Some [] - else if topo_compare u v = 1 then None - else - let visited = - try not (UMap.find u.univ !visited_strict) || strict - with Not_found -> false - in - if visited then None - else begin - visited_strict := UMap.add u.univ strict !visited_strict; - try - UMap.iter (fun u' strictu' -> - match traverse (strict && not strictu') (repr g u') with - | None -> () - | Some exp -> - let typ = if strictu' then Lt else Le in - raise (Found_explanation ((typ, make u') :: exp))) - u.ltle; - None - with Found_explanation exp -> Some exp - end - in - let u = repr g u in - if u == v then [(Eq, make v.univ)] - else match traverse strict u with Some exp -> exp | None -> assert false - -let get_explanation strict u v g = - Some (lazy (get_explanation strict u v g)) - -(* To compare two nodes, we simply do a forward search. - We implement two improvements: - - we ignore nodes that are higher than the destination; - - we do a BFS rather than a DFS because we expect to have a short - path (typically, the shortest path has length 1) -*) -exception Found of canonical_node list -let search_path strict u v g = - let rec loop to_revert todo next_todo = - match todo, next_todo with - | [], [] -> to_revert (* No path found *) - | [], _ -> loop to_revert next_todo [] - | (u, strict)::todo, _ -> - if u.status = Visited || (u.status = WeakVisited && strict) - then loop to_revert todo next_todo - else - let to_revert = - if u.status = NoMark then u::to_revert else to_revert - in - u.status <- if strict then WeakVisited else Visited; - if try UMap.find v.univ u.ltle || not strict - with Not_found -> false - then raise (Found to_revert) - else - begin - let next_todo = - UMap.fold (fun u strictu next_todo -> - let strict = not strictu && strict in - let u = repr g u in - if u == v && not strict then raise (Found to_revert) - else if topo_compare u v = 1 then next_todo - else (u, strict)::next_todo) - u.ltle next_todo - in - loop to_revert todo next_todo - end - in - if u == v then not strict - else - try - let res, to_revert = - try false, loop [] [u, strict] [] - with Found to_revert -> true, to_revert - in - List.iter (fun u -> u.status <- NoMark) to_revert; - res - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e - -(** Uncomment to debug the cycle detection algorithm. *) -(*let insert_edge strict ucan vcan g = - check_universes_invariants g; - let g = insert_edge strict ucan vcan g in - check_universes_invariants g; - let ucan = repr g ucan.univ in - let vcan = repr g vcan.univ in - assert (search_path strict ucan vcan g); - g*) - -(** First, checks on universe levels *) - -let check_equal g u v = - let arcu = repr g u and arcv = repr g v in - arcu == arcv - -let check_eq_level g u v = u == v || check_equal g u v - -let check_smaller g strict u v = - let arcu = repr g u and arcv = repr g v in - if strict then - search_path true arcu arcv g - else - is_prop_arc arcu - || (is_set_arc arcu && not (is_prop_arc arcv)) - || search_path false arcu arcv g - -(** Then, checks on universes *) - -type 'a check_function = universes -> 'a -> 'a -> bool +let make_sprop_cumulative g = {g with sprop_cumulative=true} let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with - | 0 -> check_smaller g false u v - | 1 -> check_smaller g true u v - | x when x < 0 -> check_smaller g false u v + | 0 -> G.check_leq g.graph u v + | 1 -> G.check_lt g.graph u v + | x when x < 0 -> G.check_leq g.graph u v | _ -> false let exists_bigger g ul l = - Universe.exists (fun ul' -> + Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u - + let check_leq g u v = + Universe.equal u v || (g.sprop_cumulative && Universe.is_sprop u) || + (not (Universe.is_sprop u) && not (Universe.is_sprop v) && + (is_type0m_univ u || + real_check_leq g u v)) + +let check_eq g u v = Universe.equal u v || - is_type0m_univ u || - real_check_leq g u v + (not (Universe.is_sprop u || Universe.is_sprop v) && + (real_check_leq g u v && real_check_leq g v u)) -let check_eq_univs g l1 l2 = - real_check_leq g l1 l2 && real_check_leq g l2 l1 +let check_eq_level g u v = + u == v || + (not (Level.is_sprop u || Level.is_sprop v) && G.check_eq g.graph u v) -let check_eq g u v = - Universe.equal u v || check_eq_univs g u v - -(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) - -let rec enforce_univ_eq u v g = - let ucan = repr g u in - let vcan = repr g v in - if topo_compare ucan vcan = 1 then enforce_univ_eq v u g - else - let g = insert_edge false ucan vcan g in (* Cannot fail *) - try insert_edge false vcan ucan g - with CycleDetected -> - error_inconsistency Eq v u (get_explanation true u v g) - -(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) -let enforce_univ_leq u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge false ucan vcan g - with CycleDetected -> - error_inconsistency Le u v (get_explanation true v u g) - -(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) -let enforce_univ_lt u v g = - let ucan = repr g u in - let vcan = repr g v in - try insert_edge true ucan vcan g - with CycleDetected -> - error_inconsistency Lt u v (get_explanation false v u g) - -let empty_universes = - { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 } +let empty_universes = {graph=G.empty; sprop_cumulative=false} let initial_universes = - let set_arc = Canonical { - univ = Level.set; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = (-1); - status = NoMark; - } in - let prop_arc = Canonical { - univ = Level.prop; - ltle = LMap.empty; - gtge = LSet.empty; - rank = big_rank; - klvl = 0; - ilvl = 0; - status = NoMark; - } in - let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in - let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in - enforce_univ_lt Level.prop Level.set empty - -let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries - -let enforce_constraint cst g = - match cst with - | (u,Lt,v) -> enforce_univ_lt u v g - | (u,Le,v) -> enforce_univ_leq u v g - | (u,Eq,v) -> enforce_univ_eq u v g - -let merge_constraints c g = - Constraint.fold enforce_constraint c g - -let check_constraint g (l,d,r) = + let big_rank = 1000000 in + let g = G.empty in + let g = G.add ~rank:big_rank Level.prop g in + let g = G.add ~rank:big_rank Level.set g in + {graph=G.enforce_lt Level.prop Level.set g; sprop_cumulative=false} + +let enforce_constraint (u,d,v) g = + match d with + | Le -> G.enforce_leq u v g + | Lt -> G.enforce_lt u v g + | Eq -> G.enforce_eq u v g + +let enforce_constraint (u,d,v as cst) g = + match Level.is_sprop u, d, Level.is_sprop v with + | false, _, false -> g_map (enforce_constraint cst) g + | true, (Eq|Le), true -> g + | true, Le, false when g.sprop_cumulative -> g + | _ -> raise (UniverseInconsistency (d,Universe.make u, Universe.make v, None)) + +let merge_constraints csts g = Constraint.fold enforce_constraint csts g + +let check_constraint g (u,d,v) = match d with - | Eq -> check_equal g l r - | Le -> check_smaller g false l r - | Lt -> check_smaller g true l r + | Le -> G.check_leq g u v + | Lt -> G.check_lt g u v + | Eq -> G.check_eq g u v -let check_constraints c g = - Constraint.for_all (check_constraint g) c +let check_constraint g (u,d,v as cst) = + match Level.is_sprop u, d, Level.is_sprop v with + | false, _, false -> check_constraint g.graph cst + | true, (Eq|Le), true -> true + | true, Le, false -> g.sprop_cumulative + | _ -> false + +let check_constraints csts g = Constraint.for_all (check_constraint g) csts let leq_expr (u,m) (v,n) = let d = match m - n with @@ -760,6 +116,7 @@ let leq_expr (u,m) (v,n) = (u,d,v) let enforce_leq_alg u v g = + let open Util in let enforce_one (u,v) = function | Inr _ as orig -> orig | Inl (cstrs,g) as orig -> @@ -791,131 +148,19 @@ let enforce_leq_alg u v g = assert (check_leq g u v); cg -(* Normalization *) - -(** [normalize_universes g] returns a graph where all edges point - directly to the canonical representent of their target. The output - graph should be equivalent to the input graph from a logical point - of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges. *) -let normalize_universes g = - let g = - { g with - entries = UMap.map (fun entry -> - match entry with - | Equiv u -> Equiv ((repr g u).univ) - | Canonical ucan -> Canonical { ucan with rank = 1 }) - g.entries } - in - UMap.fold (fun _ u g -> - match u with - | Equiv _u -> g - | Canonical u -> - let _, u, g = get_ltle g u in - let _, _, g = get_gtge g u in - g) - g.entries g - -let constraints_of_universes g = - let module UF = Unionfind.Make (LSet) (LMap) in - let uf = UF.create () in - let constraints_of u v acc = - match v with - | Canonical {univ=u; ltle; _} -> - UMap.fold (fun v strict acc-> - let typ = if strict then Lt else Le in - Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> UF.union u v uf; acc - in - let csts = UMap.fold constraints_of g.entries Constraint.empty in - csts, UF.partition uf - -(* domain g.entries = kept + removed *) -let constraints_for ~kept g = - (* rmap: partial map from canonical universes to kept universes *) - let rmap, csts = LSet.fold (fun u (rmap,csts) -> - let arcu = repr g u in - if LSet.mem arcu.univ kept then - LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts - else - match LMap.find arcu.univ rmap with - | v -> rmap, enforce_eq_level u v csts - | exception Not_found -> LMap.add arcu.univ u rmap, csts) - kept (LMap.empty,Constraint.empty) - in - let rec add_from u csts todo = match todo with - | [] -> csts - | (v,strict)::todo -> - let v = repr g v in - (match LMap.find v.univ rmap with - | v -> - let d = if strict then Lt else Le in - let csts = Constraint.add (u,d,v) csts in - add_from u csts todo - | exception Not_found -> - (* v is not equal to any kept universe *) - let todo = LMap.fold (fun v' strict' todo -> - (v',strict || strict') :: todo) - v.ltle todo - in - add_from u csts todo) - in - LSet.fold (fun u csts -> - let arc = repr g u in - LMap.fold (fun v strict csts -> add_from u csts [v,strict]) - arc.ltle csts) - kept csts - -(** [sort_universes g] builds a totally ordered universe graph. The - output graph should imply the input graph (and the implication - will be strict most of the time), but is not necessarily minimal. - Moreover, it adds levels [Type.n] to identify universes at level - n. An artificial constraint Set < Type.2 is added to ensure that - Type.n and small universes are not merged. Note: the result is - unspecified if the input graph already contains [Type.n] nodes - (calling a module Type is probably a bad idea anyway). *) -let sort_universes g = - let cans = - UMap.fold (fun _ u l -> - match u with - | Equiv _ -> l - | Canonical can -> can :: l - ) g.entries [] - in - let cans = List.sort topo_compare cans in - let lowest_levels = - UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) - (UMap.filter - (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) - g.entries) - in - let lowest_levels = - List.fold_left (fun lowest_levels can -> - let lvl = UMap.find can.univ lowest_levels in - UMap.fold (fun u' strict lowest_levels -> - let cost = if strict then 1 else 0 in - let u' = (repr g u').univ in - UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) - can.ltle lowest_levels) - lowest_levels cans - in - let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in - let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max_lvl + 1) (function - | 0 -> Level.prop - | 1 -> Level.set - | n -> Level.make mp (n-2)) - in - let g = Array.fold_left (fun g u -> - let g, u = safe_repr g u in - change_node g { u with rank = big_rank }) g types - in - let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in - let g = - UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) - lowest_levels g - in - normalize_universes g +exception AlreadyDeclared = G.AlreadyDeclared +let add_universe u strict g = + let graph = G.add u g.graph in + let d = if strict then Lt else Le in + enforce_constraint (Level.set,d,u) {g with graph} + +let add_universe_unconstrained u g = {g with graph=G.add u g.graph} + +exception UndeclaredLevel = G.Undeclared +let check_declared_universes g l = G.check_declared g.graph (LSet.remove Level.sprop l) + +let constraints_of_universes g = G.constraints_of g.graph +let constraints_for ~kept g = G.constraints_for ~kept:(LSet.remove Level.sprop kept) g.graph (** Subtyping of polymorphic contexts *) @@ -940,43 +185,25 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) -(** Pretty-printing *) - -let pr_arc prl = function - | _, Canonical {univ=u; ltle; _} -> - if UMap.is_empty ltle then mt () - else - prl u ++ str " " ++ - v 0 - (pr_sequence (fun (v, strict) -> - (if strict then str "< " else str "<= ") ++ prl v) - (UMap.bindings ltle)) ++ - fnl () - | u, Equiv v -> - prl u ++ str " = " ++ prl v ++ fnl () - -let pr_universes prl g = - let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in - prlist (pr_arc prl) graph - -(* Dumping constraints to a file *) - -let dump_universes output g = - let dump_arc u = function - | Canonical {univ=u; ltle; _} -> - let u_str = Level.to_string u in - UMap.iter (fun v strict -> - let typ = if strict then Lt else Le in - output typ u_str (Level.to_string v)) ltle; - | Equiv v -> - output Eq (Level.to_string u) (Level.to_string v) - in - UMap.iter dump_arc g.entries +let domain g = LSet.add Level.sprop (G.domain g.graph) +let choose p g u = if Level.is_sprop u + then if p u then Some u else None + else G.choose p g.graph u + +let dump_universes f g = G.dump f g.graph + +let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g.graph + +let pr_universes prl g = G.pr prl g.graph + +let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] +let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) +let sort_universes g = g_map (G.sort make_dummy [Level.prop;Level.set]) g (** Profiling *) -let merge_constraints = - if Flags.profile then +let merge_constraints = + if Flags.profile then let key = CProfile.declare_profile "merge_constraints" in CProfile.profile2 key merge_constraints else merge_constraints @@ -986,15 +213,14 @@ let check_constraints = CProfile.profile2 key check_constraints else check_constraints -let check_eq = +let check_eq = if Flags.profile then let check_eq_key = CProfile.declare_profile "check_eq" in CProfile.profile3 check_eq_key check_eq else check_eq -let check_leq = - if Flags.profile then +let check_leq = + if Flags.profile then let check_leq_key = CProfile.declare_profile "check_leq" in CProfile.profile3 check_leq_key check_leq else check_leq - diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 4336a22b8c..17d6c6e6d3 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -13,6 +13,9 @@ open Univ (** {6 Graphs of universes. } *) type t +val make_sprop_cumulative : t -> t +(** Don't use this in the kernel, it makes the system incomplete. *) + type 'a check_function = t -> 'a -> 'a -> bool val check_leq : Universe.t check_function @@ -22,9 +25,6 @@ val check_eq_level : Level.t check_function (** The initial graph of universes: Prop < Set *) val initial_universes : t -(** Check if we are in the initial case *) -val is_initial_universes : t -> bool - (** Check equality of instances w.r.t. a universe graph *) val check_eq_instances : Instance.t check_function @@ -73,12 +73,19 @@ val sort_universes : t -> t of the universes into equivalence classes. *) val constraints_of_universes : t -> Constraint.t * LSet.t list +val choose : (Level.t -> bool) -> t -> Level.t -> Level.t option +(** [choose p g u] picks a universe verifying [p] and equal + to [u] in [g]. *) + (** [constraints_for ~kept g] returns the constraints about the universes [kept] in [g] up to transitivity. eg if [g] is [a <= b <= c] then [constraints_for ~kept:{a, c} g] is [a <= c]. *) val constraints_for : kept:LSet.t -> t -> Constraint.t +val domain : t -> LSet.t +(** Known universes *) + val check_subtype : AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) @@ -86,7 +93,7 @@ val check_subtype : AUContext.t check_function (** {6 Dumping to a file } *) val dump_universes : - (constraint_type -> string -> string -> unit) -> t -> unit + (constraint_type -> Level.t -> Level.t -> unit) -> t -> unit (** {6 Debugging} *) val check_universes_invariants : t -> unit diff --git a/kernel/uint31.ml b/kernel/uint31.ml deleted file mode 100644 index d9c723c243..0000000000 --- a/kernel/uint31.ml +++ /dev/null @@ -1,153 +0,0 @@ - (* Invariant: For arch64 all extra bytes are set to 0 *) -type t = int - - (* to be used only on 32 bits architectures *) -let maxuint31 = Int32.of_string "0x7FFFFFFF" -let uint_32 i = Int32.logand (Int32.of_int i) maxuint31 - -let select f32 f64 = if Sys.word_size = 64 then f64 else f32 - - (* conversion to an int *) -let to_int i = i - -let of_int_32 i = i -let of_int_64 i = i land 0x7FFFFFFF - -let of_int = select of_int_32 of_int_64 -let of_uint i = i - - (* conversion of an uint31 to a string *) -let to_string_32 i = Int32.to_string (uint_32 i) -let to_string_64 = string_of_int - -let to_string = select to_string_32 to_string_64 -let of_string s = - let i32 = Int32.of_string s in - if Int32.compare Int32.zero i32 <= 0 - && Int32.compare i32 maxuint31 <= 0 - then Int32.to_int i32 - else raise (Failure "int_of_string") - - - - (* logical shift *) -let l_sl x y = - of_int (if 0 <= y && y < 31 then x lsl y else 0) - -let l_sr x y = - if 0 <= y && y < 31 then x lsr y else 0 - -let l_and x y = x land y -let l_or x y = x lor y -let l_xor x y = x lxor y - - (* addition of int31 *) -let add x y = of_int (x + y) - - (* subtraction *) -let sub x y = of_int (x - y) - - (* multiplication *) -let mul x y = of_int (x * y) - - (* exact multiplication *) -let mulc_32 x y = - let x = Int64.of_int32 (uint_32 x) in - let y = Int64.of_int32 (uint_32 y) in - let m = Int64.mul x y in - let l = Int64.to_int m in - let h = Int64.to_int (Int64.shift_right_logical m 31) in - h,l - -let mulc_64 x y = - let m = x * y in - let l = of_int_64 m in - let h = of_int_64 (m lsr 31) in - h, l -let mulc = select mulc_32 mulc_64 - - (* division *) -let div_32 x y = - if y = 0 then 0 else - Int32.to_int (Int32.div (uint_32 x) (uint_32 y)) -let div_64 x y = if y = 0 then 0 else x / y -let div = select div_32 div_64 - - (* modulo *) -let rem_32 x y = - if y = 0 then 0 - else Int32.to_int (Int32.rem (uint_32 x) (uint_32 y)) -let rem_64 x y = if y = 0 then 0 else x mod y -let rem = select rem_32 rem_64 - - (* division of two numbers by one *) -let div21_32 xh xl y = - if y = 0 then (0,0) - else - let x = - Int64.logor - (Int64.shift_left (Int64.of_int32 (uint_32 xh)) 31) - (Int64.of_int32 (uint_32 xl)) in - let y = Int64.of_int32 (uint_32 y) in - let q = Int64.div x y in - let r = Int64.rem x y in - Int64.to_int q, Int64.to_int r -let div21_64 xh xl y = - if y = 0 then (0,0) - else - let x = (xh lsl 31) lor xl in - let q = x / y in - let r = x mod y in - q, r -let div21 = select div21_32 div21_64 - - (* comparison *) -let lt_32 x y = (x lxor 0x40000000) < (y lxor 0x40000000) - -(* Do not remove the type information it is really important for - efficiency *) -let lt_64 (x:int) (y:int) = x < y -let lt = select lt_32 lt_64 - -let le_32 x y = - (x lxor 0x40000000) <= (y lxor 0x40000000) - -(* Do not remove the type information it is really important for - efficiency *) -let le_64 (x:int) (y:int) = x <= y -let le = select le_32 le_64 - -let equal (x:int) (y:int) = x == y - -let cmp_32 x y = Int32.compare (uint_32 x) (uint_32 y) -(* Do not remove the type information it is really important for - efficiency *) -let cmp_64 (x:int) (y:int) = compare x y -let compare = select cmp_32 cmp_64 - - (* head tail *) - -let head0 x = - let r = ref 0 in - let x = ref x in - if !x land 0x7FFF0000 = 0 then r := !r + 15 - else x := !x lsr 15; - if !x land 0xFF00 = 0 then (x := !x lsl 8; r := !r + 8); - if !x land 0xF000 = 0 then (x := !x lsl 4; r := !r + 4); - if !x land 0xC000 = 0 then (x := !x lsl 2; r := !r + 2); - if !x land 0x8000 = 0 then (x := !x lsl 1; r := !r + 1); - if !x land 0x8000 = 0 then ( r := !r + 1); - !r;; - -let tail0 x = - let r = ref 0 in - let x = ref x in - if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16); - if !x land 0xFF = 0 then (x := !x lsr 8; r := !r + 8); - if !x land 0xF = 0 then (x := !x lsr 4; r := !r + 4); - if !x land 0x3 = 0 then (x := !x lsr 2; r := !r + 2); - if !x land 0x1 = 0 then ( r := !r + 1); - !r - -let add_digit x d = - (x lsl 1) lor d diff --git a/kernel/uint31.mli b/kernel/uint63.mli index d1f933cc4e..b5f40ca804 100644 --- a/kernel/uint31.mli +++ b/kernel/uint63.mli @@ -1,14 +1,28 @@ type t +val uint_size : int +val maxuint31 : t + (* conversion to int *) -val to_int : t -> int val of_int : int -> t +val to_int2 : t -> int * int (* msb, lsb *) +val of_int64 : Int64.t -> t +(* val of_uint : int -> t +*) + +val hash : t -> int - (* conversion to a string *) + (* convertion to a string *) val to_string : t -> string val of_string : string -> t +val compile : t -> string + +(* constants *) +val zero : t +val one : t + (* logical operations *) val l_sl : t -> t -> t val l_sr : t -> t -> t @@ -16,20 +30,21 @@ val l_and : t -> t -> t val l_xor : t -> t -> t val l_or : t -> t -> t - (* Arithmetic operations *) + (* Arithmetic operations *) val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t - + (* Specific arithmetic operations *) val mulc : t -> t -> t * t +val addmuldiv : t -> t -> t -> t val div21 : t -> t -> t -> t * t - + (* comparison *) val lt : t -> t -> bool -val equal : t -> t -> bool +val equal : t -> t -> bool val le : t -> t -> bool val compare : t -> t -> int @@ -37,5 +52,4 @@ val compare : t -> t -> int val head0 : t -> t val tail0 : t -> t -(** Used by retroknowledge *) -val add_digit : t -> t -> t +val is_uint63 : Obj.t -> bool diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64.ml new file mode 100644 index 0000000000..010b594de8 --- /dev/null +++ b/kernel/uint63_amd64.ml @@ -0,0 +1,215 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type t = int + +let _ = assert (Sys.word_size = 64) + +let uint_size = 63 + +let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF" +let maxuint31 = 0x7FFFFFFF + + (* conversion from an int *) +let to_uint64 i = Int64.logand (Int64.of_int i) maxuint63 + +let of_int i = i +[@@ocaml.inline always] + +let to_int2 i = (0,i) + +let of_int64 _i = assert false + +let hash i = i +[@@ocaml.inline always] + + (* conversion of an uint63 to a string *) +let to_string i = Int64.to_string (to_uint64 i) + +let of_string s = + let i64 = Int64.of_string s in + if Int64.compare Int64.zero i64 <= 0 + && Int64.compare i64 maxuint63 <= 0 + then Int64.to_int i64 + else raise (Failure "Int64.of_string") + +(* Compiles an unsigned int to OCaml code *) +let compile i = Printf.sprintf "Uint63.of_int (%i)" i + +let zero = 0 +let one = 1 + + (* logical shift *) +let l_sl x y = + if 0 <= y && y < 63 then x lsl y else 0 + +let l_sr x y = + if 0 <= y && y < 63 then x lsr y else 0 + +let l_and x y = x land y +[@@ocaml.inline always] + +let l_or x y = x lor y +[@@ocaml.inline always] + +let l_xor x y = x lxor y +[@@ocaml.inline always] + + (* addition of int63 *) +let add x y = x + y +[@@ocaml.inline always] + + (* subtraction *) +let sub x y = x - y +[@@ocaml.inline always] + + (* multiplication *) +let mul x y = x * y +[@@ocaml.inline always] + + (* division *) +let div (x : int) (y : int) = + if y = 0 then 0 else Int64.to_int (Int64.div (to_uint64 x) (to_uint64 y)) + + (* modulo *) +let rem (x : int) (y : int) = + if y = 0 then 0 else Int64.to_int (Int64.rem (to_uint64 x) (to_uint64 y)) + +let addmuldiv p x y = + l_or (l_sl x p) (l_sr y (uint_size - p)) + + (* comparison *) +let lt (x : int) (y : int) = + (x lxor 0x4000000000000000) < (y lxor 0x4000000000000000) +[@@ocaml.inline always] + +let le (x : int) (y : int) = + (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) +[@@ocaml.inline always] + +(* A few helper functions on 128 bits *) +let lt128 xh xl yh yl = + lt xh yh || (xh = yh && lt xl yl) + +let le128 xh xl yh yl = + lt xh yh || (xh = yh && le xl yl) + + (* division of two numbers by one *) +let div21 xh xl y = + let maskh = ref 0 in + let maskl = ref 1 in + let dh = ref 0 in + let dl = ref y in + let cmp = ref true in + while !dh >= 0 && !cmp do + cmp := lt128 !dh !dl xh xl; + (* We don't use addmuldiv below to avoid checks on 1 *) + dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); + dl := !dl lsl 1; + maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); + maskl := !maskl lsl 1 + done; (* mask = 2^N, d = 2^N * d, d >= x *) + let remh = ref xh in + let reml = ref xl in + let quotient = ref 0 in + while !maskh lor !maskl <> 0 do + if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) + quotient := !quotient lor !maskl; + remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; + reml := !reml - !dl; + end; + maskl := (!maskl lsr 1) lor (!maskh lsl (uint_size - 1)); + maskh := !maskh lsr 1; + dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); + dh := !dh lsr 1; + done; + !quotient, !reml + + (* exact multiplication *) +(* TODO: check that none of these additions could be a logical or *) + + +(* size = 32 + 31 + (hx << 31 + lx) * (hy << 31 + ly) = + hxhy << 62 + (hxly + lxhy) << 31 + lxly +*) + +(* precondition : (x lsr 62 = 0 || y lsr 62 = 0) *) +let mulc_aux x y = + let lx = x land maxuint31 in + let ly = y land maxuint31 in + let hx = x lsr 31 in + let hy = y lsr 31 in + (* hx and hy are 32 bits value but at most one is 32 *) + let hxy = hx * hy in (* 63 bits *) + let hxly = hx * ly in (* 63 bits *) + let lxhy = lx * hy in (* 63 bits *) + let lxy = lx * ly in (* 62 bits *) + let l = lxy lor (hxy lsl 62) (* 63 bits *) in + let h = hxy lsr 1 in (* 62 bits *) + let hl = hxly + lxhy in (* We can have a carry *) + let h = if lt hl hxly then h + (1 lsl 31) else h in + let hl'= hl lsl 31 in + let l = l + hl' in + let h = if lt l hl' then h + 1 else h in + let h = h + (hl lsr 32) in + (h,l) + +let mulc x y = + if (x lsr 62 = 0 || y lsr 62 = 0) then mulc_aux x y + else + let yl = y lxor (1 lsl 62) in + let (h,l) = mulc_aux x yl in + (* h << 63 + l = x * yl + x * y = x * (1 << 62 + yl) = + x << 62 + x*yl = x << 62 + h << 63 + l *) + let l' = l + (x lsl 62) in + let h = if lt l' l then h + 1 else h in + (h + (x lsr 1), l') + +let equal (x : int) (y : int) = x = y +[@@ocaml.inline always] + +let compare (x:int) (y:int) = + let x = x lxor 0x4000000000000000 in + let y = y lxor 0x4000000000000000 in + if x > y then 1 + else if y > x then -1 + else 0 + + (* head tail *) + +let head0 x = + let r = ref 0 in + let x = ref x in + if !x land 0x7FFFFFFF00000000 = 0 then r := !r + 31 + else x := !x lsr 31; + if !x land 0xFFFF0000 = 0 then (x := !x lsl 16; r := !r + 16); + if !x land 0xFF000000 = 0 then (x := !x lsl 8; r := !r + 8); + if !x land 0xF0000000 = 0 then (x := !x lsl 4; r := !r + 4); + if !x land 0xC0000000 = 0 then (x := !x lsl 2; r := !r + 2); + if !x land 0x80000000 = 0 then (x := !x lsl 1; r := !r + 1); + if !x land 0x80000000 = 0 then ( r := !r + 1); + !r;; + +let tail0 x = + let r = ref 0 in + let x = ref x in + if !x land 0xFFFFFFFF = 0 then (x := !x lsr 32; r := !r + 32); + if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16); + if !x land 0xFF = 0 then (x := !x lsr 8; r := !r + 8); + if !x land 0xF = 0 then (x := !x lsr 4; r := !r + 4); + if !x land 0x3 = 0 then (x := !x lsr 2; r := !r + 2); + if !x land 0x1 = 0 then ( r := !r + 1); + !r + +let is_uint63 t = + Obj.is_int t +[@@ocaml.inline always] diff --git a/kernel/uint63_x86.ml b/kernel/uint63_x86.ml new file mode 100644 index 0000000000..461184c432 --- /dev/null +++ b/kernel/uint63_x86.ml @@ -0,0 +1,209 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Invariant: the msb should be 0 *) +type t = Int64.t + +let _ = assert (Sys.word_size = 32) + +let uint_size = 63 + +let maxuint63 = Int64.of_string "0x7FFFFFFFFFFFFFFF" +let maxuint31 = Int64.of_string "0x7FFFFFFF" + +let zero = Int64.zero +let one = Int64.one + + (* conversion from an int *) +let mask63 i = Int64.logand i maxuint63 +let of_int i = Int64.of_int i +let to_int2 i = (Int64.to_int (Int64.shift_right_logical i 31), Int64.to_int i) +let of_int64 i = i +let hash i = + let (h,l) = to_int2 i in + (*Hashset.combine h l*) + h * 65599 + l + + (* conversion of an uint63 to a string *) +let to_string i = Int64.to_string i + +let of_string s = + let i64 = Int64.of_string s in + if Int64.compare Int64.zero i64 <= 0 + && Int64.compare i64 maxuint63 <= 0 + then i64 + else raise (Failure "Int63.of_string") + +(* Compiles an unsigned int to OCaml code *) +let compile i = Printf.sprintf "Uint63.of_int64 (%LiL)" i + + (* comparison *) +let lt x y = + Int64.compare x y < 0 + +let le x y = + Int64.compare x y <= 0 + + (* logical shift *) +let l_sl x y = + if le 0L y && lt y 63L then mask63 (Int64.shift_left x (Int64.to_int y)) else 0L + +let l_sr x y = + if le 0L y && lt y 63L then Int64.shift_right x (Int64.to_int y) else 0L + +let l_and x y = Int64.logand x y +let l_or x y = Int64.logor x y +let l_xor x y = Int64.logxor x y + + (* addition of int63 *) +let add x y = mask63 (Int64.add x y) + +let addcarry x y = add (add x y) Int64.one + + (* subtraction *) +let sub x y = mask63 (Int64.sub x y) + +let subcarry x y = sub (sub x y) Int64.one + + (* multiplication *) +let mul x y = mask63 (Int64.mul x y) + + (* division *) +let div x y = + if y = 0L then 0L else Int64.div x y + + (* modulo *) +let rem x y = + if y = 0L then 0L else Int64.rem x y + +let addmuldiv p x y = + l_or (l_sl x p) (l_sr y Int64.(sub (of_int uint_size) p)) + +(* A few helper functions on 128 bits *) +let lt128 xh xl yh yl = + lt xh yh || (xh = yh && lt xl yl) + +let le128 xh xl yh yl = + lt xh yh || (xh = yh && le xl yl) + + (* division of two numbers by one *) +let div21 xh xl y = + let maskh = ref zero in + let maskl = ref one in + let dh = ref zero in + let dl = ref y in + let cmp = ref true in + while le zero !dh && !cmp do + cmp := lt128 !dh !dl xh xl; + (* We don't use addmuldiv below to avoid checks on 1 *) + dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); + dl := l_sl !dl one; + maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); + maskl := l_sl !maskl one + done; (* mask = 2^N, d = 2^N * d, d >= x *) + let remh = ref xh in + let reml = ref xl in + let quotient = ref zero in + while not (Int64.equal (l_or !maskh !maskl) zero) do + if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) + quotient := l_or !quotient !maskl; + remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; + reml := sub !reml !dl + end; + maskl := l_or (l_sr !maskl one) (l_sl !maskh (of_int (uint_size - 1))); + maskh := l_sr !maskh one; + dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); + dh := l_sr !dh one + done; + !quotient, !reml + + + (* exact multiplication *) +let mulc x y = + let lx = ref (Int64.logand x maxuint31) in + let ly = ref (Int64.logand y maxuint31) in + let hx = Int64.shift_right x 31 in + let hy = Int64.shift_right y 31 in + let hr = ref (Int64.mul hx hy) in + let lr = ref (Int64.logor (Int64.mul !lx !ly) (Int64.shift_left !hr 62)) in + hr := (Int64.shift_right_logical !hr 1); + lx := Int64.mul !lx hy; + ly := Int64.mul hx !ly; + hr := Int64.logor !hr (Int64.add (Int64.shift_right !lx 32) (Int64.shift_right !ly 32)); + lr := Int64.add !lr (Int64.shift_left !lx 31); + hr := Int64.add !hr (Int64.shift_right_logical !lr 63); + lr := Int64.add (Int64.shift_left !ly 31) (mask63 !lr); + hr := Int64.add !hr (Int64.shift_right_logical !lr 63); + if Int64.logand !lr Int64.min_int <> 0L + then Int64.(sub !hr one, mask63 !lr) + else (!hr, !lr) + +let equal x y = mask63 x = mask63 y + +let compare x y = Int64.compare x y + +(* Number of leading zeroes *) +let head0 x = + let r = ref 0 in + let x = ref x in + if Int64.logand !x 0x7FFFFFFF00000000L = 0L then r := !r + 31 + else x := Int64.shift_right !x 31; + if Int64.logand !x 0xFFFF0000L = 0L then (x := Int64.shift_left !x 16; r := !r + 16); + if Int64.logand !x 0xFF000000L = 0L then (x := Int64.shift_left !x 8; r := !r + 8); + if Int64.logand !x 0xF0000000L = 0L then (x := Int64.shift_left !x 4; r := !r + 4); + if Int64.logand !x 0xC0000000L = 0L then (x := Int64.shift_left !x 2; r := !r + 2); + if Int64.logand !x 0x80000000L = 0L then (x := Int64.shift_left !x 1; r := !r + 1); + if Int64.logand !x 0x80000000L = 0L then (r := !r + 1); + Int64.of_int !r + +(* Number of trailing zeroes *) +let tail0 x = + let r = ref 0 in + let x = ref x in + if Int64.logand !x 0xFFFFFFFFL = 0L then (x := Int64.shift_right !x 32; r := !r + 32); + if Int64.logand !x 0xFFFFL = 0L then (x := Int64.shift_right !x 16; r := !r + 16); + if Int64.logand !x 0xFFL = 0L then (x := Int64.shift_right !x 8; r := !r + 8); + if Int64.logand !x 0xFL = 0L then (x := Int64.shift_right !x 4; r := !r + 4); + if Int64.logand !x 0x3L = 0L then (x := Int64.shift_right !x 2; r := !r + 2); + if Int64.logand !x 0x1L = 0L then (r := !r + 1); + Int64.of_int !r + +(* May an object be safely cast into an Uint63.t ? *) +let is_uint63 t = + Obj.is_block t && Int.equal (Obj.tag t) Obj.custom_tag + && le (Obj.magic t) maxuint63 + +(* Register all exported functions so that they can be called from C code *) + +let () = + Callback.register "uint63 add" add; + Callback.register "uint63 addcarry" addcarry; + Callback.register "uint63 addmuldiv" addmuldiv; + Callback.register "uint63 div" div; + Callback.register "uint63 div21_ml" div21; + Callback.register "uint63 eq" equal; + Callback.register "uint63 eq0" (equal Int64.zero); + Callback.register "uint63 head0" head0; + Callback.register "uint63 land" l_and; + Callback.register "uint63 leq" le; + Callback.register "uint63 lor" l_or; + Callback.register "uint63 lsl" l_sl; + Callback.register "uint63 lsl1" (fun x -> l_sl x Int64.one); + Callback.register "uint63 lsr" l_sr; + Callback.register "uint63 lsr1" (fun x -> l_sr x Int64.one); + Callback.register "uint63 lt" lt; + Callback.register "uint63 lxor" l_xor; + Callback.register "uint63 mod" rem; + Callback.register "uint63 mul" mul; + Callback.register "uint63 mulc_ml" mulc; + Callback.register "uint63 one" one; + Callback.register "uint63 sub" sub; + Callback.register "uint63 subcarry" subcarry; + Callback.register "uint63 tail0" tail0 diff --git a/kernel/univ.ml b/kernel/univ.ml index fa37834a23..8263c68bf5 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -36,10 +36,27 @@ open Util module RawLevel = struct open Names + + module UGlobal = struct + type t = DirPath.t * int + + let make dp i = (DirPath.hcons dp,i) + + let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' + + let hash (d,i) = Hashset.Combine.combine i (DirPath.hash d) + + let compare (d, i) (d', i') = + let c = Int.compare i i' in + if Int.equal c 0 then DirPath.compare d d' + else c + end + type t = + | SProp | Prop | Set - | Level of int * DirPath.t + | Level of UGlobal.t | Var of int (* Hash-consing *) @@ -47,22 +64,25 @@ struct let equal x y = x == y || match x, y with + | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true - | Level (n,d), Level (n',d') -> - Int.equal n n' && DirPath.equal d d' + | Level l, Level l' -> UGlobal.equal l l' | Var n, Var n' -> Int.equal n n' | _ -> false let compare u v = match u, v with + | SProp, SProp -> 0 + | SProp, _ -> -1 + | _, SProp -> 1 | Prop,Prop -> 0 | Prop, _ -> -1 | _, Prop -> 1 | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 - | Level (i1, dp1), Level (i2, dp2) -> + | Level (dp1, i1), Level (dp2, i2) -> if i1 < i2 then -1 else if i1 > i2 then 1 else DirPath.compare dp1 dp2 @@ -73,6 +93,7 @@ struct let hequal x y = x == y || match x, y with + | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> @@ -81,31 +102,34 @@ struct | _ -> false let hcons = function + | SProp as x -> x | Prop as x -> x | Set as x -> x - | Level (n,d) as x -> + | Level (d,n) as x -> let d' = Names.DirPath.hcons d in - if d' == d then x else Level (n,d') + if d' == d then x else Level (d',n) | Var _n as x -> x open Hashset.Combine let hash = function - | Prop -> combinesmall 1 0 - | Set -> combinesmall 1 1 + | SProp -> combinesmall 1 0 + | Prop -> combinesmall 1 1 + | Set -> combinesmall 1 2 | Var n -> combinesmall 2 n - | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d)) + | Level (d, n) -> combinesmall 3 (combine n (Names.DirPath.hash d)) end module Level = struct - open Names + module UGlobal = RawLevel.UGlobal type raw_level = RawLevel.t = + | SProp | Prop | Set - | Level of int * DirPath.t + | Level of UGlobal.t | Var of int (** Embed levels with their hash value *) @@ -140,11 +164,13 @@ module Level = struct let set = make Set let prop = make Prop + let sprop = make SProp let is_small x = match data x with | Level _ -> false | Var _ -> false + | SProp -> true | Prop -> true | Set -> true @@ -158,21 +184,28 @@ module Level = struct | Set -> true | _ -> false + let is_sprop x = + match data x with + | SProp -> true + | _ -> false + let compare u v = if u == v then 0 else RawLevel.compare (data u) (data v) let to_string x = match data x with + | SProp -> "SProp" | Prop -> "Prop" | Set -> "Set" - | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n + | Level (d,n) -> Names.DirPath.to_string d^"."^string_of_int n | Var n -> "Var(" ^ string_of_int n ^ ")" let pr u = str (to_string u) let apart u v = match data u, data v with + | SProp, _ | _, SProp | Prop, Set | Set, Prop -> true | _ -> false @@ -185,11 +218,11 @@ module Level = struct match data u with | Var n -> Some n | _ -> None - let make m n = make (Level (n, Names.DirPath.hcons m)) + let make qid = make (Level qid) let name u = match data u with - | Level (n, d) -> Some (d, n) + | Level (d, n) -> Some (d, n) | _ -> None end @@ -293,6 +326,7 @@ struct if Int.equal n n' then Level.compare x x' else n - n' + let sprop = hcons (Level.sprop, 0) let prop = hcons (Level.prop, 0) let set = hcons (Level.set, 0) let type1 = hcons (Level.set, 1) @@ -311,16 +345,16 @@ struct let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' else if n <= n' then - (Level.is_prop u && Level.is_small v) + (Level.is_prop u && not (Level.is_sprop v)) else false let successor (u,n) = - if Level.is_prop u then type1 + if Level.is_small u then type1 else (u, n + 1) let addn k (u,n as x) = if k = 0 then x - else if Level.is_prop u then + else if Level.is_small u then (Level.set,n+k) else (u,n+k) @@ -338,13 +372,16 @@ struct left expression is "smaller" than the right one in both cases. *) let super (u,n) (v,n') = let cmp = Level.compare u v in - if Int.equal cmp 0 then SuperSame (n < n') + if Int.equal cmp 0 then SuperSame (n < n') else let open RawLevel in match Level.data u, n, Level.data v, n' with - | Prop, _, Prop, _ -> SuperSame (n < n') - | Prop, 0, _, _ -> SuperSame true - | _, _, Prop, 0 -> SuperSame false + | SProp, _, SProp, _ | Prop, _, Prop, _ -> SuperSame (n < n') + | SProp, 0, Prop, 0 -> SuperSame true + | Prop, 0, SProp, 0 -> SuperSame false + | (SProp | Prop), 0, _, _ -> SuperSame true + | _, _, (SProp | Prop), 0 -> SuperSame false + | _, _, _, _ -> SuperDiff cmp let to_string (v, n) = @@ -430,6 +467,8 @@ struct | [l] -> Expr.is_small l | _ -> false + let sprop = tip Expr.sprop + (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m = tip Expr.prop @@ -439,8 +478,9 @@ struct (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) - let type1 = tip (Expr.successor Expr.set) + let type1 = tip Expr.type1 + let is_sprop x = equal sprop x let is_type0m x = equal type0m x let is_type0 x = equal type0 x @@ -518,9 +558,9 @@ open Universe let universe_level = Universe.level -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq -type explanation = (constraint_type * universe) list +type explanation = (constraint_type * Level.t) list let constraint_type_ord c1 c2 = match c1, c2 with | Lt, Lt -> 0 @@ -570,9 +610,9 @@ struct include S let pr prl c = - fold (fun (u1,op,u2) pp_std -> - pp_std ++ prl u1 ++ pr_constraint_type op ++ - prl u2 ++ fnl () ) c (str "") + v 0 (prlist_with_sep spc (fun (u1,op,u2) -> + hov 0 (prl u1 ++ pr_constraint_type op ++ prl u2)) + (elements c)) end @@ -641,7 +681,7 @@ let enforce_eq u v c = let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) if Expr.equal v u then c - else + else match v, u with | (x,n), (y,m) -> let j = m - n in @@ -664,7 +704,12 @@ let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v + match is_sprop u, is_sprop v with + | true, true -> c + | true, false | false, true -> + raise (UniverseInconsistency (Le, u, v, None)) + | false, false -> + List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v let enforce_leq u v c = if check_univ_leq u v then c @@ -830,7 +875,7 @@ struct else Array.append x y let of_array a = - assert(Array.for_all (fun x -> not (Level.is_prop x)) a); + assert(Array.for_all (fun x -> not (Level.is_prop x || Level.is_sprop x)) a); a let to_array a = a @@ -937,65 +982,42 @@ let hcons_universe_context = UContext.hcons module AUContext = struct - include UContext + type t = Names.Name.t array constrained let repr (inst, cst) = - (Array.mapi (fun i _l -> Level.var i) inst, cst) + (Array.init (Array.length inst) (fun i -> Level.var i), cst) - let pr f ?variance ctx = pr f ?variance (repr ctx) + let pr f ?variance ctx = UContext.pr f ?variance (repr ctx) let instantiate inst (u, cst) = assert (Array.length u = Array.length inst); subst_instance_constraints inst cst -end - -let hcons_abstract_universe_context = AUContext.hcons - -(** Universe info for cumulative inductive types: A context of - universe levels with universe constraints, representing local - universe variables and constraints, together with an array of - Variance.t. - - This data structure maintains the invariant that the variance - array has the same length as the universe instance. *) -module CumulativityInfo = -struct - type t = universe_context * Variance.t array - - let make x = - if (Instance.length (UContext.instance (fst x))) = - (Array.length (snd x)) then x - else anomaly (Pp.str "Invalid subtyping information encountered!") + let names (nas, _) = nas - let empty = (UContext.empty, [||]) - let is_empty (univs, variance) = UContext.is_empty univs && Array.is_empty variance - - let pr prl (univs, variance) = - UContext.pr prl ~variance univs + let hcons (univs, cst) = + (Array.map Names.Name.hcons univs, hcons_constraints cst) - let hcons (univs, variance) = (* should variance be hconsed? *) - (UContext.hcons univs, variance) + let empty = ([||], Constraint.empty) - let univ_context (univs, _subtypcst) = univs - let variance (_univs, variance) = variance + let is_empty (nas, cst) = Array.is_empty nas && Constraint.is_empty cst - (** This function takes a universe context representing constraints - of an inductive and produces a CumulativityInfo.t with the - trivial subtyping relation. *) - let from_universe_context univs = - (univs, Array.init (UContext.size univs) (fun _ -> Variance.Invariant)) + let union (nas, cst) (nas', cst') = (Array.append nas nas', Constraint.union cst cst') - let leq_constraints (_,variance) u u' csts = Variance.leq_constraints variance u u' csts - let eq_constraints (_,variance) u u' csts = Variance.eq_constraints variance u u' csts + let size (nas, _) = Array.length nas end -let hcons_cumulativity_info = CumulativityInfo.hcons +type 'a univ_abstracted = { + univ_abstracted_value : 'a; + univ_abstracted_binder : AUContext.t; +} -module ACumulativityInfo = CumulativityInfo +let map_univ_abstracted f {univ_abstracted_value;univ_abstracted_binder} = + let univ_abstracted_value = f univ_abstracted_value in + {univ_abstracted_value;univ_abstracted_binder} -let hcons_abstract_cumulativity_info = ACumulativityInfo.hcons +let hcons_abstract_universe_context = AUContext.hcons (** A set of universes with universe constraints. We linearize the set to a list after typechecking. @@ -1065,6 +1087,9 @@ type universe_context_set = ContextSet.t type 'a in_universe_context = 'a * universe_context type 'a in_universe_context_set = 'a * universe_context_set +let extend_in_context_set (a, ctx) ctx' = + (a, ContextSet.union ctx ctx') + (** Substitutions. *) let empty_subst = LMap.empty @@ -1142,21 +1167,18 @@ let make_inverse_instance_subst i = LMap.empty arr let make_abstract_instance (ctx, _) = - Array.mapi (fun i _l -> Level.var i) ctx + Array.init (Array.length ctx) (fun i -> Level.var i) -let abstract_universes ctx = +let abstract_universes nas ctx = let instance = UContext.instance ctx in + let () = assert (Int.equal (Array.length nas) (Instance.length instance)) in let subst = make_instance_subst instance in let cstrs = subst_univs_level_constraints subst (UContext.constraints ctx) in - let ctx = UContext.make (instance, cstrs) in + let ctx = (nas, cstrs) in instance, ctx -let abstract_cumulativity_info (univs, variance) = - let subst, univs = abstract_universes univs in - subst, (univs, variance) - let rec compact_univ s vars i u = match u with | [] -> (s, List.rev vars) @@ -1177,12 +1199,8 @@ let pr_constraints prl = Constraint.pr prl let pr_universe_context = UContext.pr -let pr_cumulativity_info = CumulativityInfo.pr - let pr_abstract_universe_context = AUContext.pr -let pr_abstract_cumulativity_info = ACumulativityInfo.pr - let pr_universe_context_set = ContextSet.pr let pr_universe_subst = @@ -1211,7 +1229,7 @@ let hcons_universe_context_set (v, c) = let hcons_univ x = Universe.hcons x -let explain_universe_inconsistency prl (o,u,v,p) = +let explain_universe_inconsistency prl (o,u,v,p : univ_inconsistency) = let pr_uni = Universe.pr_with prl in let pr_rel = function | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" @@ -1223,9 +1241,9 @@ let explain_universe_inconsistency prl (o,u,v,p) = if p = [] then mt () else str " because" ++ spc() ++ pr_uni v ++ - prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ prl v) p ++ - (if Universe.equal (snd (List.last p)) u then mt() else + (if Universe.equal (Universe.make (snd (List.last p))) u then mt() else (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ diff --git a/kernel/univ.mli b/kernel/univ.mli index 1aa53b8aa8..5543c35741 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -11,17 +11,32 @@ (** Universes. *) module Level : sig + + module UGlobal : sig + type t + + val make : Names.DirPath.t -> int -> t + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int + + end + (** Qualified global universe level *) + type t (** Type of universe levels. A universe level is essentially a unique name - that will be associated to constraints later on. *) + that will be associated to constraints later on. A level can be local to a + definition or global. *) val set : t val prop : t + val sprop : t (** The set and prop universe levels. *) val is_small : t -> bool (** Is the universe set or prop? *) + val is_sprop : t -> bool val is_prop : t -> bool val is_set : t -> bool (** Is it specifically Prop or Set *) @@ -34,9 +49,7 @@ sig val hash : t -> int - val make : Names.DirPath.t -> int -> t - (** Create a new universe level from a unique identifier and an associated - module path. *) + val make : UGlobal.t -> t val pr : t -> Pp.t (** Pretty-printing *) @@ -48,7 +61,7 @@ sig val var_index : t -> int option - val name : t -> (Names.DirPath.t * int) option + val name : t -> UGlobal.t option end (** Sets of universe levels *) @@ -108,6 +121,8 @@ sig val sup : t -> t -> t (** The l.u.b. of 2 universes *) + val sprop : t + val type0m : t (** image of Prop in the universes hierarchy *) @@ -117,6 +132,10 @@ sig val type1 : t (** the universe of the type of Prop/Set *) + val is_sprop : t -> bool + val is_type0m : t -> bool + val is_type0 : t -> bool + val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool @@ -155,7 +174,7 @@ val univ_level_rem : Level.t -> Universe.t -> Universe.t -> Universe.t (** {6 Constraints. } *) -type constraint_type = Lt | Le | Eq +type constraint_type = AcyclicGraph.constraint_type = Lt | Le | Eq type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig @@ -192,7 +211,7 @@ val enforce_leq_level : Level.t constraint_function system stores the graph and may result from combination of several Constraint.t... *) -type explanation = (constraint_type * Universe.t) list +type explanation = (constraint_type * Level.t) list type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency @@ -336,9 +355,6 @@ sig val empty : t val is_empty : t -> bool - (** Don't use. *) - val instance : t -> Instance.t - val size : t -> int (** Keeps the order of the instances *) @@ -347,45 +363,18 @@ sig val instantiate : Instance.t -> t -> Constraint.t (** Generate the set of instantiated Constraint.t **) -end - -(** Universe info for cumulative inductive types: A context of - universe levels with universe constraints, representing local - universe variables and constraints, together with an array of - Variance.t. + val names : t -> Names.Name.t array + (** Return the names of the bound universe variables *) - This data structure maintains the invariant that the variance - array has the same length as the universe instance. *) -module CumulativityInfo : -sig - type t - - val make : UContext.t * Variance.t array -> t - - val empty : t - val is_empty : t -> bool - - val univ_context : t -> UContext.t - val variance : t -> Variance.t array - - (** This function takes a universe context representing constraints - of an inductive and produces a CumulativityInfo.t with the - trivial subtyping relation. *) - val from_universe_context : UContext.t -> t - - val leq_constraints : t -> Instance.t constraint_function - val eq_constraints : t -> Instance.t constraint_function end -module ACumulativityInfo : -sig - type t +type 'a univ_abstracted = { + univ_abstracted_value : 'a; + univ_abstracted_binder : AUContext.t; +} +(** A value with bound universe levels. *) - val univ_context : t -> AUContext.t - val variance : t -> Variance.t array - val leq_constraints : t -> Instance.t constraint_function - val eq_constraints : t -> Instance.t constraint_function -end +val map_univ_abstracted : ('a -> 'b) -> 'a univ_abstracted -> 'b univ_abstracted (** Universe contexts (as sets) *) @@ -433,6 +422,9 @@ end type 'a in_universe_context = 'a * UContext.t type 'a in_universe_context_set = 'a * ContextSet.t +val extend_in_context_set : 'a in_universe_context_set -> ContextSet.t -> + 'a in_universe_context_set + val empty_level_subst : universe_level_subst val is_empty_level_subst : universe_level_subst -> bool @@ -463,8 +455,7 @@ val make_instance_subst : Instance.t -> universe_level_subst val make_inverse_instance_subst : Instance.t -> universe_level_subst -val abstract_universes : UContext.t -> Instance.t * AUContext.t -val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativityInfo.t +val abstract_universes : Names.Name.t array -> UContext.t -> Instance.t * AUContext.t (** TODO: move universe abstraction out of the kernel *) val make_abstract_instance : AUContext.t -> Instance.t @@ -482,10 +473,8 @@ val pr_constraint_type : constraint_type -> Pp.t val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t val pr_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> UContext.t -> Pp.t -val pr_cumulativity_info : (Level.t -> Pp.t) -> CumulativityInfo.t -> Pp.t val pr_abstract_universe_context : (Level.t -> Pp.t) -> ?variance:Variance.t array -> AUContext.t -> Pp.t -val pr_abstract_cumulativity_info : (Level.t -> Pp.t) -> ACumulativityInfo.t -> Pp.t val pr_universe_context_set : (Level.t -> Pp.t) -> ContextSet.t -> Pp.t val explain_universe_inconsistency : (Level.t -> Pp.t) -> univ_inconsistency -> Pp.t @@ -501,5 +490,3 @@ val hcons_universe_set : LSet.t -> LSet.t val hcons_universe_context : UContext.t -> UContext.t val hcons_abstract_universe_context : AUContext.t -> AUContext.t val hcons_universe_context_set : ContextSet.t -> ContextSet.t -val hcons_cumulativity_info : CumulativityInfo.t -> CumulativityInfo.t -val hcons_abstract_cumulativity_info : ACumulativityInfo.t -> ACumulativityInfo.t diff --git a/kernel/vars.ml b/kernel/vars.ml index 9d5d79124b..bd56d60053 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Esubst module RelDecl = Context.Rel.Declaration @@ -80,19 +79,9 @@ let noccur_with_meta n m term = (* Lifting *) (*********************) -(* The generic lifting function *) -let rec exliftn el c = match Constr.kind c with - | Constr.Rel i -> Constr.mkRel(reloc_rel i el) - | _ -> Constr.map_with_binders el_lift exliftn el c - -(* Lifting the binding depth across k bindings *) - -let liftn n k c = - match el_liftn (pred k) (el_shft n el_id) with - | ELID -> c - | el -> exliftn el c - -let lift n = liftn n 1 +let exliftn = Constr.exliftn +let liftn = Constr.liftn +let lift = Constr.lift (*********************) (* Substituting *) @@ -306,9 +295,28 @@ let subst_instance_constr subst c = in aux c +let univ_instantiate_constr u c = + let open Univ in + assert (Int.equal (Instance.length u) (AUContext.size c.univ_abstracted_binder)); + subst_instance_constr u c.univ_abstracted_value + (* let substkey = CProfile.declare_profile "subst_instance_constr";; *) (* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else Context.Rel.map (fun x -> subst_instance_constr s x) ctx + +let universes_of_constr c = + let open Univ in + let rec aux s c = + match kind c with + | Const (_c, u) -> + LSet.fold LSet.add (Instance.levels u) s + | Ind ((_mind,_), u) | Construct (((_mind,_),_), u) -> + LSet.fold LSet.add (Instance.levels u) s + | Sort u when not (Sorts.is_small u) -> + let u = Sorts.univ_of_sort u in + LSet.fold LSet.add (Universe.levels u) s + | _ -> Constr.fold aux s c + in aux LSet.empty c diff --git a/kernel/vars.mli b/kernel/vars.mli index fdddbdb342..f2c32b3625 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -139,3 +139,8 @@ val subst_univs_level_context : Univ.universe_level_subst -> Constr.rel_context (** Instance substitution for polymorphism. *) val subst_instance_constr : Instance.t -> constr -> constr val subst_instance_context : Instance.t -> Constr.rel_context -> Constr.rel_context + +val univ_instantiate_constr : Instance.t -> constr univ_abstracted -> constr +(** Ignores the constraints carried by [univ_abstracted]. *) + +val universes_of_constr : constr -> Univ.LSet.t diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 5965853e1e..414c443c4e 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -71,13 +71,15 @@ and conv_whd env pb k whd1 whd2 cu = done; !rcu else raise NotConvertible + | Vint64 i1, Vint64 i2 -> + if Int64.equal i1 i2 then cu else raise NotConvertible | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> (* on the fly eta expansion *) conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu - | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ + | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ | Vint64 _, _ | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible @@ -86,17 +88,11 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = match a1, a2 with | Aind ((mi,_i) as ind1) , Aind ind2 -> if eq_ind ind1 ind2 && compare_stack stk1 stk2 then - if Environ.polymorphic_ind ind1 env then - let mib = Environ.lookup_mind mi env in - let ulen = - match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind ctx -> Univ.ContextSet.size ctx - | Declarations.Polymorphic_ind auctx -> Univ.AUContext.size auctx - | Declarations.Cumulative_ind cumi -> - Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) - in + let ulen = Univ.AUContext.size (Environ.mind_context env mi) in + if ulen = 0 then + conv_stack env k stk1 stk2 cu + else match stk1 , stk2 with - | [], [] -> assert (Int.equal ulen 0); cu | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> assert (ulen <= nargs args1); assert (ulen <= nargs args2); @@ -108,8 +104,6 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = conv_arguments env ~from:ulen k args1 args2 (conv_stack env k stk1' stk2' cu) | _, _ -> assert false (* Should not happen if problem is well typed *) - else - conv_stack env k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> if Vmvalues.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then @@ -189,9 +183,9 @@ let warn_bytecode_compiler_failed = strbrk "falling back to standard conversion") let vm_conv_gen cv_pb env univs t1 t2 = - if not Coq_config.bytecode_compiler then + if not (typing_flags env).Declarations.enable_VM then Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) - full_transparent_state env univs t1 t2 + TransparentState.full env univs t1 t2 else try let v1 = val_of_constr env t1 in @@ -200,7 +194,7 @@ let vm_conv_gen cv_pb env univs t1 t2 = with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) - full_transparent_state env univs t1 t2 + TransparentState.full env univs t1 t2 let vm_conv cv_pb env t1 t2 = let univs = Environ.universes env in diff --git a/kernel/vm.ml b/kernel/vm.ml index eaf64ba4af..83312a8530 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -7,7 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) - open Vmvalues external set_drawinstr : unit -> unit = "coq_set_drawinstr" @@ -170,7 +169,7 @@ let rec apply_stack a stk v = let apply_whd k whd = let v = val_of_rel k in match whd with - | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false + | Vprod _ | Vconstr_const _ | Vconstr_block _ | Vint64 _ -> assert false | Vfun f -> reduce_fun k f | Vfix(f, None) -> push_ra stop; diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 217ef4b8e5..777a207013 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Sorts open Univ open Constr @@ -57,6 +56,7 @@ type structured_constant = | Const_b0 of tag | Const_univ_level of Univ.Level.t | Const_val of structured_values + | Const_uint of Uint63.t type reloc_table = (tag * int) array @@ -73,7 +73,9 @@ let rec eq_structured_values v1 v2 = let t2 = Obj.tag o2 in if Int.equal t1 t2 && Int.equal (Obj.size o1) (Obj.size o2) - then begin + then if Int.equal t1 Obj.custom_tag + then Int64.equal (Obj.magic v1 : int64) (Obj.magic v2 : int64) + else begin assert (t1 <= Obj.last_non_constant_constructor_tag && t2 <= Obj.last_non_constant_constructor_tag); let i = ref 0 in @@ -100,7 +102,9 @@ let eq_structured_constant c1 c2 = match c1, c2 with | Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2 | Const_univ_level _ , _ -> false | Const_val v1, Const_val v2 -> eq_structured_values v1 v2 -| Const_val _v1, _ -> false +| Const_val _, _ -> false +| Const_uint i1, Const_uint i2 -> Uint63.equal i1 i2 +| Const_uint _, _ -> false let hash_structured_constant c = let open Hashset.Combine in @@ -110,6 +114,7 @@ let hash_structured_constant c = | Const_b0 t -> combinesmall 3 (Int.hash t) | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l) | Const_val v -> combinesmall 5 (hash_structured_values v) + | Const_uint i -> combinesmall 6 (Uint63.hash i) let eq_annot_switch asw1 asw2 = let eq_ci ci1 ci2 = @@ -132,6 +137,7 @@ let hash_annot_switch asw = let pp_sort s = let open Sorts in match s with + | SProp -> Pp.str "SProp" | Prop -> Pp.str "Prop" | Set -> Pp.str "Set" | Type u -> Pp.(str "Type@{" ++ Univ.pr_uni u ++ str "}") @@ -142,6 +148,7 @@ let pp_struct_const = function | Const_b0 i -> Pp.int i | Const_univ_level l -> Univ.Level.pr l | Const_val _ -> Pp.str "(value)" + | Const_uint i -> Pp.str (Uint63.to_string i) (* Abstract data *) type vprod @@ -276,6 +283,7 @@ type whd = | Vcofix of vcofix * to_update * arguments option | Vconstr_const of int | Vconstr_block of vblock + | Vint64 of int64 | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -306,8 +314,9 @@ let uni_lvl_val (v : values) : Univ.Level.t = | Vcofix _ -> str "Vcofix" | Vconstr_const _i -> str "Vconstr_const" | Vconstr_block _b -> str "Vconstr_block" + | Vint64 _ -> str "Vint64" | Vatom_stk (_a,_stk) -> str "Vatom_stk" - | _ -> assert false + | Vuniv_level _ -> assert false in CErrors.anomaly Pp.( strbrk "Parsing virtual machine value expected universe level, got " @@ -326,10 +335,10 @@ let rec whd_accu a stk = let args = Array.init (nargs args) (arg args) in let s = Obj.obj (Obj.field at 0) in begin match s with - | Type u -> + | Sorts.Type u -> let inst = Instance.of_array (Array.map uni_lvl_val args) in let u = Univ.subst_instance_universe inst u in - Vatom_stk (Asort (Type u), []) + Vatom_stk (Asort (Sorts.sort_of_univ u), []) | _ -> assert false end | _ -> assert false @@ -363,6 +372,8 @@ let rec whd_accu a stk = | [Zapp args] -> Vcofix(vcofix, res, Some args) | _ -> assert false end + | i when Int.equal i Obj.custom_tag -> + Vint64 (Obj.magic i) | tg -> CErrors.anomaly Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") @@ -391,6 +402,7 @@ let whd_val : values -> whd = | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) else Vconstr_block(Obj.obj o) @@ -413,6 +425,7 @@ let obj_of_str_const str = | Const_b0 tag -> Obj.repr tag | Const_univ_level l -> Obj.repr (Vuniv_level l) | Const_val v -> Obj.repr v + | Const_uint i -> Obj.repr i let val_of_block tag (args : structured_values array) = let nargs = Array.length args in @@ -430,6 +443,8 @@ let val_of_atom a = val_of_obj (obj_of_atom a) let val_of_int i = (Obj.magic i : values) +let val_of_uint i = (Obj.magic i : values) + let atom_of_proj kn v = let r = Obj.new_block proj_tag 2 in Obj.set_field r 0 (Obj.repr kn); @@ -659,6 +674,7 @@ and pr_whd w = | Vcofix _ -> str "Vcofix" | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" | Vconstr_block _b -> str "Vconstr_block" + | Vint64 i -> i |> Format.sprintf "Vint64(%LiL)" |> str | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" | Vuniv_level _ -> assert false) and pr_stack stk = diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index ae1d416ed5..6d984d5f49 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -44,6 +44,7 @@ type structured_constant = | Const_b0 of tag | Const_univ_level of Univ.Level.t | Const_val of structured_values + | Const_uint of Uint63.t val pp_struct_const : structured_constant -> Pp.t @@ -125,6 +126,7 @@ type whd = | Vcofix of vcofix * to_update * arguments option | Vconstr_const of int | Vconstr_block of vblock + | Vint64 of int64 | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -145,6 +147,7 @@ val val_of_proj : Projection.Repr.t -> values -> values val val_of_atom : atom -> values val val_of_int : int -> structured_values val val_of_block : tag -> structured_values array -> structured_values +val val_of_uint : Uint63.t -> structured_values external val_of_annot_switch : annot_switch -> values = "%identity" external val_of_proj_name : Projection.Repr.t -> values = "%identity" diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml new file mode 100644 index 0000000000..beb59ce205 --- /dev/null +++ b/kernel/write_uint63.ml @@ -0,0 +1,38 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Equivalent of rm -f *) +let safe_remove f = + try Unix.chmod f 0o644; Sys.remove f with _ -> () + +(** * Generate an implementation of 63-bit arithmetic *) +let ml_file_copy input output = + safe_remove output; + let i = open_in input in + let o = open_out output in + let pr s = Printf.fprintf o s in + pr "(* DO NOT EDIT THIS FILE: automatically generated by ./write_uint63.ml *)\n"; + pr "(* see uint63_amd64.ml and uint63_x86.ml *)\n"; + try + while true do + output_string o (input_line i); output_char o '\n' + done + with End_of_file -> + close_in i; + close_out o; + Unix.chmod output 0o444 + +let write_uint63 () = + ml_file_copy + (if max_int = 1073741823 (* 32-bits *) then "uint63_x86.ml" + else (* 64 bits *) "uint63_amd64.ml") + "uint63.ml" + +let () = write_uint63 () |