Imported Upstream version 8.5~beta1+dfsg

100 files changed, 17656 insertions, 7283 deletions

diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
index 5d302660..3fded663 100644
--- a/kernel/byterun/coq_fix_code.c
+++ b/kernel/byterun/coq_fix_code.c
@@ -46,7 +46,8 @@ void init_arity () {
     arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]=
     arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]=
     arity[HEAD0INT31]=arity[TAIL0INT31]=
-    arity[COMPINT31]=arity[DECOMPINT31]=0;
+    arity[COMPINT31]=arity[DECOMPINT31]=
+    arity[ORINT31]=arity[ANDINT31]=arity[XORINT31]=0;
   /* instruction with one operand */
   arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]=
     arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]=
@@ -54,7 +55,7 @@ void init_arity () {
     arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]=
     arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]=
     arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=
-    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]=
+    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=
     arity[BRANCH]=arity[ISCONST]= 1;
   /* instruction with two operands */
   arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=
@@ -84,15 +85,6 @@ value coq_makeaccu (value i) {
   return (value)res;
 }
 
-value coq_accucond (value i) {
-  code_t q;
-  code_t res = coq_stat_alloc(8);
-  q = res;
-  *q++ = VALINSTR(ACCUMULATECOND);
-  *q = (opcode_t)Int_val(i);
-  return (value)res;
-}
-
 value coq_pushpop (value i) {
   code_t res;
   int n;
@@ -117,7 +109,7 @@ value coq_is_accumulate_code(value code){
   code_t q;
   int res;
   q = (code_t)code;
-  res = Is_instruction(q,ACCUMULATECOND) || Is_instruction(q,ACCUMULATE);
+  res = Is_instruction(q,ACCUMULATE);
   return Val_bool(res);
 }
 
diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h
index c1a4e0ae..5c85389d 100644
--- a/kernel/byterun/coq_fix_code.h
+++ b/kernel/byterun/coq_fix_code.h
@@ -29,7 +29,6 @@ void init_arity();
 value coq_tcode_of_code(value code, value len);
 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
index e224a108..9cbf4077 100644
--- a/kernel/byterun/coq_instruct.h
+++ b/kernel/byterun/coq_instruct.h
@@ -38,7 +38,7 @@ enum instructions {
   SETFIELD0, SETFIELD1, SETFIELD,
   CONST0, CONST1, CONST2, CONST3, CONSTINT,
   PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
-  ACCUMULATE, ACCUMULATECOND, 
+  ACCUMULATE,
   MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, 
 /* spiwack: */
   BRANCH,
@@ -49,6 +49,7 @@ enum instructions {
   HEAD0INT31, TAIL0INT31,
   ISCONST, ARECONST,
   COMPINT31, DECOMPINT31,
+  ORINT31, ANDINT31, XORINT31,
 /* /spiwack  */
   STOP
 };
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index aab08d89..f9e0dc7f 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -543,21 +543,21 @@ value coq_interprete
 	    coq_extra_args = Long_val(sp[2]);
 	    sp += 3;
 	  } else {
-	    /* L'argument recursif est un accumulateur */
+	    /* The recursif argument is an accumulator */
 	    mlsize_t num_args, i;
-	    /* Construction du PF partiellement appliqué */ 
+	    /* Construction of partially applied PF */
 	    Alloc_small(accu, rec_pos + 2, Closure_tag); 
 	    Field(accu, 1) = coq_env;
 	    for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i];
 	    Code_val(accu) = pc;
 	    sp += rec_pos;
 	    *--sp = accu;
-	      /* Construction de l'atom */
+	      /* Construction of the atom */
 	    Alloc_small(accu, 2, ATOM_FIX_TAG);
 	    Field(accu,1) = sp[0];
 	    Field(accu,0)  = sp[1];
 	    sp++; sp[0] = accu;
-	      /* Construction de l'accumulateur */
+	      /* Construction of the accumulator */
 	    num_args = coq_extra_args - rec_pos;
 	    Alloc_small(accu, 2+num_args, Accu_tag);
 	    Code_val(accu) = accumulate;
@@ -922,26 +922,6 @@ value coq_interprete
       }
 
       /* Special operations for reduction of open term */
-      Instruct(ACCUMULATECOND) {
-	int i, num;
-	print_instr("ACCUMULATECOND");
-	num = *pc;
-	pc++;
-	if (Field(coq_global_boxed, num) == Val_false || coq_all_transp) {
-	  /*	  printf ("false\n");
-		  printf ("tag = %d", Tag_val(Field(accu,1))); */
-	  num = Wosize_val(coq_env);
-	  for(i = 2; i < num; i++) *--sp = Field(accu,i);
-	  coq_extra_args = coq_extra_args + (num - 2);
-	  coq_env = Field(Field(accu,1),1);
-	  pc = Code_val(coq_env);
-	  accu = coq_env;
-	  /*	  printf ("end\n"); */
-	  Next;
-	};
-	/*	printf ("true\n"); */
-      }
-      
       Instruct(ACCUMULATE) {
 	mlsize_t i, size;
 	print_instr("ACCUMULATE");
@@ -1373,7 +1353,29 @@ value coq_interprete
         Next;
       }
 
+      Instruct (ORINT31) {
+	/* returns the bitwise or */
+	print_instr("ORINT31");
+        accu =
+	  value_of_uint32((uint32_of_value(accu)) | (uint32_of_value(*sp++)));
+	Next;
+      }
 
+      Instruct (ANDINT31) {
+	/* returns the bitwise and */
+	print_instr("ANDINT31");
+        accu =
+	  value_of_uint32((uint32_of_value(accu)) & (uint32_of_value(*sp++)));
+	Next;
+      }
+
+      Instruct (XORINT31) {
+	/* returns the bitwise xor */
+	print_instr("XORINT31");
+        accu =
+	  value_of_uint32((uint32_of_value(accu)) ^ (uint32_of_value(*sp++)));
+	Next;
+      }
 
       /*  /spiwack   */
 
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index 00f5eb3b..8d03829a 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -26,7 +26,6 @@ asize_t coq_max_stack_size = Coq_max_stack_size;
 
 
 value coq_global_data;
-value coq_global_boxed;
 int coq_all_transp;
 value coq_atom_tbl;
 
@@ -62,7 +61,6 @@ static void coq_scan_roots(scanning_action action)
   register value * i;
   /* Scan the global variables */
   (*action)(coq_global_data, &coq_global_data);
-  (*action)(coq_global_boxed, &coq_global_boxed);
   (*action)(coq_atom_tbl, &coq_atom_tbl);
   /* Scan the stack */
   for (i = coq_sp; i < coq_stack_high; i++) {
@@ -90,14 +88,6 @@ void init_coq_global_data(long requested_size)
     Field (coq_global_data, i) = Val_unit;
 }
 
-void init_coq_global_boxed(long requested_size)
-{
-  int i;
-  coq_global_boxed = alloc_shr(requested_size, 0);
-  for (i = 0; i < requested_size; i++) 
-    Field (coq_global_boxed, i) = Val_true;
-}
-
 void init_coq_atom_tbl(long requested_size){
   int i;
   coq_atom_tbl = alloc_shr(requested_size, 0);
@@ -125,7 +115,6 @@ value init_coq_vm(value unit) /* ML */
     /* Allocate the table of global and the stack */
     init_coq_stack();
     init_coq_global_data(Coq_global_data_Size);
-    init_coq_global_boxed(40);
     init_coq_atom_tbl(40);
     /* Initialing the interpreter */
     coq_all_transp = 0;
@@ -181,11 +170,6 @@ value get_coq_atom_tbl(value unit)                  /* ML */
   return coq_atom_tbl;
 }
 
-value get_coq_global_boxed(value unit)        /* ML */
-{
-  return coq_global_boxed;
-}
-
 value realloc_coq_global_data(value size)           /* ML */
 {
   mlsize_t requested_size, actual_size, i;
@@ -205,24 +189,6 @@ value realloc_coq_global_data(value size)           /* ML */
   return Val_unit;
 }
 
-value realloc_coq_global_boxed(value size)           /* ML */
-{
-  mlsize_t requested_size, actual_size, i;
-  value new_global_boxed;
-  requested_size = Long_val(size);
-  actual_size = Wosize_val(coq_global_boxed);
-  if (requested_size >= actual_size) {
-    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
-    new_global_boxed = alloc_shr(requested_size, 0);
-    for (i = 0; i < actual_size; i++)
-      initialize(&Field(new_global_boxed, i), Field(coq_global_boxed, i));
-    for (i = actual_size; i < requested_size; i++)
-      Field (new_global_boxed, i) = Val_long (0);
-    coq_global_boxed = new_global_boxed;
-  }
-  return Val_unit;
-}
-
 value realloc_coq_atom_tbl(value size)            /* ML */
 {
   mlsize_t requested_size, actual_size, i;
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
index 79e4d0fe..cec34f56 100644
--- a/kernel/byterun/coq_memory.h
+++ b/kernel/byterun/coq_memory.h
@@ -35,7 +35,6 @@ extern value * coq_stack_threshold;
 /* global_data */
 
 extern value coq_global_data;
-extern value coq_global_boxed;
 extern int coq_all_transp;
 extern value coq_atom_tbl;
 
@@ -56,8 +55,6 @@ value re_init_coq_vm(value unit); /* ML */
 void  realloc_coq_stack(asize_t required_space); 
 value get_coq_global_data(value unit); /* ML */
 value realloc_coq_global_data(value size); /* ML */
-value get_coq_global_boxed(value unit);
-value realloc_coq_global_boxed(value size); /* ML */
 value get_coq_atom_tbl(value unit); /* ML */
 value realloc_coq_atom_tbl(value size); /* ML */
 value coq_set_transp_value(value transp); /* ML */
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index 5d6d92ff..ae679027 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -27,7 +27,7 @@ let cofix_evaluated_tag = 6
 
 type structured_constant =
   | Const_sorts of sorts
-  | Const_ind of inductive
+  | Const_ind of pinductive
   | Const_b0 of tag
   | Const_bn of tag * structured_constant array
 
@@ -67,7 +67,7 @@ type instruction =
                    (* nb fv, init, lbl types, lbl bodies *)
   | Kclosurecofix of int * int * Label.t array * Label.t array
                    (* nb fv, init, lbl types, lbl bodies *)
-  | Kgetglobal of constant
+  | Kgetglobal of pconstant
   | Kconst of structured_constant
   | Kmakeblock of int * tag             (* size, tag *)
   | Kmakeprod
@@ -114,11 +114,14 @@ type instruction =
   | 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 *)
 
 and bytecodes = instruction list
 
-type fv_elem = FVnamed of identifier | FVrel of int
+type fv_elem = FVnamed of Id.t | FVrel of int
 
 type fv = fv_elem array
 
@@ -182,7 +185,7 @@ let rec instruction ppf = function
       Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt;
       print_string " bodies = ";
       Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
-  | Kgetglobal id -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id)
+  | Kgetglobal (id,u) -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id)
   | Kconst cst ->
       fprintf ppf "\tconst"
   | Kmakeblock(n, m) ->
@@ -220,6 +223,9 @@ let rec instruction ppf = function
   | Kareconst(n,lbl) -> fprintf ppf "\tareconst %i %i" n lbl
   | Kcompint31 -> fprintf ppf "\tcompint31"
   | Kdecompint31 -> fprintf ppf "\tdecompint"
+  | Klorint31 -> fprintf ppf "\tlorint31"
+  | Klandint31 -> fprintf ppf "\tlandint31"
+  | Klxorint31 -> fprintf ppf "\tlxorint31"
 
 (* /spiwack *)
 
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index c8cc9503..b65268f7 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -23,7 +23,7 @@ val cofix_evaluated_tag : tag
 
 type structured_constant =
   | Const_sorts of sorts
-  | Const_ind of inductive
+  | Const_ind of pinductive
   | Const_b0 of tag
   | Const_bn of tag * structured_constant array
 
@@ -60,7 +60,7 @@ type instruction =
                    (** nb fv, init, lbl types, lbl bodies *)
   | Kclosurecofix of int * int * Label.t array * Label.t array
                    (** nb fv, init, lbl types, lbl bodies *)
-  | Kgetglobal of constant
+  | Kgetglobal of pconstant
   | Kconst of structured_constant
   | Kmakeblock of int * tag             (** size, tag *)
   | Kmakeprod
@@ -107,13 +107,14 @@ type instruction =
   | Kisconst of Label.t                 (** conditional jump *)
   | Kareconst of int*Label.t            (** conditional jump *)
   | Kcompint31                          (** dynamic compilation of int31 *)
-  | Kdecompint31                        (** dynamix decompilation of int31 
-   /spiwack *)
-
+  | Kdecompint31                        (** dynamix decompilation of int31 *)
+  | Klorint31                           (** bitwise operations: or and xor *)
+  | Klandint31
+  | Klxorint31
 
 and bytecodes = instruction list
 
-type fv_elem = FVnamed of identifier | FVrel of int
+type fv_elem = FVnamed of Id.t | FVrel of int
 
 type fv = fv_elem array
 
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 56008749..d6c160c3 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -50,7 +50,7 @@ open Pre_env
 (* Access to these variables is performed by the [Koffsetclosure n]       *)
 (* instruction that shifts the environment pointer of [n] fields.         *)
 
-(* This allows to represent mutual fixpoints in just one block.           *)
+(* This allows representing mutual fixpoints in just one block.           *)
 (* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint    *)
 (* types. They are used in conversion tests (which requires that          *)
 (* fixpoint types must be convertible). Their environment is the one of   *)
@@ -108,7 +108,7 @@ let empty_comp_env ()=
 (*i Creation functions for comp_env *)
 
 let rec add_param n sz l =
-  if n = 0 then l else add_param (n - 1) sz (n+sz::l)
+  if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l)
 
 let comp_env_fun arity =
   { nb_stack = arity;
@@ -179,16 +179,17 @@ let push_local sz r =
 
 
 (*i Compilation of variables *)
-let find_at el l =
+let find_at f l =
   let rec aux n = function
     | [] -> raise Not_found
-    | hd :: tl -> if hd = el then n else aux (n+1) tl
+    | hd :: tl -> if f hd then n else aux (n + 1) tl
   in aux 1 l
 
 let pos_named id r =
   let env = !(r.in_env) in
   let cid = FVnamed id in
-  try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev))
+  let f = function FVnamed id' -> Id.equal id id' | _ -> false in
+  try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
   with Not_found ->
     let pos = env.size in
     r.in_env := { size = pos+1; fv_rev =  cid:: env.fv_rev};
@@ -206,7 +207,8 @@ let pos_rel i r sz =
       let i = i - r.nb_rec in
       let db = FVrel(i) in
       let env = !(r.in_env) in
-      try Kenvacc(r.offset + env.size - (find_at db env.fv_rev))
+      let f = function FVrel j -> Int.equal i j | _ -> false in
+      try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
       with Not_found ->
 	let pos = env.size in
 	r.in_env := { size = pos+1; fv_rev =  db:: env.fv_rev};
@@ -219,7 +221,7 @@ let pos_rel i r sz =
 (* non-terminating instruction (branch, raise, return, appterm)          *)
 (* in front of it.                                                       *)
 
-let rec discard_dead_code cont = cont
+let discard_dead_code cont = cont
 (*function
     [] -> []
   | (Klabel _ | Krestart ) :: _ as cont -> cont
@@ -280,14 +282,14 @@ let rec is_tailcall = function
 let rec add_pop n = function
   | Kpop m :: cont -> add_pop (n+m) cont
   | Kreturn m:: cont -> Kreturn (n+m) ::cont
-  | cont -> if n = 0 then cont else Kpop n :: cont
+  | cont -> if Int.equal n 0 then cont else Kpop n :: cont
 
 let add_grab arity lbl cont =
-  if arity = 1 then Klabel lbl :: cont
+  if Int.equal arity 1 then Klabel lbl :: cont
   else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont
 
 let add_grabrec rec_arg arity lbl cont =
-  if arity = 1 then
+  if Int.equal arity 1 && rec_arg < arity then
     Klabel lbl :: Kgrabrec 0 :: Krestart :: cont
   else
     Krestart :: Klabel lbl :: Kgrabrec rec_arg ::
@@ -331,7 +333,7 @@ let init_fun_code () = fun_code := []
 let code_construct tag nparams arity cont =
   let f_cont =
       add_pop nparams
-      (if arity = 0 then
+      (if Int.equal arity 0 then
 	[Kconst (Const_b0 tag); Kreturn 0]
        else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0])
     in
@@ -351,13 +353,13 @@ let rec str_const c =
   | App(f,args) ->
       begin
 	match kind_of_term f with
-	| Construct((kn,j),i) -> 
+	| Construct(((kn,j),i),u) -> 
             begin
 	    let oib = lookup_mind kn !global_env in
 	    let oip = oib.mind_packets.(j) in
 	    let num,arity = oip.mind_reloc_tbl.(i-1) in
 	    let nparams = oib.mind_nparams in
-	    if nparams + arity = Array.length args then
+	    if Int.equal (nparams + arity) (Array.length args) then
               (* spiwack: *)
               (* 1/ tries to compile the constructor in an optimal way,
                     it is supposed to work only if the arguments are
@@ -371,7 +373,7 @@ let rec str_const c =
 		try
 		  Bstrconst (Retroknowledge.get_vm_constant_static_info
                                               (!global_env).retroknowledge
-                                              (kind_of_term f) args)
+                                              f args)
                 with NotClosed ->
 		  (* 2/ if the arguments are not all closed (this is
                         expectingly (and it is currently the case) the only
@@ -392,12 +394,12 @@ let rec str_const c =
 		  let b_args = Array.map str_const rargs in
 		  Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
-                                           (kind_of_term f)),
+                                           f),
                            b_args)
               with Not_found ->
 		(* 3/ if no special behavior is available, then the compiler
 		      falls back to the normal behavior *)
-		if arity = 0 then Bstrconst(Const_b0 num)
+		if Int.equal arity 0 then Bstrconst(Const_b0 num)
 		else
 		  let rargs = Array.sub args nparams arity in
 		  let b_args = Array.map str_const rargs in
@@ -413,7 +415,7 @@ let rec str_const c =
 	      try
 		Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
-                                           (kind_of_term f)),
+                                           f),
                          b_args)
 	      with Not_found ->
 	        Bconstruct_app(num, nparams, arity, b_args)
@@ -421,21 +423,21 @@ let rec str_const c =
 	| _ -> Bconstr c
       end
   | Ind ind -> Bstrconst (Const_ind ind)
-  | Construct ((kn,j),i) ->  
+  | Construct (((kn,j),i),u) ->  
       begin
       (* spiwack: tries first to apply the run-time compilation
            behavior of the constructor, as in 2/ above *)
       try
 	Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
-                                           (kind_of_term c)),
+                                           c),
                          [| |])
       with Not_found ->
 	let oib = lookup_mind kn !global_env in
 	let oip = oib.mind_packets.(j) in
 	let num,arity = oip.mind_reloc_tbl.(i-1) in
 	let nparams = oib.mind_nparams in
-	if nparams + arity = 0 then Bstrconst(Const_b0 num)
+	if Int.equal (nparams + arity) 0 then Bstrconst(Const_b0 num)
 	else Bconstruct_app(num,nparams,arity,[||])
       end
   | _ -> Bconstr c
@@ -484,25 +486,33 @@ let rec compile_fv reloc l sz cont =
 
 (* Compiling constants *)
 
-let rec get_allias env kn =
-  let tps = (lookup_constant kn env).const_body_code in
-  match Cemitcodes.force tps with
-  | BCallias kn' -> get_allias env kn'
-  | _ -> kn
-
+let rec get_allias env (kn,u as p) =
+  let cb = lookup_constant kn env in
+  let tps = cb.const_body_code in
+    (match Cemitcodes.force tps with
+    | BCallias (kn',u') -> get_allias env (kn', Univ.subst_instance_instance u u')
+    | _ -> p)
 
 (* Compiling expressions *)
 
 let rec compile_constr reloc c sz cont =
   match kind_of_term c with
-  | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta")
-  | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar")
+  | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta"
+  | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar"
+  | Proj (p,c) -> 
+    (* compile_const reloc p [|c|] sz cont *)
+    let kn = Projection.constant p in
+    let cb = lookup_constant kn !global_env in
+      (* TODO: better representation of projections *)
+    let pb = Option.get cb.const_proj in
+    let args = Array.make pb.proj_npars mkProp in
+      compile_const reloc kn Univ.Instance.empty (Array.append args [|c|]) sz cont
 
   | Cast(c,_,_) -> compile_constr reloc c sz cont
 
   | Rel i -> pos_rel i reloc sz :: cont
   | Var id -> pos_named id reloc :: cont
-  | Const kn -> compile_const reloc kn [||] sz cont
+  | Const (kn,u) -> compile_const reloc kn u [||] sz cont
   | Sort _  | Ind _ | Construct _ ->
       compile_str_cst reloc (str_const c) sz cont
 
@@ -529,14 +539,14 @@ let rec compile_constr reloc c sz cont =
       begin
 	match kind_of_term f with
 	| Construct _ -> compile_str_cst reloc (str_const c) sz cont
-        | Const kn -> compile_const reloc kn args sz cont
+        | Const (kn,u) -> compile_const reloc kn u args sz cont
 	| _ -> comp_app compile_constr compile_constr reloc f args sz cont
       end
   | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) ->
       let ndef = Array.length type_bodies in
       let rfv = ref empty_fv in
-      let lbl_types = Array.create ndef Label.no in
-      let lbl_bodies = Array.create ndef Label.no in
+      let lbl_types = Array.make ndef Label.no in
+      let lbl_bodies = Array.make ndef Label.no in
       (* Compilation des types *)
       let env_type = comp_env_fix_type rfv in
       for i = 0 to ndef - 1 do
@@ -564,8 +574,8 @@ let rec compile_constr reloc c sz cont =
 
   | CoFix(init,(_,type_bodies,rec_bodies)) ->
       let ndef = Array.length type_bodies in
-      let lbl_types = Array.create ndef Label.no in
-      let lbl_bodies = Array.create ndef Label.no in
+      let lbl_types = Array.make ndef Label.no in
+      let lbl_bodies = Array.make ndef Label.no in
       (* Compiling types *)
       let rfv = ref empty_fv in
       let env_type = comp_env_cofix_type ndef rfv in
@@ -598,8 +608,8 @@ let rec compile_constr reloc c sz cont =
       let mib = lookup_mind (fst ind) !global_env in
       let oib = mib.mind_packets.(snd ind) in
       let tbl = oib.mind_reloc_tbl in
-      let lbl_consts = Array.create oib.mind_nb_constant Label.no in
-      let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in
+      let lbl_consts = Array.make oib.mind_nb_constant Label.no in
+      let lbl_blocks = Array.make (oib.mind_nb_args+1) Label.no in
       let branch1,cont = make_branch cont in
       (* Compiling return type *)
       let lbl_typ,fcode =
@@ -609,7 +619,7 @@ let rec compile_constr reloc c sz cont =
       let lbl_sw = Label.create () in
       let sz_b,branch,is_tailcall =
 	match branch1 with
-	| Kreturn k -> assert (k = sz); sz, branch1, true
+	| Kreturn k -> assert (Int.equal k sz); sz, branch1, true
 	| _ -> sz+3, Kjump, false
       in
       let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
@@ -622,7 +632,7 @@ let rec compile_constr reloc c sz cont =
       (* Compiling regular constructor branches *)
       for i = 0 to Array.length tbl - 1 do
 	let tag, arity = tbl.(i) in
-	if arity = 0 then
+	if Int.equal arity 0 then
 	  let lbl_b,code_b =
 	    label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in
 	  lbl_consts.(tag) <- lbl_b;
@@ -632,7 +642,7 @@ let rec compile_constr reloc c sz cont =
 	  let nargs = List.length args in
 	  let lbl_b,code_b =
 	    label_code(
-	    if nargs = arity then
+	    if Int.equal nargs arity then
 	      Kpushfields arity ::
 	      compile_constr (push_param arity sz_b reloc)
 		body (sz_b+arity) (add_pop arity (branch :: !c))
@@ -655,7 +665,7 @@ let rec compile_constr reloc c sz cont =
       in
       compile_constr reloc a sz
       (try
-	let entry = Term.Ind ind in
+	let entry = mkInd ind in
 	Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge
 	                                       entry code_sw
       with Not_found ->
@@ -669,7 +679,7 @@ and compile_str_cst reloc sc sz cont =
       let nargs = Array.length args in
       comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont)
   | Bconstruct_app(tag,nparams,arity,args) ->
-      if Array.length args = 0 then code_construct tag nparams arity cont
+      if Int.equal (Array.length args) 0 then code_construct tag nparams arity cont
       else
 	comp_app
 	  (fun _ _ _ cont -> code_construct tag nparams arity cont)
@@ -680,20 +690,20 @@ and compile_str_cst reloc sc sz cont =
 (* spiwack : compilation of constants with their arguments.
    Makes a special treatment with 31-bit integer addition *)
 and compile_const =
-  fun reloc-> fun  kn -> fun args -> fun sz -> fun cont ->
+  fun reloc-> fun  kn u -> fun args -> fun sz -> fun cont ->
   let nargs = Array.length args in
   (* spiwack: checks if there is a specific way to compile the constant
               if there is not, Not_found is raised, and the function
               falls back on its normal behavior *)
   try
     Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge
-                  (kind_of_term (mkConst kn)) reloc args sz cont
+                  (mkConstU (kn,u)) reloc args sz cont
   with Not_found ->
-    if nargs = 0 then
-      Kgetglobal (get_allias !global_env kn) :: cont
+    if Int.equal nargs 0 then
+      Kgetglobal (get_allias !global_env (kn, u)) :: cont
     else
       comp_app (fun _ _ _ cont ->
-                   Kgetglobal (get_allias !global_env kn) :: cont)
+                   Kgetglobal (get_allias !global_env (kn,u)) :: cont)
         compile_constr reloc () args sz cont
 
 let compile env c =
@@ -708,7 +718,7 @@ let compile env c =
   Format.print_string "fv = ";
   List.iter (fun v ->
     match v with
-    | FVnamed id -> Format.print_string ((string_of_id id)^"; ")
+    | FVnamed id -> Format.print_string ((Id.to_string id)^"; ")
     | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv;  Format
     .print_string "\n";
   Format.print_flush();  *)
@@ -717,12 +727,12 @@ let compile env c =
 let compile_constant_body env = function
   | Undef _ | OpaqueDef _ -> BCconstant
   | Def sb ->
-      let body = Declarations.force sb in
+      let body = Mod_subst.force_constr sb in
       match kind_of_term body with
-	| Const kn' ->
+	| Const (kn',u) ->
 	    (* we use the canonical name of the constant*)
 	    let con= constant_of_kn (canonical_con kn') in
-	      BCallias (get_allias env con)
+	      BCallias (get_allias env (con,u))
 	| _ ->
 	    let res = compile env body in
 	    let to_patch = to_memory res in
@@ -730,7 +740,7 @@ let compile_constant_body env = function
 
 (* Shortcut of the previous function used during module strengthening *)
 
-let compile_alias kn = BCallias (constant_of_kn (canonical_con kn))
+let compile_alias (kn,u) = BCallias (constant_of_kn (canonical_con kn), u)
 
 (* spiwack: additional function which allow different part of compilation of the
       31-bit integers *)
@@ -749,7 +759,7 @@ let compile_structured_int31 fc args =
   Const_b0
     (Array.fold_left
        (fun temp_i -> fun t -> match kind_of_term t with
-          | Construct (_,d) -> 2*temp_i+d-1
+          | Construct ((_,d),_) -> 2*temp_i+d-1
           | _ -> raise NotClosed)
        0 args
     )
@@ -760,7 +770,7 @@ let compile_structured_int31 fc args =
 let dynamic_int31_compilation fc reloc args sz cont =
   if not fc then raise Not_found else
     let nargs = Array.length args in
-      if nargs = 31 then
+      if Int.equal nargs 31 then
 	let (escape,labeled_cont) = make_branch cont in
 	let else_lbl = Label.create() in
 	  comp_args compile_str_cst reloc args sz
@@ -778,7 +788,7 @@ let dynamic_int31_compilation fc reloc args sz cont =
 	    fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)];
 	    Kclosure(lbl,0) :: cont
 	in
-	  if nargs = 0 then
+	  if Int.equal nargs 0 then
 	    code_construct cont
 	  else
 	    comp_app (fun _ _ _ cont -> code_construct cont)
@@ -844,7 +854,7 @@ let op_compilation n op =
   fun kn fc reloc args sz cont ->
   if not fc then raise Not_found else
   let nargs = Array.length args in
-  if nargs=n then (*if it is a fully applied addition*)
+  if Int.equal nargs n then (*if it is a fully applied addition*)
     let (escape, labeled_cont) = make_branch cont in
     let else_lbl = Label.create () in
       comp_args compile_constr reloc args sz
@@ -854,7 +864,7 @@ let op_compilation n op =
            (* works as comp_app with nargs = n and non-tailcall cont*)
            Kgetglobal (get_allias !global_env kn)::
            Kapply n::labeled_cont)))
-  else if nargs=0 then
+  else if Int.equal nargs 0 then
     code_construct kn cont
   else
     comp_app (fun _ _ _ cont -> code_construct kn cont)
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index d0bfd46c..eab36d8b 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -13,7 +13,7 @@ val compile_constant_body : env -> constant_def -> body_code
 
 (** Shortcut of the previous function used during module strengthening *)
 
-val compile_alias : constant -> body_code
+val compile_alias : pconstant -> body_code
 
 (** spiwack: this function contains the information needed to perform
             the static compilation of int31 (trying and obtaining
@@ -33,7 +33,7 @@ val dynamic_int31_compilation : bool -> comp_env ->
            works as follow: checks if all the arguments are non-pointers
            if they are applies the operation (second argument) if not
            all of them are, returns to a coq definition (third argument) *)
-val op_compilation : int -> instruction -> constant -> bool -> comp_env ->
+val op_compilation : int -> instruction -> pconstant -> bool -> comp_env ->
                              constr array -> int -> bytecodes-> bytecodes
 
 (*spiwack: compiling function to insert dynamic decompilation before
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 897464e6..3c9692a5 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -20,7 +20,7 @@ open Mod_subst
 type reloc_info =
   | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
-  | Reloc_getglobal of constant
+  | Reloc_getglobal of pconstant
 
 type patch = reloc_info * int
 
@@ -61,8 +61,7 @@ let out_word b1 b2 b3 b4 =
       then 2 * len
       else
 	if len = Sys.max_string_length
-	then raise (Invalid_argument "String.create")  (* Pas la bonne execption
-.... *)
+	then invalid_arg "String.create"  (* Pas la bonne exception .... *)
 	else Sys.max_string_length in
     let new_buffer = String.create new_len in
     String.blit !out_buffer 0 new_buffer 0 len;
@@ -97,7 +96,7 @@ let label_table  = ref ([| |] : label_definition array)
 let extend_label_table needed =
   let new_size = ref(Array.length !label_table) in
   while needed >= !new_size do new_size := 2 * !new_size done;
-  let new_table = Array.create !new_size (Label_undefined []) in
+  let new_table = Array.make !new_size (Label_undefined []) in
   Array.blit !label_table 0 new_table 0 (Array.length !label_table);
   label_table := new_table
 
@@ -148,8 +147,8 @@ and slot_for_annot a =
   enter (Reloc_annot a);
   out_int 0
 
-and slot_for_getglobal id =
-  enter (Reloc_getglobal id);
+and slot_for_getglobal p =
+  enter (Reloc_getglobal p);
   out_int 0
 
 
@@ -165,7 +164,7 @@ let emit_instr = function
       then out(opENVACC1 + n - 1)
       else (out opENVACC; out_int n)
   | Koffsetclosure ofs ->
-      if ofs = -2 || ofs = 0 || ofs = 2
+      if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2
       then out (opOFFSETCLOSURE0 + ofs / 2)
       else (out opOFFSETCLOSURE; out_int ofs)
   | Kpush ->
@@ -214,7 +213,7 @@ let emit_instr = function
   | Kconst c ->
       out opGETGLOBAL; slot_for_const c
   | Kmakeblock(n, t) ->
-      if n = 0 then raise (Invalid_argument "emit_instr : block size = 0")
+      if Int.equal n 0 then invalid_arg "emit_instr : block size = 0"
       else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
       else (out opMAKEBLOCK; out_int n; out_int t)
   | Kmakeprod ->
@@ -237,7 +236,7 @@ let emit_instr = function
   | Ksetfield n ->
       if n <= 1 then out (opSETFIELD0+n)
       else (out opSETFIELD;out_int n)
-  | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
+  | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr"
   (* spiwack *)
   | Kbranch lbl -> out opBRANCH; out_label lbl
   | Kaddint31 -> out opADDINT31
@@ -258,6 +257,9 @@ let emit_instr = function
   | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl
   | Kcompint31 -> out opCOMPINT31
   | Kdecompint31 -> out opDECOMPINT31
+  | Klorint31 -> out opORINT31
+  | Klandint31 -> out opANDINT31
+  | Klxorint31 -> out opXORINT31
   (*/spiwack *)
   | Kstop ->
       out opSTOP
@@ -276,7 +278,7 @@ let rec emit = function
       else (out opPUSHENVACC; out_int n);
       emit c
   | Kpush :: Koffsetclosure ofs :: c ->
-      if ofs = -2 || ofs = 0 || ofs = 2
+      if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2
       then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
       else (out opPUSHOFFSETCLOSURE; out_int ofs);
       emit c
@@ -302,7 +304,7 @@ let rec emit = function
 
 let init () =
   out_position := 0;
-  label_table := Array.create 16 (Label_undefined []);
+  label_table := Array.make 16 (Label_undefined []);
   reloc_info := []
 
 type emitcodes = string
@@ -318,28 +320,28 @@ let rec subst_strcst s sc =
   match sc with
   | Const_sorts _ | Const_b0 _ -> sc
   | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args)
-  | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i))
+  | Const_ind(ind,u) -> let kn,i = ind in Const_ind((subst_mind s kn, i), u)
 
 let subst_patch s (ri,pos) =
   match ri with
   | Reloc_annot a ->
       let (kn,i) = a.ci.ci_ind in
-      let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in
+      let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in
       (Reloc_annot {a with ci = ci},pos)
   | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos)
-  | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos)
+  | Reloc_getglobal kn -> (Reloc_getglobal (subst_pcon s kn), pos)
 
 let subst_to_patch s (code,pl,fv) =
   code,List.rev_map (subst_patch s) pl,fv
 
 type body_code =
   | BCdefined of to_patch
-  | BCallias of constant
+  | BCallias of pconstant
   | BCconstant
 
 let subst_body_code s = function
   | BCdefined tp -> BCdefined (subst_to_patch s tp)
-  | BCallias kn -> BCallias (fst (subst_con s kn))
+  | BCallias (kn,u) -> BCallias (fst (subst_con_kn s kn), u)
   | BCconstant -> BCconstant
 
 type to_patch_substituted = body_code substituted
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 287c3930..cec90130 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -4,7 +4,7 @@ open Cbytecodes
 type reloc_info =
   | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
-  | Reloc_getglobal of constant
+  | Reloc_getglobal of constant Univ.puniverses
 
 type patch = reloc_info * int
 
@@ -25,7 +25,7 @@ val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
 
 type body_code =
   | BCdefined of to_patch
-  | BCallias of constant
+  | BCallias of constant Univ.puniverses
   | BCconstant
 
 
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 9e2af94b..f06b13d8 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -19,11 +19,12 @@
 (* This file implements a lazy reduction for the Calculus of Inductive
    Constructions *)
 
+open Errors
 open Util
 open Pp
-open Term
 open Names
-open Declarations
+open Term
+open Vars
 open Environ
 open Esubst
 
@@ -33,6 +34,7 @@ let share = ref true
 (* Profiling *)
 let beta = ref 0
 let delta = ref 0
+let eta = ref 0
 let zeta = ref 0
 let evar = ref 0
 let iota = ref 0
@@ -43,9 +45,10 @@ let reset () =
   prune := 0
 
 let stop() =
-  msgnl (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
-	 str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++
-         str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]")
+  msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+	 str " eta=" ++ int !eta ++ str" zeta=" ++ int !zeta ++ str" evar=" ++
+	 int !evar ++ str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++
+	 str"]")
 
 let incr_cnt red cnt =
   if red then begin
@@ -63,10 +66,10 @@ let with_stats c =
   end else
     Lazy.force c
 
-let all_opaque = (Idpred.empty, Cpred.empty)
-let all_transparent = (Idpred.full, Cpred.full)
+let all_opaque = (Id.Pred.empty, Cpred.empty)
+let all_transparent = (Id.Pred.full, Cpred.full)
 
-let is_transparent_variable (ids, _) id = Idpred.mem id ids
+let is_transparent_variable (ids, _) id = Id.Pred.mem id ids
 let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
 
 module type RedFlagsSig = sig
@@ -74,16 +77,18 @@ module type RedFlagsSig = sig
   type red_kind
   val fBETA : red_kind
   val fDELTA : red_kind
+  val fETA : red_kind
   val fIOTA : red_kind
   val fZETA : red_kind
   val fCONST : constant -> red_kind
-  val fVAR : identifier -> red_kind
+  val fVAR : Id.t -> red_kind
   val no_red : reds
   val red_add : reds -> red_kind -> reds
   val red_sub : reds -> red_kind -> reds
   val red_add_transparent : reds -> transparent_state -> reds
   val mkflags : red_kind list -> reds
   val red_set : reds -> red_kind -> bool
+  val red_projection : reds -> projection -> bool
 end
 
 module RedFlags = (struct
@@ -95,14 +100,16 @@ module RedFlags = (struct
   type reds = {
     r_beta : bool;
     r_delta : bool;
+    r_eta : bool;
     r_const : transparent_state;
     r_zeta : bool;
     r_iota : bool }
 
-  type red_kind = BETA | DELTA | IOTA | ZETA
-	      | CONST of constant | VAR of identifier
+  type red_kind = BETA | DELTA | ETA | IOTA | ZETA
+	      | CONST of constant | VAR of Id.t
   let fBETA = BETA
   let fDELTA = DELTA
+  let fETA = ETA
   let fIOTA = IOTA
   let fZETA = ZETA
   let fCONST kn  = CONST kn
@@ -110,12 +117,14 @@ module RedFlags = (struct
   let no_red = {
     r_beta = false;
     r_delta = false;
+    r_eta = false;
     r_const = all_opaque;
     r_zeta = false;
     r_iota = false }
 
   let red_add red = function
     | BETA -> { red with r_beta = true }
+    | 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
@@ -124,10 +133,11 @@ module RedFlags = (struct
     | ZETA -> { red with r_zeta = true }
     | VAR id ->
 	let (l1,l2) = red.r_const in
-	{ red with r_const = Idpred.add id l1, l2 }
+	{ red with r_const = Id.Pred.add id l1, l2 }
 
   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
@@ -136,7 +146,7 @@ module RedFlags = (struct
     | ZETA -> { red with r_zeta = false }
     | VAR id ->
 	let (l1,l2) = red.r_const in
-	{ red with r_const = Idpred.remove id l1, l2 }
+	{ red with r_const = Id.Pred.remove id l1, l2 }
 
   let red_add_transparent red tr =
     { red with r_const = tr }
@@ -145,19 +155,24 @@ module RedFlags = (struct
 
   let red_set red = function
     | 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
 	incr_cnt c delta
     | VAR id -> (* En attendant d'avoir des kn pour les Var *)
 	let (l,_) = red.r_const in
-	let c = Idpred.mem id l in
+	let c = Id.Pred.mem id l in
 	incr_cnt c delta
     | ZETA -> incr_cnt red.r_zeta zeta
     | IOTA -> incr_cnt red.r_iota iota
     | DELTA -> (* Used for Rel/Var defined in context *)
 	incr_cnt red.r_delta delta
 
+  let red_projection red p = 
+    if Projection.unfolded p then true
+    else red_set red (fCONST (Projection.constant p))
+
 end : RedFlagsSig)
 
 open RedFlags
@@ -185,9 +200,8 @@ let unfold_red kn =
  *  * 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 = (4,[(1,c);(3,d)]) means there are 4 free rel variables
- *    and only those with index 1 and 3 have bodies which are c and d resp.
- *  * i_vars is the list of _defined_ named variables.
+ *  * 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
@@ -197,72 +211,96 @@ let unfold_red kn =
  * instantiations (cbv or lazy) are.
  *)
 
-type table_key = id_key
+type table_key = constant puniverses tableKey
+
+let eq_pconstant_key (c,u) (c',u') =
+  eq_constant_key c c' && Univ.Instance.equal u u'
+  
+module IdKeyHash =
+struct
+  open Hashset.Combine
+  type t = table_key
+  let equal = Names.eq_table_key eq_pconstant_key
+  let hash = function
+  | ConstKey (c, _) -> combinesmall 1 (Constant.UserOrd.hash c)
+  | VarKey id -> combinesmall 2 (Id.hash id)
+  | RelKey i -> combinesmall 3 (Int.hash i)
+end
 
-let eq_table_key = Names.eq_id_key
+module KeyTable = Hashtbl.Make(IdKeyHash)
 
-type 'a infos = {
-  i_flags : reds;
+let eq_table_key = IdKeyHash.equal
+
+type 'a infos_cache = {
   i_repr : 'a infos -> constr -> 'a;
   i_env : env;
   i_sigma : existential -> constr option;
-  i_rels : int * (int * constr) list;
-  i_vars : (identifier * constr) list;
-  i_tab : (table_key, 'a) Hashtbl.t }
+  i_rels : constr option array;
+  i_tab : 'a KeyTable.t }
+
+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
 
-let ref_value_cache info ref =
+let rec assoc_defined id = function
+| [] -> raise Not_found
+| (_, None, _) :: ctxt -> assoc_defined id ctxt
+| (id', Some c, _) :: ctxt ->
+  if Id.equal id id' then c else assoc_defined id ctxt
+
+let ref_value_cache ({i_cache = cache} as infos)  ref =
   try
-    Some (Hashtbl.find info.i_tab ref)
+    Some (KeyTable.find cache.i_tab ref)
   with Not_found ->
   try
     let body =
       match ref with
 	| RelKey n ->
-	    let (s,l) = info.i_rels in lift n (List.assoc (s-n) l)
-	| VarKey id -> List.assoc id info.i_vars
-	| ConstKey cst -> constant_value info.i_env cst
+            let len = Array.length cache.i_rels in
+            let i = n - 1 in
+            let () = if i < 0 || len <= i then raise Not_found in
+            begin match Array.unsafe_get cache.i_rels i with
+            | None -> raise Not_found
+            | Some t -> lift n t
+            end
+	| VarKey id -> assoc_defined id (named_context cache.i_env)
+	| ConstKey cst -> constant_value_in cache.i_env cst
     in
-    let v = info.i_repr info body in
-    Hashtbl.add info.i_tab ref v;
+    let v = cache.i_repr infos body in
+    KeyTable.add cache.i_tab ref v;
     Some v
   with
     | Not_found (* List.assoc *)
     | NotEvaluableConst _ (* Const *)
       -> None
 
-let evar_value info ev =
-  info.i_sigma ev
-
-let defined_vars flags env =
-(*  if red_local_const (snd flags) then*)
-    Sign.fold_named_context
-      (fun (id,b,_) e ->
-	 match b with
-	   | None -> e
-	   | Some body -> (id, body)::e)
-       (named_context env) ~init:[]
-(*  else []*)
+let evar_value cache ev =
+  cache.i_sigma ev
 
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
-  Sign.fold_rel_context
-      (fun (id,b,t) (i,subs) ->
-	 match b with
-	   | None -> (i+1, subs)
-	   | Some body -> (i+1, (i,body) :: subs))
-      (rel_context env) ~init:(0,[])
+  let ctx = rel_context env in
+  let len = List.length ctx in
+  let ans = Array.make len None in
+  let iter i (_, b, _) = match b with
+  | None -> ()
+  | Some _ -> Array.unsafe_set ans i b
+  in
+  let () = List.iteri iter ctx in
+  ans
 (*  else (0,[])*)
 
 let create mk_cl flgs env evars =
-  { i_flags = flgs;
-    i_repr = mk_cl;
-    i_env = env;
-    i_sigma = evars;
-    i_rels = defined_rels flgs env;
-    i_vars = defined_vars flgs env;
-    i_tab = Hashtbl.create 17 }
+  let cache = 
+    { i_repr = mk_cl;
+      i_env = env;
+      i_sigma = evars;
+      i_rels = defined_rels flgs env;
+      i_tab = KeyTable.create 17 }
+  in { i_flags = flgs; i_cache = cache }
 
 
 (**********************************************************************)
@@ -302,15 +340,17 @@ and fterm =
   | FAtom of constr (* Metas and Sorts *)
   | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
-  | FInd of inductive
-  | FConstruct of constructor
+  | FInd of pinductive
+  | FConstruct of pconstructor
   | FApp of fconstr * fconstr array
+  | FProj of projection * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * fconstr subs
-  | FCases of case_info * fconstr * fconstr * fconstr array
-  | FLambda of int * (name * constr) list * constr * fconstr subs
-  | FProd of name * fconstr * fconstr
-  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FCase of case_info * fconstr * fconstr * fconstr array
+  | 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
   | FEvar of existential * fconstr subs
   | FLIFT of int * fconstr
   | FCLOS of constr * fconstr subs
@@ -318,13 +358,13 @@ and fterm =
 
 let fterm_of v = v.term
 let set_norm v = v.norm <- Norm
-let is_val v = v.norm = Norm
+let is_val v = match v.norm with Norm -> true | _ -> false
 
 let mk_atom c = {norm=Norm;term=FAtom c}
 
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
-let update v1 (no,t) =
+let update v1 no t =
   if !share then
     (v1.norm <- no;
      v1.term <- t;
@@ -337,6 +377,8 @@ let update v1 (no,t) =
 type stack_member =
   | Zapp of fconstr array
   | Zcase of case_info * fconstr * fconstr array
+  | ZcaseT of case_info * constr * constr array * fconstr subs
+  | Zproj of int * int * constant
   | Zfix of fconstr * stack
   | Zshift of int
   | Zupdate of fconstr
@@ -345,7 +387,7 @@ and stack = stack_member list
 
 let empty_stack = []
 let append_stack v s =
-  if Array.length v = 0 then s else
+  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
@@ -389,7 +431,7 @@ let rec stack_assign s p c = match s with
          Zapp nargs :: s)
   | _ -> s
 let rec stack_tail p s =
-  if p = 0 then s else
+  if Int.equal p 0 then s else
     match s with
       | Zapp args :: s ->
 	  let q = Array.length args in
@@ -417,9 +459,9 @@ let rec lft_fconstr n ft =
     | FLOCKED -> assert false
     | _ -> {norm=ft.norm; term=FLIFT(n,ft)}
 let lift_fconstr k f =
-  if k=0 then f else lft_fconstr k f
+  if Int.equal k 0 then f else lft_fconstr k f
 let lift_fconstr_vect k v =
-  if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
+  if Int.equal k 0 then v else CArray.Fun1.map lft_fconstr k v
 
 let clos_rel e i =
   match expand_rel i e with
@@ -436,88 +478,21 @@ let compact_stack head stk =
         (* Be sure to create a new cell otherwise sharing would be
            lost by the update operation *)
         let h' = lft_fconstr depth head in
-        let _ = update m (h'.norm,h'.term) in
+        let _ = update m h'.norm h'.term in
         strip_rec depth s
     | stk -> zshift depth stk in
   strip_rec 0 stk
 
 (* Put an update mark in the stack, only if needed *)
 let zupdate m s =
-  if !share & m.norm = Red
+  if !share && begin match m.norm with Red -> true | _ -> false end
   then
     let s' = compact_stack m s in
     let _ = m.term <- FLOCKED in
     Zupdate(m)::s'
   else s
 
-(* Closure optimization: *)
-let rec compact_constr (lg, subs as s) c k =
-  match kind_of_term c with
-      Rel i ->
-        if i < k then c,s else
-          (try mkRel (k + lg - list_index (i-k+1) subs), (lg,subs)
-          with Not_found -> mkRel (k+lg), (lg+1, (i-k+1)::subs))
-    | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s
-    | Evar(ev,v) ->
-        let (v',s) = compact_vect s v k in
-        if v==v' then c,s else mkEvar(ev,v'),s
-    | Cast(a,ck,b) ->
-        let (a',s) = compact_constr s a k in
-        let (b',s) = compact_constr s b k in
-        if a==a' && b==b' then c,s else mkCast(a', ck, b'), s
-    | App(f,v) ->
-        let (f',s) = compact_constr s f k in
-        let (v',s) = compact_vect s v k in
-        if f==f' && v==v' then c,s else mkApp(f',v'), s
-    | Lambda(n,a,b) ->
-        let (a',s) = compact_constr s a k in
-        let (b',s) = compact_constr s b (k+1) in
-        if a==a' && b==b' then c,s else mkLambda(n,a',b'), s
-    | Prod(n,a,b) ->
-        let (a',s) = compact_constr s a k in
-        let (b',s) = compact_constr s b (k+1) in
-        if a==a' && b==b' then c,s else mkProd(n,a',b'), s
-    | LetIn(n,a,ty,b) ->
-        let (a',s) = compact_constr s a k in
-        let (ty',s) = compact_constr s ty k in
-        let (b',s) = compact_constr s b (k+1) in
-        if a==a' && ty==ty' && b==b' then c,s else mkLetIn(n,a',ty',b'), s
-    | Fix(fi,(na,ty,bd)) ->
-        let (ty',s) = compact_vect s ty k in
-        let (bd',s) = compact_vect s bd (k+Array.length ty) in
-        if ty==ty' && bd==bd' then c,s else mkFix(fi,(na,ty',bd')), s
-    | CoFix(i,(na,ty,bd)) ->
-        let (ty',s) = compact_vect s ty k in
-        let (bd',s) = compact_vect s bd (k+Array.length ty) in
-        if ty==ty' && bd==bd' then c,s else mkCoFix(i,(na,ty',bd')), s
-    | Case(ci,p,a,br) ->
-        let (p',s) = compact_constr s p k in
-        let (a',s) = compact_constr s a k in
-        let (br',s) = compact_vect s br k in
-        if p==p' && a==a' && br==br' then c,s else mkCase(ci,p',a',br'),s
-and compact_vect s v k = compact_v [] s v k (Array.length v - 1)
-and compact_v acc s v k i =
-  if i < 0 then
-    let v' = Array.of_list acc in
-    if array_for_all2 (==) v v' then v,s else v',s
-  else
-    let (a',s') = compact_constr s v.(i) k in
-    compact_v (a'::acc) s' v k (i-1)
-
-(* Computes the minimal environment of a closure.
-   Idea: if the subs is not identity, the term will have to be
-   reallocated entirely (to propagate the substitution). So,
-   computing the set of free variables does not change the
-   complexity. *)
-let optimise_closure env c =
-  if is_subs_id env then (env,c) else
-    let (c',(_,s)) = compact_constr (0,[]) c 1 in
-    let env' =
-      Array.map (fun i -> clos_rel env i) (Array.of_list s) in
-    (subs_cons (env', subs_id 0),c')
-
 let mk_lambda env t =
-  let (env,t) = optimise_closure env t in
   let (rvars,t') = decompose_lam t in
   FLambda(List.length rvars, List.rev rvars, t', env)
 
@@ -539,10 +514,10 @@ let mk_clos e t =
     | Meta _ | Sort _ ->  { norm = Norm; term = FAtom t }
     | Ind kn -> { norm = Norm; term = FInd kn }
     | Construct kn -> { norm = Cstr; term = FConstruct kn }
-    | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) ->
+    | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) ->
         {norm = Red; term = FCLOS(t,e)}
 
-let mk_clos_vect env v = Array.map (mk_clos env) v
+let mk_clos_vect env v = CArray.Fun1.map mk_clos env v
 
 (* Translate the head constructor of t from constr to fconstr. This
    function is parameterized by the function to apply on the direct
@@ -557,11 +532,13 @@ let mk_clos_deep clos_fun env t =
           term = FCast (clos_fun env a, k, clos_fun env b)}
     | App (f,v) ->
         { norm = Red;
-	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
+	  term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) }
+    | Proj (p,c) ->
+	{ norm = Red;
+	  term = FProj (p, clos_fun env c) }
     | Case (ci,p,c,v) ->
         { norm = Red;
-	  term = FCases (ci, clos_fun env p, clos_fun env c,
-			 Array.map (clos_fun env) v) }
+	  term = FCaseT (ci, p, clos_fun env c, v, env) }
     | Fix fx ->
         { norm = Cstr; term = FFix (fx, env) }
     | CoFix cfx ->
@@ -589,30 +566,37 @@ let rec to_constr constr_fun lfts v =
     | FAtom c -> exliftn lfts c
     | FCast (a,k,b) ->
         mkCast (constr_fun lfts a, k, constr_fun lfts b)
-    | FFlex (ConstKey op) -> mkConst op
-    | FInd op -> mkInd op
-    | FConstruct op -> mkConstruct op
-    | FCases (ci,p,c,ve) ->
+    | FFlex (ConstKey op) -> mkConstU op
+    | FInd op -> mkIndU op
+    | FConstruct op -> mkConstructU op
+    | FCase (ci,p,c,ve) ->
 	mkCase (ci, constr_fun lfts p,
                 constr_fun lfts c,
-		Array.map (constr_fun lfts) ve)
+		CArray.Fun1.map constr_fun lfts ve)
+    | FCaseT (ci,p,c,ve,env) ->
+	mkCase (ci, constr_fun lfts (mk_clos env p),
+                constr_fun lfts c,
+		Array.map (fun b -> constr_fun lfts (mk_clos env b)) ve)
     | FFix ((op,(lna,tys,bds)),e) ->
         let n = Array.length bds in
-        let ftys = Array.map (mk_clos e) tys in
-        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+        let ftys = CArray.Fun1.map mk_clos e tys in
+        let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in
 	let lfts' = el_liftn n lfts in
-	mkFix (op, (lna, Array.map (constr_fun lfts) ftys,
-		         Array.map (constr_fun lfts') fbds))
+	mkFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys,
+		         CArray.Fun1.map constr_fun lfts' fbds))
     | FCoFix ((op,(lna,tys,bds)),e) ->
         let n = Array.length bds in
-        let ftys = Array.map (mk_clos e) tys in
-        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+        let ftys = CArray.Fun1.map mk_clos e tys in
+        let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in
 	let lfts' = el_liftn (Array.length bds) lfts in
-	mkCoFix (op, (lna, Array.map (constr_fun lfts) ftys,
-		           Array.map (constr_fun lfts') fbds))
+	mkCoFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys,
+		           CArray.Fun1.map constr_fun lfts' fbds))
     | FApp (f,ve) ->
 	mkApp (constr_fun lfts f,
-	       Array.map (constr_fun lfts) ve)
+	       CArray.Fun1.map constr_fun lfts ve)
+    | FProj (p,c) ->
+        mkProj (p,constr_fun lfts c)
+
     | FLambda _ ->
         let (na,ty,bd) = destFLambda mk_clos2 v in
 	mkLambda (na, constr_fun lfts ty,
@@ -630,9 +614,9 @@ let rec to_constr constr_fun lfts v =
     | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a
     | FCLOS (t,env) ->
         let fr = mk_clos2 env t in
-        let unfv = update v (fr.norm,fr.term) in
+        let unfv = update v fr.norm fr.term in
         to_constr constr_fun lfts unfv
-    | FLOCKED -> assert false (*mkVar(id_of_string"_LOCK_")*)
+    | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*)
 
 (* This function defines the correspondance between constr and
    fconstr. When we find a closure whose substitution is the identity,
@@ -641,11 +625,11 @@ let rec to_constr constr_fun lfts v =
 let term_of_fconstr =
   let rec term_of_fconstr_lift lfts v =
     match v.term with
-      | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t
-      | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts ->
+      | FCLOS(t,env) when is_subs_id env && is_lift_id lfts -> t
+      | FLambda(_,tys,f,e) when is_subs_id e && is_lift_id lfts ->
           compose_lam (List.rev tys) f
-      | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx
-      | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx
+      | FFix(fx,e) when is_subs_id e && is_lift_id lfts -> mkFix fx
+      | FCoFix(cfx,e) when is_subs_id e && is_lift_id lfts -> mkCoFix cfx
       | _ -> to_constr term_of_fconstr_lift lfts v in
   term_of_fconstr_lift el_id
 
@@ -663,14 +647,19 @@ let rec zip m stk =
     | [] -> m
     | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s
     | Zcase(ci,p,br)::s ->
-        let t = FCases(ci, p, m, br) in
+        let t = FCase(ci, p, m, br) in
+        zip {norm=neutr m.norm; term=t} s
+    | ZcaseT(ci,p,br,e)::s ->
+        let t = FCaseT(ci, p, m, br, e) in
         zip {norm=neutr m.norm; term=t} s
+    | Zproj (i,j,cst) :: s -> 
+        zip {norm=neutr m.norm; term=FProj(Projection.make cst true,m)} s
     | Zfix(fx,par)::s ->
         zip fx (par @ append_stack [|m|] s)
     | Zshift(n)::s ->
         zip (lift_fconstr n m) s
     | Zupdate(rf)::s ->
-        zip (update rf (m.norm,m.term)) s
+        zip (update rf m.norm m.term) s
 
 let fapp_stack (m,stk) = zip m stk
 
@@ -682,8 +671,7 @@ let fapp_stack (m,stk) = zip m stk
    (strip_update_shift, through get_arg). *)
 
 (* optimised for the case where there are no shifts... *)
-let strip_update_shift_app head stk =
-  assert (head.norm <> Red);
+let strip_update_shift_app_red head stk =
   let rec strip_rec rstk h depth = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s
@@ -691,13 +679,16 @@ let strip_update_shift_app head stk =
         strip_rec (Zapp args :: rstk)
           {norm=h.norm;term=FApp(h,args)} depth s
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) depth s
+        strip_rec rstk (update m h.norm h.term) depth s
     | 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);
+  strip_update_shift_app_red head stack
 
 let get_nth_arg head n stk =
-  assert (head.norm <> Red);
+  assert (match head.norm with Red -> false | _ -> true);
   let rec strip_rec rstk h n = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) n s
@@ -710,10 +701,10 @@ let get_nth_arg head n stk =
           let bef = Array.sub args 0 n in
           let aft = Array.sub args (n+1) (q-n-1) in
           let stk' =
-            List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
+            List.rev (if Int.equal n 0 then rstk else (Zapp bef :: rstk)) in
           (Some (stk', args.(n)), append_stack aft s')
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) n s
+        strip_rec rstk (update m h.norm h.term) n s
     | s -> (None, List.rev rstk @ s) in
   strip_rec [] head n stk
 
@@ -722,7 +713,7 @@ let get_nth_arg head n stk =
 let rec get_args n tys f e stk =
   match stk with
       Zupdate r :: s ->
-        let _hd = update r (Cstr,FLambda(n,tys,f,e)) in
+        let _hd = update r Cstr (FLambda(n,tys,f,e)) in
         get_args n tys f e s
     | Zshift k :: s ->
         get_args n tys f (subs_shft (k,e)) s
@@ -734,13 +725,14 @@ let rec get_args n tys f e stk =
           let eargs = Array.sub l n (na-n) in
           (Inl (subs_cons(args,e)), Zapp eargs :: s)
         else (* more lambdas *)
-          let etys = list_skipn na tys in
+          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)
 
 (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
 let rec eta_expand_stack = function
-  | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s ->
+  | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ 
+	| Zshift _ | Zupdate _ as e) :: s ->
       e :: eta_expand_stack s
   | [] ->
       [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]]
@@ -751,29 +743,88 @@ 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 k=depth then s else reloc_rargs_rec (depth-k) s
+    | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s
     | _ -> stk
 
 let reloc_rargs depth stk =
-  if depth = 0 then stk else reloc_rargs_rec depth stk
+  if Int.equal depth 0 then stk else reloc_rargs_rec depth stk
 
-let rec drop_parameters depth n argstk =
+let rec try_drop_parameters depth n argstk =
   match argstk with
       Zapp args::s ->
         let q = Array.length args in
-        if n > q then drop_parameters depth (n-q) s
-        else if n = q then reloc_rargs depth s
+        if n > q then try_drop_parameters depth (n-q) s
+        else if Int.equal n q then reloc_rargs depth s
         else
           let aft = Array.sub args n (q-n) in
           reloc_rargs depth (append_stack aft s)
-    | Zshift(k)::s -> drop_parameters (depth-k) n s
+    | Zshift(k)::s -> try_drop_parameters (depth-k) n s
+    | [] -> 
+	if Int.equal n 0 then []
+	else raise Not_found
+    | _ -> assert false
+	(* strip_update_shift_app only produces Zapp and Zshift items *)
+
+let drop_parameters depth n argstk =
+  try try_drop_parameters depth n argstk
+  with Not_found ->
+  (* we know that n < stack_args_size(argstk) (if well-typed term) *) 
+  anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor")
+
+
+let rec get_parameters depth n argstk =
+  match argstk with
+      Zapp args::s ->
+        let q = Array.length args in
+        if n > q then Array.append args (get_parameters depth (n-q) s)
+        else if Int.equal n q then [||]
+        else Array.sub args 0 n
+    | Zshift(k)::s -> 
+      get_parameters (depth-k) n s
     | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *)
-	if n=0 then []
-	else anomaly
-	  "ill-typed term: found a match on a partially applied constructor"
+	if Int.equal n 0 then [||]
+	else raise Not_found (* Trying to eta-expand a partial application..., should do 
+				eta expansion first? *)
     | _ -> assert false
 	(* strip_update_shift_app only produces Zapp and Zshift items *)
 
+
+(** [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 
+    of ind, and the Constructor c of this inductive type applied to arguments
+    s.
+    @assumes [t] is an irreducible term, and not a constructor. [ind] is the inductive
+    of the constructor term [c] 
+    @raises Not_found if the inductive is not a primitive record, or if the 
+    constructor is partially applied.
+ *)
+let eta_expand_ind_stack env ind m s (f, s') =
+  let mib = lookup_mind (fst ind) env in
+    match mib.Declarations.mind_record with
+    | Some (Some (_,projs,pbs)) when
+	mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> 
+	(* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') ->
+	   arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *)
+      let pars = mib.Declarations.mind_nparams in
+      let right = fapp_stack (f, s') in
+      let (depth, args, s) = strip_update_shift_app m s in
+      (** Try to drop the params, might fail on partially applied constructors. *)
+      let argss = try_drop_parameters depth pars args in
+      let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *)
+					 term = FProj (Projection.make p true, right) }) projs in
+	argss, [Zapp hstack]	
+    | _ -> raise Not_found (* disallow eta-exp for non-primitive records *)
+
+let rec project_nth_arg n argstk =
+  match argstk with
+  | 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
+      (* After drop_parameters we have a purely applicative stack *)
+
+
 (* Iota reduction: expansion of a fixpoint.
  * Given a fixpoint and a substitution, returns the corresponding
  * fixpoint body, and the substitution in which it should be
@@ -798,39 +849,51 @@ let contract_fix_vect fix =
   in
   (subs_cons(Array.init nfix make_body, env), thisbody)
 
-
 (*********************************************************************)
 (* A machine that inspects the head of a term until it finds an
    atom or a subterm that may produce a redex (abstraction,
    constructor, cofix, letin, constant), or a neutral term (product,
    inductive) *)
-let rec knh m stk =
+let rec knh info m stk =
   match m.term with
-    | FLIFT(k,a) -> knh a (zshift k stk)
-    | FCLOS(t,e) -> knht e t (zupdate m stk)
+    | FLIFT(k,a) -> knh info a (zshift k stk)
+    | FCLOS(t,e) -> knht info e t (zupdate m stk)
     | FLOCKED -> assert false
-    | FApp(a,b) -> knh a (append_stack b (zupdate m stk))
-    | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk)
+    | FApp(a,b) -> knh info a (append_stack b (zupdate m stk))
+    | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk)
+    | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate m stk)
     | FFix(((ri,n),(_,_,_)),_) ->
         (match get_nth_arg m ri.(n) stk with
-             (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk')
+             (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk')
            | (None, stk') -> (m,stk'))
-    | FCast(t,_,_) -> knh t stk
+    | FCast(t,_,_) -> knh info t stk
+    | FProj (p,c) ->
+      let unf = Projection.unfolded p in
+        if unf || red_set info.i_flags (fCONST (Projection.constant p)) then
+          (match try Some (lookup_projection p (info_env info)) with Not_found -> None with
+	  | None -> (m, stk)
+	  | Some pb ->
+	     knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, 
+				Projection.constant p)
+			 :: zupdate m stk))
+	else (m,stk)
+
 (* cases where knh stops *)
     | (FFlex _|FLetIn _|FConstruct _|FEvar _|
        FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) ->
         (m, stk)
 
 (* The same for pure terms *)
-and knht e t stk =
+and knht info e t stk =
   match kind_of_term t with
     | App(a,b) ->
-        knht e a (append_stack (mk_clos_vect e b) stk)
+        knht info e a (append_stack (mk_clos_vect e b) stk)
     | Case(ci,p,t,br) ->
-        knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk)
-    | Fix _ -> knh (mk_clos2 e t) stk
-    | Cast(a,_,_) -> knht e a stk
-    | Rel n -> knh (clos_rel e n) stk
+        knht info e t (ZcaseT(ci, p, br, e)::stk)
+    | Fix _ -> knh info (mk_clos2 e t) stk
+    | Cast(a,_,_) -> knht info e a stk
+    | Rel n -> knh info (clos_rel e n) stk
+    | Proj (p,c) -> knh info (mk_clos2 e t) stk
     | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
        LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
         (mk_clos2 e t, stk)
@@ -845,8 +908,8 @@ let rec knr info m stk =
       (match get_args n tys f e stk with
           Inl e', s -> knit info e' f s
         | Inr lam, s -> (lam,s))
-  | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) ->
-      (match ref_value_cache info (ConstKey kn) with
+  | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) ->
+      (match ref_value_cache info (ConstKey c) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
   | FFlex(VarKey id) when red_set info.i_flags (fVAR id) ->
@@ -857,38 +920,46 @@ let rec knr info m stk =
       (match ref_value_cache info (RelKey k) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
-  | FConstruct(ind,c) when red_set info.i_flags fIOTA ->
+  | FConstruct((ind,c),u) when red_set info.i_flags fIOTA ->
       (match strip_update_shift_app m stk with
           (depth, args, Zcase(ci,_,br)::s) ->
             assert (ci.ci_npar>=0);
             let rargs = drop_parameters depth ci.ci_npar args in
             kni info br.(c-1) (rargs@s)
+        | (depth, args, ZcaseT(ci,_,br,e)::s) ->
+            assert (ci.ci_npar>=0);
+            let rargs = drop_parameters depth ci.ci_npar args in
+            knit info e br.(c-1) (rargs@s)
         | (_, cargs, Zfix(fx,par)::s) ->
             let rarg = fapp_stack(m,cargs) in
             let stk' = par @ append_stack [|rarg|] s in
             let (fxe,fxbd) = contract_fix_vect fx.term in
             knit info fxe fxbd stk'
+	| (depth, args, Zproj (n, m, cst)::s) ->
+	    let rargs = drop_parameters depth n args in
+	    let rarg = project_nth_arg m rargs in
+	      kni info rarg s
         | (_,args,s) -> (m,args@s))
   | FCoFix _ when red_set info.i_flags fIOTA ->
       (match strip_update_shift_app m stk with
-          (_, args, ((Zcase _::_) as stk')) ->
+          (_, args, (((Zcase _|ZcaseT _)::_) as stk')) ->
             let (fxe,fxbd) = contract_fix_vect m.term in
             knit info fxe fxbd (args@stk')
         | (_,args,s) -> (m,args@s))
   | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA ->
       knit info (subs_cons([|v|],e)) bd stk
   | FEvar(ev,env) ->
-      (match evar_value info ev with
+      (match evar_value info.i_cache ev with
           Some c -> knit info env c stk
         | None -> (m,stk))
   | _ -> (m,stk)
 
 (* Computes the weak head normal form of a term *)
 and kni info m stk =
-  let (hm,s) = knh m stk in
+  let (hm,s) = knh info m stk in
   knr info hm s
 and knit info e t stk =
-  let (ht,s) = knht e t stk in
+  let (ht,s) = knht info e t stk in
   knr info ht s
 
 let kh info v stk = fapp_stack(kni info v stk)
@@ -903,6 +974,13 @@ let rec zip_term zfun m stk =
     | Zcase(ci,p,br)::s ->
         let t = mkCase(ci, zfun p, m, Array.map zfun br) in
         zip_term zfun t s
+    | ZcaseT(ci,p,br,e)::s ->
+        let t = mkCase(ci, zfun (mk_clos e p), m,
+		       Array.map (fun b -> zfun (mk_clos e b)) br) in
+        zip_term zfun t s
+    | Zproj(_,_,p)::s -> 
+        let t = mkProj (Projection.make p true, m) in 
+	zip_term zfun t s
     | Zfix(fx,par)::s ->
         let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in
         zip_term zfun h s
@@ -940,17 +1018,19 @@ and norm_head info m =
       | FProd(na,dom,rng) ->
           mkProd(na, kl info dom, kl info rng)
       | FCoFix((n,(na,tys,bds)),e) ->
-          let ftys = Array.map (mk_clos e) tys in
+          let ftys = CArray.Fun1.map mk_clos e tys in
           let fbds =
-            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
-          mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+            CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
+          mkCoFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds))
       | FFix((n,(na,tys,bds)),e) ->
-          let ftys = Array.map (mk_clos e) tys in
+          let ftys = CArray.Fun1.map mk_clos e tys in
           let fbds =
-            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
-          mkFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+            CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
+          mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds))
       | FEvar((i,args),env) ->
           mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args)
+      | FProj (p,c) ->
+          mkProj (p, kl info c)
       | t -> term_of_fconstr m
 
 (* Initialization and then normalization *)
@@ -963,7 +1043,7 @@ let whd_val info v =
 let norm_val info v =
   with_stats (lazy (kl info v))
 
-let inject = mk_clos (subs_id 0)
+let inject c = mk_clos (subs_id 0) c
 
 let whd_stack infos m stk =
   let k = kni infos m stk in
@@ -975,5 +1055,22 @@ type clos_infos = fconstr infos
 
 let create_clos_infos ?(evars=fun _ -> None) flgs env =
   create (fun _ -> inject) flgs env evars
-
-let unfold_reference = ref_value_cache
+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 }
+
+let unfold_reference info key = 
+  match key with
+  | ConstKey (kn,_) ->
+    if red_set info.i_flags (fCONST kn) then
+      ref_value_cache info key  
+    else None
+  | VarKey i -> 
+    if red_set info.i_flags (fVAR i) then
+      ref_value_cache info key
+    else None
+  | _ -> ref_value_cache info key
+  
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 0818d42f..a3b0e0f3 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp
 open Names
 open Term
 open Environ
@@ -37,13 +36,16 @@ module type RedFlagsSig = sig
   type reds
   type red_kind
 
-  (** The different kinds of reduction *)
+  (** {7 The different kinds of reduction } *)
+
   val fBETA : red_kind
   val fDELTA : red_kind
+  val fETA : red_kind
+  (** This flag is never used by the kernel reduction but pretyping does *)
   val fIOTA : red_kind
   val fZETA : red_kind
   val fCONST : constant -> red_kind
-  val fVAR : identifier -> red_kind
+  val fVAR : Id.t -> red_kind
 
   (** No reduction at all *)
   val no_red : reds
@@ -62,7 +64,10 @@ module type RedFlagsSig = sig
 
   (** Tests if a reduction kind is set *)
   val red_set : reds -> red_kind -> bool
-
+    
+  (** This tests if the projection is in unfolded state already or
+      is unfodable due to delta. *)
+  val red_projection : reds -> projection -> bool
 end
 
 module RedFlags : RedFlagsSig
@@ -78,14 +83,20 @@ val unfold_side_red : reds
 val unfold_red : evaluable_global_reference -> reds
 
 (***********************************************************************)
-type table_key = id_key
+type table_key = constant puniverses tableKey
+
+type 'a infos_cache
+type 'a infos = { 
+  i_flags : reds;
+  i_cache : 'a infos_cache }
 
-type 'a infos
 val ref_value_cache: 'a infos -> table_key -> 'a option
-val info_flags: 'a infos -> reds
 val create: ('a infos -> constr -> 'a) -> reds -> env ->
   (existential -> constr option) -> 'a infos
-val evar_value : 'a infos -> existential -> constr option
+val evar_value : 'a infos_cache -> existential -> constr option
+
+val info_env : 'a infos -> env
+val info_flags: 'a infos -> reds
 
 (***********************************************************************
   s Lazy reduction. *)
@@ -102,15 +113,17 @@ type fterm =
   | FAtom of constr (** Metas and Sorts *)
   | FCast of fconstr * cast_kind * fconstr
   | FFlex of table_key
-  | FInd of inductive
-  | FConstruct of constructor
+  | FInd of inductive puniverses
+  | FConstruct of constructor puniverses
   | FApp of fconstr * fconstr array
+  | FProj of projection * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * fconstr subs
-  | FCases of case_info * fconstr * fconstr * fconstr array
-  | FLambda of int * (name * constr) list * constr * fconstr subs
-  | FProd of name * fconstr * fconstr
-  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | FCase of case_info * fconstr * fconstr * fconstr array
+  | 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
   | FEvar of existential * fconstr subs
   | FLIFT of int * fconstr
   | FCLOS of constr * fconstr subs
@@ -124,6 +137,8 @@ type fterm =
 type stack_member =
   | Zapp of fconstr array
   | Zcase of case_info * fconstr * fconstr array
+  | ZcaseT of case_info * constr * constr array * fconstr subs
+  | Zproj of int * int * constant
   | Zfix of fconstr * stack
   | Zshift of int
   | Zupdate of fconstr
@@ -154,12 +169,17 @@ val mk_atom : constr -> fconstr
 val fterm_of : fconstr -> fterm
 val term_of_fconstr : fconstr -> constr
 val destFLambda :
-  (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
+  (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr
 
 (** Global and local constant cache *)
-type clos_infos
+type clos_infos = fconstr infos
 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 : clos_infos -> env
+
+val infos_with_reds : clos_infos -> reds -> clos_infos
 
 (** Reduction function *)
 
@@ -174,6 +194,18 @@ val whd_val : clos_infos -> fconstr -> constr
 val whd_stack :
   clos_infos -> 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 
+    of ind, and the Constructor c of this inductive type applied to arguments
+    s.
+    @assumes [t] is a rigid term, and not a constructor. [ind] is the inductive
+    of the constructor term [c] 
+    @raises Not_found if the inductive is not a primitive record, or if the 
+    constructor is partially applied.
+ *)
+val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> 
+   (fconstr * stack) -> stack * stack
+
 (** Conversion auxiliary functions to do step by step normalisation *)
 
 (** [unfold_reference] unfolds references in a [fconstr] *)
@@ -198,6 +230,5 @@ val knr: clos_infos -> fconstr -> stack -> fconstr * stack
 val kl : clos_infos -> fconstr -> constr
 
 val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
-val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
 
 (** End of cbn debug section i*)
diff --git a/kernel/constr.ml b/kernel/constr.ml
new file mode 100644
index 00000000..49f74841
--- /dev/null
+++ b/kernel/constr.ml
@@ -0,0 +1,1011 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
+(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
+(* Extension to mutual inductive constructions by Christine Paulin for
+   Coq V5.10.2 *)
+(* Extension to co-inductive constructions by Eduardo Gimenez *)
+(* Optimization of substitution functions by Chet Murthy *)
+(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Restructuration of Coq of the type-checking kernel by Jean-Christophe 
+   Filliâtre, 1999 *)
+(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+
+(* This file defines the internal syntax of the Calculus of
+   Inductive Constructions (CIC) terms together with constructors,
+   destructors, iterators and basic functions *)
+
+open Util
+open Names
+open Univ
+
+type existential_key = Evar.t
+type metavariable = int
+
+(* This defines the strategy to use for verifiying a Cast *)
+(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
+(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
+type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast
+
+(* This defines Cases annotations *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
+type case_printing =
+  { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *)
+    cstr_tags : bool list array; (* whether each pattern var of each constructor is a let-in (true) or not (false) *)
+    style     : case_style }
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*)
+    ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *)
+    ci_pp_info    : case_printing (* not interpreted by the kernel *)
+  }
+
+(********************************************************************)
+(*       Constructions as implemented                               *)
+(********************************************************************)
+
+(* [constr array] is an instance matching definitional [named_context] in
+   the same order (i.e. last argument first) *)
+type 'constr pexistential = existential_key * 'constr array
+type ('constr, 'types) prec_declaration =
+    Name.t array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+type 'a puniverses = 'a Univ.puniverses
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+(* [Var] is used for named variables and [Rel] for variables as
+   de Bruijn indices. *)
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of Id.t
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of Sorts.t
+  | Cast      of 'constr * cast_kind * 'types
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of pconstant
+  | Ind       of pinductive
+  | Construct of pconstructor
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
+(* constr is the fixpoint of the previous type. Requires option
+   -rectypes of the Caml compiler to be set *)
+type t = (t,t) kind_of_term
+type constr = t
+
+type existential = existential_key * constr array
+type rec_declaration = Name.t array * constr array * constr array
+type fixpoint = (int array * int) * rec_declaration
+type cofixpoint = int * rec_declaration
+
+type types = constr
+
+(*********************)
+(* Term constructors *)
+(*********************)
+
+(* Constructs a DeBrujin index with number n *)
+let rels =
+  [|Rel  1;Rel  2;Rel  3;Rel  4;Rel  5;Rel  6;Rel  7; Rel  8;
+    Rel  9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|]
+
+let mkRel n = if 0<n && n<=16 then rels.(n-1) else Rel n
+
+(* Construct a type *)
+let mkProp   = Sort Sorts.prop
+let mkSet    = Sort Sorts.set
+let mkType u = Sort (Sorts.Type u)
+let mkSort   = function
+  | Sorts.Prop Sorts.Null -> mkProp (* Easy sharing *)
+  | Sorts.Prop Sorts.Pos -> mkSet
+  | s -> Sort s
+
+(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
+(* (that means t2 is declared as the type of t1) *)
+let mkCast (t1,k2,t2) =
+  match t1 with
+  | Cast (c,k1, _) when (k1 == VMcast || k1 == NATIVEcast) && k1 == k2 -> Cast (c,k1,t2)
+  | _ -> Cast (t1,k2,t2)
+
+(* Constructs the product (x:t1)t2 *)
+let mkProd (x,t1,t2) = Prod (x,t1,t2)
+
+(* Constructs the abstraction [x:t1]t2 *)
+let mkLambda (x,t1,t2) = Lambda (x,t1,t2)
+
+(* Constructs [x=c_1:t]c_2 *)
+let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
+
+(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
+(* We ensure applicative terms have at least one argument and the
+   function is not itself an applicative term *)
+let mkApp (f, a) =
+  if Int.equal (Array.length a) 0 then f else
+    match f with
+      | App (g, cl) -> App (g, Array.append cl a)
+      | _ -> App (f, a)
+
+let map_puniverses f (x,u) = (f x, u)
+let in_punivs a = (a, Univ.Instance.empty)
+
+(* Constructs a constant *)
+let mkConst c = Const (in_punivs c)
+let mkConstU c = Const c
+
+(* Constructs an applied projection *)
+let mkProj (p,c) = Proj (p,c)
+
+(* Constructs an existential variable *)
+let mkEvar e = Evar e
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+let mkInd m = Ind (in_punivs m)
+let mkIndU m = Ind m
+
+(* Constructs the jth constructor of the ith (co)inductive type of the
+   block named kn. *)
+let mkConstruct c = Construct (in_punivs c)
+let mkConstructU c = Construct c
+let mkConstructUi ((ind,u),i) = Construct ((ind,i),u)
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
+
+(* If recindxs = [|i1,...in|]
+      funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then
+
+      mkFix ((recindxs,i),(funnames,typarray,bodies))
+
+   constructs the ith function of the block
+
+    Fixpoint f1 [ctx1] : t1 := b1
+    with     f2 [ctx2] : t2 := b2
+    ...
+    with     fn [ctxn] : tn := bn.
+
+   where the length of the jth context is ij.
+*)
+
+let mkFix fix = Fix fix
+
+(* If funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then
+
+      mkCoFix (i,(funnames,typsarray,bodies))
+
+   constructs the ith function of the block
+
+    CoFixpoint f1 : t1 := b1
+    with       f2 : t2 := b2
+    ...
+    with       fn : tn := bn.
+*)
+let mkCoFix cofix= CoFix cofix
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta  n =  Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
+
+
+(************************************************************************)
+(*    kind_of_term = constructions as seen by the user                 *)
+(************************************************************************)
+
+(* User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+let kind c = c
+
+(****************************************************************************)
+(*              Functions to recur through subterms                         *)
+(****************************************************************************)
+
+(* [fold f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+let fold f acc c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> 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
+  | LetIn (_,b,t,c) -> f (f (f acc b) t) c
+  | App (c,l) -> Array.fold_left f (f acc c) l
+  | Proj (p,c) -> f acc c
+  | Evar (_,l) -> Array.fold_left f acc l
+  | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
+  | Fix (_,(lna,tl,bl)) ->
+    Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl
+  | CoFix (_,(lna,tl,bl)) ->
+    Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl
+
+(* [iter f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+let iter f c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,_,t) -> f c; f t
+  | Prod (_,t,c) -> f t; f c
+  | Lambda (_,t,c) -> f t; f c
+  | LetIn (_,b,t,c) -> f b; f t; f c
+  | App (c,l) -> f c; Array.iter f l
+  | Proj (p,c) -> f c
+  | Evar (_,l) -> Array.iter f l
+  | Case (_,p,c,bl) -> f p; f c; Array.iter f bl
+  | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+  | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+
+(* [iter_with_binders g f n c] iters [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let iter_with_binders g f n c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,_,t) -> f n c; f n t
+  | Prod (_,t,c) -> f n t; f (g n) c
+  | Lambda (_,t,c) -> f n t; f (g n) c
+  | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
+  | App (c,l) -> f n c; CArray.Fun1.iter f n l
+  | Evar (_,l) -> CArray.Fun1.iter f n l
+  | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl
+  | Proj (p,c) -> f n c
+  | Fix (_,(_,tl,bl)) ->
+      CArray.Fun1.iter f n tl;
+      CArray.Fun1.iter f (iterate g (Array.length tl) n) bl
+  | CoFix (_,(_,tl,bl)) ->
+      CArray.Fun1.iter f n tl;
+      CArray.Fun1.iter f (iterate g (Array.length tl) n) bl
+
+(* [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 *)
+
+let map f c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c
+  | Cast (b,k,t) ->
+      let b' = f b in
+      let t' = f t in
+      if b'==b && t' == t then c
+      else mkCast (b', k, t')
+  | Prod (na,t,b) ->
+      let b' = f b in
+      let t' = f t in
+      if b'==b && t' == t then c
+      else mkProd (na, t', b')
+  | Lambda (na,t,b) ->
+      let b' = f b in
+      let t' = f t in
+      if b'==b && t' == t then c
+      else mkLambda (na, t', b')
+  | LetIn (na,b,t,k) ->
+      let b' = f b in
+      let t' = f t in
+      let k' = f k in
+      if b'==b && t' == t && k'==k then c
+      else mkLetIn (na, b', t', k')
+  | App (b,l) ->
+      let b' = f b in
+      let l' = Array.smartmap f l in
+      if b'==b && l'==l then c
+      else mkApp (b', l')
+  | Proj (p,t) ->
+      let t' = f t in
+      if t' == t then c
+      else mkProj (p, t')
+  | Evar (e,l) ->
+      let l' = Array.smartmap f l in
+      if l'==l then c
+      else mkEvar (e, l')
+  | Case (ci,p,b,bl) ->
+      let b' = f b in
+      let p' = f p in
+      let bl' = Array.smartmap f bl in
+      if b'==b && p'==p && bl'==bl then c
+      else mkCase (ci, p', b', bl')
+  | Fix (ln,(lna,tl,bl)) ->
+      let tl' = Array.smartmap f tl in
+      let bl' = Array.smartmap f bl in
+      if tl'==tl && bl'==bl then c
+      else mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let tl' = Array.smartmap f tl in
+      let bl' = Array.smartmap f bl in
+      if tl'==tl && bl'==bl then c
+      else mkCoFix (ln,(lna,tl',bl'))
+
+(* Like {!map} but with an accumulator. *)
+
+let fold_map f accu c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> accu, c
+  | Cast (b,k,t) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      if b'==b && t' == t then accu, c
+      else accu, mkCast (b', k, t')
+  | Prod (na,t,b) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      if b'==b && t' == t then accu, c
+      else accu, mkProd (na, t', b')
+  | Lambda (na,t,b) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      if b'==b && t' == t then accu, c
+      else accu, mkLambda (na, t', b')
+  | LetIn (na,b,t,k) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      let accu, k' = f accu k in
+      if b'==b && t' == t && k'==k then accu, c
+      else accu, mkLetIn (na, b', t', k')
+  | App (b,l) ->
+      let accu, b' = f accu b in
+      let accu, l' = Array.smartfoldmap f accu l in
+      if b'==b && l'==l then accu, c
+      else accu, mkApp (b', l')
+  | Proj (p,t) ->
+      let accu, t' = f accu t in
+      if t' == t then accu, c
+      else accu, mkProj (p, t')
+  | Evar (e,l) ->
+      let accu, l' = Array.smartfoldmap f accu l in
+      if l'==l then accu, c
+      else accu, mkEvar (e, l')
+  | Case (ci,p,b,bl) ->
+      let accu, b' = f accu b in
+      let accu, p' = f accu p in
+      let accu, bl' = Array.smartfoldmap f accu bl in
+      if b'==b && p'==p && bl'==bl then accu, c
+      else accu, mkCase (ci, p', b', bl')
+  | Fix (ln,(lna,tl,bl)) ->
+      let accu, tl' = Array.smartfoldmap f accu tl in
+      let accu, bl' = Array.smartfoldmap f accu bl in
+      if tl'==tl && bl'==bl then accu, c
+      else accu, mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let accu, tl' = Array.smartfoldmap f accu tl in
+      let accu, bl' = Array.smartfoldmap f accu bl in
+      if tl'==tl && bl'==bl then accu, c
+      else accu, mkCoFix (ln,(lna,tl',bl'))
+
+(* [map_with_binders g f n c] maps [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let map_with_binders g f l c0 = match kind c0 with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c0
+  | Cast (c, k, t) ->
+    let c' = f l c in
+    let t' = f l t in
+    if c' == c && t' == t then c0
+    else mkCast (c', k, t')
+  | Prod (na, t, c) ->
+    let t' = f l t in
+    let c' = f (g l) c in
+    if t' == t && c' == c then c0
+    else mkProd (na, t', c')
+  | Lambda (na, t, c) ->
+    let t' = f l t in
+    let c' = f (g l) c in
+    if t' == t && c' == c then c0
+    else mkLambda (na, t', c')
+  | LetIn (na, b, t, c) ->
+    let b' = f l b in
+    let t' = f l t in
+    let c' = f (g l) c in
+    if b' == b && t' == t && c' == c then c0
+    else mkLetIn (na, b', t', c')
+  | App (c, al) ->
+    let c' = f l c in
+    let al' = CArray.Fun1.smartmap f l al in
+    if c' == c && al' == al then c0
+    else mkApp (c', al')
+  | Proj (p, t) ->
+    let t' = f l t in
+    if t' == t then c0
+    else mkProj (p, t')
+  | Evar (e, al) ->
+    let al' = CArray.Fun1.smartmap f l al in
+    if al' == al then c0
+    else mkEvar (e, al')
+  | Case (ci, p, c, bl) ->
+    let p' = f l p in
+    let c' = f l c in
+    let bl' = CArray.Fun1.smartmap f l bl in
+    if p' == p && c' == c && bl' == bl then c0
+    else mkCase (ci, p', c', bl')
+  | Fix (ln, (lna, tl, bl)) ->
+    let tl' = CArray.Fun1.smartmap f l tl in
+    let l' = iterate g (Array.length tl) l in
+    let bl' = CArray.Fun1.smartmap f l' bl in
+    if tl' == tl && bl' == bl then c0
+    else mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+    let tl' = CArray.Fun1.smartmap f l tl in
+    let l' = iterate g (Array.length tl) l in
+    let bl' = CArray.Fun1.smartmap f l' bl in
+    mkCoFix (ln,(lna,tl',bl'))
+
+(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed, [u] to compare universe
+   instances and [s] to compare sorts; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let compare_head_gen eq_universes eq_sorts f t1 t2 =
+  match kind t1, kind t2 with
+  | Rel n1, Rel n2 -> Int.equal n1 n2
+  | Meta m1, Meta m2 -> Int.equal m1 m2
+  | Var id1, Var id2 -> Id.equal id1 id2
+  | Sort s1, Sort s2 -> eq_sorts s1 s2
+  | Cast (c1,_,_), _ -> f c1 t2
+  | _, Cast (c2,_,_) -> f t1 c2
+  | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 && f c1 c2
+  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 && f c1 c2
+  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 && f t1 t2 && f c1 c2
+  | App (Cast(c1, _, _),l1), _ -> f (mkApp (c1,l1)) t2
+  | _, App (Cast (c2, _, _),l2) -> f t1 (mkApp (c2,l2))
+  | App (c1,l1), App (c2,l2) ->
+    Int.equal (Array.length l1) (Array.length l2) &&
+      f c1 c2 && Array.equal f l1 l2
+  | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal f l1 l2
+  | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && f c1 c2
+  | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2
+  | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2
+  | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+      f p1 p2 && f c1 c2 && Array.equal f bl1 bl2
+  | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
+      Int.equal i1 i2 && Array.equal Int.equal ln1 ln2
+      && Array.equal f tl1 tl2 && Array.equal f bl1 bl2
+  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+      Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2
+  | _ -> false
+
+let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal
+
+(* [compare_head_gen_leq u s sl 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,
+   [u] to compare universe instances and [s] to compare sorts; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 =
+  match kind t1, kind t2 with
+  | Rel n1, Rel n2 -> Int.equal n1 n2
+  | Meta m1, Meta m2 -> Int.equal m1 m2
+  | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0
+  | Sort s1, Sort s2 -> leq_sorts s1 s2
+  | Cast (c1,_,_), _ -> leq c1 t2
+  | _, Cast (c2,_,_) -> leq t1 c2
+  | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2
+  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2
+  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2
+  | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2
+  | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2))
+  | App (c1,l1), App (c2,l2) ->
+    Int.equal (Array.length l1) (Array.length l2) &&
+      eq c1 c2 && Array.equal eq l1 l2
+  | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq c1 c2
+  | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2
+  | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2
+  | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2
+  | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+      eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2
+  | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
+      Int.equal i1 i2 && Array.equal Int.equal ln1 ln2
+      && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2
+  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+      Int.equal ln1 ln2 && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2
+  | _ -> false
+
+(*******************************)
+(*  alpha conversion functions *)
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+let rec eq_constr m n =
+  (m == n) || compare_head_gen (fun _ -> Instance.equal) Sorts.equal eq_constr m n
+
+let equal m n = eq_constr m n (* to avoid tracing a recursive fun *)
+
+let eq_constr_univs univs m n =
+  if m == n then true
+  else 
+    let eq_universes _ = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = s1 == s2 || Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in compare_head_gen eq_universes eq_sorts eq_constr' m n
+
+let leq_constr_univs univs m n =
+  if m == n then true
+  else 
+    let eq_universes _ = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = s1 == s2 || 
+      Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+    let leq_sorts s1 s2 = s1 == s2 || 
+      Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let rec compare_leq m n =
+      compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n
+    and leq_constr' m n = m == n || compare_leq m n in
+      compare_leq m n
+
+let eq_constr_univs_infer univs m n =
+  if m == n then true, Constraint.empty
+  else 
+    let cstrs = ref Constraint.empty in
+    let eq_universes strict = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_eq univs u1 u2 then true
+	  else
+	    (cstrs := Univ.enforce_eq u1 u2 !cstrs;
+	     true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in
+      res, !cstrs
+
+let leq_constr_univs_infer univs m n =
+  if m == n then true, Constraint.empty
+  else 
+    let cstrs = ref Constraint.empty in
+    let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_eq univs u1 u2 then true
+	  else (cstrs := Univ.enforce_eq u1 u2 !cstrs;
+		true)
+    in
+    let leq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else 
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_leq univs u1 u2 then true
+	  else
+	    (cstrs := Univ.enforce_leq u1 u2 !cstrs; 
+	     true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let rec compare_leq m n =
+      compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n
+    and leq_constr' m n = m == n || compare_leq m n in
+    let res = compare_leq m n in
+      res, !cstrs
+
+let always_true _ _ = true
+
+let rec eq_constr_nounivs m n =
+  (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n
+
+(** We only use this function over blocks! *)
+let tag t = Obj.tag (Obj.repr t)
+
+let constr_ord_int f t1 t2 =
+  let (=?) f g i1 i2 j1 j2=
+    let c = f i1 i2 in
+    if Int.equal c 0 then g j1 j2 else c in
+  let (==?) fg h i1 i2 j1 j2 k1 k2=
+    let c=fg i1 i2 j1 j2 in
+    if Int.equal c 0 then h k1 k2 else c in
+  let fix_cmp (a1, i1) (a2, i2) =
+    ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2
+  in
+  match kind t1, kind t2 with
+    | Rel n1, Rel n2 -> Int.compare n1 n2
+    | Meta m1, Meta m2 -> Int.compare m1 m2
+    | Var id1, Var id2 -> Id.compare id1 id2
+    | Sort s1, Sort s2 -> Sorts.compare s1 s2
+    | Cast (c1,_,_), _ -> f c1 t2
+    | _, Cast (c2,_,_) -> f t1 c2
+    | Prod (_,t1,c1), Prod (_,t2,c2)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+        (f =? f) t1 t2 c1 c2
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
+        ((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+    | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2
+    | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2))
+    | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2
+    | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2
+    | Evar (e1,l1), Evar (e2,l2) ->
+        (Evar.compare =? (Array.compare f)) e1 e2 l1 l2
+    | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2
+    | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2
+    | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+        ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+        ((fix_cmp =? (Array.compare f)) ==? (Array.compare f))
+        ln1 ln2 tl1 tl2 bl1 bl2
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+        ((Int.compare =? (Array.compare f)) ==? (Array.compare f))
+        ln1 ln2 tl1 tl2 bl1 bl2
+    | t1, t2 -> Int.compare (tag t1) (tag t2)
+
+let rec compare m n=
+  constr_ord_int compare m n
+
+(*******************)
+(*  hash-consing   *)
+(*******************)
+
+(* Hash-consing of [constr] does not use the module [Hashcons] because
+   [Hashcons] is not efficient on deep tree-like data
+   structures. Indeed, [Hashcons] is based the (very efficient)
+   generic hash function [Hashtbl.hash], which computes the hash key
+   through a depth bounded traversal of the data structure to be
+   hashed. As a consequence, for a deep [constr] like the natural
+   number 1000 (S (S (... (S O)))), the same hash is assigned to all
+   the sub [constr]s greater than the maximal depth handled by
+   [Hashtbl.hash]. This entails a huge number of collisions in the
+   hash table and leads to cubic hash-consing in this worst-case.
+
+   In order to compute a hash key that is independent of the data
+   structure depth while being constant-time, an incremental hashing
+   function must be devised. A standard implementation creates a cache
+   of the hashing function by decorating each node of the hash-consed
+   data structure with its hash key. In that case, the hash function
+   can deduce the hash key of a toplevel data structure by a local
+   computation based on the cache held on its substructures.
+   Unfortunately, this simple implementation introduces a space
+   overhead that is damageable for the hash-consing of small [constr]s
+   (the most common case). One can think of an heterogeneous
+   distribution of caches on smartly chosen nodes, but this is forbidden
+   by the use of generic equality in Coq source code. (Indeed, this forces
+   each [constr] to have a unique canonical representation.)
+
+   Given that hash-consing proceeds inductively, we can nonetheless
+   computes the hash key incrementally during hash-consing by changing
+   a little the signature of the hash-consing function: it now returns
+   both the hash-consed term and its hash key. This simple solution is
+   implemented in the following code: it does not introduce a space
+   overhead in [constr], that's why the efficiency is unchanged for
+   small [constr]s. Besides, it does handle deep [constr]s without
+   introducing an unreasonable number of collisions in the hash table.
+   Some benchmarks make us think that this implementation of
+   hash-consing is linear in the size of the hash-consed data
+   structure for our daily use of Coq.
+*)
+
+let array_eqeq t1 t2 =
+  t1 == t2 ||
+  (Int.equal (Array.length t1) (Array.length t2) &&
+   let rec aux i =
+     (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1))
+   in aux 0)
+
+let hasheq t1 t2 =
+  match t1, t2 with
+    | Rel n1, Rel n2 -> n1 == n2
+    | Meta m1, Meta m2 -> m1 == m2
+    | Var id1, Var id2 -> id1 == id2
+    | Sort s1, Sort s2 -> s1 == s2
+    | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 && k1 == k2 && t1 == t2
+    | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2
+    | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2
+    | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
+      n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2
+    | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2
+    | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2
+    | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2
+    | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2
+    | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> 
+      sp1 == sp2 && Int.equal i1 i2 && u1 == u2
+    | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) ->
+      sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && u1 == u2
+    | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
+      ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2
+    | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) ->
+      Int.equal i1 i2
+      && Array.equal Int.equal ln1 ln2
+      && array_eqeq lna1 lna2
+      && array_eqeq tl1 tl2
+      && array_eqeq bl1 bl2
+    | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+      Int.equal ln1 ln2
+      && array_eqeq lna1 lna2
+      && array_eqeq tl1 tl2
+      && array_eqeq bl1 bl2
+    | _ -> false
+
+(** Note that the following Make has the side effect of creating
+    once and for all the table we'll use for hash-consing all constr *)
+
+module HashsetTerm =
+  Hashset.Make(struct type t = constr let equal = hasheq end)
+
+module HashsetTermArray =
+  Hashset.Make(struct type t = constr array let equal = array_eqeq end)
+
+let term_table = HashsetTerm.create 19991
+(* The associative table to hashcons terms. *)
+
+let term_array_table = HashsetTermArray.create 4999
+(* The associative table to hashcons term arrays. *)
+
+open Hashset.Combine
+
+let hash_cast_kind = function
+| VMcast -> 0
+| NATIVEcast -> 1
+| DEFAULTcast -> 2
+| REVERTcast -> 3
+
+let sh_instance = Univ.Instance.share
+
+(* [hashcons hash_consing_functions constr] computes an hash-consed
+   representation for [constr] using [hash_consing_functions] on
+   leaves. *)
+let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
+  let rec hash_term t =
+    match t with
+      | Var i ->
+	(Var (sh_id i), combinesmall 1 (Id.hash i))
+      | Sort s ->
+	(Sort (sh_sort s), combinesmall 2 (Sorts.hash s))
+      | Cast (c, k, t) ->
+	let c, hc = sh_rec c in
+	let t, ht = sh_rec t in
+	(Cast (c, k, t), combinesmall 3 (combine3 hc (hash_cast_kind k) ht))
+      | Prod (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Prod (sh_na na, t, c), combinesmall 4 (combine3 (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))
+      | 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))
+      | App (c,l) ->
+	let c, hc = sh_rec c in
+	let l, hl = hash_term_array l in
+	(App (c,l), combinesmall 7 (combine hl hc))
+      | 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.hash p') hc))
+      | Const (c,u) ->
+	let c' = sh_con c in
+	let u', hu = sh_instance u in
+	(Const (c', u'), combinesmall 9 (combine (Constant.hash c) hu))
+      | Ind ((kn,i) as ind,u) ->
+	let u', hu = sh_instance u in
+	(Ind (sh_ind ind, u'), 
+	 combinesmall 10 (combine (ind_hash ind) hu))
+      | Construct ((((kn,i),j) as c,u))->
+	let u', hu = sh_instance u in
+	(Construct (sh_construct c, u'),
+	 combinesmall 11 (combine (constructor_hash c) hu))
+      | Case (ci,p,c,bl) ->
+	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
+	(Case (sh_ci ci, p, c, bl), combinesmall 12 hbl)
+      | Fix (ln,(lna,tl,bl)) ->
+	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 hna = Array.fold_left fold 0 lna in
+        let h = combine3 hna hbl htl in
+	(Fix (ln,(lna,tl,bl)), combinesmall 13 h)
+      | CoFix(ln,(lna,tl,bl)) ->
+	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 hna = Array.fold_left fold 0 lna in
+        let h = combine3 hna hbl htl in
+	(CoFix (ln,(lna,tl,bl)), combinesmall 14 h)
+      | Meta n ->
+	(t, combinesmall 15 n)
+      | Rel n ->
+	(t, combinesmall 16 n)
+
+  and sh_rec t =
+    let (y, h) = hash_term t in
+    (* [h] must be positive. *)
+    let h = h land 0x3FFFFFFF in
+    (HashsetTerm.repr h y term_table, h)
+
+  (* Note : During hash-cons of arrays, we modify them *in place* *)
+
+  and hash_term_array t =
+    let accu = ref 0 in
+    for i = 0 to Array.length t - 1 do
+      let x, h = sh_rec (Array.unsafe_get t i) in
+      accu := combine !accu h;
+      Array.unsafe_set t i x
+    done;
+    (* [h] must be positive. *)
+    let h = !accu land 0x3FFFFFFF in
+    (HashsetTermArray.repr h t term_array_table, h)
+
+  in
+  (* Make sure our statically allocated Rels (1 to 16) are considered
+     as canonical, and hence hash-consed to themselves *)
+  ignore (hash_term_array rels);
+
+  fun t -> fst (sh_rec t)
+
+(* Exported hashing fonction on constr, used mainly in plugins.
+   Appears to have slight differences from [snd (hash_term t)] above ? *)
+
+let rec hash t =
+  match kind t with
+    | Var i -> combinesmall 1 (Id.hash i)
+    | Sort s -> combinesmall 2 (Sorts.hash s)
+    | Cast (c, k, t) ->
+      let hc = hash c in
+      let ht = hash t in
+      combinesmall 3 (combine3 hc (hash_cast_kind k) ht)
+    | Prod (_, t, c) -> combinesmall 4 (combine (hash t) (hash c))
+    | Lambda (_, t, c) -> combinesmall 5 (combine (hash t) (hash c))
+    | LetIn (_, b, t, c) ->
+      combinesmall 6 (combine3 (hash b) (hash t) (hash c))
+    | 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) ->
+      combinesmall 9 (combine (Constant.hash c) (Instance.hash u))
+    | Ind (ind,u) ->
+      combinesmall 10 (combine (ind_hash ind) (Instance.hash u))
+    | Construct (c,u) ->
+      combinesmall 11 (combine (constructor_hash c) (Instance.hash u))
+    | Case (_ , p, c, bl) ->
+      combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl))
+    | Fix (ln ,(_, tl, bl)) ->
+      combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
+    | CoFix(ln, (_, tl, bl)) ->
+       combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
+    | Meta n -> combinesmall 15 n
+    | Rel n -> combinesmall 16 n
+
+and hash_term_array t =
+  Array.fold_left (fun acc t -> combine (hash t) acc) 0 t
+
+module CaseinfoHash =
+struct
+  type t = case_info
+  type u = inductive -> inductive
+  let hashcons hind ci = { ci with ci_ind = hind ci.ci_ind }
+  let pp_info_equal info1 info2 =
+    List.equal (==) info1.ind_tags info2.ind_tags &&
+    Array.equal (List.equal (==)) info1.cstr_tags info2.cstr_tags &&
+    info1.style == info2.style
+  let equal ci ci' =
+    ci.ci_ind == ci'.ci_ind &&
+    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 *)
+    pp_info_equal ci.ci_pp_info ci'.ci_pp_info  (* we use (=) on purpose *)
+  open Hashset.Combine
+  let hash_bool b = if b then 0 else 1
+  let hash_bool_list = List.fold_left (fun n b -> combine n (hash_bool b))
+  let hash_pp_info info =
+    let h1 = match info.style with
+    | LetStyle -> 0
+    | IfStyle -> 1
+    | LetPatternStyle -> 2
+    | MatchStyle -> 3
+    | RegularStyle -> 4 in
+    let h2 = hash_bool_list 0 info.ind_tags in
+    let h3 = Array.fold_left hash_bool_list 0 info.cstr_tags in
+    combine3 h1 h2 h3
+  let hash ci =
+    let h1 = ind_hash ci.ci_ind in
+    let h2 = Int.hash ci.ci_npar in
+    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
+end
+
+module Hcaseinfo = Hashcons.Make(CaseinfoHash)
+
+let case_info_hash = CaseinfoHash.hash
+
+module Hsorts =
+  Hashcons.Make(
+    struct
+      open Sorts
+
+      type t = Sorts.t
+      type u = universe -> universe
+      let hashcons huniv = function
+          Prop c -> Prop c
+        | Type u -> Type (huniv u)
+      let equal s1 s2 =
+        s1 == s2 ||
+	  match (s1,s2) with
+            (Prop c1, Prop c2) -> c1 == c2
+          | (Type u1, Type u2) -> u1 == u2
+          |_ -> false
+      let hash = function
+	| Prop Null -> 0 | Prop Pos -> 1
+	| Type u -> 2 + Universe.hash u
+    end)
+
+(* let hcons_sorts = Hashcons.simple_hcons Hsorts.generate hcons_univ *)
+let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate Hcaseinfo.hcons hcons_ind
+
+let hcons =
+  hashcons
+    (Sorts.hcons,
+     hcons_caseinfo,
+     hcons_construct,
+     hcons_ind,
+     hcons_con,
+     Name.hcons,
+     Id.hcons)
+
+(* let hcons_types = hcons_constr *)
+
+(*******)
+(* Type of abstract machine values *)
+(** FIXME: nothing to do there *)
+type values
diff --git a/kernel/constr.mli b/kernel/constr.mli
new file mode 100644
index 00000000..5d11511b
--- /dev/null
+++ b/kernel/constr.mli
@@ -0,0 +1,313 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+
+(** {6 Value under universe substitution } *)
+type 'a puniverses = 'a Univ.puniverses
+
+(** {6 Simply type aliases } *)
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+(** {6 Existential variables } *)
+type existential_key = Evar.t
+
+(** {6 Existential variables } *)
+type metavariable = int
+
+(** {6 Case annotation } *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle 
+  | RegularStyle (** infer printing form from number of constructor *)
+type case_printing =
+  { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *)
+    cstr_tags : bool list array; (** tell whether letin or lambda in the signature of each constructor *)
+    style     : case_style }
+
+(** the integer is the number of real args, needed for reduction *)
+type case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*)
+    ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *)
+    ci_pp_info    : case_printing (** not interpreted by the kernel *)
+  }
+
+(** {6 The type of constructions } *)
+
+type t
+type constr = t
+(** [types] is the same as [constr] but is intended to be used for
+   documentation to indicate that such or such function specifically works
+   with {e types} (i.e. terms of type a sort).
+   (Rem:plurial form since [type] is a reserved ML keyword) *)
+
+type types = constr
+
+(** {5 Functions for dealing with constr terms. }
+  The following functions are intended to simplify and to uniform the
+  manipulation of terms. Some of these functions may be overlapped with
+  previous ones. *)
+
+(** {6 Term constructors. } *)
+
+(** Constructs a DeBrujin index (DB indices begin at 1) *)
+val mkRel : int -> constr
+
+(** Constructs a Variable *)
+val mkVar : Id.t -> constr
+
+(** Constructs an patvar named "?n" *)
+val mkMeta : metavariable -> constr
+
+(** Constructs an existential variable *)
+type existential = existential_key * constr array
+val mkEvar : existential -> constr
+
+(** Construct a sort *)
+val mkSort : Sorts.t -> types
+val mkProp : types
+val mkSet  : types
+val mkType : Univ.universe -> types
+
+
+(** This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast
+
+(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the
+   type t{_ 2} (that means t2 is declared as the type of t1). *)
+val mkCast : constr * cast_kind * constr -> constr
+
+(** Constructs the product [(x:t1)t2] *)
+val mkProd : Name.t * types * types -> types
+
+(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *)
+val mkLambda : Name.t * types * constr -> constr
+
+(** Constructs the product [let x = t1 : t2 in t3] *)
+val mkLetIn : Name.t * constr * types * constr -> constr
+
+(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application
+   {% $(f~t_1~\dots~t_n)$ %}. *)
+val mkApp : constr * constr array -> constr
+
+val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses
+
+(** Constructs a constant *)
+val mkConst : constant -> constr
+val mkConstU : pconstant -> constr
+
+(** Constructs a projection application *)
+val mkProj : (projection * constr) -> constr
+
+(** Inductive types *)
+
+(** Constructs the ith (co)inductive type of the block named kn *)
+val mkInd : inductive -> constr
+val mkIndU : pinductive -> constr
+
+(** Constructs the jth constructor of the ith (co)inductive type of the
+   block named kn. *)
+val mkConstruct : constructor -> constr
+val mkConstructU : pconstructor -> constr
+val mkConstructUi : pinductive * int -> 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] 
+    presented as describe in [ci].
+
+    [p] stucture is [fun args x -> "return clause"]
+
+    [ac]{^ ith} element is ith constructor case presented as 
+    {e lambda construct_args (without params). case_term } *)
+val mkCase : case_info * constr * constr * constr array -> constr
+
+(** If [recindxs = [|i1,...in|]]
+      [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [|b1,.....bn|]]
+   then [mkFix ((recindxs,i), funnames, typarray, bodies) ]
+   constructs the {% $ %}i{% $ %}th function of the block (counting from 0)
+
+    [Fixpoint f1 [ctx1] = b1
+     with     f2 [ctx2] = b2
+     ...
+     with     fn [ctxn] = bn.]
+
+   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
+*)
+type rec_declaration = Name.t array * types array * constr array
+type fixpoint = (int array * int) * rec_declaration
+val mkFix : fixpoint -> constr
+
+(** If [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [b1,.....bn]] 
+   then [mkCoFix (i, (funnames, typarray, bodies))]
+   constructs the ith function of the block
+   
+    [CoFixpoint f1 = b1
+     with       f2 = b2
+     ...
+     with       fn = bn.]
+ *)
+type cofixpoint = int * rec_declaration
+val mkCoFix : cofixpoint -> constr
+
+
+(** {6 Concrete type for making pattern-matching. } *)
+
+(** [constr array] is an instance matching definitional [named_context] in
+   the same order (i.e. last argument first) *)
+type 'constr pexistential = existential_key * 'constr array
+type ('constr, 'types) prec_declaration =
+    Name.t array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of Id.t
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of Sorts.t
+  | Cast      of 'constr * cast_kind * 'types
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of constant puniverses
+  | Ind       of inductive puniverses
+  | Construct of constructor puniverses
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
+
+(** User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+val kind : constr -> (constr, types) kind_of_term
+
+(** [equal a b] is true if [a] equals [b] modulo alpha, casts,
+   and application grouping *)
+val equal : constr -> constr -> bool
+
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe equalities in [u]. *)
+val eq_constr_univs : constr Univ.check_function
+
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe inequalities in [u]. *)
+val leq_constr_univs : constr Univ.check_function
+
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe equalities in [u]. *)
+val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained
+
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe inequalities in [u]. *)
+val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained
+
+(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping and ignoring universe instances. *)
+val eq_constr_nounivs : constr -> constr -> bool
+
+(** Total ordering compatible with [equal] *)
+val compare : constr -> constr -> int
+
+(** {6 Functionals working on the immediate subterm of a construction } *)
+
+(** [fold f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a
+
+(** [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 *)
+
+val map : (constr -> constr) -> constr -> constr
+
+(** Like {!map}, but also has an additional accumulator. *)
+
+val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr
+
+(** [map_with_binders g f n c] maps [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val map_with_binders :
+  ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
+
+(** [iter f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val iter : (constr -> unit) -> constr -> unit
+
+(** [iter_with_binders g f n c] iters [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val iter_with_binders :
+  ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
+
+(** [compare_head f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's, binders
+   name and Cases annotations are not taken into account *)
+
+val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool
+
+(** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed, [u] to compare universe
+   instances (the first boolean tells if they belong to a constant), [s] to 
+   compare sorts; Cast's, binders name and Cases annotations are not taken 
+    into account *)
+
+val compare_head_gen : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) ->
+  (Sorts.t -> Sorts.t -> bool) ->
+  (constr -> constr -> bool) ->
+  constr -> constr -> bool
+
+(** [compare_head_gen_leq u s sle f fle c1 c2] compare [c1] and [c2]
+    using [f] to compare the immediate subterms of [c1] of [c2] for
+    conversion, [fle] for cumulativity, [u] to compare universe
+    instances (the first boolean tells if they belong to a constant),
+    [s] to compare sorts for equality and [sle] for subtyping; Cast's,
+    binders name and Cases annotations are not taken into account *)
+
+val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) ->
+  (Sorts.t -> Sorts.t -> bool) ->
+  (Sorts.t -> Sorts.t -> bool) ->
+  (constr -> constr -> bool) ->
+  (constr -> constr -> bool) ->
+  constr -> constr -> bool
+  
+(** {6 Hashconsing} *)
+
+val hash : constr -> int
+val case_info_hash : case_info -> int
+
+(*********************************************************************)
+
+val hcons : constr -> constr
+
+(**************************************)
+
+type values
diff --git a/kernel/context.ml b/kernel/context.ml
new file mode 100644
index 00000000..796f06d3
--- /dev/null
+++ b/kernel/context.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* Created by Jean-Christophe Filliâtre out of names.ml as part of the
+   rebuilding of Coq around a purely functional abstract type-checker,
+   Aug 1999 *)
+(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
+   Herbelin and Bruno Barras *)
+
+(* This file defines types and combinators regarding indexes-based and
+   names-based contexts *)
+
+open Util
+open Names
+
+(***************************************************************************)
+(*     Type of assumptions                                                 *)
+(***************************************************************************)
+
+type named_declaration = Id.t * Constr.t option * Constr.t
+type named_list_declaration = Id.t list * Constr.t option * Constr.t
+type rel_declaration = Name.t * Constr.t option * Constr.t
+
+let map_named_declaration_skel f (id, (v : Constr.t option), ty) =
+  (id, Option.map f v, f ty)
+let map_named_list_declaration = map_named_declaration_skel
+let map_named_declaration = map_named_declaration_skel
+
+let map_rel_declaration = map_named_declaration
+
+let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
+let fold_rel_declaration = fold_named_declaration
+
+let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
+let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
+
+let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
+let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
+
+let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
+  Id.equal i1 i2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
+
+let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
+  Name.equal n1 n2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
+
+(***************************************************************************)
+(*     Type of local contexts (telescopes)                                 *)
+(***************************************************************************)
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices (to represent bound variables) *)
+
+type rel_context = rel_declaration list
+
+let empty_rel_context = []
+
+let add_rel_decl d ctxt = d::ctxt
+
+let rec lookup_rel n sign =
+  match n, sign with
+  | 1, decl :: _ -> decl
+  | n, _ :: sign -> lookup_rel (n-1) sign
+  | _, []        -> raise Not_found
+
+let rel_context_length = List.length
+
+let rel_context_nhyps hyps =
+  let rec nhyps acc = function
+    | [] -> acc
+    | (_,None,_)::hyps -> nhyps (1+acc) hyps
+    | (_,Some _,_)::hyps -> nhyps acc hyps in
+  nhyps 0 hyps
+
+let rel_context_tags ctx =
+  let rec aux l = function
+  | [] -> l
+  | (_,Some _,_)::ctx -> aux (true::l) ctx
+  | (_,None,_)::ctx -> aux (false::l) ctx
+  in aux [] ctx
+
+(*s Signatures of named hypotheses. Used for section variables and
+    goal assumptions. *)
+
+type named_context = named_declaration list
+type named_list_context = named_list_declaration list
+
+let empty_named_context = []
+
+let add_named_decl d sign = d::sign
+
+let rec lookup_named id = function
+  | (id',_,_ as decl) :: _ when Id.equal id id' -> decl
+  | _ :: sign -> lookup_named id sign
+  | [] -> raise Not_found
+
+let named_context_length = List.length
+let named_context_equal = List.equal eq_named_declaration
+
+let vars_of_named_context ctx =
+  List.fold_left (fun accu (id, _, _) -> Id.Set.add id accu) Id.Set.empty ctx
+
+let instance_from_named_context sign =
+  let filter = function
+  | (id, None, _) -> Some (Constr.mkVar id)
+  | (_, Some _, _) -> None
+  in
+  List.map_filter filter sign
+
+let fold_named_context f l ~init = List.fold_right f l init
+let fold_named_list_context f l ~init = List.fold_right f l init
+let fold_named_context_reverse f ~init l = List.fold_left f init l
+
+(*s Signatures of ordered section variables *)
+type section_context = named_context
+
+let fold_rel_context f l ~init:x = List.fold_right f l x
+let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
+
+let map_context f l =
+  let map_decl (n, body_o, typ as decl) =
+    let body_o' = Option.smartmap f body_o in
+    let typ' = f typ in
+      if body_o' == body_o && typ' == typ then decl else
+        (n, body_o', typ')
+  in
+    List.smartmap map_decl l
+
+let map_rel_context = map_context
+let map_named_context = map_context
+
+let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
+let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
diff --git a/kernel/context.mli b/kernel/context.mli
new file mode 100644
index 00000000..5279aefb
--- /dev/null
+++ b/kernel/context.mli
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+
+(** TODO: cleanup *)
+
+(** {6 Declarations} *)
+(** A {e declaration} has the form [(name,body,type)]. It is either an
+    {e assumption} if [body=None] or a {e definition} if
+    [body=Some actualbody]. It is referred by {e name} if [na] is an
+    identifier or by {e relative index} if [na] is not an identifier
+    (in the latter case, [na] is of type [name] but just for printing
+    purpose) *)
+
+type named_declaration = Id.t * Constr.t option * Constr.t
+type named_list_declaration = Id.t list * Constr.t option * Constr.t
+type rel_declaration = Name.t * Constr.t option * Constr.t
+
+val map_named_declaration :
+  (Constr.t -> Constr.t) -> named_declaration -> named_declaration
+val map_named_list_declaration :
+  (Constr.t -> Constr.t) -> named_list_declaration -> named_list_declaration
+val map_rel_declaration :
+  (Constr.t -> Constr.t) -> rel_declaration -> rel_declaration
+
+val fold_named_declaration :
+  (Constr.t -> 'a -> 'a) -> named_declaration -> 'a -> 'a
+val fold_rel_declaration :
+  (Constr.t -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
+
+val exists_named_declaration :
+  (Constr.t -> bool) -> named_declaration -> bool
+val exists_rel_declaration :
+  (Constr.t -> bool) -> rel_declaration -> bool
+
+val for_all_named_declaration :
+  (Constr.t -> bool) -> named_declaration -> bool
+val for_all_rel_declaration :
+  (Constr.t -> bool) -> rel_declaration -> bool
+
+val eq_named_declaration :
+  named_declaration -> named_declaration -> bool
+
+val eq_rel_declaration :
+    rel_declaration -> rel_declaration -> bool
+
+(** {6 Signatures of ordered named declarations } *)
+
+type named_context = named_declaration list
+type section_context = named_context
+type named_list_context = named_list_declaration list
+type rel_context = rel_declaration list
+(** In [rel_context], more recent declaration is on top *)
+
+val empty_named_context : named_context
+val add_named_decl : named_declaration -> named_context -> named_context
+val vars_of_named_context : named_context -> Id.Set.t
+
+val lookup_named : Id.t -> named_context -> named_declaration
+
+(** number of declarations *)
+val named_context_length : named_context -> int
+
+(** named context equality *)
+val named_context_equal : named_context -> named_context -> bool
+
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
+val fold_named_context :
+  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
+
+val fold_named_list_context :
+  (named_list_declaration -> 'a -> 'a) -> named_list_context -> init:'a -> 'a
+
+(** newer declarations first *)
+val fold_named_context_reverse :
+  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
+
+(** {6 Section-related auxiliary functions } *)
+val instance_from_named_context : named_context -> Constr.t list
+
+(** {6 ... } *)
+(** Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices *)
+
+(** {6 Recurrence on [rel_context]: older declarations processed first } *)
+val fold_rel_context :
+  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
+
+(** newer declarations first *)
+val fold_rel_context_reverse :
+  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
+
+(** {6 Map function of [rel_context] } *)
+val map_rel_context : (Constr.t -> Constr.t) -> rel_context -> rel_context
+
+(** {6 Map function of [named_context] } *)
+val map_named_context : (Constr.t -> Constr.t) -> named_context -> named_context
+
+(** {6 Map function of [rel_context] } *)
+val iter_rel_context : (Constr.t -> unit) -> rel_context -> unit
+
+(** {6 Map function of [named_context] } *)
+val iter_named_context : (Constr.t -> unit) -> named_context -> unit
+
+(** {6 Contexts of declarations referred to by de Bruijn indices } *)
+
+val empty_rel_context : rel_context
+val add_rel_decl : rel_declaration -> rel_context -> rel_context
+
+val lookup_rel : int -> rel_context -> rel_declaration
+(** Size of the [rel_context] including LetIns *)
+val rel_context_length : rel_context -> int
+(** Size of the [rel_context] without LetIns *)
+val rel_context_nhyps : rel_context -> int
+(** Indicates whether a LetIn or a Lambda, starting from oldest declaration *)
+val rel_context_tags : rel_context -> bool list
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 26b7a397..3b01538b 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -18,52 +18,76 @@ open Names
  *)
 type level = Expand | Level of int | Opaque
 let default = Level 0
+let is_default = function
+| Level 0 -> true
+| _ -> false
 let transparent = default
+let is_transparent = function
+| Level 0 -> true
+| _ -> false
 
-type oracle = level Idmap.t * level Cmap.t
+type oracle = {
+  var_opacity : level Id.Map.t;
+  cst_opacity : level Cmap.t;
+  var_trstate : Id.Pred.t;
+  cst_trstate : Cpred.t;
+}
 
-let var_opacity = ref Idmap.empty
-let cst_opacity = ref Cmap.empty
+let empty = {
+  var_opacity = Id.Map.empty;
+  cst_opacity = Cmap.empty;
+  var_trstate = Id.Pred.full;
+  cst_trstate = Cpred.full;
+}
 
-let get_strategy = function
+let get_strategy { var_opacity; cst_opacity } f = function
   | VarKey id ->
-      (try Idmap.find id !var_opacity
+      (try Id.Map.find id var_opacity
       with Not_found -> default)
   | ConstKey c ->
-      (try Cmap.find c !cst_opacity
+      (try Cmap.find (f c) cst_opacity
       with Not_found -> default)
   | RelKey _ -> Expand
 
-let set_strategy k l =
+let set_strategy ({ var_opacity; cst_opacity } as oracle) k l =
   match k with
   | VarKey id ->
-      var_opacity :=
-      if l=default then Idmap.remove id !var_opacity
-      else Idmap.add id l !var_opacity
+    let var_opacity =
+      if is_default l then Id.Map.remove id var_opacity
+      else Id.Map.add id l var_opacity
+    in
+    let var_trstate = match l with
+    | Opaque -> Id.Pred.remove id oracle.var_trstate
+    | _ -> Id.Pred.add id oracle.var_trstate
+    in
+    { oracle with var_opacity; var_trstate; }
   | ConstKey c ->
-      cst_opacity :=
-      if l=default then Cmap.remove c !cst_opacity
-      else Cmap.add c l !cst_opacity
-  | RelKey _ -> Util.error "set_strategy: RelKey"
+    let cst_opacity =
+      if is_default l then Cmap.remove c cst_opacity
+      else Cmap.add c l cst_opacity
+    in
+    let cst_trstate = match l with
+    | Opaque -> Cpred.remove c oracle.cst_trstate
+    | _ -> Cpred.add c oracle.cst_trstate
+    in
+    { oracle with cst_opacity; cst_trstate; }
+  | RelKey _ -> Errors.error "set_strategy: RelKey"
 
-let get_transp_state () =
-  (Idmap.fold
-    (fun id l ts -> if  l=Opaque then Idpred.remove id ts else ts)
-    !var_opacity Idpred.full,
-   Cmap.fold
-    (fun c l ts -> if  l=Opaque then Cpred.remove c ts else ts)
-    !cst_opacity Cpred.full)
+let fold_strategy f { var_opacity; cst_opacity; } accu =
+  let fvar id lvl accu = f (VarKey id) lvl accu in
+  let fcst cst lvl accu = f (ConstKey cst) lvl accu in
+  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)
 
 (* Unfold the first constant only if it is "more transparent" than the
    second one. In case of tie, expand the second one. *)
-let oracle_order l2r k1 k2 =
-  match get_strategy k1, get_strategy k2 with
+let oracle_order f o l2r k1 k2 =
+  match get_strategy o f k1, get_strategy o f k2 with
     | Expand, _ -> true
     | Level n1, Opaque -> true
     | Level n1, Level n2 -> n1 < n2
     | _ -> l2r (* use recommended default *)
 
-(* summary operations *)
-let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty)
-let freeze () = (!var_opacity, !cst_opacity)
-let unfreeze (vo,co) = (cst_opacity := co; var_opacity := vo)
+let get_strategy o = get_strategy o (fun x -> x)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index c8cfdf62..62991222 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,11 +8,16 @@
 
 open Names
 
+type oracle
+
+val empty : oracle
+
 (** Order on section paths for unfolding.
    If [oracle_order kn1 kn2] is true, then unfold kn1 first.
    Note: the oracle does not introduce incompleteness, it only
    tries to postpone unfolding of "opaque" constants. *)
-val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
+val oracle_order : ('a -> constant) -> oracle -> bool -> 
+  'a tableKey -> 'a tableKey -> bool
 
 (** Priority for the expansion of constant in the conversion test.
  * Higher levels means that the expansion is less prioritary.
@@ -22,17 +27,17 @@ val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
 type level = Expand | Level of int | Opaque
 val transparent : level
 
-val get_strategy : 'a tableKey -> level
+(** Check whether a level is transparent *)
+val is_transparent : level -> bool
+
+val get_strategy : oracle -> constant tableKey -> level
 
 (** Sets the level of a constant.
  * Level of RelKey constant cannot be set. *)
-val set_strategy : 'a tableKey -> level -> unit
+val set_strategy : oracle -> constant tableKey -> level -> oracle
 
-val get_transp_state : unit -> transparent_state
+(** Fold over the non-transparent levels of the oracle. Order unspecified. *)
+val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a
+
+val get_transp_state : oracle -> transparent_state
 
-(****************************
-   Summary operations *)
-type oracle
-val init     : unit -> unit
-val freeze   : unit -> oracle
-val unfreeze : oracle -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 9ec99f99..be71bd7b 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,22 +13,19 @@
 (* This module implements kernel-level discharching of local
    declarations over global constants and inductive types *)
 
-open Pp
+open Errors
 open Util
 open Names
 open Term
-open Sign
 open Declarations
 open Environ
-open Reduction
+open Univ
 
 (*s Cooking the constants. *)
 
-type work_list = identifier array Cmap.t * identifier array Mindmap.t
-
-let pop_dirpath p = match repr_dirpath p with
-  | [] -> anomaly "dirpath_prefix: empty dirpath"
-  | _::l -> make_dirpath l
+let pop_dirpath p = match DirPath.repr p with
+  | [] -> anomaly ~label:"dirpath_prefix" (Pp.str "empty dirpath")
+  | _::l -> DirPath.make l
 
 let pop_mind kn =
   let (mp,dir,l) = Names.repr_mind kn in
@@ -43,67 +40,104 @@ type my_global_reference =
   | IndRef of inductive
   | ConstructRef of constructor
 
-let cache = (Hashtbl.create 13 : (my_global_reference, constr) Hashtbl.t)
-
-let clear_cooking_sharing () = Hashtbl.clear cache
-
-let share r (cstl,knl) =
-  try Hashtbl.find cache r
+module RefHash =
+struct
+  type t = my_global_reference
+  let equal gr1 gr2 = match gr1, gr2 with
+  | ConstRef c1, ConstRef c2 -> Constant.CanOrd.equal c1 c2
+  | IndRef i1, IndRef i2 -> eq_ind i1 i2
+  | ConstructRef c1, ConstructRef c2 -> eq_constructor c1 c2
+  | _ -> false
+  open Hashset.Combine
+  let hash = function
+  | ConstRef c -> combinesmall 1 (Constant.hash c)
+  | IndRef i -> combinesmall 2 (ind_hash i)
+  | ConstructRef c -> combinesmall 3 (constructor_hash c)
+end
+
+module RefTable = Hashtbl.Make(RefHash)
+
+let instantiate_my_gr gr u =
+  match gr with
+  | ConstRef c -> mkConstU (c, u)
+  | IndRef i -> mkIndU (i, u)
+  | ConstructRef c -> mkConstructU (c, u)
+
+let share cache r (cstl,knl) =
+  try RefTable.find cache r
   with Not_found ->
-  let f,l =
+  let f,(u,l) =
     match r with
     | IndRef (kn,i) ->
-	mkInd (pop_mind kn,i), Mindmap.find kn knl
+	IndRef (pop_mind kn,i), Mindmap.find kn knl
     | ConstructRef ((kn,i),j) ->
-	mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl
+	ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl
     | ConstRef cst ->
-	mkConst (pop_con cst), Cmap.find cst cstl in
-  let c = mkApp (f, Array.map mkVar l) in
-  Hashtbl.add cache r c;
-  (* has raised Not_found if not in work_list *)
+	ConstRef (pop_con cst), Cmap.find cst cstl in
+  let c = (f, (u, Array.map mkVar l)) in
+  RefTable.add cache r c;
   c
 
-let update_case_info ci modlist =
+let share_univs cache r u l =
+  let r', (u', args) = share cache r l in
+    mkApp (instantiate_my_gr r' (Instance.append u' u), args)
+
+let update_case_info cache ci modlist =
   try
     let ind, n =
-      match kind_of_term (share (IndRef ci.ci_ind) modlist) with
-      | App (f,l) -> (destInd f, Array.length l)
-      | Ind ind -> ind, 0
+      match share cache (IndRef ci.ci_ind) modlist with
+      | (IndRef f,(u,l)) -> (f, Array.length l)
       | _ -> assert false in
     { ci with ci_ind = ind; ci_npar = ci.ci_npar + n }
   with Not_found ->
     ci
 
-let empty_modlist = (Cmap.empty, Mindmap.empty)
+let is_empty_modlist (cm, mm) =
+  Cmap.is_empty cm && Mindmap.is_empty mm
 
-let expmod_constr modlist c =
+let expmod_constr cache modlist c =
+  let share_univs = share_univs cache in
+  let update_case_info = update_case_info cache in
   let rec substrec c =
     match kind_of_term c with
       | Case (ci,p,t,br) ->
 	  map_constr substrec (mkCase (update_case_info ci modlist,p,t,br))
 
-      | Ind ind ->
+      | Ind (ind,u) ->
 	  (try
-	    share (IndRef ind) modlist
+	    share_univs (IndRef ind) u modlist
 	   with
 	    | Not_found -> map_constr substrec c)
 
-      | Construct cstr ->
+      | Construct (cstr,u) ->
 	  (try
-	    share (ConstructRef cstr) modlist
+	     share_univs (ConstructRef cstr) u modlist
 	   with
 	    | Not_found -> map_constr substrec c)
 
-      | Const cst ->
+      | Const (cst,u) ->
 	  (try
-	    share (ConstRef cst) modlist
+	    share_univs (ConstRef cst) u modlist
 	   with
 	    | Not_found -> map_constr substrec c)
 
+      | Proj (p, c') ->
+          (try 
+	     let p' = share_univs (ConstRef (Projection.constant p)) Univ.Instance.empty modlist in
+	     let make c = Projection.make c (Projection.unfolded p) in
+	     match kind_of_term p' with
+	     | Const (p',_) -> mkProj (make p', substrec c')
+	     | App (f, args) -> 
+	       (match kind_of_term f with 
+	       | Const (p', _) -> mkProj (make p', substrec c')
+	       | _ -> assert false)
+	     | _ -> assert false
+	   with Not_found -> map_constr substrec c)
+
   | _ -> map_constr substrec c
 
   in
-  if modlist = empty_modlist then c
+  if is_empty_modlist modlist then c
   else substrec c
 
 let abstract_constant_type =
@@ -112,41 +146,108 @@ let abstract_constant_type =
 let abstract_constant_body =
   List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c)
 
-type recipe = {
-  d_from : constant_body;
-  d_abstract : named_context;
-  d_modlist : work_list }
+type recipe = { from : constant_body; info : Opaqueproof.cooking_info }
+type inline = bool
 
-let on_body f = function
-  | Undef inl -> Undef inl
-  | Def cs -> Def (Declarations.from_val (f (Declarations.force cs)))
-  | OpaqueDef lc ->
-    OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc)))
+type result =
+  constant_def * constant_type * projection_body option * 
+    bool * constant_universes * inline
+    * Context.section_context option
 
-let constr_of_def = function
+let on_body ml hy f = function
+  | Undef _ as x -> x
+  | Def cs -> Def (Mod_subst.from_val (f (Mod_subst.force_constr cs)))
+  | OpaqueDef o ->
+    OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f
+                 { Opaqueproof.modlist = ml; abstract = hy } o)
+
+let constr_of_def otab = function
   | Undef _ -> assert false
-  | Def cs -> Declarations.force cs
-  | OpaqueDef lc -> Declarations.force_opaque lc
-
-let cook_constant env r =
-  let cb = r.d_from in
-  let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
-  let body = on_body
-    (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps)
+  | Def cs -> Mod_subst.force_constr cs
+  | OpaqueDef lc -> Opaqueproof.force_proof otab lc
+
+let expmod_constr_subst cache modlist subst c =
+  let c = expmod_constr cache modlist c in
+    Vars.subst_univs_level_constr subst c
+
+let cook_constr { Opaqueproof.modlist ; abstract } c =
+  let cache = RefTable.create 13 in
+  let expmod = expmod_constr_subst cache modlist (pi2 abstract) in
+  let hyps = Context.map_named_context expmod (pi1 abstract) in
+  abstract_constant_body (expmod c) hyps
+
+let lift_univs cb subst =
+  if cb.const_polymorphic && not (Univ.LMap.is_empty subst) then
+    let inst = Univ.UContext.instance cb.const_universes in
+    let cstrs = Univ.UContext.constraints cb.const_universes in
+    let len = Univ.LMap.cardinal subst in
+    let subst = 
+      Array.fold_left_i (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc)
+	subst (Univ.Instance.to_array inst)
+    in
+    let cstrs' = Univ.subst_univs_level_constraints subst cstrs in
+      subst, Univ.UContext.make (inst,cstrs')
+  else subst, cb.const_universes
+
+let cook_constant env { from = cb; info } =
+  let { Opaqueproof.modlist; abstract } = info in
+  let cache = RefTable.create 13 in
+  let abstract, usubst, abs_ctx = abstract in
+  let usubst, univs = lift_univs cb usubst in
+  let expmod = expmod_constr_subst cache modlist usubst in
+  let hyps = Context.map_named_context expmod abstract in
+  let body = on_body modlist (hyps, usubst, abs_ctx)
+    (fun c -> abstract_constant_body (expmod c) hyps)
     cb.const_body
   in
   let const_hyps =
-    Sign.fold_named_context (fun (h,_,_) hyps ->
-      List.filter (fun (id,_,_) -> id <> h) hyps)
+    Context.fold_named_context (fun (h,_,_) hyps ->
+      List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps)
       hyps ~init:cb.const_hyps in
   let typ = match cb.const_type with
-    | NonPolymorphicType t ->
-	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
-	NonPolymorphicType typ
-    | PolymorphicArity (ctx,s) ->
-	let t = mkArity (ctx,Type s.poly_level) in
-	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
-	let j = make_judge (constr_of_def body) typ in
-	Typeops.make_polymorphic_if_constant_for_ind env j
+    | RegularArity t ->
+  	let typ =
+          abstract_constant_type (expmod t) hyps in
+  	RegularArity typ
+    | TemplateArity (ctx,s) ->
+  	let t = mkArity (ctx,Type s.template_level) in
+  	let typ = abstract_constant_type (expmod t) hyps in
+  	let j = make_judge (constr_of_def (opaque_tables env) body) typ in
+  	Typeops.make_polymorphic_if_constant_for_ind env j
+  in
+  let projection pb =
+    let c' = abstract_constant_body (expmod pb.proj_body) hyps in
+    let etab = abstract_constant_body (expmod (fst pb.proj_eta)) hyps in
+    let etat = abstract_constant_body (expmod (snd pb.proj_eta)) hyps in
+    let ((mind, _), _), n' =
+      try 
+	let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in
+	  match kind_of_term c' with
+	  | App (f,l) -> (destInd f, Array.length l)
+	  | Ind ind -> ind, 0
+	  | _ -> assert false 
+      with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0)
+    in 
+    let typ = (* By invariant, a regular arity *)
+      match typ with RegularArity t -> t | TemplateArity _ -> assert false 
+    in
+    let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in
+      { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg;
+	proj_eta = etab, etat;
+	proj_type = ty'; proj_body = c' }
+  in
+  let univs = 
+    let abs' = 
+      if cb.const_polymorphic then abs_ctx
+      else instantiate_univ_context abs_ctx
+    in
+      UContext.union abs' univs
   in
-  (body, typ, cb.const_constraints, const_hyps)
+    (body, typ, Option.map projection cb.const_proj, 
+     cb.const_polymorphic, univs, cb.const_inline_code, 
+     Some const_hyps)
+
+(* let cook_constant_key = Profile.declare_profile "cook_constant" *)
+(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *)
+
+let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index a5141568..441c9dd2 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -1,36 +1,30 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Names
 open Term
 open Declarations
 open Environ
-open Univ
 
 (** {6 Cooking the constants. } *)
 
-type work_list = identifier array Cmap.t * identifier array Mindmap.t
+type recipe = { from : constant_body; info : Opaqueproof.cooking_info }
 
-type recipe = {
-  d_from : constant_body;
-  d_abstract : Sign.named_context;
-  d_modlist : work_list }
+type inline = bool
 
-val cook_constant :
-  env -> recipe ->
-    constant_def * constant_type * constraints * Sign.section_context
+type result =
+  constant_def * constant_type * projection_body option * 
+    bool * constant_universes * inline
+    * Context.section_context option
 
+val cook_constant : env -> recipe -> result
+val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr
 
 (** {6 Utility functions used in module [Discharge]. } *)
 
-val expmod_constr : work_list -> constr -> constr
-
-val clear_cooking_sharing : unit -> unit
-
-
+val expmod_constr : Opaqueproof.work_list -> constr -> constr
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 2f931818..ed8b0a6d 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,8 +12,10 @@
 
 (* This file manages the table of global symbols for the bytecode machine *)
 
+open Util
 open Names
 open Term
+open Context
 open Vm
 open Cemitcodes
 open Cbytecodes
@@ -51,41 +53,60 @@ let set_global v =
   incr num_global;
   n
 
-(* [global_transp],[global_boxed] contiennent les valeurs des
-   definitions gelees. Les deux versions sont maintenues en //.
-   [global_transp] contient la version transparente.
-   [global_boxed] contient la version gelees. *)
-
-external global_boxed : unit -> bool array = "get_coq_global_boxed"
-
-(* [realloc_global_data n] augmente de n la taille de [global_data] *)
-external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed"
-
-let check_global_boxed n =
-  if n >= Array.length (global_boxed()) then realloc_global_boxed n
-
-let num_boxed = ref 0
-
-let boxed_tbl = Hashtbl.create 53
-
-let cst_opaque = ref Cpred.full
-
-let is_opaque kn = Cpred.mem kn !cst_opaque
-
-let set_global_boxed kn v =
-  let n = !num_boxed in
-  check_global_boxed n;
-  (global_boxed()).(n) <- (is_opaque kn);
-  Hashtbl.add boxed_tbl kn n ;
-  incr num_boxed;
-  set_global (val_of_constant_def n kn v)
-
 (* table pour les structured_constant et les annotations des switchs *)
 
-let str_cst_tbl = Hashtbl.create 31
-    (* (structured_constant * int) Hashtbl.t*)
-
-let annot_tbl = Hashtbl.create 31
+let rec eq_structured_constant c1 c2 = match c1, c2 with
+| Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2
+| Const_ind i1, Const_ind i2 -> Univ.eq_puniverses eq_ind i1 i2
+| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2
+| Const_bn (t1, a1), Const_bn (t2, a2) ->
+  Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2
+| _ -> false
+
+let rec hash_structured_constant c =
+  let open Hashset.Combine in
+  match c with
+  | Const_sorts s -> combinesmall 1 (Sorts.hash s)
+  | Const_ind (i,u) -> combinesmall 2 (combine (ind_hash i) (Univ.Instance.hash u))
+  | Const_b0 t -> combinesmall 3 (Int.hash t)
+  | Const_bn (t, a) ->
+    let fold h c = combine h (hash_structured_constant c) in
+    let h = Array.fold_left fold 0 a in
+    combinesmall 4 (combine (Int.hash t) h)
+
+module SConstTable = Hashtbl.Make (struct
+  type t = structured_constant
+  let equal = eq_structured_constant
+  let hash = hash_structured_constant
+end)
+
+let eq_annot_switch asw1 asw2 =
+  let eq_ci ci1 ci2 =
+    eq_ind ci1.ci_ind ci2.ci_ind &&
+    Int.equal ci1.ci_npar ci2.ci_npar &&
+    Array.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls
+  in
+  let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in
+  eq_ci asw1.ci asw2.ci &&
+  Array.equal eq_rlc asw1.rtbl asw2.rtbl &&
+  (asw1.tailcall : bool) == asw2.tailcall
+
+let hash_annot_switch asw =
+  let open Hashset.Combine in
+  let h1 = Constr.case_info_hash asw.ci in
+  let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in
+  let h3 = if asw.tailcall then 1 else 0 in
+  combine3 h1 h2 h3
+
+module AnnotTable = Hashtbl.Make (struct
+  type t = annot_switch
+  let equal = eq_annot_switch
+  let hash = hash_annot_switch
+end)
+
+let str_cst_tbl : int SConstTable.t = SConstTable.create 31
+
+let annot_tbl : int AnnotTable.t = AnnotTable.create 31
     (* (annot_switch * int) Hashtbl.t  *)
 
 (*************************************************************)
@@ -94,11 +115,12 @@ let annot_tbl = Hashtbl.create 31
 
 exception NotEvaluated
 
-open Pp
 let key rk =
   match !rk with
-  | Some k -> (*Pp.msgnl (str"found at: "++int k);*)  k
-  | _ -> raise NotEvaluated
+  | None -> raise NotEvaluated
+  | Some k -> (*Pp.msgnl (str"found at: "++int k);*)
+      try Ephemeron.get k
+      with Ephemeron.InvalidKey -> raise NotEvaluated
 
 (************************)
 (* traduction des patch *)
@@ -107,65 +129,64 @@ let key rk =
    dans la table global, rend sa position dans la table *)
 
 let slot_for_str_cst key =
-  try Hashtbl.find str_cst_tbl key
+  try SConstTable.find str_cst_tbl key
   with Not_found ->
     let n = set_global (val_of_str_const key) in
-    Hashtbl.add str_cst_tbl key n;
+    SConstTable.add str_cst_tbl key n;
     n
 
 let slot_for_annot key =
-  try Hashtbl.find annot_tbl key
+  try AnnotTable.find annot_tbl key
   with Not_found ->
     let n =  set_global (val_of_annot_switch key) in
-    Hashtbl.add annot_tbl key n;
+    AnnotTable.add annot_tbl key n;
     n
 
-let rec slot_for_getglobal env kn =
-  let (cb,rk) = lookup_constant_key kn env in
+let rec slot_for_getglobal env (kn,u) =
+  let (cb,(_,rk)) = lookup_constant_key kn env in
   try key rk
   with NotEvaluated ->
 (*    Pp.msgnl(str"not yet evaluated");*)
     let pos =
       match Cemitcodes.force cb.const_body_code with
       | BCdefined(code,pl,fv) ->
-	let v = eval_to_patch env (code,pl,fv) in
-	set_global v
+	if Univ.Instance.is_empty u then
+	  let v = eval_to_patch env (code,pl,fv) in
+	    set_global v
+	else set_global (val_of_constant (kn,u))
     | BCallias kn' -> slot_for_getglobal env kn'
-    | BCconstant -> set_global (val_of_constant kn) in
+    | BCconstant -> set_global (val_of_constant (kn,u)) in
 (*Pp.msgnl(str"value stored at: "++int pos);*)
-    rk := Some pos;
+    rk := Some (Ephemeron.create pos);
     pos
 
 and slot_for_fv env fv =
+  let fill_fv_cache cache id v_of_id env_of_id b =
+    let v,d =
+      match b with
+      | None -> v_of_id id, Id.Set.empty
+      | Some c ->
+          val_of_constr (env_of_id id env) c,
+          Environ.global_vars_set (Environ.env_of_pre_env env) c in
+    build_lazy_val cache (v, d); v in
+  let val_of_rel i = val_of_rel (nb_rel env - i) in
+  let idfun _ x = x in
   match fv with
   | FVnamed id ->
       let nv = Pre_env.lookup_named_val id env in
-      begin
-	match !nv with
-	| VKvalue (v,_) -> v
-	| VKnone ->
-	    let (_, b, _) = Sign.lookup_named id env.env_named_context in
-	    let v,d =
-	      match b with
-		| None -> (val_of_named id, Idset.empty)
-		| Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c)
-	    in
-	      nv := VKvalue (v,d); v
+      begin match force_lazy_val nv with
+      | None ->
+          let _, b, _ = Context.lookup_named id env.env_named_context in
+          fill_fv_cache nv id val_of_named idfun b
+      | Some (v, _) -> v
       end
   | FVrel i ->
       let rv = Pre_env.lookup_rel_val i env in
-      begin
-	match !rv with
-	| VKvalue (v, _) -> v
-	| VKnone ->
-	    let (_, b, _) = lookup_rel i env.env_rel_context in
-	    let (v, d) =
-	      match b with
-		| None -> (val_of_rel (nb_rel env - i), Idset.empty)
-		| Some c -> let renv =  env_of_rel i env in
-			      (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c)
-	    in
-	      rv := VKvalue (v,d); v
+      begin match force_lazy_val rv with
+      | None ->
+          let _, b, _ = lookup_rel i env.env_rel_context in
+          fill_fv_cache rv i val_of_rel env_of_rel b
+      | Some (v, _) -> v
       end
 
 and eval_to_patch env (buff,pl,fv) =
@@ -191,18 +212,14 @@ and val_of_constr env c =
   let (_,fun_code,_ as ccfv) =
     try compile env c
     with reraise ->
-      print_string "can not compile \n";Format.print_flush();raise reraise
+      let reraise = Errors.push reraise in
+      let () = print_string "can not compile \n" in
+      let () = Format.print_flush () in
+      iraise reraise
   in
   eval_to_patch env (to_memory ccfv)
 
-let set_transparent_const kn =
-  cst_opaque := Cpred.remove kn !cst_opaque;
-  List.iter (fun n -> (global_boxed()).(n) <- false)
-    (Hashtbl.find_all boxed_tbl kn)
-
-let set_opaque_const kn =
-  cst_opaque := Cpred.add kn !cst_opaque;
-  List.iter (fun n -> (global_boxed()).(n) <- true)
-    (Hashtbl.find_all boxed_tbl kn)
+let set_transparent_const kn = () (* !?! *)
+let set_opaque_const kn = () (* !?! *)
 
 
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 5fb2f975..ca5f8ac2 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
deleted file mode 100644
index 88d28323..00000000
--- a/kernel/declarations.ml
+++ /dev/null
@@ -1,409 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* This file is a late renaming in May 2000 of constant.ml which
-   itself was made for V7.0 in Aug 1999 out of a dispatch by
-   Jean-Christophe Filliâtre of Chet Murthy's constants.ml in V5.10.5
-   into cooking.ml, declare.ml and constant.ml, ...; renaming done
-   because the new contents exceeded in extent what the name
-   suggested *)
-(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
-(* Declarations for the module systems added by Jacek Chrzaszcz, Aug 2002 *)
-(* Miscellaneous extensions, cleaning or restructurations by Bruno
-   Barras, Hugo Herbelin, Jean-Christophe Filliâtre, Pierre Letouzey *)
-
-(* This module defines the types of global declarations. This includes
-   global constants/axioms, mutual inductive definitions and the
-   module system *)
-
-open Util
-open Names
-open Univ
-open Term
-open Sign
-open Mod_subst
-
-type engagement = ImpredicativeSet
-
-(*s Constants (internal representation) (Definition/Axiom) *)
-
-type polymorphic_arity = {
-  poly_param_levels : universe option list;
-  poly_level : universe;
-}
-
-type constant_type =
-  | NonPolymorphicType of types
-  | PolymorphicArity of rel_context * polymorphic_arity
-
-type constr_substituted = constr substituted
-
-let from_val = from_val
-
-let force = force subst_mps
-
-let subst_constr_subst = subst_substituted
-
-(** Opaque proof terms are not loaded immediately, but are there
-    in a lazy form. Forcing this lazy may trigger some unmarshal of
-    the necessary structure. The ['a substituted] type isn't really great
-    here, so we store "manually" a substitution list, the younger one at top.
-*)
-
-type lazy_constr = constr_substituted Lazy.t * substitution list
-
-let force_lazy_constr (c,l) =
-  List.fold_right subst_constr_subst l (Lazy.force c)
-
-let lazy_constr_is_val (c,_) = Lazy.lazy_is_val c
-
-let make_lazy_constr c = (c, [])
-
-let force_opaque lc = force (force_lazy_constr lc)
-
-let opaque_from_val c = (Lazy.lazy_from_val (from_val c), [])
-
-let subst_lazy_constr sub (c,l) = (c,sub::l)
-
-(** Inlining level of parameters at functor applications.
-    None means no inlining *)
-
-type inline = int option
-
-(** A constant can have no body (axiom/parameter), or a
-    transparent body, or an opaque one *)
-
-type constant_def =
-  | Undef of inline
-  | Def of constr_substituted
-  | OpaqueDef of lazy_constr
-
-type constant_body = {
-    const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constant_def;
-    const_type : constant_type;
-    const_body_code : Cemitcodes.to_patch_substituted;
-    const_constraints : constraints }
-
-let body_of_constant cb = match cb.const_body with
-  | Undef _ -> None
-  | Def c -> Some c
-  | OpaqueDef lc -> Some (force_lazy_constr lc)
-
-let constant_has_body cb = match cb.const_body with
-  | Undef _ -> false
-  | Def _ | OpaqueDef _ -> true
-
-let is_opaque cb = match cb.const_body with
-  | OpaqueDef _ -> true
-  | Undef _ | Def _ -> false
-
-(* Substitutions of [constant_body] *)
-
-let subst_rel_declaration sub (id,copt,t as x) =
-  let copt' = Option.smartmap (subst_mps sub) copt in
-  let t' = subst_mps sub t in
-  if copt == copt' & t == t' then x else (id,copt',t')
-
-let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
-
-(* TODO: these substitution functions could avoid duplicating things
-   when the substitution have preserved all the fields *)
-
-let subst_const_type sub arity =
-  if is_empty_subst sub then arity
-  else match arity with
-    | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
-    | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
-
-let subst_const_def sub = function
-  | Undef inl -> Undef inl
-  | Def c -> Def (subst_constr_subst sub c)
-  | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
-
-let subst_const_body sub cb = {
-  const_hyps = (assert (cb.const_hyps=[]); []);
-  const_body = subst_const_def sub cb.const_body;
-  const_type = subst_const_type sub cb.const_type;
-  const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
-  const_constraints = cb.const_constraints}
-
-(* Hash-consing of [constant_body] *)
-
-let hcons_rel_decl ((n,oc,t) as d) =
-  let n' = hcons_name n
-  and oc' = Option.smartmap hcons_constr oc
-  and t' = hcons_types t
-  in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
-
-let hcons_rel_context l = list_smartmap hcons_rel_decl l
-
-let hcons_polyarity ar =
-  { poly_param_levels =
-      list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels;
-    poly_level = hcons_univ ar.poly_level }
-
-let hcons_const_type = function
-  | NonPolymorphicType t ->
-    NonPolymorphicType (hcons_constr t)
-  | PolymorphicArity (ctx,s) ->
-    PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s)
-
-let hcons_const_def = function
-  | Undef inl -> Undef inl
-  | Def l_constr ->
-    let constr = force l_constr in
-    Def (from_val (hcons_constr constr))
-  | OpaqueDef lc ->
-    if lazy_constr_is_val lc then
-      let constr = force_opaque lc in
-      OpaqueDef (opaque_from_val (hcons_constr constr))
-    else OpaqueDef lc
-
-let hcons_const_body cb =
-  { cb with
-    const_body = hcons_const_def cb.const_body;
-    const_type = hcons_const_type cb.const_type;
-    const_constraints = hcons_constraints cb.const_constraints }
-
-
-(*s Inductive types (internal representation with redundant
-    information). *)
-
-type recarg =
-  | Norec
-  | Mrec of inductive
-  | Imbr of inductive
-
-let subst_recarg sub r = match r with
-  | Norec -> r
-  | Mrec (kn,i) -> let kn' = subst_ind sub kn in
-      if kn==kn' then r else Mrec (kn',i)
-  | Imbr (kn,i) -> let kn' = subst_ind sub kn in
-      if kn==kn' then r else Imbr (kn',i)
-
-type wf_paths = recarg Rtree.t
-
-let mk_norec = Rtree.mk_node Norec [||]
-
-let mk_paths r recargs =
-  Rtree.mk_node r
-    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
-
-let dest_recarg p = fst (Rtree.dest_node p)
-
-(* dest_subterms returns the sizes of each argument of each constructor of
-   an inductive object of size [p]. This should never be done for Norec,
-   because the number of sons does not correspond to the number of
-   constructors.
- *)
-let dest_subterms p =
-  let (ra,cstrs) = Rtree.dest_node p in
-  assert (ra<>Norec);
-  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
-
-let recarg_length p j =
-  let (_,cstrs) = Rtree.dest_node p in
-  Array.length (snd (Rtree.dest_node cstrs.(j-1)))
-
-let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
-
-(**********************************************************************)
-(* Representation of mutual inductive types in the kernel             *)
-(*
-   Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
-   ...
-   with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
-*)
-
-type monomorphic_inductive_arity = {
-  mind_user_arity : constr;
-  mind_sort : sorts;
-}
-
-type inductive_arity =
-| Monomorphic of monomorphic_inductive_arity
-| Polymorphic of polymorphic_arity
-
-type one_inductive_body = {
-
-(* Primitive datas *)
-
- (* Name of the type: [Ii] *)
-    mind_typename : identifier;
-
- (* Arity context of [Ii] with parameters: [forall params, Ui] *)
-    mind_arity_ctxt : rel_context;
-
- (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *)
-    mind_arity : inductive_arity;
-
- (* Names of the constructors: [cij] *)
-    mind_consnames : identifier array;
-
- (* Types of the constructors with parameters: [forall params, Tij],
-    where the Ik are replaced by de Bruijn index in the context
-    I1:forall params, U1 ..  In:forall params, Un *)
-    mind_user_lc : types array;
-
-(* Derived datas *)
-
- (* Number of expected real arguments of the type (no let, no params) *)
-    mind_nrealargs : int;
-
- (* Length of realargs context (with let, no params) *)
-    mind_nrealargs_ctxt : int;
-
- (* List of allowed elimination sorts *)
-    mind_kelim : sorts_family list;
-
- (* Head normalized constructor types so that their conclusion is atomic *)
-    mind_nf_lc : types array;
-
- (* Length of the signature of the constructors (with let, w/o params) *)
-    mind_consnrealdecls : int array;
-
- (* Signature of recursive arguments in the constructors *)
-    mind_recargs : wf_paths;
-
-(* Datas for bytecode compilation *)
-
- (* number of constant constructor *)
-    mind_nb_constant : int;
-
- (* number of no constant constructor *)
-    mind_nb_args : int;
-
-    mind_reloc_tbl :  Cbytecodes.reloc_table;
-  }
-
-type mutual_inductive_body = {
-
-  (* The component of the mutual inductive block *)
-    mind_packets : one_inductive_body array;
-
-  (* Whether the inductive type has been declared as a record *)
-    mind_record : bool;
-
-  (* Whether the type is inductive or coinductive *)
-    mind_finite : bool;
-
-  (* Number of types in the block *)
-    mind_ntypes : int;
-
-  (* Section hypotheses on which the block depends *)
-    mind_hyps : section_context;
-
-  (* Number of expected parameters *)
-    mind_nparams : int;
-
-  (* Number of recursively uniform (i.e. ordinary) parameters *)
-    mind_nparams_rec : int;
-
-  (* The context of parameters (includes let-in declaration) *)
-    mind_params_ctxt : rel_context;
-
-  (* Universes constraints enforced by the inductive declaration *)
-    mind_constraints : constraints;
-
-  }
-
-let subst_indarity sub = function
-| Monomorphic s ->
-    Monomorphic {
-      mind_user_arity = subst_mps sub s.mind_user_arity;
-      mind_sort = s.mind_sort;
-    }
-| Polymorphic s as x -> x
-
-let subst_mind_packet sub mbp =
-  { mind_consnames = mbp.mind_consnames;
-    mind_consnrealdecls = mbp.mind_consnrealdecls;
-    mind_typename = mbp.mind_typename;
-    mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
-    mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
-    mind_arity = subst_indarity sub mbp.mind_arity;
-    mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
-    mind_nrealargs = mbp.mind_nrealargs;
-    mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
-    mind_kelim = mbp.mind_kelim;
-    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
-    mind_nb_constant = mbp.mind_nb_constant;
-    mind_nb_args = mbp.mind_nb_args;
-    mind_reloc_tbl = mbp.mind_reloc_tbl }
-
-let subst_mind sub mib =
-  { mind_record = mib.mind_record ;
-    mind_finite = mib.mind_finite ;
-    mind_ntypes = mib.mind_ntypes ;
-    mind_hyps = (assert (mib.mind_hyps=[]); []) ;
-    mind_nparams = mib.mind_nparams;
-    mind_nparams_rec = mib.mind_nparams_rec;
-    mind_params_ctxt =
-      map_rel_context (subst_mps sub) mib.mind_params_ctxt;
-    mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
-    mind_constraints = mib.mind_constraints  }
-
-let hcons_indarity = function
-  | Monomorphic a ->
-    Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity;
-		  mind_sort = hcons_sorts a.mind_sort }
-  | Polymorphic a -> Polymorphic (hcons_polyarity a)
-
-let hcons_mind_packet oib =
- { oib with
-   mind_typename = hcons_ident oib.mind_typename;
-   mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
-   mind_arity = hcons_indarity oib.mind_arity;
-   mind_consnames = array_smartmap hcons_ident oib.mind_consnames;
-   mind_user_lc = array_smartmap hcons_types oib.mind_user_lc;
-   mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc }
-
-let hcons_mind mib =
-  { mib with
-    mind_packets = array_smartmap hcons_mind_packet mib.mind_packets;
-    mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
-    mind_constraints = hcons_constraints mib.mind_constraints }
-
-(*s Modules: signature component specifications, module types, and
-  module declarations *)
-
-type structure_field_body =
-  | SFBconst of constant_body
-  | SFBmind of mutual_inductive_body
-  | SFBmodule of module_body
-  | SFBmodtype of module_type_body
-
-and structure_body = (label * structure_field_body) list
-
-and struct_expr_body =
-  | SEBident of module_path
-  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body
-  | SEBapply of struct_expr_body * struct_expr_body * constraints
-  | SEBstruct of structure_body
-  | SEBwith of struct_expr_body * with_declaration_body
-
-and with_declaration_body =
-    With_module_body of identifier list * module_path
-  | With_definition_body of  identifier list * constant_body
-
-and module_body =
-    { mod_mp : module_path;
-      mod_expr : struct_expr_body option; 
-      mod_type : struct_expr_body;
-      mod_type_alg : struct_expr_body option;
-      mod_constraints : constraints;
-      mod_delta : delta_resolver;
-      mod_retroknowledge : Retroknowledge.action list}
-
-and module_type_body =
-    { typ_mp : module_path;
-      typ_expr : struct_expr_body;
-      typ_expr_alg : struct_expr_body option ;
-      typ_constraints : constraints;
-      typ_delta :delta_resolver}
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index 4ee2fe57..bec52122 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -1,17 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Univ
 open Term
-open Cemitcodes
-open Sign
-open Mod_subst
+open Context
 
 (** This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
@@ -21,33 +18,24 @@ type engagement = ImpredicativeSet
 
 (** {6 Representation of constants (Definition/Axiom) } *)
 
-type polymorphic_arity = {
-  poly_param_levels : universe option list;
-  poly_level : universe;
-}
-
-type constant_type =
-  | NonPolymorphicType of types
-  | PolymorphicArity of rel_context * polymorphic_arity
-
-type constr_substituted
-
-val from_val : constr -> constr_substituted
-val force : constr_substituted -> constr
-
-(** Opaque proof terms are not loaded immediately, but are there
-    in a lazy form. Forcing this lazy may trigger some unmarshal of
-    the necessary structure. *)
+(** Non-universe polymorphic mode polymorphism (Coq 8.2+): inductives
+    and constants hiding inductives are implicitely polymorphic when
+    applied to parameters, on the universes appearing in the whnf of
+    their parameters and their conclusion, in a template style.
+    
+    In truely universe polymorphic mode, we always use RegularArity.
+*)
 
-type lazy_constr
+type template_arity = {
+  template_param_levels : Univ.universe_level option list;
+  template_level : Univ.universe;
+}
 
-val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr
-val force_lazy_constr : lazy_constr -> constr_substituted
-val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr
-val lazy_constr_is_val : lazy_constr -> bool
+type ('a, 'b) declaration_arity = 
+  | RegularArity of 'a
+  | TemplateArity of 'b
 
-val force_opaque : lazy_constr -> constr
-val opaque_from_val : constr -> lazy_constr
+type constant_type = (types, rel_context * template_arity) declaration_arity
 
 (** Inlining level of parameters at functor applications.
     None means no inlining *)
@@ -57,31 +45,43 @@ type inline = int option
 (** A constant can have no body (axiom/parameter), or a
     transparent body, or an opaque one *)
 
+(** Projections are a particular kind of constant: 
+    always transparent. *)
+
+type projection_body = {
+  proj_ind : mutual_inductive;
+  proj_npars : int;
+  proj_arg : int;
+  proj_type : types; (* Type under params *)
+  proj_eta : constr * types; (* Eta-expanded term and type *)
+  proj_body : constr; (* For compatibility with VMs only, the match version *)
+}
+
 type constant_def =
   | Undef of inline
-  | Def of constr_substituted
-  | OpaqueDef of lazy_constr
+  | Def of constr Mod_subst.substituted
+  | OpaqueDef of Opaqueproof.opaque
 
+type constant_universes = Univ.universe_context
+
+(* some contraints are in constant_constraints, some other may be in
+ * the OpaueDef *)
 type constant_body = {
-    const_hyps : section_context; (** New: younger hyp at top *)
+    const_hyps : Context.section_context; (** New: younger hyp at top *)
     const_body : constant_def;
     const_type : constant_type;
-    const_body_code : to_patch_substituted;
-    const_constraints : constraints }
-
-val subst_const_def : substitution -> constant_def -> constant_def
-val subst_const_body : substitution -> constant_body -> constant_body
-
-(** Is there a actual body in const_body or const_body_opaque ? *)
-
-val constant_has_body : constant_body -> bool
-
-(** Accessing const_body_opaque or const_body *)
-
-val body_of_constant : constant_body -> constr_substituted option
-
-val is_opaque : constant_body -> bool
-
+    const_body_code : Cemitcodes.to_patch_substituted;
+    const_polymorphic : bool; (** Is it polymorphic or not *)
+    const_universes : constant_universes;
+    const_proj : projection_body option;
+    const_inline_code : bool }
+
+type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ]
+
+type side_effect =
+  | SEsubproof of constant * constant_body * seff_env
+  | SEscheme of (inductive * constant * constant_body * seff_env) list * string
+    
 (** {6 Representation of mutual inductive types in the kernel } *)
 
 type recarg =
@@ -89,18 +89,8 @@ type recarg =
   | Mrec of inductive
   | Imbr of inductive
 
-val subst_recarg : substitution -> recarg -> recarg
-
 type wf_paths = recarg Rtree.t
 
-val mk_norec : wf_paths
-val mk_paths : recarg -> wf_paths list array -> wf_paths
-val dest_recarg : wf_paths -> recarg
-val dest_subterms : wf_paths -> wf_paths list array
-val recarg_length : wf_paths -> int -> int
-
-val subst_wf_paths : substitution -> wf_paths -> wf_paths
-
 (**
 {v
    Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
@@ -109,25 +99,32 @@ val subst_wf_paths : substitution -> wf_paths -> wf_paths
 v}
 *)
 
-type monomorphic_inductive_arity = {
-  mind_user_arity : constr;
+(** Record information:
+    If the record is not primitive, then None
+    Otherwise, we get:
+    - The identifier for the binder name of the record in primitive projections.
+    - The constants associated to each projection.
+    - The checked projection bodies. *)
+
+type record_body = (Id.t * constant array * projection_body array) option
+
+type regular_inductive_arity = {
+  mind_user_arity : types;
   mind_sort : sorts;
 }
 
-type inductive_arity =
-| Monomorphic of monomorphic_inductive_arity
-| Polymorphic of polymorphic_arity
+type inductive_arity = (regular_inductive_arity, template_arity) declaration_arity
 
 type one_inductive_body = {
 (** {8 Primitive datas } *)
 
-    mind_typename : identifier; (** Name of the type: [Ii] *)
+    mind_typename : Id.t; (** Name of the type: [Ii] *)
 
     mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
 
-    mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *)
+    mind_arity : inductive_arity; (** Arity sort and original user arity *)
 
-    mind_consnames : identifier array; (** Names of the constructors: [cij] *)
+    mind_consnames : Id.t array; (** Names of the constructors: [cij] *)
 
     mind_user_lc : types array;
  (** Types of the constructors with parameters:  [forall params, Tij],
@@ -138,12 +135,16 @@ type one_inductive_body = {
 
     mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *)
 
-    mind_nrealargs_ctxt : int; (** Length of realargs context (with let, no params) *)
+    mind_nrealdecls : int; (** Length of realargs context (with let, no params) *)
 
     mind_kelim : sorts_family list; (** List of allowed elimination sorts *)
 
     mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *)
 
+    mind_consnrealargs : int array;
+ (** Number of expected proper arguments of the constructors (w/o params)
+    (not used in the kernel) *)
+
     mind_consnrealdecls : int array;
  (** Length of the signature of the constructors (with let, w/o params)
     (not used in the kernel) *)
@@ -163,13 +164,13 @@ type mutual_inductive_body = {
 
     mind_packets : one_inductive_body array;  (** The component of the mutual inductive block *)
 
-    mind_record : bool;  (** Whether the inductive type has been declared as a record *)
+    mind_record : record_body option; (** The record information *)
 
-    mind_finite : bool;  (** Whether the type is inductive or coinductive *)
+    mind_finite : Decl_kinds.recursivity_kind;  (** Whether the type is inductive or coinductive *)
 
     mind_ntypes : int;  (** Number of types in the block *)
 
-    mind_hyps : section_context;  (** Section hypotheses on which the block depends *)
+    mind_hyps : Context.section_context;  (** Section hypotheses on which the block depends *)
 
     mind_nparams : int;  (** Number of expected parameters *)
 
@@ -177,14 +178,38 @@ type mutual_inductive_body = {
 
     mind_params_ctxt : rel_context;  (** The context of parameters (includes let-in declaration) *)
 
-    mind_constraints : constraints;  (** Universes constraints enforced by the inductive declaration *)
+    mind_polymorphic : bool; (** Is it polymorphic or not *)
 
-  }
+    mind_universes : Univ.universe_context; (** Local universe variables and constraints *)
+
+    mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *)
+  
+}
+
+(** {6 Module declarations } *)
 
-val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
+(** Functor expressions are forced to be on top of other expressions *)
 
-(** {6 Modules: signature component specifications, module types, and
-  module declarations } *)
+type ('ty,'a) functorize =
+  | NoFunctor of 'a
+  | MoreFunctor of MBId.t * 'ty * ('ty,'a) functorize
+
+(** The fully-algebraic module expressions : names, applications, 'with ...'.
+    They correspond to the user entries of non-interactive modules.
+    They will be later expanded into module structures in [Mod_typing],
+    and won't play any role into the kernel after that : they are kept
+    only for short module printing and for extraction. *)
+
+type with_declaration =
+  | WithMod of Id.t list * module_path
+  | WithDef of Id.t list * constr
+
+type module_alg_expr =
+  | MEident of module_path
+  | MEapply of module_alg_expr * module_path
+  | MEwith of module_alg_expr * with_declaration
+
+(** A component of a module structure *)
 
 type structure_field_body =
   | SFBconst of constant_body
@@ -192,57 +217,52 @@ type structure_field_body =
   | SFBmodule of module_body
   | SFBmodtype of module_type_body
 
-(** NB: we may encounter now (at most) twice the same label in
+(** A module structure is a list of labeled components.
+
+    Note : we may encounter now (at most) twice the same label in
     a [structure_body], once for a module ([SFBmodule] or [SFBmodtype])
     and once for an object ([SFBconst] or [SFBmind]) *)
 
-and structure_body = (label * structure_field_body) list
+and structure_body = (Label.t * structure_field_body) list
 
-and struct_expr_body =
-  | SEBident of module_path
-  | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body
-  | SEBapply of struct_expr_body * struct_expr_body * constraints
-  | SEBstruct of structure_body
-  | SEBwith of struct_expr_body * with_declaration_body
+(** A module signature is a structure, with possibly functors on top of it *)
 
-and with_declaration_body =
-    With_module_body of identifier list * module_path
-  | With_definition_body of  identifier list * constant_body
+and module_signature = (module_type_body,structure_body) functorize
+
+(** A module expression is an algebraic expression, possibly functorized. *)
+
+and module_expression = (module_type_body,module_alg_expr) functorize
+
+and module_implementation =
+  | Abstract (** no accessible implementation *)
+  | Algebraic of module_expression (** non-interactive algebraic expression *)
+  | Struct of module_signature (** interactive body *)
+  | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *)
 
 and module_body =
-    {  (** absolute path of the module *)
-      mod_mp : module_path;
-      (** Implementation *)
-      mod_expr : struct_expr_body option; 
-      (** Signature *)
-      mod_type : struct_expr_body;
-      (** algebraic structure expression is kept 
-	 if it's relevant for extraction  *)
-      mod_type_alg : struct_expr_body option; 
-      (** set of all constraint in the module  *)
-      mod_constraints : constraints;
-      (** quotiented set of equivalent constant and inductive name  *)
-      mod_delta : delta_resolver;
-      mod_retroknowledge : Retroknowledge.action list}
-      
-and module_type_body =
-    { 
-      (** Path of the module type *)
-      typ_mp : module_path;
-      typ_expr : struct_expr_body;
-      (** algebraic structure expression is kept 
-	 if it's relevant for extraction  *)
-      typ_expr_alg : struct_expr_body option ;
-      typ_constraints : constraints;
-      (** quotiented set of equivalent constant and inductive name  *)
-      typ_delta :delta_resolver}
-
-
-(** Hash-consing *)
-
-(** Here, strictly speaking, we don't perform true hash-consing
-    of the structure, but simply hash-cons all inner constr
-    and other known elements *)
-
-val hcons_const_body : constant_body -> constant_body
-val hcons_mind : mutual_inductive_body -> mutual_inductive_body
+  { mod_mp : module_path; (** absolute path of the module *)
+    mod_expr : module_implementation; (** implementation *)
+    mod_type : module_signature; (** expanded type *)
+    (** algebraic type, kept if it's relevant for extraction *)
+    mod_type_alg : module_expression option;
+    (** set of all constraints in the module  *)
+    mod_constraints : Univ.constraints;
+    (** quotiented set of equivalent constants and inductive names *)
+    mod_delta : Mod_subst.delta_resolver;
+    mod_retroknowledge : Retroknowledge.action list }
+
+(** A [module_type_body] is just a [module_body] with no
+    implementation ([mod_expr] always [Abstract]) and also
+    an empty [mod_retroknowledge] *)
+
+and module_type_body = module_body
+
+(** Extra invariants :
+
+    - No [MEwith] inside a [mod_expr] implementation : the 'with' syntax
+      is only supported for module types
+
+    - A module application is atomic, for instance ((M N) P) :
+      * the head of [MEapply] can only be another [MEapply] or a [MEident]
+      * the argument of [MEapply] is now directly forced to be a [module_path].
+*)
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
new file mode 100644
index 00000000..48a6098e
--- /dev/null
+++ b/kernel/declareops.ml
@@ -0,0 +1,320 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Declarations
+open Mod_subst
+open Util
+
+(** Operations concernings types in [Declarations] :
+    [constant_body], [mutual_inductive_body], [module_body] ... *)
+
+(** {6 Arities } *)
+
+let subst_decl_arity f g sub ar = 
+  match ar with
+  | RegularArity x -> 
+    let x' = f sub x in 
+      if x' == x then ar
+      else RegularArity x'
+  | TemplateArity x -> 
+    let x' = g sub x in 
+      if x' == x then ar
+      else TemplateArity x'
+
+let map_decl_arity f g = function
+  | RegularArity a -> RegularArity (f a)
+  | TemplateArity a -> TemplateArity (g a)
+
+let hcons_template_arity ar =
+  { template_param_levels = ar.template_param_levels;
+      (* List.smartmap (Option.smartmap Univ.hcons_univ_level) ar.template_param_levels; *)
+    template_level = Univ.hcons_univ ar.template_level }
+
+(** {6 Constants } *)
+
+let instantiate cb c =
+  if cb.const_polymorphic then 
+    Vars.subst_instance_constr (Univ.UContext.instance cb.const_universes) c
+  else c
+
+let body_of_constant otab cb = match cb.const_body with
+  | Undef _ -> None
+  | Def c -> Some (instantiate cb (force_constr c))
+  | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o))
+
+let type_of_constant cb =
+  match cb.const_type with
+  | RegularArity t as x -> 
+    let t' = instantiate cb t in
+      if t' == t then x else RegularArity t'
+  | TemplateArity _ as x -> x
+
+let constraints_of_constant otab cb = Univ.Constraint.union 
+  (Univ.UContext.constraints cb.const_universes)
+  (match cb.const_body with
+  | Undef _ -> Univ.empty_constraint
+  | Def c -> Univ.empty_constraint
+  | OpaqueDef o ->
+      Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o))
+
+let universes_of_constant otab cb = 
+  match cb.const_body with
+  | Undef _ | Def _ -> cb.const_universes
+  | OpaqueDef o -> 
+      let body_uctxs = Opaqueproof.force_constraints otab o in
+      assert(not cb.const_polymorphic || Univ.ContextSet.is_empty body_uctxs);
+      let uctxs = Univ.ContextSet.of_context cb.const_universes in
+      Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) 
+
+let universes_of_polymorphic_constant otab cb = 
+  if cb.const_polymorphic then 
+    let univs = universes_of_constant otab cb in
+      Univ.instantiate_univ_context univs
+  else Univ.UContext.empty
+
+let constant_has_body cb = match cb.const_body with
+  | Undef _ -> false
+  | Def _ | OpaqueDef _ -> true
+
+let is_opaque cb = match cb.const_body with
+  | OpaqueDef _ -> true
+  | Undef _ | Def _ -> false
+
+(** {7 Constant substitutions } *)
+
+let subst_rel_declaration sub (id,copt,t as x) =
+  let copt' = Option.smartmap (subst_mps sub) copt in
+  let t' = subst_mps sub t in
+  if copt == copt' && t == t' then x else (id,copt',t')
+
+let subst_rel_context sub = List.smartmap (subst_rel_declaration sub)
+
+let subst_template_cst_arity sub (ctx,s as arity) =
+  let ctx' = subst_rel_context sub ctx in
+    if ctx==ctx' then arity else (ctx',s)
+      
+let subst_const_type sub arity =
+  if is_empty_subst sub then arity
+  else subst_mps sub arity
+
+(** 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
+  | Def c -> Def (subst_constr sub c)
+  | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o)
+
+let subst_const_proj sub pb =
+  { pb with proj_ind = subst_mind sub pb.proj_ind;
+    proj_type = subst_mps sub pb.proj_type;
+    proj_body = subst_const_type sub pb.proj_body }
+
+let subst_const_body sub cb =
+  assert (List.is_empty cb.const_hyps); (* we're outside sections *)
+  if is_empty_subst sub then cb
+  else
+    let body' = subst_const_def sub cb.const_body in
+    let type' = subst_decl_arity subst_const_type subst_template_cst_arity sub cb.const_type in
+    let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in
+    if body' == cb.const_body && type' == cb.const_type
+      && proj' == cb.const_proj then cb
+    else
+      { const_hyps = [];
+        const_body = body';
+        const_type = type';
+        const_proj = proj';
+        const_body_code =
+          Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+        const_polymorphic = cb.const_polymorphic;
+        const_universes = cb.const_universes;
+        const_inline_code = cb.const_inline_code }
+
+(** {7 Hash-consing of constants } *)
+
+(** This hash-consing is currently quite partial : we only
+    share internal fields (e.g. constr), and not the records
+    themselves. But would it really bring substantial gains ? *)
+
+let hcons_rel_decl ((n,oc,t) as d) =
+  let n' = Names.Name.hcons n
+  and oc' = Option.smartmap Term.hcons_constr oc
+  and t' = Term.hcons_types t
+  in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
+
+let hcons_rel_context l = List.smartmap hcons_rel_decl l
+
+let hcons_regular_const_arity t = Term.hcons_constr t
+
+let hcons_template_const_arity (ctx, ar) = 
+  (hcons_rel_context ctx, hcons_template_arity ar)
+
+let hcons_const_type = 
+  map_decl_arity hcons_regular_const_arity hcons_template_const_arity
+
+let hcons_const_def = function
+  | Undef inl -> Undef inl
+  | Def l_constr ->
+    let constr = force_constr l_constr in
+    Def (from_val (Term.hcons_constr constr))
+  | OpaqueDef _ as x -> x (* hashconsed when turned indirect *)
+
+let hcons_const_body cb =
+  { cb with
+    const_body = hcons_const_def cb.const_body;
+    const_type = hcons_const_type cb.const_type;
+    const_universes = Univ.hcons_universe_context cb.const_universes }
+
+(** {6 Inductive types } *)
+
+let eq_recarg r1 r2 = match r1, r2 with
+| Norec, Norec -> true
+| Mrec i1, Mrec i2 -> Names.eq_ind i1 i2
+| Imbr i1, Imbr i2 -> Names.eq_ind i1 i2
+| _ -> false
+
+let subst_recarg sub r = match r with
+  | Norec -> r
+  | Mrec (kn,i) ->
+    let kn' = subst_mind sub kn in
+    if kn==kn' then r else Mrec (kn',i)
+  | Imbr (kn,i) ->
+    let kn' = subst_mind sub kn in
+    if kn==kn' then r else Imbr (kn',i)
+
+let mk_norec = Rtree.mk_node Norec [||]
+
+let mk_paths r recargs =
+  Rtree.mk_node r
+    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
+
+let dest_recarg p = fst (Rtree.dest_node p)
+
+(* dest_subterms returns the sizes of each argument of each constructor of
+   an inductive object of size [p]. This should never be done for Norec,
+   because the number of sons does not correspond to the number of
+   constructors.
+ *)
+let dest_subterms p =
+  let (ra,cstrs) = Rtree.dest_node p in
+  assert (match ra with Norec -> false | _ -> true);
+  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
+
+let recarg_length p j =
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.length (snd (Rtree.dest_node cstrs.(j-1)))
+
+let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
+
+(** {7 Substitution of inductive declarations } *)
+
+let subst_regular_ind_arity sub s =
+  let uar' = subst_mps sub s.mind_user_arity in
+    if uar' == s.mind_user_arity then s 
+    else { mind_user_arity = uar'; mind_sort = s.mind_sort }
+
+let subst_template_ind_arity sub s = s
+
+(* FIXME records *)
+let subst_ind_arity =
+  subst_decl_arity subst_regular_ind_arity subst_template_ind_arity
+
+let subst_mind_packet sub mbp =
+  { mind_consnames = mbp.mind_consnames;
+    mind_consnrealdecls = mbp.mind_consnrealdecls;
+    mind_consnrealargs = mbp.mind_consnrealargs;
+    mind_typename = mbp.mind_typename;
+    mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc;
+    mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
+    mind_arity = subst_ind_arity sub mbp.mind_arity;
+    mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc;
+    mind_nrealargs = mbp.mind_nrealargs;
+    mind_nrealdecls = mbp.mind_nrealdecls;
+    mind_kelim = mbp.mind_kelim;
+    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
+    mind_nb_constant = mbp.mind_nb_constant;
+    mind_nb_args = mbp.mind_nb_args;
+    mind_reloc_tbl = mbp.mind_reloc_tbl }
+
+let subst_mind_record sub (id, ps, pb as r) =
+  let ps' = Array.smartmap (subst_constant sub) ps in
+  let pb' = Array.smartmap (subst_const_proj sub) pb in
+    if ps' == ps && pb' == pb then r
+    else (id, ps', pb')
+
+let subst_mind_body sub mib =
+  { mind_record = Option.smartmap (Option.smartmap (subst_mind_record sub)) mib.mind_record ;
+    mind_finite = mib.mind_finite ;
+    mind_ntypes = mib.mind_ntypes ;
+    mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false);
+    mind_nparams = mib.mind_nparams;
+    mind_nparams_rec = mib.mind_nparams_rec;
+    mind_params_ctxt =
+      Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt;
+    mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ;
+    mind_polymorphic = mib.mind_polymorphic;
+    mind_universes = mib.mind_universes;
+    mind_private = mib.mind_private }
+
+let inductive_instance mib =
+  if mib.mind_polymorphic then
+    Univ.UContext.instance mib.mind_universes
+  else Univ.Instance.empty
+
+let inductive_context mib =
+  if mib.mind_polymorphic then 
+    Univ.instantiate_univ_context mib.mind_universes 
+  else Univ.UContext.empty
+
+(** {6 Hash-consing of inductive declarations } *)
+
+let hcons_regular_ind_arity a =
+  { mind_user_arity = Term.hcons_constr a.mind_user_arity;
+    mind_sort = Term.hcons_sorts a.mind_sort }
+
+(** Just as for constants, this hash-consing is quite partial *)
+
+let hcons_ind_arity =
+  map_decl_arity hcons_regular_ind_arity hcons_template_arity
+
+(** Substitution of inductive declarations *)
+
+let hcons_mind_packet oib =
+  let user = Array.smartmap Term.hcons_types oib.mind_user_lc in
+  let nf = Array.smartmap Term.hcons_types oib.mind_nf_lc in
+  (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *)
+  let nf = if Array.equal (==) user nf then user else nf in
+  { oib with
+    mind_typename = Names.Id.hcons oib.mind_typename;
+    mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
+    mind_arity = hcons_ind_arity oib.mind_arity;
+    mind_consnames = Array.smartmap Names.Id.hcons oib.mind_consnames;
+    mind_user_lc = user;
+    mind_nf_lc = nf }
+
+let hcons_mind mib =
+  { mib with
+    mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets;
+    mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
+    mind_universes = Univ.hcons_universe_context mib.mind_universes }
+
+(** {6 Stm machinery } *)
+
+let string_of_side_effect = function
+  | SEsubproof (c,_,_) -> Names.string_of_con c
+  | SEscheme (cl,_) ->
+      String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl)
+type side_effects = side_effect list
+let no_seff = ([] : side_effects)
+let iter_side_effects f l = List.iter f (List.rev l)
+let fold_side_effects f a l = List.fold_left f a l
+let uniquize_side_effects l = List.rev (CList.uniquize (List.rev l))
+let union_side_effects l1 l2 = l1 @ l2
+let flatten_side_effects l = List.flatten l
+let side_effects_of_list l = l
+let cons_side_effects x l = x :: l
+let side_effects_is_empty = List.is_empty
diff --git a/kernel/declareops.mli b/kernel/declareops.mli
new file mode 100644
index 00000000..47a82cc6
--- /dev/null
+++ b/kernel/declareops.mli
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Declarations
+open Mod_subst
+open Univ
+open Context
+
+(** Operations concerning types in [Declarations] :
+    [constant_body], [mutual_inductive_body], [module_body] ... *)
+
+(** {6 Arities} *)
+
+val map_decl_arity : ('a -> 'c) -> ('b -> 'd) ->
+  ('a, 'b) declaration_arity -> ('c, 'd) declaration_arity
+
+(** {6 Constants} *)
+
+val subst_const_body : substitution -> constant_body -> constant_body
+
+(** Is there a actual body in const_body ? *)
+
+val constant_has_body : constant_body -> bool
+
+(** Accessing const_body, forcing access to opaque proof term if needed.
+    Only use this function if you know what you're doing. *)
+
+val body_of_constant :
+  Opaqueproof.opaquetab -> constant_body -> Term.constr option
+val type_of_constant : constant_body -> constant_type
+val constraints_of_constant :
+  Opaqueproof.opaquetab -> constant_body -> Univ.constraints
+val universes_of_constant :
+  Opaqueproof.opaquetab -> constant_body -> Univ.universe_context
+
+(** Return the universe context, in case the definition is polymorphic, otherwise
+    the context is empty. *)
+
+val universes_of_polymorphic_constant :
+  Opaqueproof.opaquetab -> constant_body -> Univ.universe_context
+
+val is_opaque : constant_body -> bool
+
+(** Side effects *)
+
+val string_of_side_effect : side_effect -> string
+
+type side_effects
+val no_seff : side_effects
+val iter_side_effects : (side_effect -> unit) -> side_effects -> unit
+val fold_side_effects : ('a -> side_effect -> 'a) -> 'a -> side_effects -> 'a
+val uniquize_side_effects : side_effects -> side_effects
+val union_side_effects : side_effects -> side_effects -> side_effects
+val flatten_side_effects : side_effects list -> side_effects
+val side_effects_of_list : side_effect list -> side_effects
+val cons_side_effects : side_effect -> side_effects -> side_effects
+val side_effects_is_empty : side_effects -> bool
+
+(** {6 Inductive types} *)
+
+val eq_recarg : recarg -> recarg -> bool
+
+val subst_recarg : substitution -> recarg -> recarg
+
+val mk_norec : wf_paths
+val mk_paths : recarg -> wf_paths list array -> wf_paths
+val dest_recarg : wf_paths -> recarg
+val dest_subterms : wf_paths -> wf_paths list array
+val recarg_length : wf_paths -> int -> int
+
+val subst_wf_paths : substitution -> wf_paths -> wf_paths
+
+val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body
+
+val inductive_instance : mutual_inductive_body -> universe_instance
+val inductive_context : mutual_inductive_body -> universe_context
+
+(** {6 Hash-consing} *)
+
+(** Here, strictly speaking, we don't perform true hash-consing
+    of the structure, but simply hash-cons all inner constr
+    and other known elements *)
+
+val hcons_const_body : constant_body -> constant_body
+val hcons_mind : mutual_inductive_body -> mutual_inductive_body
diff --git a/kernel/entries.ml b/kernel/entries.ml
deleted file mode 100644
index 1b98c7b8..00000000
--- a/kernel/entries.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Names
-open Univ
-open Term
-open Sign
-(*i*)
-
-(* This module defines the entry types for global declarations. This
-   information is entered in the environments. This includes global
-   constants/axioms, mutual inductive definitions, modules and module
-   types *)
-
-
-(*s Local entries *)
-
-type local_entry =
-  | LocalDef of constr
-  | LocalAssum of constr
-
-
-(*s Declaration of inductive types. *)
-
-(* Assume the following definition in concrete syntax:
-\begin{verbatim}
-Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
-...
-with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
-\end{verbatim}
-then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
-[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
-[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 one_inductive_entry = {
-  mind_entry_typename : identifier;
-  mind_entry_arity : constr;
-  mind_entry_consnames : identifier list;
-  mind_entry_lc : constr list }
-
-type mutual_inductive_entry = {
-  mind_entry_record : bool;
-  mind_entry_finite : bool;
-  mind_entry_params : (identifier * local_entry) list;
-  mind_entry_inds : one_inductive_entry list }
-
-
-(*s Constants (Definition/Axiom) *)
-
-type definition_entry = {
-  const_entry_body   : constr;
-  const_entry_secctx : section_context option;
-  const_entry_type   : types option;
-  const_entry_opaque : bool }
-
-type inline = int option (* inlining level, None for no inlining *)
-
-type parameter_entry = section_context option * types * inline 
-
-type constant_entry =
-  | DefinitionEntry of definition_entry
-  | ParameterEntry of parameter_entry
-
-(*s Modules *)
-
-type module_struct_entry =
-    MSEident of module_path
-  | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
-  | MSEwith of module_struct_entry * with_declaration
-  | MSEapply of module_struct_entry * module_struct_entry
-
-and with_declaration =
-    With_Module of identifier list * module_path
-  | With_Definition of identifier list * constr
-
-and module_entry =
-    { mod_entry_type : module_struct_entry option;
-      mod_entry_expr : module_struct_entry option}
-
-
diff --git a/kernel/entries.mli b/kernel/entries.mli
index 5782d092..303d27d3 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Univ
 open Term
-open Sign
 
 (** This module defines the entry types for global declarations. This
    information is entered in the environments. This includes global
@@ -37,47 +35,64 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1];
 *)
 
 type one_inductive_entry = {
-  mind_entry_typename : identifier;
+  mind_entry_typename : Id.t;
   mind_entry_arity : constr;
-  mind_entry_consnames : identifier list;
+  mind_entry_template : bool; (* Use template polymorphism *)
+  mind_entry_consnames : Id.t list;
   mind_entry_lc : constr list }
 
 type mutual_inductive_entry = {
-  mind_entry_record : bool;
-  mind_entry_finite : bool;
-  mind_entry_params : (identifier * local_entry) list;
-  mind_entry_inds : one_inductive_entry list }
+  mind_entry_record : (Id.t option) option; 
+  (** Some (Some id): primitive record with id the binder name of the record
+      in projections.
+      Some None: non-primitive record *)
+  mind_entry_finite : Decl_kinds.recursivity_kind;
+  mind_entry_params : (Id.t * local_entry) list;
+  mind_entry_inds : one_inductive_entry list;
+  mind_entry_polymorphic : bool; 
+  mind_entry_universes : Univ.universe_context;
+  mind_entry_private : bool option }
 
 (** {6 Constants (Definition/Axiom) } *)
+type proof_output = constr Univ.in_universe_context_set * Declareops.side_effects
+type const_entry_body = proof_output Future.computation
 
 type definition_entry = {
-  const_entry_body   : constr;
-  const_entry_secctx : section_context option;
-  const_entry_type   : types option;
-  const_entry_opaque : bool }
+  const_entry_body   : const_entry_body;
+  (* List of section variables *)
+  const_entry_secctx : Context.section_context option;
+  (* State id on which the completion of type checking is reported *)
+  const_entry_feedback : Stateid.t option;
+  const_entry_type        : types option;
+  const_entry_polymorphic : bool;
+  const_entry_universes   : Univ.universe_context;
+  const_entry_opaque      : bool;
+  const_entry_inline_code : bool }
 
 type inline = int option (* inlining level, None for no inlining *)
 
-type parameter_entry = section_context option * types * inline 
+type parameter_entry = 
+    Context.section_context option * bool * types Univ.in_universe_context * inline 
+
+type projection_entry = {
+  proj_entry_ind : mutual_inductive;
+  proj_entry_arg : int }
 
 type constant_entry =
   | DefinitionEntry of definition_entry
   | ParameterEntry of parameter_entry
+  | ProjectionEntry of projection_entry
 
 (** {6 Modules } *)
 
-type module_struct_entry =
-    MSEident of module_path
-  | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
-  | MSEwith of module_struct_entry * with_declaration
-  | MSEapply of module_struct_entry * module_struct_entry
-
-and with_declaration =
-    With_Module of identifier list * module_path
-  | With_Definition of identifier list * constr
+type module_struct_entry = Declarations.module_alg_expr
 
-and module_entry =
-    { mod_entry_type : module_struct_entry option;
-      mod_entry_expr : module_struct_entry option}
+type module_params_entry =
+  (MBId.t * module_struct_entry) list (** older first *)
 
+type module_type_entry = module_params_entry * module_struct_entry
 
+type module_entry =
+  | MType of module_params_entry * module_struct_entry
+  | MExpr of
+      module_params_entry * module_struct_entry * module_struct_entry option
diff --git a/kernel/environ.ml b/kernel/environ.ml
index b8818950..0ebff440 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -20,11 +20,12 @@
 (* This file defines the type of environments on which the
    type-checker works, together with simple related functions *)
 
+open Errors
 open Util
 open Names
-open Sign
-open Univ
 open Term
+open Context
+open Vars
 open Declarations
 open Pre_env
 
@@ -36,20 +37,33 @@ type env = Pre_env.env
 
 let pre_env env = env
 let env_of_pre_env env = env
+let oracle env = env.env_conv_oracle
+let set_oracle env o = { env with env_conv_oracle = o }
 
 let empty_named_context_val = empty_named_context_val
 
 let empty_env = empty_env
 
 let engagement env = env.env_stratification.env_engagement
+
+let type_in_type env = env.env_stratification.env_type_in_type
+
+let is_impredicative_set env = 
+  match engagement env with
+  | Some ImpredicativeSet -> true
+  | _ -> false
+
 let universes env = env.env_stratification.env_universes
 let named_context env = env.env_named_context
 let named_context_val env = env.env_named_context,env.env_named_vals
 let rel_context env = env.env_rel_context
+let opaque_tables env = env.indirect_pterms
+let set_opaque_tables env indirect_pterms = { env with indirect_pterms }
 
 let empty_context env =
-  env.env_rel_context = empty_rel_context
-  && env.env_named_context = empty_named_context
+  match env.env_rel_context, env.env_named_context with
+  | [], [] -> true
+  | _ -> false
 
 (* Rel context *)
 let lookup_rel n env =
@@ -64,10 +78,10 @@ let nb_rel env = env.env_nb_rel
 
 let push_rel = push_rel
 
-let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x
+let push_rel_context ctxt x = Context.fold_rel_context push_rel ctxt ~init:x
 
 let push_rec_types (lna,typarray,_) env =
-  let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
+  let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in
   Array.fold_left (fun e assum -> push_rel assum e) env ctxt
 
 let fold_rel_context f env ~init =
@@ -92,21 +106,29 @@ let named_vals_of_val = snd
    each declarations.
    *** /!\ ***   [f t] should be convertible with t *)
 let map_named_val f (ctxt,ctxtv) =
-  let ctxt =
-    List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in
-  (ctxt,ctxtv)
+  let rec map ctx = match ctx with
+  | [] -> []
+  | (id, body, typ) :: rem ->
+    let body' = Option.smartmap f body in
+    let typ' = f typ in
+    let rem' = map rem in
+    if body' == body && typ' == typ && rem' == rem then ctx
+    else (id, body', typ') :: rem'
+  in
+  (map ctxt, ctxtv)
 
 let empty_named_context = empty_named_context
 
 let push_named = push_named
+let push_named_context = List.fold_right push_named
 let push_named_context_val = push_named_context_val
 
 let val_of_named_context ctxt =
   List.fold_right push_named_context_val ctxt empty_named_context_val
 
 
-let lookup_named id env = Sign.lookup_named id env.env_named_context
-let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
+let lookup_named id env = Context.lookup_named id env.env_named_context
+let lookup_named_val id (ctxt,_) = Context.lookup_named id ctxt
 
 let eq_named_context_val c1 c2 =
    c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2)
@@ -134,6 +156,12 @@ let reset_with_named_context (ctxt,ctxtv) env =
 
 let reset_context = reset_with_named_context empty_named_context_val
 
+let pop_rel_context n env =
+  let ctxt = env.env_rel_context in
+  { env with
+    env_rel_context = List.firstn (List.length ctxt - n) ctxt;
+    env_nb_rel = env.env_nb_rel - n }
+
 let fold_named_context f env ~init =
   let rec fold_right env =
     match env.env_named_context with
@@ -145,77 +173,210 @@ let fold_named_context f env ~init =
   in fold_right env
 
 let fold_named_context_reverse f ~init env =
-  Sign.fold_named_context_reverse f ~init:init (named_context env)
+  Context.fold_named_context_reverse f ~init:init (named_context env)
+
+
+(* Universe constraints *)
+
+let add_constraints c env =
+  if Univ.Constraint.is_empty c then
+    env
+  else
+    let s = env.env_stratification in
+    { env with env_stratification =
+      { s with env_universes = Univ.merge_constraints c s.env_universes } }
+
+let check_constraints c env =
+  Univ.check_constraints c env.env_stratification.env_universes
+
+let set_engagement c env = (* Unsafe *)
+  { env with env_stratification =
+    { env.env_stratification with env_engagement = Some c } }
+
+let set_type_in_type env =
+  { env with env_stratification =
+    { env.env_stratification with env_type_in_type = true } }
+
+let push_constraints_to_env (_,univs) env =
+  add_constraints univs env
+
+let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env
+let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env
 
 (* Global constants *)
 
 let lookup_constant = lookup_constant
 
-let add_constant kn cs env =
+let no_link_info = NotLinked
+
+let add_constant_key kn cb linkinfo env =
   let new_constants =
-    Cmap_env.add kn (cs,ref None) env.env_globals.env_constants in
+    Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.env_constants in
   let new_globals =
     { env.env_globals with
 	env_constants = new_constants } in
   { env with env_globals = new_globals }
 
+let add_constant kn cb env =
+  add_constant_key kn cb no_link_info env
+
+let constraints_of cb u =
+  let univs = cb.const_universes in
+    Univ.subst_instance_constraints u (Univ.UContext.constraints univs)
+
+let map_regular_arity f = function
+  | RegularArity a as ar -> 
+    let a' = f a in 
+      if a' == a then ar else RegularArity a'
+  | TemplateArity _ -> assert false
+
 (* constant_type gives the type of a constant *)
-let constant_type env kn =
+let constant_type env (kn,u) =
   let cb = lookup_constant kn env in
-    cb.const_type
+    if cb.const_polymorphic then
+      let csts = constraints_of cb u in
+	(map_regular_arity (subst_instance_constr u) cb.const_type, csts)
+    else cb.const_type, Univ.Constraint.empty
 
-type const_evaluation_result = NoBody | Opaque
+let constant_context env kn =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic then cb.const_universes
+    else Univ.UContext.empty
+
+type const_evaluation_result = NoBody | Opaque | IsProj
 
 exception NotEvaluableConst of const_evaluation_result
 
-let constant_value env kn =
+let constant_value env (kn,u) =
+  let cb = lookup_constant kn env in
+    if cb.const_proj = None then
+      match cb.const_body with
+      | Def l_body -> 
+	if cb.const_polymorphic then
+	  let csts = constraints_of cb u in
+	    (subst_instance_constr u (Mod_subst.force_constr l_body), csts)
+	else Mod_subst.force_constr l_body, Univ.Constraint.empty
+      | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
+      | Undef _ -> raise (NotEvaluableConst NoBody)
+    else raise (NotEvaluableConst IsProj)
+
+let constant_opt_value env cst =
+  try Some (constant_value env cst)
+  with NotEvaluableConst _ -> None
+
+let constant_value_and_type env (kn, u) =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic 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', map_regular_arity (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
+
+(* These functions should be called under the invariant that [env] 
+   already contains the constraints corresponding to the constant 
+   application. *)
+
+(* constant_type gives the type of a constant *)
+let constant_type_in env (kn,u) =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic then
+      map_regular_arity (subst_instance_constr u) cb.const_type
+    else cb.const_type
+
+let constant_value_in env (kn,u) =
   let cb = lookup_constant kn env in
   match cb.const_body with
-    | Def l_body -> Declarations.force l_body
+    | Def l_body -> 
+      let b = Mod_subst.force_constr l_body in
+	subst_instance_constr u b
     | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
     | Undef _ -> raise (NotEvaluableConst NoBody)
 
-let constant_opt_value env cst =
-  try Some (constant_value env cst)
+let constant_opt_value_in env cst =
+  try Some (constant_value_in env cst)
   with NotEvaluableConst _ -> None
 
 (* A global const is evaluable if it is defined and not opaque *)
-let evaluable_constant cst env =
-  try let _  = constant_value env cst in true
-  with NotEvaluableConst _ -> false
+let evaluable_constant kn env =
+  let cb = lookup_constant kn env in
+    match cb.const_body with
+    | Def _ -> true
+    | OpaqueDef _ -> false
+    | Undef _ -> false
+
+let polymorphic_constant cst env =
+  (lookup_constant cst env).const_polymorphic
+
+let polymorphic_pconstant (cst,u) env =
+  if Univ.Instance.is_empty u then false
+  else polymorphic_constant cst env
+
+let template_polymorphic_constant cst env =
+  match (lookup_constant cst env).const_type with 
+  | TemplateArity _ -> true
+  | RegularArity _ -> false
+
+let template_polymorphic_pconstant (cst,u) env =
+  if not (Univ.Instance.is_empty u) then false
+  else template_polymorphic_constant cst env
+
+let lookup_projection cst env =
+  match (lookup_constant (Projection.constant cst) env).const_proj with 
+  | Some pb -> pb
+  | None -> anomaly (Pp.str "lookup_projection: constant is not a projection")
+
+let is_projection cst env =
+  match (lookup_constant cst env).const_proj with 
+  | Some _ -> true
+  | None -> false
 
 (* Mutual Inductives *)
 let lookup_mind = lookup_mind
+
+let polymorphic_ind (mind,i) env =
+  (lookup_mind mind env).mind_polymorphic
+
+let polymorphic_pind (ind,u) env =
+  if Univ.Instance.is_empty u then false
+  else polymorphic_ind ind env
+
+let template_polymorphic_ind (mind,i) env =
+  match (lookup_mind mind env).mind_packets.(i).mind_arity with 
+  | TemplateArity _ -> true
+  | RegularArity _ -> false
+
+let template_polymorphic_pind (ind,u) env =
+  if not (Univ.Instance.is_empty u) then false
+  else template_polymorphic_ind ind env
   
-let add_mind kn mib env =
-  let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in
+let add_mind_key kn mind_key env =
+  let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in
   let new_globals =
     { env.env_globals with
 	env_inductives = new_inds } in
   { env with env_globals = new_globals }
 
-(* Universe constraints *)
-
-let add_constraints c env =
-  if is_empty_constraint c then
-    env
-  else
-    let s = env.env_stratification in
-    { env with env_stratification =
-      { s with env_universes = merge_constraints c s.env_universes } }
-
-let set_engagement c env = (* Unsafe *)
-  { env with env_stratification =
-    { env.env_stratification with env_engagement = Some c } }
+let add_mind kn mib env =
+  let li = ref no_link_info in add_mind_key kn (mib, li) env
 
 (* Lookup of section variables *)
+
 let lookup_constant_variables c env =
   let cmap = lookup_constant c env in
-  Sign.vars_of_named_context cmap.const_hyps
+  Context.vars_of_named_context cmap.const_hyps
 
 let lookup_inductive_variables (kn,i) env =
   let mis = lookup_mind kn env in
-  Sign.vars_of_named_context mis.mind_hyps
+  Context.vars_of_named_context mis.mind_hyps
 
 let lookup_constructor_variables (ind,_) env =
   lookup_inductive_variables ind env
@@ -224,10 +385,11 @@ let lookup_constructor_variables (ind,_) env =
 
 let vars_of_global env constr =
   match kind_of_term constr with
-      Var id -> [id]
-    | Const kn -> lookup_constant_variables kn env
-    | Ind ind -> lookup_inductive_variables ind env
-    | Construct cstr -> lookup_constructor_variables cstr env
+      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 global_vars_set env constr =
@@ -235,54 +397,54 @@ let global_vars_set env constr =
     let acc =
       match kind_of_term c with
       | Var _ | Const _ | Ind _ | Construct _ ->
-	  List.fold_right Idset.add (vars_of_global env c) acc
+	  Id.Set.union (vars_of_global env c) acc
       | _ ->
 	  acc in
     fold_constr filtrec acc c
   in
-    filtrec Idset.empty constr
+    filtrec Id.Set.empty constr
 
 
 (* [keep_hyps env ids] keeps the part of the section context of [env] which
    contains the variables of the set [ids], and recursively the variables
    contained in the types of the needed variables. *)
 
+let really_needed env needed =
+  Context.fold_named_context_reverse
+    (fun need (id,copt,t) ->
+      if Id.Set.mem id need then
+        let globc =
+          match copt with
+            | None -> Id.Set.empty
+            | Some c -> global_vars_set env c in
+        Id.Set.union
+          (global_vars_set env t)
+          (Id.Set.union globc need)
+      else need)
+    ~init:needed
+    (named_context env)
+
 let keep_hyps env needed =
-  let really_needed =
-    Sign.fold_named_context_reverse
-      (fun need (id,copt,t) ->
-        if Idset.mem id need then
-          let globc =
-	    match copt with
-	      | None -> Idset.empty
-	      | Some c -> global_vars_set env c in
-	  Idset.union
-            (global_vars_set env t)
-	    (Idset.union globc need)
-        else need)
-      ~init:needed
-      (named_context env) in
-  Sign.fold_named_context
+  let really_needed = really_needed env needed in
+  Context.fold_named_context
     (fun (id,_,_ as d) nsign ->
-      if Idset.mem id really_needed then add_named_decl d nsign
+      if Id.Set.mem id really_needed then add_named_decl d nsign
       else nsign)
     (named_context env)
     ~init:empty_named_context
 
 (* Modules *)
 
-let add_modtype ln mtb env =
-  let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
-  let new_globals =
-    { env.env_globals with
-	env_modtypes = new_modtypes } in
+let add_modtype mtb env =
+  let mp = mtb.mod_mp in
+  let new_modtypes = MPmap.add mp mtb env.env_globals.env_modtypes in
+  let new_globals = { env.env_globals with env_modtypes = new_modtypes } in
   { env with env_globals = new_globals }
 
-let shallow_add_module mp mb env =
+let shallow_add_module mb env =
+  let mp = mb.mod_mp in
   let new_mods = MPmap.add mp mb env.env_globals.env_modules in
-  let new_globals =
-    { env.env_globals with
-	env_modules = new_mods } in
+  let new_globals = { env.env_globals with env_modules = new_mods } in
   { env with env_globals = new_globals }
 
 let lookup_module mp env =
@@ -315,11 +477,11 @@ let compile_constant_body = Cbytegen.compile_constant_body
 
 exception Hyp_not_found
 
-let rec apply_to_hyp (ctxt,vals) id f =
+let apply_to_hyp (ctxt,vals) id f =
   let rec aux rtail ctxt vals =
     match ctxt, vals with
     | (idc,c,ct as d)::ctxt, v::vals ->
-	if idc = id then
+	if Id.equal idc id then
 	  (f ctxt d rtail)::ctxt, v::vals
 	else
 	  let ctxt',vals' = aux (d::rtail) ctxt vals in
@@ -328,11 +490,11 @@ let rec apply_to_hyp (ctxt,vals) id f =
     | _, _ -> assert false
   in aux [] ctxt vals
 
-let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
+let apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
   let rec aux ctxt vals =
     match ctxt,vals with
     | (idc,c,ct as d)::ctxt, v::vals ->
-	if idc = id then
+	if Id.equal idc id then
 	  let sign = ctxt,vals in
 	  push_named_context_val (f d sign) sign
 	else
@@ -346,7 +508,7 @@ let insert_after_hyp (ctxt,vals) id d check =
   let rec aux ctxt vals =
     match  ctxt, vals with
     | (idc,c,ct)::ctxt', v::vals' ->
-	if idc = id then begin
+	if Id.equal idc id then begin
 	  check ctxt;
 	  push_named_context_val d (ctxt,vals)
 	end else
@@ -359,18 +521,22 @@ let insert_after_hyp (ctxt,vals) id d check =
 
 (* To be used in Logic.clear_hyps *)
 let remove_hyps ids check_context check_value (ctxt, vals) =
-  List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) ->
-      if List.mem id ids then
-	(ctxt,vals)
-      else
-	let nd = check_context d in
-	let nv = check_value v in
-	  (nd::ctxt,(id',nv)::vals))
-		     ctxt vals ([],[])
-
-
-
-
+  let rec remove_hyps ctxt vals = match ctxt, vals with
+  | [], [] -> [], []
+  | d :: rctxt, (nid, v) :: rvals ->
+    let (id, _, _) = d in
+    let ans = remove_hyps rctxt rvals in
+    if Id.Set.mem id ids then ans
+    else
+      let (rctxt', rvals') = ans in
+      let d' = check_context d in
+      let v' = check_value v in
+      if d == d' && v == v' && rctxt == rctxt' && rvals == rvals' then
+        ctxt, vals
+      else (d' :: rctxt', (nid, v') :: rvals')
+  | _ -> assert false
+  in
+  remove_hyps ctxt vals
 
 (*spiwack: the following functions assemble the pieces of the retroknowledge
    note that the "consistent" register function is available in the module
@@ -385,35 +551,23 @@ let retroknowledge f env =
 let registered env field =
     retroknowledge mem env field
 
-(* spiwack: this unregistration function is not in operation yet. It should
-            not be used *)
-(* this unregistration function assumes that no "constr" can hold two different
-   places in the retroknowledge. There is no reason why it shouldn't be true,
-   but in case someone needs it, remember to add special branches to the
-   unregister function *)
-let unregister env field =
-  match field with
-    | KInt31 (_,Int31Type) ->
-	(*there is only one matching kind due to the fact that Environ.env
-          is abstract, and that the only function which add elements to the
-          retroknowledge is Environ.register which enforces this shape *)
-	(match retroknowledge find env field with
-	   | Ind i31t -> let i31c = Construct (i31t, 1) in
-	     {env with retroknowledge =
-		 remove (retroknowledge clear_info env i31c) field}
-	   | _ -> assert false)
-    |_ -> {env with retroknowledge =
-	   try
-	     remove (retroknowledge clear_info env
-                       (retroknowledge find env field)) field
-	   with Not_found ->
-	     retroknowledge remove 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 entry =
+  match field with
+    | KInt31 (grp, Int31Type) ->
+        let i31c = match kind_of_term entry with
+                     | Ind i31t -> mkConstructUi (i31t, 1)
+		     | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type")
+	in
+        register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry
+    | field -> register_one env field entry
 
 (* the Environ.register function syncrhonizes the proactive and reactive
    retroknowledge. *)
-let register =
+let dispatch =
 
   (* subfunction used for static decompilation of int31 (after a vm_compute,
      see pretyping/vnorm.ml for more information) *)
@@ -421,7 +575,7 @@ let register =
     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 (land) i ((lsl) 1 n) = 0 then
+      if Int.equal (i land (1 lsl n)) 0 then
         1
       else
         2
@@ -434,92 +588,94 @@ let register =
 	  mkApp(mkConstruct(ind, 1), array_of_int tag)
   in
 
-  (* subfunction which adds the information bound to the constructor of
-     the int31 type to the reactive retroknowledge *)
-  let add_int31c retroknowledge c =
-    let rk = add_vm_constant_static_info retroknowledge c
-                                         Cbytegen.compile_structured_int31
-    in
-    add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation
-  in
-
-  (* subfunction which adds the compiling information of an
+  (* 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 add_int31_op retroknowledge v n op kn =
-    add_vm_compiling_info retroknowledge v (Cbytegen.op_compilation n op kn)
+  let int31_op n op prim kn =
+    { empty_reactive_info with
+      vm_compiling = Some (Cbytegen.op_compilation n op kn);
+      native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn));
+    }
   in
 
-fun env field value ->
-  (* subfunction which shortens the (very often use) registration of binary
-     operators to the reactive retroknowledge. *)
-  let add_int31_binop_from_const op =
-    match value with
-      | Const kn ->  retroknowledge add_int31_op env value 2
-	                               op kn
-      | _ -> anomaly "Environ.register: should be a constant"
-  in
-  let add_int31_unop_from_const op =
-    match value with
-      | Const kn ->  retroknowledge add_int31_op env value 1
-	                               op kn
-      | _ -> anomaly "Environ.register: should be a constant"
-  in
-  (* subfunction which completes the function constr_of_int31 above
-     by performing the actual retroknowledge operations *)
-  let add_int31_decompilation_from_type rk =
-    (* invariant : the type of bits is registered, otherwise the function
-       would raise Not_found. The invariant is enforced in safe_typing.ml *)
-    match field with
-      | KInt31 (grp, Int31Type) ->
-	  (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with
-	    | Ind i31bit_type ->
-		(match value with
-		  | Ind i31t ->
-		      Retroknowledge.add_vm_decompile_constant_info rk
-		               value (constr_of_int31 i31t i31bit_type)
-		  | _ -> anomaly "Environ.register: should be an inductive type")
-	    | _ -> anomaly "Environ.register: Int31Bits should be an inductive type")
-      | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field"
+fun rk value field ->
+  (* subfunction which shortens the (very common) dispatch of operations *)
+  let int31_op_from_const n op prim =
+    match kind_of_term value with
+      | Const kn ->  int31_op n op prim kn
+      | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")
   in
-  {env with retroknowledge =
-  let retroknowledge_with_reactive_info =
+  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 i31c = match value with
-                     | Ind i31t -> (Construct (i31t, 1))
-		     | _ -> anomaly "Environ.register: should be an inductive type"
-	in
-	add_int31_decompilation_from_type
-	  (add_vm_before_match_info
-	     (retroknowledge add_int31c env i31c)
-	     value Cbytegen.int31_escape_before_match)
-    | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31
-    | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31
-    | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31
-    | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31
-    | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31
-    | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const
-	                                           Cbytecodes.Ksubcarrycint31
-    | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31
-    | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31
-    | KInt31 (_, Int31Div21) -> (* this is a ternary operation *)
-                                (match value with
-				 | Const kn ->
-				     retroknowledge add_int31_op env value 3
-	                               Cbytecodes.Kdiv21int31 kn
-				 | _ -> anomaly "Environ.register: should be a constant")
-    | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31
-    | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *)
-                                (match value with
-				 | Const kn ->
-				     retroknowledge add_int31_op env value 3
-	                               Cbytecodes.Kaddmuldivint31 kn
-				 | _ -> anomaly "Environ.register: should be a constant")
-    | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31
-    | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31
-    | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31
-    | _ -> env.retroknowledge
-  in
-  Retroknowledge.add_field retroknowledge_with_reactive_info field value
-  }
+    | KInt31 (grp, Int31Type) ->
+        let int31bit =
+          (* invariant : the type of bits is registered, otherwise the function
+             would raise Not_found. The invariant is enforced in safe_typing.ml *)
+          match field with
+          | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits))
+          | _ -> anomaly ~label:"Environ.register"
+              (Pp.str "add_int31_decompilation_from_type called with an abnormal field")
+        in
+        let i31bit_type =
+          match kind_of_term int31bit with
+          | Ind (i31bit_type,_) -> i31bit_type
+          |  _ -> anomaly ~label:"Environ.register"
+              (Pp.str "Int31Bits should be an inductive type")
+        in
+        let int31_decompilation =
+          match kind_of_term value with
+          | Ind (i31t,_) ->
+              constr_of_int31 i31t i31bit_type
+          | _ -> anomaly ~label:"Environ.register"
+              (Pp.str "should be an inductive type")
+        in
+        { empty_reactive_info with
+          vm_decompile_const = Some int31_decompilation;
+          vm_before_match = Some Cbytegen.int31_escape_before_match;
+          native_before_match = Some (Nativelambda.before_match_int31 i31bit_type);
+        }
+    | KInt31 (_, Int31Constructor) ->
+        { empty_reactive_info with
+          vm_constant_static = Some Cbytegen.compile_structured_int31;
+          vm_constant_dynamic = Some Cbytegen.dynamic_int31_compilation;
+          native_constant_static = Some Nativelambda.compile_static_int31;
+          native_constant_dynamic = Some Nativelambda.compile_dynamic_int31;
+        }
+    | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31
+							  Primitives.Int31add
+    | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31
+							   Primitives.Int31addc
+    | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31
+								Primitives.Int31addcarryc
+    | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31
+							   Primitives.Int31sub
+    | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31
+							    Primitives.Int31subc
+    | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const
+	                                Cbytecodes.Ksubcarrycint31 Primitives.Int31subcarryc
+    | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31
+							   Primitives.Int31mul
+    | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31
+							   Primitives.Int31mulc
+    | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31
+                                                           Primitives.Int31div21
+    | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31
+							 Primitives.Int31diveucl
+    | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31
+                                                         Primitives.Int31addmuldiv
+    | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31
+							     Primitives.Int31compare
+    | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31
+							  Primitives.Int31head0
+    | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31
+							  Primitives.Int31tail0
+    | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31
+							 Primitives.Int31lor
+    | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31
+							  Primitives.Int31land
+    | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31
+							  Primitives.Int31lxor
+    | _ -> empty_reactive_info
+
+let _ = Hook.set Retroknowledge.dispatch_hook dispatch
diff --git a/kernel/environ.mli b/kernel/environ.mli
index 76e3ecf0..de960ecc 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,9 @@
 
 open Names
 open Term
+open Context
 open Declarations
-open Sign
+open Univ
 
 (** Unsafe environments. We define here a datatype for environments.
    Since typing is not yet defined, it is not possible to check the
@@ -32,6 +33,8 @@ open Sign
 type env
 val pre_env : env -> Pre_env.env
 val env_of_pre_env : Pre_env.env -> env
+val oracle : env -> Conv_oracle.oracle
+val set_oracle : env -> Conv_oracle.oracle -> env
 
 type named_context_val
 val eq_named_context_val : named_context_val -> named_context_val -> bool
@@ -43,8 +46,14 @@ val rel_context   : env -> rel_context
 val named_context : env -> named_context
 val named_context_val : env -> named_context_val
 
+val opaque_tables : env -> Opaqueproof.opaquetab
+val set_opaque_tables : env -> Opaqueproof.opaquetab -> env
+
 
 val engagement    : env -> engagement option
+val is_impredicative_set : env -> bool
+
+val type_in_type  : env -> bool
 
 (** is the local context empty *)
 val empty_context : env -> bool
@@ -81,13 +90,14 @@ val map_named_val :
    (constr -> constr) -> named_context_val -> named_context_val
 
 val push_named : named_declaration -> env -> env
+val push_named_context : named_context -> env -> env
 val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 
 
 
 (** Looks up in the context of local vars referred by names ([named_context]) 
-   raises [Not_found] if the identifier is not found *)
+   raises [Not_found] if the Id.t is not found *)
 
 val lookup_named     : variable -> env -> named_declaration
 val lookup_named_val : variable -> named_context_val -> named_declaration
@@ -110,63 +120,118 @@ val reset_context : env -> env
 (** This forgets rel context and sets a new named context *)
 val reset_with_named_context : named_context_val -> env -> env
 
+(** This removes the [n] last declarations from the rel context *)
+val pop_rel_context : int -> env -> env
+
 (** {5 Global constants }
   {6 Add entries to global environment } *)
 
 val add_constant : constant -> constant_body -> env -> env
+val add_constant_key : constant -> constant_body -> Pre_env.link_info ->
+  env -> env
 
 (** Looks up in the context of global constant names 
    raises [Not_found] if the required path is not found *)
 val lookup_constant    : constant -> env -> constant_body
 val evaluable_constant : constant -> env -> bool
 
+(** New-style polymorphism *)
+val polymorphic_constant  : constant -> env -> bool
+val polymorphic_pconstant : pconstant -> env -> bool
+
+(** Old-style polymorphism *)
+val template_polymorphic_constant  : constant -> env -> bool
+val template_polymorphic_pconstant : pconstant -> env -> bool
+
 (** {6 ... } *)
 (** [constant_value env c] raises [NotEvaluableConst Opaque] if
    [c] is opaque and [NotEvaluableConst NoBody] if it has no
-   body and [Not_found] if it does not exist in [env] *)
+   body and [NotEvaluableConst IsProj] if [c] is a projection 
+   and [Not_found] if it does not exist in [env] *)
 
-type const_evaluation_result = NoBody | Opaque
+type const_evaluation_result = NoBody | Opaque | IsProj
 exception NotEvaluableConst of const_evaluation_result
 
-val constant_value     : env -> constant -> constr
-val constant_type      : env -> constant -> constant_type
-val constant_opt_value : env -> constant -> constr option
+val constant_value : env -> constant puniverses -> constr constrained
+val constant_type : env -> constant puniverses -> constant_type constrained
 
-(** {5 Inductive types } *)
+val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option
+val constant_value_and_type : env -> constant puniverses -> 
+  constr option * constant_type * Univ.constraints
+(** The universe context associated to the constant, empty if not 
+    polymorphic *)
+val constant_context : env -> constant -> Univ.universe_context
+
+(* These functions should be called under the invariant that [env] 
+   already contains the constraints corresponding to the constant 
+   application. *)
+val constant_value_in : env -> constant puniverses -> constr
+val constant_type_in : env -> constant puniverses -> constant_type
+val constant_opt_value_in : env -> constant puniverses -> constr option
+
+(** {6 Primitive projections} *)
+
+val lookup_projection    : Names.projection -> env -> projection_body
+val is_projection : constant -> env -> bool
 
+(** {5 Inductive types } *)
+val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env
 val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
 
 (** Looks up in the context of global inductive names 
    raises [Not_found] if the required path is not found *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
+(** New-style polymorphism *)
+val polymorphic_ind  : inductive -> env -> bool
+val polymorphic_pind : pinductive -> env -> bool
+
+(** Old-style polymorphism *)
+val template_polymorphic_ind : inductive -> env -> bool
+val template_polymorphic_pind : pinductive -> env -> bool
+
 (** {5 Modules } *)
 
-val add_modtype : module_path -> module_type_body -> env -> env
+val add_modtype : module_type_body -> env -> env
 
 (** [shallow_add_module] does not add module components *)
-val shallow_add_module : module_path -> module_body -> env -> env
+val shallow_add_module : module_body -> env -> env
 
 val lookup_module : module_path -> env -> module_body
 val lookup_modtype : module_path -> env -> module_type_body
 
 (** {5 Universe constraints } *)
 
+(** Add universe constraints to the environment.
+    @raises UniverseInconsistency
+*)
 val add_constraints : Univ.constraints -> env -> env
 
+(** Check constraints are satifiable in the environment. *)
+val check_constraints : Univ.constraints -> env -> bool
+val push_context : Univ.universe_context -> env -> env
+val push_context_set : Univ.universe_context_set -> env -> env
+val push_constraints_to_env : 'a Univ.constrained -> env -> env
+
 val set_engagement : engagement -> env -> env
 
+val set_type_in_type : env -> env
+
 (** {6 Sets of referred section variables }
    [global_vars_set env c] returns the list of [id]'s occurring either
    directly as [Var id] in [c] or indirectly as a section variable
    dependent in a global reference occurring in [c] *)
 
-val global_vars_set : env -> constr -> Idset.t
+val global_vars_set : env -> constr -> Id.Set.t
 
 (** the constr must be a global reference *)
-val vars_of_global : env -> constr -> identifier list
+val vars_of_global : env -> constr -> Id.Set.t
+
+(** closure of the input id set w.r.t. dependency *)
+val really_needed : env -> Id.Set.t -> Id.Set.t
 
-val keep_hyps : env -> Idset.t -> section_context
+(** like [really_needed] but computes a well ordered named context *)
+val keep_hyps : env -> Id.Set.t -> section_context
 
 (** {5 Unsafe judgments. }
     We introduce here the pre-type of judgments, which is
@@ -211,7 +276,7 @@ val insert_after_hyp : named_context_val -> variable ->
   named_declaration ->
     (named_context -> unit) -> named_context_val
 
-val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
+val remove_hyps : Id.Set.t -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
 
 
 
@@ -222,8 +287,7 @@ val retroknowledge : (retroknowledge->'a) -> env -> 'a
 
 val registered : env -> field -> bool
 
-val unregister : env -> field -> env
-
 val register : env -> field -> Retroknowledge.entry -> env
 
-
+(** Native compiler *)
+val no_link_info : Pre_env.link_info
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 5bb34253..42ca48ef 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -29,14 +29,14 @@ let el_id = ELID
 let rec el_shft_rec n = function
   | ELSHFT(el,k) -> el_shft_rec (k+n) el
   | el           -> ELSHFT(el,n)
-let el_shft n el = if n = 0 then el else el_shft_rec n el
+let el_shft n el = if Int.equal n 0 then el else el_shft_rec n el
 
 (* cross n binders *)
 let rec el_liftn_rec n = function
   | ELID        -> ELID
   | ELLFT(k,el) -> el_liftn_rec (n+k) el
   | el          -> ELLFT(n, el)
-let el_liftn n el = if n = 0 then el else el_liftn_rec n el
+let el_liftn n el = if Int.equal n 0 then el else el_liftn_rec n el
 
 let el_lift el = el_liftn_rec 1 el
 
@@ -49,7 +49,7 @@ let rec reloc_rel n = function
 
 let rec is_lift_id = function
   | ELID -> true
-  | ELSHFT(e,n) -> n=0 & is_lift_id e
+  | ELSHFT(e,n) -> Int.equal n 0 && is_lift_id e
   | ELLFT (_,e) -> is_lift_id e
 
 (*********************)
@@ -73,7 +73,7 @@ type 'a subs =
 
 let subs_id i = ESID i
 
-let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s)
+let subs_cons(x,s) = if Int.equal (Array.length x) 0 then s else CONS(x,s)
 
 let subs_liftn n = function
   | ESID p        -> ESID (p+n) (* bounded identity lifted extends by p *)
@@ -81,13 +81,13 @@ let subs_liftn n = function
   | lenv          -> LIFT (n,lenv)
 
 let subs_lift a = subs_liftn 1 a
-let subs_liftn n a = if n = 0 then a else subs_liftn n a
+let subs_liftn n a = if Int.equal n 0 then a else subs_liftn n a
 
 let subs_shft = function
   | (0, s)            -> s
   | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1)
   | (n, s)            -> SHIFT (n,s)
-let subs_shft (n,a) = if n = 0 then a else subs_shft(n,a)
+let subs_shft s = if Int.equal (fst s) 0 then snd s else subs_shft s
 
 let subs_shift_cons = function
   (0, s, t)           -> CONS(t,s)
@@ -99,7 +99,7 @@ let rec is_subs_id = function
     ESID _     -> true
   | LIFT(_,s)  -> is_subs_id s
   | SHIFT(0,s) -> is_subs_id s
-  | CONS(x,s)  -> Array.length x = 0 && is_subs_id s
+  | CONS(x,s)  -> Int.equal (Array.length x) 0 && is_subs_id s
   | _          -> false
 
 (* Expands de Bruijn k in the explicit substitution subs
@@ -136,7 +136,7 @@ let rec comp mk_cl s1 s2 =
     | ESID _, _ -> s2
     | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2)
     | _, CONS(x,s') ->
-        CONS(Array.map (fun t -> mk_cl(s1,t)) x, comp mk_cl s1 s')
+        CONS(CArray.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s')
     | CONS(x,s), SHIFT(k,s') ->
         let lg = Array.length x in
         if k == lg then comp mk_cl s s'
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index c3980c30..2b34da4d 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/kernel/evar.ml b/kernel/evar.ml
new file mode 100644
index 00000000..54f15df4
--- /dev/null
+++ b/kernel/evar.ml
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+type t = int
+
+let repr x = x
+let unsafe_of_int x = x
+let compare = Int.compare
+let equal = Int.equal
+let hash = Int.hash
+
+module Set = Int.Set
+module Map = Int.Map
diff --git a/kernel/evar.mli b/kernel/evar.mli
new file mode 100644
index 00000000..2c94db3f
--- /dev/null
+++ b/kernel/evar.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This module defines existential variables, which are isomorphic to [int].
+    Nonetheless, casting from an [int] to a variable is deemed unsafe, so that
+    to keep track of such casts, one has to use the provided {!unsafe_of_int}
+    function. *)
+
+type t
+(** Type of existential variables. *)
+
+val repr : t -> int
+(** Recover the underlying integer. *)
+
+val unsafe_of_int : int -> t
+(** This is not for dummies. Do not use this function if you don't know what you
+    are doing. *)
+
+val equal : t -> t -> bool
+(** Equality over existential variables. *)
+
+val compare : t -> t -> int
+(** Comparison over existential variables. *)
+
+val hash : t -> int
+(** Hash over existential variables. *)
+
+module Set : Set.S with type elt = t
+module Map : CMap.ExtS with type key = t and module Set := Set
diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml
new file mode 100644
index 00000000..86fb1b64
--- /dev/null
+++ b/kernel/fast_typeops.ml
@@ -0,0 +1,461 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Errors
+open Util
+open Names
+open Univ
+open Term
+open Vars
+open Declarations
+open Environ
+open Reduction
+open Inductive
+open Type_errors
+
+let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y
+
+let conv_leq_vecti env v1 v2 =
+  Array.fold_left2_i
+    (fun i _ t1 t2 ->
+      try conv_leq false env t1 t2
+      with NotConvertible -> raise (NotConvertibleVect i))
+    ()
+    v1
+    v2
+
+let check_constraints cst env = 
+  if Environ.check_constraints cst env then ()
+  else error_unsatisfied_constraints env cst
+
+(* This should be a type (a priori without intension to be an assumption) *)
+let type_judgment env c t =
+  match kind_of_term(whd_betadeltaiota env t) with
+    | Sort s -> {utj_val = c; utj_type = s }
+    | _ -> error_not_type env (make_judge c t)
+
+let check_type env c t =
+  match kind_of_term(whd_betadeltaiota env t) with
+  | Sort s -> s
+  | _ -> error_not_type env (make_judge c t)
+
+(* This should be a type intended to be assumed. The error message is *)
+(* not as useful as for [type_judgment]. *)
+let assumption_of_judgment env t ty =
+  try let _ = check_type env t ty in t
+  with TypeError _ ->
+    error_assumption env (make_judge t ty)
+
+(************************************************)
+(* Incremental typing rules: builds a typing judgement given the *)
+(* judgements for the subterms. *)
+
+(*s Type of sorts *)
+
+(* Prop and Set *)
+
+let judge_of_prop = mkSort type1_sort
+
+let judge_of_prop_contents _ = judge_of_prop
+
+(* Type of Type(i). *)
+
+let judge_of_type u =
+  let uu = Universe.super u in
+    mkType uu
+
+(*s Type of a de Bruijn index. *)
+
+let judge_of_relative env n =
+  try
+    let (_,_,typ) = lookup_rel n env in
+      lift n typ
+  with Not_found ->
+    error_unbound_rel env n
+
+(* Type of variables *)
+let judge_of_variable env id =
+  try named_type id env
+  with Not_found ->
+    error_unbound_var env id
+
+(* Management of context of variables. *)
+
+(* Checks if a context of variables can be instantiated by the
+   variables of the current env *)
+(* TODO: check order? *)
+let check_hyps_inclusion env f c sign =
+  Context.fold_named_context
+    (fun (id,_,ty1) () ->
+      try
+        let ty2 = named_type id env in
+        if not (eq_constr ty2 ty1) then raise Exit
+      with Not_found | Exit ->
+        error_reference_variables env id (f c))
+    sign
+    ~init:()
+
+(* Instantiation of terms on real arguments. *)
+
+(* Make a type polymorphic if an arity *)
+
+(* Type of constants *)
+
+
+let type_of_constant_knowing_parameters_arity env t paramtyps =
+  match t with
+  | RegularArity t -> t
+  | TemplateArity (sign,ar) ->
+      let ctx = List.rev sign in
+      let ctx,s = instantiate_universes env ctx ar paramtyps in
+      mkArity (List.rev ctx,s)
+
+let type_of_constant_knowing_parameters env cst paramtyps =
+  let ty, cu = constant_type env cst in
+    type_of_constant_knowing_parameters_arity env ty paramtyps, cu
+
+let judge_of_constant_knowing_parameters env (kn,u as cst) args =
+  let cb = lookup_constant kn env in
+  let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
+  let ty, cu = type_of_constant_knowing_parameters env cst args in
+  let () = check_constraints cu env in
+    ty
+
+let judge_of_constant env cst =
+  judge_of_constant_knowing_parameters env cst [||]
+
+(* Type of a lambda-abstraction. *)
+
+(* [judge_of_abstraction env name var j] implements the rule
+
+ env, name:typ |- j.uj_val:j.uj_type     env, |- (name:typ)j.uj_type : s
+ -----------------------------------------------------------------------
+          env |- [name:typ]j.uj_val : (name:typ)j.uj_type
+
+  Since all products are defined in the Calculus of Inductive Constructions
+  and no upper constraint exists on the sort $s$, we don't need to compute $s$
+*)
+
+let judge_of_abstraction env name var ty =
+  mkProd (name, var, ty)
+
+(* Type of an application. *)
+
+let make_judgev c t = 
+  Array.map2 make_judge c t
+
+let judge_of_apply env func funt argsv argstv =
+  let len = Array.length argsv in
+  let rec apply_rec i typ = 
+    if Int.equal i len then typ
+    else 
+      (match kind_of_term (whd_betadeltaiota 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))
+	    
+      | _ ->
+	error_cant_apply_not_functional env 
+	  (make_judge func funt)
+	  (make_judgev argsv argstv))
+  in apply_rec 0 funt
+
+(* Type of product *)
+
+let sort_of_product env domsort rangsort =
+  match (domsort, rangsort) with
+    (* Product rule (s,Prop,Prop) *)
+    | (_,       Prop Null)  -> rangsort
+    (* Product rule (Prop/Set,Set,Set) *)
+    | (Prop _,  Prop Pos) -> rangsort
+    (* Product rule (Type,Set,?) *)
+    | (Type u1, Prop Pos) ->
+        begin match engagement env with
+        | Some ImpredicativeSet ->
+          (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
+          rangsort
+        | _ ->
+          (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
+          Type (Universe.sup Universe.type0 u1)
+        end
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Pos,  Type u2)  -> Type (Universe.sup Universe.type0 u2)
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Null, Type _)  -> rangsort
+    (* Product rule (Type_i,Type_i,Type_i) *)
+    | (Type u1, Type u2) -> Type (Universe.sup u1 u2)
+
+(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
+
+    env |- typ1:s1       env, name:typ1 |- typ2 : s2
+    -------------------------------------------------------------------------
+         s' >= (s1,s2), env |- (name:typ)j.uj_val : s'
+
+  where j.uj_type is convertible to a sort s2
+*)
+let judge_of_product env name s1 s2 =
+  let s = sort_of_product env s1 s2 in
+    mkSort s
+
+(* Type of a type cast *)
+
+(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule
+
+    env |- c:typ1    env |- typ2:s    env |- typ1 <= typ2
+    ---------------------------------------------------------------------
+         env |- c:typ2
+*)
+
+let judge_of_cast env c ct k expected_type =
+  try
+    match k with
+    | VMcast ->
+      vm_conv CUMUL env ct expected_type
+    | DEFAULTcast ->
+      default_conv ~l2r:false CUMUL env ct expected_type
+    | REVERTcast ->
+      default_conv ~l2r:true CUMUL env ct expected_type
+    | NATIVEcast ->
+      let sigma = Nativelambda.empty_evars in
+      native_conv CUMUL sigma env ct expected_type
+  with NotConvertible ->
+    error_actual_type env (make_judge c ct) expected_type
+
+(* Inductive types. *)
+
+(* The type is parametric over the uniform parameters whose conclusion
+   is in Type; to enforce the internal constraints between the
+   parameters and the instances of Type occurring in the type of the
+   constructors, we use the level variables _statically_ assigned to
+   the conclusions of the parameters as mediators: e.g. if a parameter
+   has conclusion Type(alpha), static constraints of the form alpha<=v
+   exist between alpha and the Type's occurring in the constructor
+   types; when the parameters is finally instantiated by a term of
+   conclusion Type(u), then the constraints u<=alpha is computed in
+   the App case of execute; from this constraints, the expected
+   dynamic constraints of the form u<=v are enforced *)
+
+let judge_of_inductive_knowing_parameters env (ind,u as indu) args =
+  let (mib,mip) as spec = lookup_mind_specif env ind in
+  check_hyps_inclusion env mkIndU indu mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters 
+    env (spec,u) args
+  in
+    check_constraints cst env;
+    t
+
+let judge_of_inductive env (ind,u as indu) =
+  let (mib,mip) = lookup_mind_specif env ind in
+  check_hyps_inclusion env mkIndU indu mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in
+    check_constraints cst env;
+    t
+
+(* Constructors. *)
+
+let judge_of_constructor env (c,u as cu) =
+  let _ =
+    let ((kn,_),_) = c in
+    let mib = lookup_mind kn env in
+    check_hyps_inclusion env mkConstructU cu mib.mind_hyps in
+  let specif = lookup_mind_specif env (inductive_of_constructor c) in
+  let t,cst = constrained_type_of_constructor cu specif in
+  let () = check_constraints cst env in
+    t
+
+(* Case. *)
+
+let check_branch_types env (ind,u) c ct lft explft =
+  try conv_leq_vecti env lft explft
+  with
+      NotConvertibleVect i ->
+        error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i)
+    | Invalid_argument _ ->
+        error_number_branches env (make_judge c ct) (Array.length explft)
+
+let judge_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 (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
+
+let judge_of_projection env p c ct =
+  let pb = lookup_projection p env in
+  let (ind,u), args =
+    try find_rectype env ct
+    with Not_found -> error_case_not_inductive env (make_judge c ct)
+  in
+    assert(eq_mind pb.proj_ind (fst ind));
+    let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
+      substl (c :: List.rev args) ty
+      
+
+(* Fixpoints. *)
+
+(* Checks the type of a general (co)fixpoint, i.e. without checking *)
+(* the specific guard condition. *)
+
+let type_fixpoint env lna lar vdef vdeft =
+  let lt = Array.length vdeft in
+  assert (Int.equal (Array.length lar) lt);
+  try
+    conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar)
+  with NotConvertibleVect i ->
+    error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar
+
+(************************************************************************)
+(************************************************************************)
+
+(* The typing machine. *)
+    (* ATTENTION : faudra faire le typage du contexte des Const,
+    Ind et Constructsi un jour cela devient des constructions
+    arbitraires et non plus des variables *)
+let rec execute env cstr =
+  match kind_of_term cstr with
+    (* Atomic terms *)
+    | Sort (Prop c) ->
+      judge_of_prop_contents c
+	
+    | Sort (Type u) ->
+      judge_of_type u
+
+    | Rel n ->
+      judge_of_relative env n
+
+    | Var id ->
+      judge_of_variable env id
+
+    | Const c ->
+      judge_of_constant env c
+	
+    | Proj (p, c) ->
+        let ct = execute env c in
+          judge_of_projection env p c ct
+
+    (* Lambda calculus operators *)
+    | App (f,args) ->
+        let argst = execute_array env args in
+	let ft =
+	  match kind_of_term f with
+	  | Ind ind when Environ.template_polymorphic_pind ind env ->
+	      (* Template sort-polymorphism of inductive types *)
+	    let args = Array.map (fun t -> lazy t) argst in
+	      judge_of_inductive_knowing_parameters env ind args
+	  | Const cst when Environ.template_polymorphic_pconstant cst env ->
+	      (* Template sort-polymorphism of constants *)
+	    let args = Array.map (fun t -> lazy t) argst in
+	      judge_of_constant_knowing_parameters env cst args
+	  | _ ->
+	    (* Full or no sort-polymorphism *)
+	    execute env f
+	in
+
+	  judge_of_apply env f ft args argst
+
+    | Lambda (name,c1,c2) ->
+      let _ = execute_is_type env c1 in
+      let env1 = push_rel (name,None,c1) env in
+      let c2t = execute env1 c2 in
+        judge_of_abstraction env name c1 c2t
+
+    | Prod (name,c1,c2) ->
+      let vars = execute_is_type env c1 in
+      let env1 = push_rel (name,None,c1) env in
+      let vars' = execute_is_type env1 c2 in
+	judge_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 _ = judge_of_cast env c1 c1t DEFAULTcast c2 in
+      let env1 = push_rel (name,Some c1,c2) env in
+      let c3t = execute env1 c3 in
+	subst1 c1 c3t
+
+    | Cast (c,k,t) ->
+      let ct = execute env c in
+      let _ts = execute_type env t in
+      let _ = judge_of_cast env c ct k t in
+	t
+
+    (* Inductive types *)
+    | Ind ind ->
+      judge_of_inductive env ind
+
+    | Construct c ->
+      judge_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
+          judge_of_case env ci p pt c ct lf lft
+
+    | Fix ((vn,i as vni),recdef) ->
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let fix = (vni,recdef') in
+        check_fix env fix; fix_ty
+	  
+    | CoFix (i,recdef) ->
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let cofix = (i,recdef') in
+        check_cofix env cofix; fix_ty
+	  
+    (* Partial proofs: unsupported by the kernel *)
+    | Meta _ ->
+	anomaly (Pp.str "the kernel does not support metavariables")
+
+    | Evar _ ->
+	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_type env constr =
+  let t = execute env constr in
+    type_judgment env constr t
+
+and execute_recdef env (names,lar,vdef) i =
+  let lart = execute_array env lar in
+  let lara = Array.map2 (assumption_of_judgment env) lar lart in
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let vdeft = execute_array env1 vdef in
+  let () = type_fixpoint env1 names lara vdef vdeft in
+    (lara.(i),(names,lara,vdef))
+
+and execute_array env = Array.map (execute env)
+
+(* Derived functions *)
+let infer env constr =
+  let t = execute env constr in
+    make_judge constr t
+
+let infer = 
+  if Flags.profile then
+    let infer_key = Profile.declare_profile "Fast_infer" in
+      Profile.profile2 infer_key infer
+  else infer
+
+let infer_type env constr =
+  execute_type env constr
+
+let infer_v env cv =
+  let jv = execute_array env cv in
+    make_judgev cv jv
diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli
new file mode 100644
index 00000000..4c2c92cc
--- /dev/null
+++ b/kernel/fast_typeops.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Univ
+open Term
+open Context
+open Environ
+open Entries
+open Declarations
+
+(** {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.
+ *)
+
+
+val infer      : env -> constr       -> unsafe_judgment
+val infer_v    : env -> constr array -> unsafe_judgment array
+val infer_type : env -> types        -> unsafe_type_judgment
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 20aaf52a..99d9f52c 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -1,22 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
 open Univ
 open Term
+open Vars
+open Context
 open Declarations
+open Declareops
 open Inductive
-open Sign
 open Environ
 open Reduction
 open Typeops
 open Entries
+open Pp
+
+(* 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
 
 (* Same as noccur_between but may perform reductions.
    Could be refined more...  *)
@@ -37,11 +49,11 @@ let is_constructor_head t =
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
-  | NotConstructor of env * identifier * constr * constr * int * int
+  | NotConstructor of env * Id.t * constr * constr * int * int
   | NonPar of env * constr * int * constr * constr
-  | SameNamesTypes of identifier
-  | SameNamesConstructors of identifier
-  | SameNamesOverlap of identifier list
+  | SameNamesTypes of Id.t
+  | SameNamesConstructors of Id.t
+  | SameNamesOverlap of Id.t list
   | NotAnArity of env * constr
   | BadEntry
   | LargeNonPropInductiveNotInType
@@ -57,10 +69,10 @@ let check_constructors_names =
   let rec check idset = function
     | [] -> idset
     | c::cl ->
-	if Idset.mem c idset then
+	if Id.Set.mem c idset then
 	  raise (InductiveError (SameNamesConstructors c))
 	else
-	  check (Idset.add c idset) cl
+	  check (Id.Set.add c idset) cl
   in
   check
 
@@ -74,13 +86,13 @@ let mind_check_names mie =
     | ind::inds ->
 	let id = ind.mind_entry_typename in
 	let cl = ind.mind_entry_consnames in
-	if Idset.mem id indset then
+	if Id.Set.mem id indset then
 	  raise (InductiveError (SameNamesTypes id))
 	else
 	  let cstset' = check_constructors_names cstset cl in
-	  check (Idset.add id indset) cstset' inds
+	  check (Id.Set.add id indset) cstset' inds
   in
-  check Idset.empty Idset.empty mie.mind_entry_inds
+  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. *)
@@ -90,40 +102,28 @@ let mind_check_names mie =
 
 (* Typing the arities and constructor types *)
 
-let is_logic_type t = (t.utj_type = prop_sort)
-
-(* [infos] is a sequence of pair [islogic,issmall] for each type in
-   the product of a constructor or arity *)
-
-let is_small infos = List.for_all (fun (logic,small) -> small) infos
-let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos
-
 (* An inductive definition is a "unit" if it has only one constructor
    and that all arguments expected by this constructor are
    logical, this is the case for equality, conjunction of logical properties
 *)
 let is_unit constrsinfos =
   match constrsinfos with  (* One info = One constructor *)
-   | [constrinfos] -> is_logic_constr constrinfos
+   | [level] -> is_type0m_univ level
    | [] -> (* type without constructors *) true
    | _ -> false
 
-let rec infos_and_sort env t =
-  let t = whd_betadeltaiota env t in
-  match kind_of_term t with
-    | Prod (name,c1,c2) ->
-        let (varj,_) = infer_type env c1 in
+let infos_and_sort env ctx t =
+  let rec aux env ctx t max =
+    let t = whd_betadeltaiota env t in
+      match kind_of_term t with
+      | Prod (name,c1,c2) ->
+        let varj = infer_type env c1 in
 	let env1 = Environ.push_rel (name,None,varj.utj_val) env in
-	let logic = is_logic_type varj in
-	let small = Term.is_small varj.utj_type in
-	(logic,small) :: (infos_and_sort env1 c2)
-    | _ when is_constructor_head t -> []
-    | _ -> (* don't fail if not positive, it is tested later *) []
-
-let small_unit constrsinfos =
-  let issmall = List.for_all is_small constrsinfos
-  and isunit = is_unit constrsinfos in
-  issmall, isunit
+	let max = Universe.sup max (univ_of_sort varj.utj_type) in
+	  aux env1 ctx c2 max
+    | _ when is_constructor_head t -> max
+    | _ -> (* don't fail if not positive, it is tested later *) max
+  in aux env ctx t Universe.type0m
 
 (* Computing the levels of polymorphic inductive types
 
@@ -145,140 +145,206 @@ let small_unit constrsinfos =
    w1,w2,w3 <= u3
 *)
 
-let extract_level (_,_,_,lc,lev) =
-  (* Enforce that the level is not in Prop if more than two constructors *)
-  if Array.length lc >= 2 then sup type0_univ lev else lev
-
-let inductive_levels arities inds =
-  let levels = Array.map pi3 arities in
-  let cstrs_levels = Array.map extract_level inds in
-  (* Take the transitive closure of the system of constructors *)
-  (* level constraints and remove the recursive dependencies *)
-  solve_constraints_system levels cstrs_levels
-
 (* This (re)computes informations relevant to extraction and the sort of an
    arity or type constructor; we do not to recompute universes constraints *)
 
-let constraint_list_union =
-  List.fold_left union_constraints empty_constraint
-
-let infer_constructor_packet env_ar_par params lc =
+let infer_constructor_packet env_ar_par ctx params lc =
   (* type-check the constructors *)
-  let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in
-  let cst = constraint_list_union cstl in
+  let jlc = List.map (infer_type env_ar_par) lc in
   let jlc = Array.of_list jlc in
   (* generalize the constructor over the parameters *)
   let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in
-  (* compute the max of the sorts of the products of the constructor type *)
-  let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in
-  (* compute *)
-  let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in
-
-  (info,lc'',level,cst)
+  (* compute the max of the sorts of the products of the constructors types *)
+  let levels = List.map (infos_and_sort env_ar_par ctx) lc in
+  let isunit = is_unit levels in
+  let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in
+  let level = List.fold_left (fun max l -> Universe.sup max l) min levels in
+  (lc'', (isunit, level))
+
+(* If indices matter *)
+let cumulate_arity_large_levels env sign =
+  fst (List.fold_right
+    (fun (_,_,t as d) (lev,env) ->
+      let tj = infer_type env t in
+      let u = univ_of_sort tj.utj_type in
+	(Universe.sup u lev, push_rel d env))
+    sign (Universe.type0m,env))
+
+let is_impredicative env u =
+  is_type0m_univ u || (is_type0_univ u && engagement env = Some ImpredicativeSet)
+
+let param_ccls params =
+  let has_some_univ u = function
+    | Some v when Univ.Level.equal u v -> true
+    | _ -> false
+  in
+  let remove_some_univ u = function
+    | Some v when Univ.Level.equal u v -> None
+    | x -> x
+  in
+  let fold l (_, b, p) = match b with
+  | None ->
+    (* Parameter contributes to polymorphism only if explicit Type *)
+    let c = strip_prod_assum p in
+    (* Add Type levels to the ordered list of parameters contributing to *)
+    (* polymorphism unless there is aliasing (i.e. non distinct levels) *)
+    begin match kind_of_term c with
+    | Sort (Type u) ->
+      (match Univ.Universe.level u with
+      | Some u ->
+	if List.exists (has_some_univ u) l then
+          None :: List.map (remove_some_univ u) l
+	else
+          Some u :: l
+      | None -> None :: l)
+    | _ ->
+      None :: l
+    end
+  | _ -> l
+  in
+    List.fold_left fold [] params
 
 (* 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 =
-  if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration";
+  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_params, params, cst1 = infer_local_decls env mie.mind_entry_params in
+  let env' = push_context mie.mind_entry_universes env in
+  let (env_params, params) = infer_local_decls env' mie.mind_entry_params in
   (* We first type arity of each inductive definition *)
-  (* This allows to build the environment of arities and to share *)
+  (* This allows building the environment of arities and to share *)
   (* the set of constraints *)
-  let cst, env_arities, rev_arity_list =
+  let env_arities, rev_arity_list =
     List.fold_left
-      (fun (cst,env_ar,l) ind ->
+      (fun (env_ar,l) ind ->
          (* Arities (without params) are typed-checked here *)
-	 let arity, cst2 = infer_type env_params ind.mind_entry_arity in
+	 let expltype = 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, prop_sort)) 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.utj_val params in
-	 let cst = union_constraints cst cst2 in
+	 let full_arity = it_mkProd_or_LetIn arity params in
 	 let id = ind.mind_entry_typename in
 	 let env_ar' =
-           push_rel (Name id, None, full_arity)
-             (add_constraints cst2 env_ar) in
-	 let lev =
-	   (* Decide that if the conclusion is not explicitly Type *)
-	   (* then the inductive type is not polymorphic *)
-	   match kind_of_term ((strip_prod_assum arity.utj_val)) with
-	   | Sort (Type u) -> Some u
-	   | _ -> None in
-         (cst,env_ar',(id,full_arity,lev)::l))
-      (cst1,env,[])
+           push_rel (Name id, None, full_arity) env_ar in
+             (* (add_constraints cst2 env_ar) in *)
+	   (env_ar', (id,full_arity,sign @ params,expltype,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 params (add_constraints cst1 env_arities) in
+  let env_ar_par = push_rel_context params env_arities in
 
   (* Now, we type the constructors (without params) *)
-  let inds,cst =
+  let inds =
     List.fold_right2
-      (fun ind arity_data (inds,cst) ->
-	 let (info,lc',cstrs_univ,cst') =
-	   infer_constructor_packet env_ar_par params ind.mind_entry_lc in
+      (fun ind arity_data inds ->
+	 let (lc',cstrs_univ) =
+	   infer_constructor_packet env_ar_par ContextSet.empty
+	     params ind.mind_entry_lc in
 	 let consnames = ind.mind_entry_consnames in
-	 let ind' = (arity_data,consnames,info,lc',cstrs_univ) in
-	 (ind'::inds, union_constraints cst cst'))
+	 let ind' = (arity_data,consnames,lc',cstrs_univ) in
+	   ind'::inds)
       mie.mind_entry_inds
       arity_list
-      ([],cst) in
+    ([]) in
 
   let inds = Array.of_list inds in
-  let arities = Array.of_list arity_list in
-  let param_ccls = List.fold_left (fun l (_,b,p) ->
-    if b = None then
-      (* Parameter contributes to polymorphism only if explicit Type *)
-      let c = strip_prod_assum p in
-      (* Add Type levels to the ordered list of parameters contributing to *)
-      (* polymorphism unless there is aliasing (i.e. non distinct levels) *)
-      match kind_of_term c with
-      | Sort (Type u) ->
-          if List.mem (Some u) l then
-            None :: List.map (function Some v when u = v -> None | x -> x) l
-          else
-            Some u :: l
-      | _ ->
-          None :: l
-    else
-      l) [] params in
 
   (* Compute/check the sorts of the inductive types *)
-  let ind_min_levels = inductive_levels arities inds in
-  let inds, cst =
-    array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst ->
-      let sign, s =
-        try dest_arity env full_arity
-        with NotArity -> raise (InductiveError (NotAnArity (env, full_arity)))
+
+  let inds =
+    Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,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 = Term.univ_of_sort def_level in
+	let is_natural =
+	  type_in_type env || (check_leq (universes env') infu defu &&
+	    not (is_type0m_univ defu && not is_unit))
+	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)
+	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
+	  match s with
+	  | Type u when expltype (* Explicitly polymorphic *) ->
+	    (* 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 || 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)
+	      else
+		TemplateArity (param_ccls params, infu)
+	  | _ (* Not an explicit occurrence of Type *) ->
+	    full_polymorphic ()
+      in
+      let arity = 
+	if mie.mind_entry_polymorphic then full_polymorphic ()
+	else template_polymorphic ()
       in
-      let status,cst = match s with
-      | Type u when ar_level <> None (* Explicitly polymorphic *)
-            && no_upper_constraints u cst ->
-	  (* 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] *)
-	  Inr (param_ccls, lev), enforce_geq u lev cst
-      | Type u (* Not an explicit occurrence of Type *) ->
-	  Inl (info,full_arity,s), enforce_geq u lev cst
-      | Prop Pos when engagement env <> Some ImpredicativeSet ->
-	  (* Predicative set: check that the content is indeed predicative *)
-	  if not (is_type0m_univ lev) & not (is_type0_univ lev) then
-	    raise (InductiveError LargeNonPropInductiveNotInType);
-	  Inl (info,full_arity,s), cst
-      | Prop _ ->
-	  Inl (info,full_arity,s), cst in
-      (id,cn,lc,(sign,status)),cst)
-      inds ind_min_levels cst in
-
-  (env_arities, params, inds, cst)
+	(id,cn,lc,(sign,arity)))
+    inds
+  in (env_arities, params, inds)
 
 (************************************************************************)
 (************************************************************************)
@@ -321,11 +387,11 @@ let failwith_non_pos n ntypes c =
 
 let failwith_non_pos_vect n ntypes v =
   Array.iter (failwith_non_pos n ntypes) v;
-  anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur"
+  anomaly ~label:"failwith_non_pos_vect" (Pp.str "some k in [n;n+ntypes-1] should occur")
 
 let failwith_non_pos_list n ntypes l =
   List.iter (failwith_non_pos n ntypes) l;
-  anomaly "failwith_non_pos_list: some k in [n;n+ntypes-1] should occur"
+  anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur")
 
 (* Check the inductive type is called with the expected parameters *)
 let check_correct_par (env,n,ntypes,_) hyps l largs =
@@ -333,17 +399,17 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
   let largs = Array.of_list largs in
   if Array.length largs < nparams then
     raise (IllFormedInd (LocalNotEnoughArgs l));
-  let (lpar,largs') = array_chop nparams largs in
+  let (lpar,largs') = Array.chop nparams largs in
   let nhyps = List.length hyps in
   let rec check k index = function
     | [] -> ()
     | (_,Some _,_)::hyps -> check k (index+1) hyps
     | _::hyps ->
         match kind_of_term (whd_betadeltaiota env lpar.(k)) with
-	  | Rel w when w = index -> check (k-1) (index+1) hyps
+	  | Rel w when Int.equal w index -> check (k-1) (index+1) hyps
 	  | _ -> raise (IllFormedInd (LocalNonPar (k+1,l)))
   in check (nparams-1) (n-nhyps) hyps;
-  if not (array_for_all (noccur_between n ntypes) largs') then
+  if not (Array.for_all (noccur_between n ntypes) largs') then
     failwith_non_pos_vect n ntypes largs'
 
 (* Computes the maximum number of recursive parameters :
@@ -352,9 +418,9 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
     recursive parameters *)
 
 let compute_rec_par (env,n,_,_) hyps nmr largs =
-if nmr = 0 then 0 else
+if Int.equal nmr 0 then 0 else
 (* start from 0, hyps will be in reverse order *)
-  let (lpar,_) = list_chop nmr largs in
+  let (lpar,_) = List.chop nmr largs in
   let rec find k index =
       function
 	  ([],_) -> nmr
@@ -362,27 +428,10 @@ if nmr = 0 then 0 else
 	| (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
 	| (p::lp,_::hyps) ->
        ( match kind_of_term (whd_betadeltaiota env p) with
-	  | Rel w when w = index -> find (k+1) (index-1) (lp,hyps)
+	  | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps)
           | _ -> k)
   in find 0 (n-1) (lpar,List.rev hyps)
 
-let lambda_implicit_lift n a =
-  let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in
-  let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in
-  iterate lambda_implicit n (lift n a)
-
-(* This removes global parameters of the inductive types in lc (for
-   nested inductive types only ) *)
-let abstract_mind_lc env ntyps npars lc =
-  if npars = 0 then
-    lc
-  else
-    let make_abs =
-      list_tabulate
-	(function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps
-    in
-    Array.map (substl make_abs) lc
-
 (* [env] is the typing environment
    [n] is the dB of the last inductive type
    [ntypes] is the number of inductive types in the definition
@@ -392,12 +441,13 @@ let abstract_mind_lc env ntyps npars lc =
 let ienv_push_var (env, n, ntypes, lra) (x,a,ra) =
  (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra)
 
-let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
+let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) =
   let auxntyp = 1 in
-  let specif = lookup_mind_specif env mi in
+  let specif = (lookup_mind_specif env mi, u) in
+  let ty = type_of_inductive env specif in
   let env' =
     push_rel (Anonymous,None,
-              hnf_prod_applist env (type_of_inductive env specif) lpar) env in
+              hnf_prod_applist env ty lpar) env in
   let ra_env' =
     (Imbr mi,(Rtree.mk_rec_calls 1).(0)) ::
     List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in
@@ -406,7 +456,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   (env', newidx, ntypes, ra_env')
 
 let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
-  if n=0 then (ienv,c) else
+  if Int.equal n 0 then (ienv,c) else
     let c' = whd_betadeltaiota env c in
     match kind_of_term c' with
 	Prod(na,a,b) ->
@@ -414,7 +464,7 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
 	  ienv_decompose_prod ienv' (n-1) b
       | _ -> assert false
 
-let array_min nmr a = if nmr = 0 then 0 else
+let array_min nmr a = if Int.equal nmr 0 then 0 else
   Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a
 
 (* The recursive function that checks positivity and builds the list
@@ -427,7 +477,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
     let x,largs = decompose_app (whd_betadeltaiota env c) in
       match kind_of_term x with
 	| Prod (na,b,d) ->
-	    assert (largs = []);
+	    let () = assert (List.is_empty largs) in
             (match weaker_noccur_between env n ntypes b with
 		None -> failwith_non_pos_list n ntypes [b]
               | Some b ->
@@ -455,12 +505,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	    else failwith_non_pos_list n ntypes (x::largs)
 
   (* accesses to the environment are not factorised, but is it worth? *)
-  and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) =
+  and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) =
     let (mib,mip) = lookup_mind_specif env mi in
     let auxnpar = mib.mind_nparams_rec in
     let nonrecpar = mib.mind_nparams - auxnpar in
     let (lpar,auxlargs) =
-      try list_chop auxnpar largs
+      try List.chop auxnpar largs
       with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
       (* If the inductive appears in the args (non params) then the
 	 definition is not positive. *)
@@ -469,12 +519,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	failwith_non_pos_list n ntypes auxlargs;
       (* We do not deal with imbricated mutual inductive types *)
       let auxntyp = mib.mind_ntypes in
-	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
+	if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n));
 	(* The nested inductive type with parameters removed *)
-	let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
+	let auxlcvect = abstract_mind_lc auxntyp auxnpar mip.mind_nf_lc in
 	  (* Extends the environment with a variable corresponding to
 	     the inductive def *)
-	let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in
+	let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in
 	  (* Parameters expressed in env' *)
 	let lpar' = List.map (lift auxntyp) lpar in
 	let irecargs_nmr =
@@ -503,25 +553,27 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	match kind_of_term x with
 
           | Prod (na,b,d) ->
-	      assert (largs = []);
+	      let () = assert (List.is_empty largs) in
               let nmr',recarg = check_pos ienv nmr b in
               let ienv' = ienv_push_var ienv (na,b,mk_norec) in
-		check_constr_rec ienv' nmr' (recarg::lrec) d
-
-	  | hd ->
-	      if check_head then
-		if hd = Rel (n+ntypes-i-1) then
-		  check_correct_par ienv hyps (ntypes-i) largs
-		else
-		  raise (IllFormedInd LocalNotConstructor)
-	      else
-		if not (List.for_all (noccur_between n ntypes) largs)
-		then failwith_non_pos_list n ntypes largs;
-	      (nmr,List.rev lrec)
+                check_constr_rec ienv' nmr' (recarg::lrec) d
+          | hd ->
+            let () =
+              if check_head then
+                begin match hd with
+                | Rel j when Int.equal j (n + ntypes - i - 1) ->
+                  check_correct_par ienv hyps (ntypes - i) largs
+                | _ -> raise (IllFormedInd LocalNotConstructor)
+                end
+              else
+                if not (List.for_all (noccur_between n ntypes) largs)
+                then failwith_non_pos_list n ntypes largs
+            in
+            (nmr, List.rev lrec)
     in check_constr_rec ienv nmr [] c
   in
   let irecargs_nmr =
-    array_map2
+    Array.map2
       (fun id c ->
         let _,rawc = mind_extract_params lparams c in
           try
@@ -537,12 +589,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 let check_positivity kn env_ar params inds =
   let ntypes = Array.length inds in
   let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
-  let lra_ind = List.rev (Array.to_list rc) in
+  let lra_ind = Array.rev_to_list rc in
   let lparams = rel_context_length params in
   let nmr = rel_context_nhyps params in
   let check_one i (_,lcnames,lc,(sign,_)) =
     let ra_env =
-      list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
+      List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in
     let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
     let nargs = rel_context_nhyps sign - nmr in
     check_positivity_one ienv params (kn,i) nargs lcnames lc
@@ -563,67 +615,143 @@ let all_sorts = [InProp;InSet;InType]
 let small_sorts = [InProp;InSet]
 let logical_sorts = [InProp]
 
-let allowed_sorts issmall isunit s =
-  match family_of_sort s with
-  (* Type: all elimination allowed *)
-  | InType -> all_sorts
-
-  (* Small Set is predicative: all elimination allowed *)
-  | InSet when issmall -> all_sorts
-
-  (* Large Set is necessarily impredicative: forbids large elimination *)
-  | InSet -> small_sorts
-
-  (* Unitary/empty Prop: elimination to all sorts are realizable *)
-  (* unless the type is large. If it is large, forbids large elimination *)
-  (* which otherwise allows to simulate the inconsistent system Type:Type *)
-  | InProp when isunit -> if issmall then all_sorts else small_sorts
-
-  (* Other propositions: elimination only to Prop *)
-  | InProp -> logical_sorts
+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 family_of_sort 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 fold_inductive_blocks f =
-  Array.fold_left (fun acc (_,_,lc,(arsign,_)) ->
-    f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (* dummy *) mkSet arsign))
+  Array.fold_left (fun acc (_,_,lc,(arsign,ar)) ->
+    f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (arity_conclusion ar) arsign))
 
 let used_section_variables env inds =
   let ids = fold_inductive_blocks
-    (fun l c -> Idset.union (Environ.global_vars_set env c) l)
-      Idset.empty inds in
+    (fun l c -> Id.Set.union (Environ.global_vars_set env c) l)
+      Id.Set.empty inds in
   keep_hyps env ids
 
-let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
+let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
+let rel_appvect n m = rel_vect n (List.length 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, _ as ind), u as indsp) n x nparamargs params
+    mind_consnrealdecls mind_consnrealargs ctx =
+  let mp, dp, l = repr_mind kn in
+  let rp = mkApp (mkIndU indsp, rel_vect 0 nparamargs) in
+  let ci = 
+    let print_info =
+      { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in
+      { ci_ind     = ind;
+	ci_npar    = nparamargs;
+	ci_cstr_ndecls = mind_consnrealdecls;
+	ci_cstr_nargs = mind_consnrealargs;
+	ci_pp_info = print_info }
+  in
+  let len = List.length ctx in
+  let x = Name x in
+  let compat_body ccl i = 
+    (* [ccl] is defined in context [params;x:rp] *)
+    (* [ccl'] is defined in context [params;x:rp;x:rp] *)
+    let ccl' = liftn 1 2 ccl in
+    let p = mkLambda (x, lift 1 rp, ccl') in
+    let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in
+    let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in
+      it_mkLambda_or_LetIn (mkLambda (x,rp,body)) params
+  in
+  let projections (na, b, t) (i, j, kns, pbs, subst) =
+    match b with
+    | Some c -> (i, j+1, kns, pbs, substl subst c :: subst)
+    | None ->
+      match na with
+      | Name id ->
+	let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in
+	let ty = substl subst (liftn 1 j t) in
+	let term = mkProj (Projection.make kn true, mkRel 1) in
+	let fterm = mkProj (Projection.make kn false, mkRel 1) in
+	let compat = compat_body ty (j - 1) in
+	let etab = it_mkLambda_or_LetIn (mkLambda (x, rp, term)) params in
+	let etat = it_mkProd_or_LetIn (mkProd (x, rp, ty)) params in
+	let body = { proj_ind = fst ind; proj_npars = nparamargs;
+		     proj_arg = i; proj_type = ty; proj_eta = etab, etat; 
+		     proj_body = compat } in
+	  (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: subst)
+      | Anonymous -> raise UndefinableExpansion
+  in
+  let (_, _, kns, pbs, subst) = List.fold_right projections ctx (0, 1, [], [], []) in
+    Array.of_list (List.rev kns),
+    Array.of_list (List.rev pbs)
+
+let build_inductive env p prv ctx env_ar params 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 hyps = used_section_variables env inds in
   let nparamargs = rel_context_nhyps params in
   let nparamdecls = rel_context_length params in
+  let subst, ctx = Univ.abstract_universes p ctx in
+  let params = Vars.subst_univs_level_context subst params in
+  let env_ar = 
+    let ctx = Environ.rel_context env_ar in 
+    let ctx' = Vars.subst_univs_level_context subst ctx in
+      Environ.push_rel_context ctx' env
+  in
   (* Check one inductive *)
   let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg =
     (* Type of constructors in normal form *)
+    let lc = Array.map (Vars.subst_univs_level_constr subst) 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 consnrealargs =
+    let consnrealdecls =
       Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
 	splayed_lc in
+    let consnrealargs =
+      Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params)
+	splayed_lc in
     (* Elimination sorts *)
-    let arkind,kelim = match ar_kind with
-      | Inr (param_levels,lev) ->
-	  Polymorphic {
-	      poly_param_levels = param_levels;
-	      poly_level = lev;
-	    }, all_sorts
-      | Inl ((issmall,isunit),ar,s) ->
-	  let kelim = allowed_sorts issmall isunit s in
-	    Monomorphic {
-		mind_user_arity = ar;
-		mind_sort = s;
-	      }, kelim in
+    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 = sort_of_univ defs in
+	let kelim = allowed_sorts info s in
+	let ar = RegularArity 
+	  { mind_user_arity = Vars.subst_univs_level_constr subst ar; 
+	    mind_sort = sort_of_univ (Univ.subst_univs_level_universe subst defs); } in
+	  ar, kelim in
     (* Assigning VM tags to constructors *)
     let nconst, nblock = ref 0, ref 0 in
     let transf num =
       let arity = List.length (dest_subterms recarg).(num) in
-	if arity = 0 then
+	if Int.equal arity 0 then
 	  let p  = (!nconst, 0) in
 	    incr nconst; p
 	else
@@ -636,12 +764,13 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
       (* Build the inductive packet *)
       { mind_typename = id;
 	mind_arity = arkind;
-	mind_arity_ctxt = ar_sign;
+	mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign;
 	mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
-	mind_nrealargs_ctxt = rel_context_length ar_sign - nparamdecls;
+	mind_nrealdecls = rel_context_length ar_sign - nparamdecls;
 	mind_kelim = kelim;
 	mind_consnames = Array.of_list cnames;
-	mind_consnrealdecls = consnrealargs;
+	mind_consnrealdecls = consnrealdecls;
+	mind_consnrealargs = consnrealargs;
 	mind_user_lc = lc;
 	mind_nf_lc = nf_lc;
 	mind_recargs = recarg;
@@ -649,7 +778,30 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
 	mind_nb_args = !nblock;
 	mind_reloc_tbl = rtbl;
       } in
-  let packets = array_map2 build_one_packet inds recargs in
+  let packets = Array.map2 build_one_packet inds recargs in
+  let pkt = packets.(0) in	  
+  let isrecord = 
+    match isrecord with
+    | Some (Some rid) when pkt.mind_kelim == all_sorts && Array.length pkt.mind_consnames == 1
+			   && pkt.mind_consnrealargs.(0) > 0 ->
+      (** The elimination criterion ensures that all projections can be defined. *)
+      let u = 
+	if p then 
+	  subst_univs_level_instance subst (Univ.UContext.instance ctx)
+	else Univ.Instance.empty 
+      in
+      let indsp = ((kn, 0), u) in
+      let rctx, _ = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in
+	(try 
+	   let fields = List.firstn pkt.mind_consnrealdecls.(0) rctx in
+	   let kns, projs = 
+	     compute_projections indsp pkt.mind_typename rid nparamargs params
+	       pkt.mind_consnrealdecls pkt.mind_consnrealargs fields
+	   in Some (Some (rid, kns, projs))
+	 with UndefinableExpansion -> Some None)
+    | Some _ -> Some None
+    | None -> None
+  in
     (* Build the mutual inductive *)
     { mind_record = isrecord;
       mind_ntypes = ntypes;
@@ -659,7 +811,9 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
       mind_nparams_rec = nmr;
       mind_params_ctxt = params;
       mind_packets = packets;
-      mind_constraints = cst
+      mind_polymorphic = p;
+      mind_universes = ctx;
+      mind_private = prv;
     }
 
 (************************************************************************)
@@ -667,9 +821,11 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
 
 let check_inductive env kn mie =
   (* First type-check the inductive definition *)
-  let (env_ar, params, inds, cst) = typecheck_inductive env mie in
+  let (env_ar, params, inds) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
   let (nmr,recargs) = check_positivity kn env_ar params inds in
   (* Build the inductive packets *)
-    build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite
-      inds nmr recargs cst
+    build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private
+      mie.mind_entry_universes
+      env_ar params kn mie.mind_entry_record mie.mind_entry_finite
+      inds nmr recargs
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 1cd0a0b0..7774e52e 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -1,18 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Univ
 open Term
 open Declarations
 open Environ
 open Entries
-open Typeops
 
 (** Inductive type checking and errors *)
 
@@ -23,11 +21,11 @@ open Typeops
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
-  | NotConstructor of env * identifier * constr * constr * int * int
+  | NotConstructor of env * Id.t * constr * constr * int * int
   | NonPar of env * constr * int * constr * constr
-  | SameNamesTypes of identifier
-  | SameNamesConstructors of identifier
-  | SameNamesOverlap of identifier list
+  | SameNamesTypes of Id.t
+  | SameNamesConstructors of Id.t
+  | SameNamesOverlap of Id.t list
   | NotAnArity of env * constr
   | BadEntry
   | LargeNonPropInductiveNotInType
@@ -36,5 +34,14 @@ exception InductiveError of inductive_error
 
 (** The following function does checks on inductive declarations. *)
 
-val check_inductive :
-  env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
+val check_inductive : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
+
+(** The following enforces a system compatible with the univalent model *)
+
+val enforce_indices_matter : unit -> unit
+val is_indices_matter : unit -> bool
+
+val compute_projections : pinductive -> Id.t -> Id.t ->
+  int -> Context.rel_context -> int array -> int array -> 
+  Context.rel_context -> 
+  (constant array * projection_body array)
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index b78fb5ae..bb57ad25 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -1,17 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
 open Univ
 open Term
-open Sign
+open Vars
+open Context
 open Declarations
+open Declareops
 open Environ
 open Reduction
 open Type_errors
@@ -35,37 +38,46 @@ let find_inductive env c =
   let (t, l) = decompose_app (whd_betadeltaiota env c) in
   match kind_of_term t with
     | Ind ind
-        when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+        when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l)
     | _ -> raise Not_found
 
 let find_coinductive env c =
   let (t, l) = decompose_app (whd_betadeltaiota env c) in
   match kind_of_term t with
     | Ind ind
-        when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+        when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l)
     | _ -> raise Not_found
 
 let inductive_params (mib,_) = mib.mind_nparams
 
+let inductive_paramdecls (mib,u) = 
+  Vars.subst_instance_context u mib.mind_params_ctxt
+
+let instantiate_inductive_constraints mib u =
+  if mib.mind_polymorphic then
+    Univ.subst_instance_constraints u (Univ.UContext.constraints mib.mind_universes)
+  else Univ.Constraint.empty
+
+
 (************************************************************************)
 
 (* Build the substitution that replaces Rels by the appropriate *)
 (* inductives *)
-let ind_subst mind mib =
+let ind_subst mind mib u =
   let ntypes = mib.mind_ntypes in
-  let make_Ik k = mkInd (mind,ntypes-k-1) in
-  list_tabulate make_Ik ntypes
+  let make_Ik k = mkIndU ((mind,ntypes-k-1),u) in
+  List.init ntypes make_Ik
 
 (* Instantiate inductives in constructor type *)
-let constructor_instantiate mind mib c =
-  let s = ind_subst mind mib in
-  substl s c
+let constructor_instantiate mind u mib c =
+  let s = ind_subst mind mib u in
+    substl s (subst_instance_constr u c)
 
 let instantiate_params full t args sign =
   let fail () =
-    anomaly "instantiate_params: type, ctxt and args mismatch" in
+    anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in
   let (rem_args, subs, ty) =
-    Sign.fold_rel_context
+    Context.fold_rel_context
       (fun (_,copt,_) (largs,subs,ty) ->
         match (copt, largs, kind_of_term ty) with
           | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t)
@@ -75,16 +87,17 @@ let instantiate_params full t args sign =
       sign
       ~init:(args,[],t)
   in
-  if rem_args <> [] then fail();
+  let () = if not (List.is_empty rem_args) then fail () in
   substl subs ty
 
-let full_inductive_instantiate mib params sign =
+let full_inductive_instantiate mib u params sign =
   let dummy = prop_sort in
   let t = mkArity (sign,dummy) in
-  fst (destArity (instantiate_params true t params mib.mind_params_ctxt))
+  let ar = fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) in
+    Vars.subst_instance_context u ar
 
-let full_constructor_instantiate ((mind,_),(mib,_),params) =
-  let inst_ind = constructor_instantiate mind mib in
+let full_constructor_instantiate ((mind,_),u,(mib,_),params) =
+  let inst_ind = constructor_instantiate mind u mib in
   (fun t ->
     instantiate_params true (inst_ind t) params mib.mind_params_ctxt)
 
@@ -116,18 +129,13 @@ Remark: Set (predicative) is encoded as Type(0)
 
 let sort_as_univ = function
 | Type u -> u
-| Prop Null -> type0m_univ
-| Prop Pos -> type0_univ
-
-let cons_subst u su subst =
-  try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst
-  with Not_found -> (u, su) :: subst
+| Prop Null -> Universe.type0m
+| Prop Pos -> Universe.type0
 
-let actualize_decl_level env lev t =
-  let sign,s = dest_arity env t in
-  mkArity (sign,lev)
+(* Template polymorphism *)
 
-let polymorphism_on_non_applied_parameters = false
+let cons_subst u su subst =
+  Univ.LMap.add u su subst
 
 (* Bind expected levels of parameters to actual levels *)
 (* Propagate the new levels in the signature *)
@@ -145,7 +153,7 @@ let rec make_subst env = function
       (* arity is a global level which, at typing time, will be enforce *)
       (* to be greater than the level of the argument; this is probably *)
       (* a useless extra constraint *)
-      let s = sort_as_univ (snd (dest_arity env a)) in
+      let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in
       let ctx,subst = make_subst env (sign, exp, args) in
       d::ctx, cons_subst u s subst
   | (na,None,t as d)::sign, Some u::exp, [] ->
@@ -154,82 +162,96 @@ let rec make_subst env = function
       (* (actualize_decl_level), then to the conclusion of the arity (via *)
       (* the substitution) *)
       let ctx,subst = make_subst env (sign, exp, []) in
-      if polymorphism_on_non_applied_parameters then
-	let s = fresh_local_univ () in
-	let t = actualize_decl_level env (Type s) t in
-	(na,None,t)::ctx, cons_subst u s subst
-      else
 	d::ctx, subst
   | sign, [], _ ->
       (* Uniform parameters are exhausted *)
-      sign,[]
+      sign, Univ.LMap.empty
   | [], _, _ ->
       assert false
 
+exception SingletonInductiveBecomesProp of Id.t
+
 let instantiate_universes env ctx ar argsorts =
   let args = Array.to_list argsorts in
-  let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in
-  let level = subst_large_constraints subst ar.poly_level in
-  ctx,
-  (* Singleton type not containing types are interpretable in Prop *)
-  if is_type0m_univ level then prop_sort
-  (* Non singleton type not containing types are interpretable in Set *)
-  else if is_type0_univ level then set_sort
-  (* This is a Type with constraints *)
- else Type level
-
-exception SingletonInductiveBecomesProp of identifier
-
-let type_of_inductive_knowing_parameters ?(polyprop=true) env mip paramtyps =
+  let ctx,subst = make_subst env (ctx,ar.template_param_levels,args) in
+  let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in
+  let ty =
+    (* Singleton type not containing types are interpretable in Prop *)
+    if is_type0m_univ level then prop_sort
+    (* Non singleton type not containing types are interpretable in Set *)
+    else if is_type0_univ level then set_sort
+    (* This is a Type with constraints *)
+    else Type level
+  in
+    (ctx, ty)
+
+(* Type of an inductive type *)
+
+let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps =
   match mip.mind_arity with
-  | Monomorphic s ->
-      s.mind_user_arity
-  | Polymorphic ar ->
-      let ctx = List.rev mip.mind_arity_ctxt in
-      let ctx,s = instantiate_universes env ctx ar paramtyps in
+  | RegularArity a -> subst_instance_constr u a.mind_user_arity
+  | TemplateArity ar ->
+    let ctx = List.rev mip.mind_arity_ctxt in
+    let ctx,s = instantiate_universes env ctx ar paramtyps in
       (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e.
          the situation where a non-Prop singleton inductive becomes Prop
          when applied to Prop params *)
-      if not polyprop && not (is_type0m_univ ar.poly_level) && s = prop_sort
+      if not polyprop && not (is_type0m_univ ar.template_level) && is_prop_sort s
       then raise (SingletonInductiveBecomesProp mip.mind_typename);
       mkArity (List.rev ctx,s)
 
-(* Type of a (non applied) inductive type *)
+let type_of_inductive env pind = 
+  type_of_inductive_gen env pind [||]
+
+let constrained_type_of_inductive env ((mib,mip),u as pind) =
+  let ty = type_of_inductive env pind in
+  let cst = instantiate_inductive_constraints mib u in
+    (ty, cst)
+
+let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) args =
+  let ty = type_of_inductive_gen env pind args in
+  let cst = instantiate_inductive_constraints mib u in
+    (ty, cst)
 
-let type_of_inductive env (_,mip) =
-  type_of_inductive_knowing_parameters env mip [||]
+let type_of_inductive_knowing_parameters env ?(polyprop=false) mip args = 
+  type_of_inductive_gen env mip args
 
 (* The max of an array of universes *)
 
 let cumulate_constructor_univ u = function
   | Prop Null -> u
-  | Prop Pos -> sup type0_univ u
-  | Type u' -> sup u u'
+  | Prop Pos -> Universe.sup Universe.type0 u
+  | Type u' -> Universe.sup u u'
 
 let max_inductive_sort =
-  Array.fold_left cumulate_constructor_univ type0m_univ
+  Array.fold_left cumulate_constructor_univ Universe.type0m
 
 (************************************************************************)
 (* Type of a constructor *)
 
-let type_of_constructor cstr (mib,mip) =
+let type_of_constructor (cstr, u) (mib,mip) =
   let ind = inductive_of_constructor cstr in
   let specif = mip.mind_user_lc in
   let i = index_of_constructor cstr in
   let nconstr = Array.length mip.mind_consnames in
   if i > nconstr then error "Not enough constructors in the type.";
-  constructor_instantiate (fst ind) mib specif.(i-1)
+  constructor_instantiate (fst ind) u mib specif.(i-1)
 
-let arities_of_specif kn (mib,mip) =
+let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) =
+  let ty = type_of_constructor cstru ind in
+  let cst = instantiate_inductive_constraints mib u in
+    (ty, cst)
+
+let arities_of_specif (kn,u) (mib,mip) =
   let specif = mip.mind_nf_lc in
-  Array.map (constructor_instantiate kn mib) specif
+    Array.map (constructor_instantiate kn u mib) specif
 
 let arities_of_constructors ind specif =
-  arities_of_specif (fst ind) specif
+  arities_of_specif (fst (fst ind), snd ind) specif
 
-let type_of_constructors ind (mib,mip) =
+let type_of_constructors (ind,u) (mib,mip) =
   let specif = mip.mind_user_lc in
-  Array.map (constructor_instantiate (fst ind) mib) specif
+    Array.map (constructor_instantiate (fst ind) u mib) specif
 
 (************************************************************************)
 
@@ -237,7 +259,7 @@ let type_of_constructors ind (mib,mip) =
 
 let local_rels ctxt =
   let (rels,_) =
-    Sign.fold_rel_context_reverse
+    Context.fold_rel_context_reverse
       (fun (rels,n) (_,copt,_) ->
         match copt with
             None   -> (mkRel n :: rels, n+1)
@@ -251,18 +273,24 @@ let local_rels ctxt =
 
 let inductive_sort_family mip =
   match mip.mind_arity with
-   | Monomorphic s -> family_of_sort s.mind_sort
-   | Polymorphic _ -> InType
+  | RegularArity s -> family_of_sort s.mind_sort
+  | TemplateArity _ -> InType
 
 let mind_arity mip =
   mip.mind_arity_ctxt, inductive_sort_family mip
 
-let get_instantiated_arity (mib,mip) params =
+let get_instantiated_arity (ind,u) (mib,mip) params =
   let sign, s = mind_arity mip in
-  full_inductive_instantiate mib params sign, s
+  full_inductive_instantiate mib u params sign, s
 
 let elim_sorts (_,mip) = mip.mind_kelim
 
+let is_private (mib,_) = mib.mind_private = Some true
+let is_primitive_record (mib,_) = 
+  match mib.mind_record with
+  | Some (Some _) -> true
+  | _ -> false
+
 let extended_rel_list n hyps =
   let rec reln l p = function
     | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
@@ -272,30 +300,33 @@ let extended_rel_list n hyps =
   reln [] 1 hyps
 
 let build_dependent_inductive ind (_,mip) params =
-  let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in
   applist
-    (mkInd ind,
-       List.map (lift mip.mind_nrealargs_ctxt) params
+    (mkIndU ind,
+       List.map (lift mip.mind_nrealdecls) params
        @ extended_rel_list 0 realargs)
 
 (* This exception is local *)
 exception LocalArity of (sorts_family * sorts_family * arity_error) option
 
 let check_allowed_sort ksort specif =
-  if not (List.exists ((=) ksort) (elim_sorts specif)) then
+  let eq_ksort s = match ksort, s with
+  | InProp, InProp | InSet, InSet | InType, InType -> true
+  | _ -> false in
+  if not (List.exists eq_ksort (elim_sorts specif)) then
     let s = inductive_sort_family (snd specif) in
     raise (LocalArity (Some(ksort,s,error_elim_explain ksort s)))
 
 let is_correct_arity env c pj ind specif params =
-  let arsign,_ = get_instantiated_arity specif params in
-  let rec srec env pt ar u =
+  let arsign,_ = get_instantiated_arity ind specif params in
+  let rec srec env pt ar =
     let pt' = whd_betadeltaiota env pt in
     match kind_of_term pt', ar with
       | Prod (na1,a1,t), (_,None,a1')::ar' ->
-          let univ =
+          let () =
             try conv env a1 a1'
             with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ)
+          srec (push_rel (na1,None,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 (na1,None,a1) env in
@@ -303,17 +334,16 @@ let is_correct_arity env c pj ind specif params =
        | Sort s -> family_of_sort s
        | _ -> raise (LocalArity None) in
 	 let dep_ind = build_dependent_inductive ind specif params in
-	 let univ =
+	 let _ =
            try conv env a1 dep_ind
            with NotConvertible -> raise (LocalArity None) in
-	 check_allowed_sort ksort specif;
-	 union_constraints u univ
+	 check_allowed_sort ksort specif
       | _, (_,Some _,_ as d)::ar' ->
-	 srec (push_rel d env) (lift 1 pt') ar' u
+	  srec (push_rel d env) (lift 1 pt') ar'
       | _ ->
 	  raise (LocalArity None)
   in
-  try srec env pj.uj_type (List.rev arsign) empty_constraint
+  try srec env pj.uj_type (List.rev arsign) 
   with LocalArity kinds ->
     error_elim_arity env ind (elim_sorts specif) c pj kinds
 
@@ -323,16 +353,16 @@ 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 (_,mip as specif) params p =
+let build_branches_type (ind,u) (_,mip as specif) params p =
   let build_one_branch i cty =
-    let typi = full_constructor_instantiate (ind,specif,params) cty in
+    let typi = full_constructor_instantiate (ind,u,specif,params) cty in
     let (args,ccl) = decompose_prod_assum typi in
     let nargs = rel_context_length args in
     let (_,allargs) = decompose_app ccl in
-    let (lparams,vargs) = list_chop (inductive_params specif) allargs in
+    let (lparams,vargs) = List.chop (inductive_params specif) allargs in
     let cargs =
       let cstr = ith_constructor_of_inductive ind (i+1) in
-      let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in
+      let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in
       vargs @ [dep_cstr] in
     let base = beta_appvect (lift nargs p) (Array.of_list cargs) in
     it_mkProd_or_LetIn base args in
@@ -340,30 +370,32 @@ let build_branches_type ind (_,mip as specif) params p =
 
 (* [p] is the predicate, [c] is the match object, [realargs] is the
    list of real args of the inductive type *)
-let build_case_type n p c realargs =
-  whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c])))
+let build_case_type env n p c realargs =
+  whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c])))
 
-let type_case_branches env (ind,largs) pj c =
-  let specif = lookup_mind_specif env ind in
+let type_case_branches env (pind,largs) pj c =
+  let specif = lookup_mind_specif env (fst pind) in
   let nparams = inductive_params specif in
-  let (params,realargs) = list_chop nparams largs in
+  let (params,realargs) = List.chop nparams largs in
   let p = pj.uj_val in
-  let univ = is_correct_arity env c pj ind specif params in
-  let lc = build_branches_type ind specif params p in
-  let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in
-  (lc, ty, univ)
+  let () = is_correct_arity env c pj pind specif params in
+  let lc = build_branches_type pind specif params p in
+  let ty = build_case_type env (snd specif).mind_nrealdecls p c realargs in
+  (lc, ty)
 
 
 (************************************************************************)
-(* Checking the case annotation is relevent *)
+(* Checking the case annotation is relevant *)
 
-let check_case_info env indsp ci =
-  let (mib,mip) = lookup_mind_specif env indsp in
+let check_case_info env (indsp,u) ci =
+  let (mib,mip as spec) = lookup_mind_specif env indsp in
   if
-    not (eq_ind indsp ci.ci_ind) or
-    (mib.mind_nparams <> ci.ci_npar) or
-    (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls)
-  then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
+    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) ||
+    is_primitive_record spec
+  then raise (TypeError(env,WrongCaseInfo((indsp,u),ci)))
 
 (************************************************************************)
 (************************************************************************)
@@ -413,23 +445,43 @@ type subterm_spec =
   | Dead_code
   | Not_subterm
 
-let spec_of_tree t = lazy
-  (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec
-   then Not_subterm
-   else Subterm(Strict,Lazy.force t))
+let eq_wf_paths = Rtree.equal Declareops.eq_recarg
+
+let pp_recarg = function
+  | Norec -> Pp.str "Norec"
+  | Mrec i -> Pp.str ("Mrec "^MutInd.to_string (fst i))
+  | Imbr i -> Pp.str ("Imbr "^MutInd.to_string (fst i))
+
+let pp_wf_paths = Rtree.pp_tree pp_recarg
+
+let inter_recarg r1 r2 = match r1, r2 with
+| Norec, Norec -> Some r1
+| Mrec i1, Mrec i2
+| Imbr i1, Imbr i2
+| Mrec i1, Imbr i2 -> if Names.eq_ind i1 i2 then Some r1 else None
+| Imbr i1, Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None
+| _ -> None
+
+let inter_wf_paths = Rtree.inter Declareops.eq_recarg inter_recarg Norec
+
+let incl_wf_paths = Rtree.incl Declareops.eq_recarg inter_recarg Norec
+
+let spec_of_tree t =
+  if eq_wf_paths t mk_norec
+  then Not_subterm
+  else Subterm (Strict, t)
+
+let inter_spec s1 s2 =
+  match s1, s2 with
+  | _, Dead_code -> s1
+  | Dead_code, _ -> s2
+  | Not_subterm, _ -> s1
+  | _, Not_subterm -> s2
+  | Subterm (a1,t1), Subterm (a2,t2) ->
+     Subterm (size_glb a1 a2, inter_wf_paths t1 t2)
 
 let subterm_spec_glb =
-  let glb2 s1 s2 = 
-    match s1, s2 with
-        s1, Dead_code -> s1
-      | Dead_code, s2 -> s2
-      | Not_subterm, _ -> Not_subterm
-      | _, Not_subterm -> Not_subterm
-      | Subterm (a1,t1), Subterm (a2,t2) ->
-          if Rtree.eq_rtree (=) t1 t2 then Subterm (size_glb a1 a2, t1)
-          (* branches do not return objects with same spec *)
-          else Not_subterm in
-  Array.fold_left glb2 Dead_code
+  Array.fold_left inter_spec Dead_code
 
 type guard_env =
   { env     : env;
@@ -439,13 +491,10 @@ type guard_env =
     genv    : subterm_spec Lazy.t list;
   }
 
-let make_renv env recarg (kn,tyi) =
-  let mib = Environ.lookup_mind kn env in
-  let mind_recvec =
-    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+let make_renv env recarg tree =
   { env = env;
-    rel_min = recarg+2;
-    genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
+    rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *)
+    genv = [Lazy.lazy_from_val(Subterm(Large,tree))] }
 
 let push_var renv (x,ty,spec) =
   { env = push_rel (x,None,ty) renv.env;
@@ -453,7 +502,7 @@ let push_var renv (x,ty,spec) =
     genv = spec:: renv.genv }
 
 let assign_var_spec renv (i,spec) =
-  { renv with genv = list_assign renv.genv (i-1) spec }
+  { renv with genv = List.assign renv.genv (i-1) spec }
 
 let push_var_renv renv (x,ty) =
   push_var renv (x,ty,lazy Not_subterm)
@@ -492,7 +541,6 @@ let lookup_subterms env ind =
   let (_,mip) = lookup_mind_specif env ind in
   mip.mind_recargs
 
-
 let match_inductive ind ra =
   match ra with
     | (Mrec i | Imbr i) -> eq_ind ind i
@@ -517,15 +565,174 @@ let branches_specif renv c_spec ci =
 	   (match Lazy.force c_spec with
 		Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) ->
 		  let vra = Array.of_list (dest_subterms t).(i) in
-		  assert (nca = Array.length vra);
-		  Array.map
-		    (fun t -> Lazy.force (spec_of_tree (lazy t)))
-		    vra
-	      | Dead_code -> Array.create nca Dead_code
-	      | _ -> Array.create nca Not_subterm) in
-	 list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
+		  assert (Int.equal nca (Array.length vra));
+		  Array.map spec_of_tree vra
+	      | Dead_code -> Array.make nca Dead_code
+	      | _ -> Array.make nca Not_subterm) in
+	 List.init nca (fun j -> lazy (Lazy.force lvra).(j)))
       car 
 
+let check_inductive_codomain env p =
+  let absctx, ar = dest_lam_assum env p in
+  let env = push_rel_context absctx env in
+  let arctx, s = dest_prod_assum env ar in
+  let env = push_rel_context arctx env in
+  let i,l' = decompose_app (whd_betadeltaiota env s) in
+  isInd i
+
+(* The following functions are almost duplicated from indtypes.ml, except
+that they carry here a poorer environment (containing less information). *)
+let ienv_push_var (env, lra) (x,a,ra) =
+  (push_rel (x,None,a) env, (Norec,ra)::lra)
+
+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 =
+     push_rel (Anonymous,None,
+		hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env
+  in
+  let env = Array.fold_right push_ind mib.mind_packets env in
+  let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in
+  let lra_ind = Array.rev_to_list rc in
+  let ra_env = List.map (fun (r,t) -> (r,Rtree.lift ntypes t)) ra_env in
+  (env, lra_ind @ ra_env)
+
+let rec ienv_decompose_prod (env,_ as ienv) n c =
+ if Int.equal n 0 then (ienv,c) else
+   let c' = whd_betadeltaiota env c in
+   match kind_of_term c' with
+   Prod(na,a,b) ->
+     let ienv' = ienv_push_var ienv (na,a,mk_norec) in
+     ienv_decompose_prod ienv' (n-1) b
+     | _ -> assert false
+
+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
+  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 =
+  if Int.equal npars 0 then
+    lc
+  else
+    let make_abs =
+      List.init ntyps
+	(function i -> lambda_implicit_lift npars (mkRel (i+1)))
+    in
+    Array.map (substl make_abs) lc
+
+(* [get_recargs_approx env tree ind args] builds an approximation of the recargs
+tree for ind, knowing args. The argument tree is used to know when candidate
+nested types should be traversed, pruning the tree otherwise. This code is very
+close to check_positive in indtypes.ml, but does no positivity check and does not
+compute the number of recursive arguments. *)
+let get_recargs_approx env tree ind args =
+  let rec build_recargs (env, ra_env as ienv) tree c =
+    let x,largs = decompose_app (whd_betadeltaiota env c) in
+    match kind_of_term x with
+    | Prod (na,b,d) ->
+       assert (List.is_empty largs);
+       build_recargs (ienv_push_var ienv (na, b, mk_norec)) tree d
+    | Rel k ->
+       (* Free variables are allowed and assigned Norec *)
+       (try snd (List.nth ra_env (k-1))
+        with Failure _ | Invalid_argument _ -> mk_norec)
+    | Ind ind_kn ->
+       (* When the inferred tree allows it, we consider that we have a potential
+       nested inductive type *)
+       begin match dest_recarg tree with
+	     | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' ->
+			   build_recargs_nested ienv tree (ind_kn, largs)
+	     | _ -> mk_norec
+       end
+    | err ->
+       mk_norec
+
+  and build_recargs_nested (env,ra_env as ienv) tree (((mind,i),u), largs) =
+    (* If the inferred tree already disallows recursion, no need to go further *)
+    if eq_wf_paths tree mk_norec then tree
+    else
+    let mib = Environ.lookup_mind mind env in
+    let auxnpar = mib.mind_nparams_rec in
+    let nonrecpar = mib.mind_nparams - auxnpar in
+    let (lpar,_) = List.chop auxnpar largs in
+    let auxntyp = mib.mind_ntypes in
+    (* Extends the environment with a variable corresponding to
+	     the inductive def *)
+    let (env',_ as ienv') = ienv_push_inductive ienv ((mind,u),lpar) in
+    (* Parameters expressed in env' *)
+    let lpar' = List.map (lift auxntyp) lpar in
+    (* In case of mutual inductive types, we use the recargs tree which was
+    computed statically. This is fine because nested inductive types with
+    mutually recursive containers are not supported. *)
+    let trees =
+      if Int.equal auxntyp 1 then [|dest_subterms tree|]
+      else Array.map (fun mip -> dest_subterms mip.mind_recargs) mib.mind_packets
+    in
+    let mk_irecargs j specif =
+      (* The nested inductive type with parameters removed *)
+      let auxlcvect = abstract_mind_lc auxntyp auxnpar specif.mind_nf_lc in
+      let paths = Array.mapi
+        (fun k c ->
+	 let c' = hnf_prod_applist env' c lpar' in
+	 (* skip non-recursive parameters *)
+	 let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in
+	 build_recargs_constructors ienv' trees.(j).(k) c')
+	auxlcvect
+      in
+      mk_paths (Imbr (mind,j)) paths
+    in
+    let irecargs = Array.mapi mk_irecargs mib.mind_packets in
+    (Rtree.mk_rec irecargs).(i)
+
+  and build_recargs_constructors ienv trees c =
+    let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c =
+      let x,largs = decompose_app (whd_betadeltaiota env c) in
+	match kind_of_term x with
+
+          | Prod (na,b,d) ->
+	     let () = assert (List.is_empty largs) in
+             let recarg = build_recargs ienv (List.hd trees) b in
+             let ienv' = ienv_push_var ienv (na,b,mk_norec) in
+             recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d
+          | hd ->
+             List.rev lrec
+    in
+    recargs_constr_rec ienv trees [] c
+  in
+  (* starting with ra_env = [] seems safe because any unbounded Rel will be
+  assigned Norec *)
+  build_recargs_nested (env,[]) tree (ind, args)
+
+(* [restrict_spec env spec p] restricts the size information in spec to what is
+   allowed to flow through a match with predicate p in environment env. *)
+let restrict_spec env spec p =
+  if spec = Not_subterm then spec
+  else let absctx, ar = dest_lam_assum env p in
+  (* Optimization: if the predicate is not dependent, no restriction is needed
+     and we avoid building the recargs tree. *)
+  if noccur_with_meta 1 (rel_context_length absctx) ar then spec
+  else
+  let env = push_rel_context absctx env in
+  let arctx, s = dest_prod_assum env ar in
+  let env = push_rel_context arctx env in
+  let i,args = decompose_app (whd_betadeltaiota env s) in
+  match kind_of_term i with
+  | Ind i ->
+     begin match spec with
+	   | Dead_code -> spec
+	   | Subterm(st,tree) ->
+	      let recargs = get_recargs_approx env tree i args in
+	      let recargs = inter_wf_paths tree recargs in
+	      Subterm(st,recargs)
+	   | _ -> assert false
+     end
+  | _ -> Not_subterm
+
 (* [subterm_specif renv t] computes the recursive structure of [t] and
    compare its size with the size of the initial recursive argument of
    the fixpoint we are checking. [renv] collects such information
@@ -536,67 +743,77 @@ let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
     match kind_of_term f with
-      | Rel k -> subterm_var k renv
-
-      | Case (ci,_,c,lbr) ->
-	  let stack' = push_stack_closures renv l stack in
-          let cases_spec = branches_specif renv 
-	    (lazy_subterm_specif renv [] c) ci in
-          let stl  =
-            Array.mapi (fun i br' ->
-			  let stack_br = push_stack_args (cases_spec.(i)) stack' in
-			    subterm_specif renv stack_br br')
-              lbr in
-            subterm_spec_glb stl
-
-      | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
-	  (* when proving that the fixpoint f(x)=e is less than n, it is enough
-	     to prove that e is less than n assuming f is less than n
-	     furthermore when f is applied to a term which is strictly less than
-	     n, one may assume that x itself is strictly less than n
-	  *)
-          let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
-          let oind =
-            let env' = push_rel_context ctxt renv.env in
-              try Some(fst(find_inductive env' clfix))
-              with Not_found -> None in
-            (match oind with
-		 None -> Not_subterm (* happens if fix is polymorphic *)
-               | Some ind ->
-		   let nbfix = Array.length typarray in
-		   let recargs = lookup_subterms renv.env ind in
-		     (* pushing the fixpoints *)
-		   let renv' = push_fix_renv renv recdef in
-		   let renv' =
+    | Rel k -> subterm_var k renv
+    | Case (ci,p,c,lbr) ->
+       let stack' = push_stack_closures renv l stack in
+       let cases_spec =
+	 branches_specif renv (lazy_subterm_specif renv [] c) ci
+       in
+       let stl =
+	 Array.mapi (fun i br' ->
+		     let stack_br = push_stack_args (cases_spec.(i)) stack' in
+		     subterm_specif renv stack_br br')
+		    lbr in
+       let spec = subterm_spec_glb stl in
+       restrict_spec renv.env spec p
+
+    | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+      (* when proving that the fixpoint f(x)=e is less than n, it is enough
+	 to prove that e is less than n assuming f is less than n
+	 furthermore when f is applied to a term which is strictly less than
+	 n, one may assume that x itself is strictly less than n
+      *)
+    if not (check_inductive_codomain renv.env typarray.(i)) then Not_subterm
+    else 
+      let (ctxt,clfix) = dest_prod renv.env typarray.(i) in	    
+      let oind =
+        let env' = push_rel_context ctxt renv.env in
+          try Some(fst(find_inductive env' clfix))
+          with Not_found -> None in
+        (match oind with
+      None -> Not_subterm (* happens if fix is polymorphic *)
+        | Some (ind, _) ->
+	let nbfix = Array.length typarray in
+	let recargs = lookup_subterms renv.env ind in
+		   (* pushing the fixpoints *)
+	let renv' = push_fix_renv renv recdef in
+	let renv' =
                      (* Why Strict here ? To be general, it could also be
 			Large... *)
-                     assign_var_spec renv'
-		       (nbfix-i, lazy (Subterm(Strict,recargs))) in
-		   let decrArg = recindxs.(i) in
-		   let theBody = bodies.(i)   in
-		   let nbOfAbst = decrArg+1 in
-		   let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
-		     (* pushing the fix parameters *)
-		   let stack' = push_stack_closures renv l stack in
-		   let renv'' = push_ctxt_renv renv' sign in
-		   let renv'' =
-                     if List.length stack' < nbOfAbst then renv''
-                     else
-		       let decrArg = List.nth stack' decrArg in
-                       let arg_spec = stack_element_specif decrArg in
-			 assign_var_spec renv'' (1, arg_spec) in
-		     subterm_specif renv'' [] strippedBody)
-
-      | Lambda (x,a,b) ->
-          assert (l=[]);
-	  let spec,stack' = extract_stack renv a stack in
-	    subterm_specif (push_var renv (x,a,spec)) stack' b
+          assign_var_spec renv'
+	  (nbfix-i, lazy (Subterm(Strict,recargs))) in
+	let decrArg = recindxs.(i) in
+	let theBody = bodies.(i)   in
+	let nbOfAbst = decrArg+1 in
+	let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+		   (* pushing the fix parameters *)
+	let stack' = push_stack_closures renv l stack in
+	let renv'' = push_ctxt_renv renv' sign in
+	let renv'' =
+          if List.length stack' < nbOfAbst then renv''
+          else
+	    let decrArg = List.nth stack' decrArg in
+            let arg_spec = stack_element_specif decrArg in
+	      assign_var_spec renv'' (1, arg_spec) in
+	  subterm_specif renv'' [] strippedBody)
+
+    | Lambda (x,a,b) ->
+      let () = assert (List.is_empty l) in
+      let spec,stack' = extract_stack renv a stack in
+	subterm_specif (push_var renv (x,a,spec)) stack' b
 
       (* Metas and evars are considered OK *)
-      | (Meta _|Evar _) -> Dead_code
+    | (Meta _|Evar _) -> Dead_code
+
+    | Proj (p, c) -> 
+      let subt = subterm_specif renv stack c in
+	(match subt with
+	| Subterm (s, wf) -> Subterm (Strict, wf)
+	| Dead_code -> Dead_code
+	| Not_subterm -> Not_subterm)
 
       (* Other terms are not subterms *)
-      | _ -> Not_subterm
+    | _ -> Not_subterm
 
 and lazy_subterm_specif renv stack t =
   lazy (subterm_specif renv stack t)
@@ -606,13 +823,14 @@ and stack_element_specif = function
   |SArg x -> x
 
 and extract_stack renv a = function
-  | [] -> Lazy.lazy_from_val Not_subterm , []
-  | h::t -> stack_element_specif h, t
+   | [] -> Lazy.lazy_from_val Not_subterm , []
+   | h::t -> stack_element_specif h, t
 
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm x =
+let check_is_subterm x tree =
   match Lazy.force x with
-    Subterm (Strict,_) | Dead_code -> true
+  | Subterm (Strict,tree') -> incl_wf_paths tree tree'
+  | Dead_code -> true
   |  _ -> false
 
 (************************************************************************)
@@ -635,25 +853,53 @@ let error_illegal_rec_call renv fx (arg_renv,arg) =
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
 
+let filter_stack_domain env ci p stack =
+  let absctx, ar = dest_lam_assum env p in
+  (* Optimization: if the predicate is not dependent, no restriction is needed
+     and we avoid building the recargs tree. *)
+  if noccur_with_meta 1 (rel_context_length absctx) ar then stack
+  else let env = push_rel_context absctx env in
+  let rec filter_stack env ar stack =
+    let t = whd_betadeltaiota env ar in
+    match stack, kind_of_term t with
+    | elt :: stack', Prod (n,a,c0) ->
+      let d = (n,None,a) in
+      let ty, args = decompose_app (whd_betadeltaiota env a) in
+      let elt = match kind_of_term ty with
+      | Ind ind -> 
+        let spec' = stack_element_specif elt in
+        (match (Lazy.force spec') with
+        | Not_subterm | Dead_code -> elt
+        | Subterm(s,path) ->
+            let recargs = get_recargs_approx env path ind args in
+            let path = inter_wf_paths path recargs in
+            SArg (lazy (Subterm(s,path))))
+      | _ -> (SArg (lazy Not_subterm))
+      in
+      elt :: filter_stack (push_rel d env) c0 stack'
+    | _,_ -> List.fold_right (fun _ l -> SArg (lazy Not_subterm) :: l) stack []
+  in
+  filter_stack env ar stack
+
 (* Check if [def] is a guarded fixpoint body with decreasing arg.
    given [recpos], the decreasing arguments of each mutually defined
    fixpoint. *)
-let check_one_fix renv recpos def =
+let check_one_fix renv recpos trees def =
   let nfi = Array.length recpos in
 
   (* Checks if [t] only make valid recursive calls 
      [stack] is the list of constructor's argument specification and 
-     arguments than will be applied after reduction.
+     arguments that will be applied after reduction.
      example u in t where we have (match .. with |.. => t end) u *)
   let rec check_rec_call renv stack t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
-      let (f,l) = decompose_app (whd_betaiotazeta t) in
+      let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
       match kind_of_term f with
         | Rel p ->
             (* Test if [p] is a fixpoint (recursive call) *)
-	    if renv.rel_min <= p & p < renv.rel_min+nfi then
+	    if renv.rel_min <= p && p < renv.rel_min+nfi then
               begin
                 List.iter (check_rec_call renv []) l;
                 (* the position of the invoked fixpoint: *)
@@ -663,9 +909,10 @@ let check_one_fix renv recpos def =
 		let stack' = push_stack_closures renv l stack in
                 if List.length stack' <= np then error_partial_apply renv glob
                 else
+		  (* Retrieve the expected tree for the argument *)
                   (* Check the decreasing arg is smaller *)
                   let z = List.nth stack' np in
-	          if not (check_is_subterm (stack_element_specif z)) then
+	          if not (check_is_subterm (stack_element_specif z) trees.(glob)) then
                     begin match z with
 		      |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') 
 		      |SArg _ -> error_partial_apply renv glob
@@ -689,6 +936,7 @@ let check_one_fix renv recpos def =
             let case_spec = branches_specif renv 
 	      (lazy_subterm_specif renv [] c_0) ci in
 	    let stack' = push_stack_closures renv l stack in
+        let stack' = filter_stack_domain renv.env ci p stack' in
               Array.iteri (fun k br' -> 
 			     let stack_br = push_stack_args case_spec.(k) stack' in
 			     check_rec_call renv stack_br br') lrest
@@ -713,29 +961,29 @@ let check_one_fix renv recpos def =
 	    let stack' = push_stack_closures renv l stack in
               Array.iteri
                 (fun j body ->
-                   if i=j && (List.length stack' > decrArg) then
+                   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
 
-        | Const kn ->
+        | Const (kn,u as cu) ->
             if evaluable_constant kn renv.env then
               try List.iter (check_rec_call renv []) l
               with (FixGuardError _ ) ->
-		let value = (applist(constant_value renv.env kn, l)) in
+		let value = (applist(constant_value_in renv.env cu, l)) in
 	        check_rec_call renv stack value
 	    else List.iter (check_rec_call renv []) l
 
         | Lambda (x,a,b) ->
-	    assert (l = []);
+            let () = assert (List.is_empty l) in
 	    check_rec_call renv [] a ;
 	    let spec, stack' = extract_stack renv a stack in
 	    check_rec_call (push_var renv (x,a,spec)) stack' b
 
         | Prod (x,a,b) ->
-	    assert (l = [] && stack = []);
+            let () = assert (List.is_empty l && List.is_empty stack) in
             check_rec_call renv [] a;
             check_rec_call (push_var_renv renv (x,a)) [] b
 
@@ -759,15 +1007,18 @@ let check_one_fix renv recpos def =
 		    check_rec_call renv stack (applist(c,l))
             end
 
-	| Sort _ -> assert (l = [])
+	| Sort _ ->
+          assert (List.is_empty l)
 
         (* l is not checked because it is considered as the meta's context *)
         | (Evar _ | Meta _) -> ()
 
         | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *)
+	
+	| Proj (p, c) -> check_rec_call renv [] c
 
   and check_nested_fix_body renv decr recArgsDecrArg body =
-    if decr = 0 then
+    if Int.equal decr 0 then
       check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
     else
       match kind_of_term body with
@@ -775,23 +1026,23 @@ let check_one_fix renv recpos def =
 	    check_rec_call renv [] a;
             let renv' = push_var_renv renv (x,a) in
 	      check_nested_fix_body renv' (decr-1) recArgsDecrArg b
-	| _ -> anomaly "Not enough abstractions in fix body"
+	| _ -> anomaly (Pp.str "Not enough abstractions in fix body")
 	    
   in
   check_rec_call renv [] def
 
 let judgment_of_fixpoint (_, types, bodies) =
-  array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
+  Array.map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
 
 let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
   let nbfix = Array.length bodies in
-  if nbfix = 0
-    or Array.length nvect <> nbfix
-    or Array.length types <> nbfix
-    or Array.length names <> nbfix
-    or bodynum < 0
-    or bodynum >= nbfix
-  then anomaly "Ill-formed fix term";
+  if Int.equal nbfix 0
+    || not (Int.equal (Array.length nvect) nbfix)
+    || not (Int.equal (Array.length types) nbfix)
+    || not (Int.equal (Array.length names) nbfix)
+    || bodynum < 0
+    || bodynum >= nbfix
+  then anomaly (Pp.str "Ill-formed fix term");
   let fixenv = push_rec_types recdef env in
   let vdefj = judgment_of_fixpoint recdef in
   let raise_err env i err =
@@ -805,7 +1056,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
         | Lambda (x,a,b) ->
 	    if noccur_with_meta n nbfix a then
 	      let env' = push_rel (x, None, a) env in
-              if n = k+1 then
+              if Int.equal n (k + 1) then
                 (* get the inductive type of the fixpoint *)
                 let (mind, _) =
                   try find_inductive env a
@@ -813,20 +1064,25 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
 		    raise_err env i (RecursionNotOnInductiveType a) in
                 (mind, (env', b))
 	      else check_occur env' (n+1) b
-            else anomaly "check_one_fix: Bad occurrence of recursive call"
+            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
   (* Do it on every fixpoint *)
-  let rv = array_map2_i find_ind nvect bodies in
+  let rv = Array.map2_i find_ind nvect bodies in
   (Array.map fst rv, Array.map snd rv)
 
 
 let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
   let (minds, rdef) = inductive_of_mutfix env fix in
+  let get_tree (kn,i) =
+    let mib = Environ.lookup_mind kn env in
+    mib.mind_packets.(i).mind_recargs
+  in
+  let trees = Array.map (fun (mind,_) -> get_tree mind) minds in
   for i = 0 to Array.length bodies - 1 do
     let (fenv,body) = rdef.(i) in
-    let renv = make_renv fenv nvect.(i) minds.(i) in
-    try check_one_fix renv nvect body
+    let renv = make_renv fenv nvect.(i) trees.(i) in
+    try check_one_fix renv nvect trees body
     with FixGuardError (fixenv,err) ->
       error_ill_formed_rec_body fixenv err names i
 	(push_rec_types recdef env) (judgment_of_fixpoint recdef)
@@ -843,7 +1099,7 @@ let check_fix env fix = Profile.profile3 cfkey check_fix env fix;;
 exception CoFixGuardError of env * guard_error
 
 let anomaly_ill_typed () =
-  anomaly "check_one_cofix: too many arguments applied to constructor"
+  anomaly ~label:"check_one_cofix" (Pp.str "too many arguments applied to constructor")
 
 let rec codomain_is_coind env c =
   let b = whd_betadeltaiota env c in
@@ -856,7 +1112,7 @@ let rec codomain_is_coind env c =
 	  raise (CoFixGuardError (env, CodomainNotInductiveType b)))
 
 let check_one_cofix env nbfix def deftype =
-  let rec check_rec_call env alreadygrd n vlra  t =
+  let rec check_rec_call env alreadygrd n tree vlra  t =
     if not (noccur_with_meta n nbfix t) then
       let c,args = decompose_app (whd_betadeltaiota env t) in
       match kind_of_term c with
@@ -867,69 +1123,76 @@ let check_one_cofix env nbfix def deftype =
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall t))
             else if not(List.for_all (noccur_with_meta n nbfix) args) then
 	      raise (CoFixGuardError (env,NestedRecursiveOccurrences))
-
-	| Construct (_,i as cstr_kn)  ->
+	| Construct ((_,i as cstr_kn),u)  ->
             let lra = vlra.(i-1) in
             let mI = inductive_of_constructor cstr_kn in
 	    let (mib,mip) = lookup_mind_specif env mI in
-            let realargs = list_skipn mib.mind_nparams args in
+            let realargs = List.skipn mib.mind_nparams args in
             let rec process_args_of_constr = function
               | (t::lr), (rar::lrar) ->
-                  if rar = mk_norec then
+                  if eq_wf_paths rar mk_norec then
                     if noccur_with_meta n nbfix t
                     then process_args_of_constr (lr, lrar)
                     else raise (CoFixGuardError
 		                 (env,RecCallInNonRecArgOfConstructor t))
-                  else
-                    let spec = dest_subterms rar in
-                    check_rec_call env true n spec t;
-                    process_args_of_constr (lr, lrar)
+                  else begin
+                      check_rec_call env true n rar (dest_subterms rar) t;
+                      process_args_of_constr (lr, lrar)
+		    end
               | [],_ -> ()
               | _ -> anomaly_ill_typed ()
             in process_args_of_constr (realargs, lra)
 
 	| Lambda (x,a,b) ->
-	     assert (args = []);
+	    let () = assert (List.is_empty args) in
             if noccur_with_meta n nbfix a then
               let env' = push_rel (x, None, a) env in
-              check_rec_call env' alreadygrd (n+1)  vlra b
+              check_rec_call env' alreadygrd (n+1) tree vlra b
             else
 	      raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a))
 
 	| CoFix (j,(_,varit,vdefs as recdef)) ->
             if List.for_all (noccur_with_meta n nbfix) args
             then
-	      if array_for_all (noccur_with_meta n nbfix) varit then
+	      if Array.for_all (noccur_with_meta n nbfix) varit then
 		let nbfix = Array.length vdefs in
 		let env' = push_rec_types recdef env in
-		(Array.iter (check_rec_call env' alreadygrd (n+nbfix) vlra) vdefs;
-		 List.iter (check_rec_call env alreadygrd n vlra) args)
+		(Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs;
+		 List.iter (check_rec_call env alreadygrd n tree vlra) args)
               else
 		raise (CoFixGuardError (env,RecCallInTypeOfDef c))
 	    else
 	      raise (CoFixGuardError (env,UnguardedRecursiveCall c))
 
 	| Case (_,p,tm,vrest) ->
-            if (noccur_with_meta n nbfix p) then
-              if (noccur_with_meta n nbfix tm) then
-		if (List.for_all (noccur_with_meta n nbfix) args) then
-		  Array.iter (check_rec_call env alreadygrd n vlra) vrest
-		else
-		  raise (CoFixGuardError (env,RecCallInCaseFun c))
-              else
-		raise (CoFixGuardError (env,RecCallInCaseArg c))
-            else
-	      raise (CoFixGuardError (env,RecCallInCasePred c))
+	   begin
+	     let tree = match restrict_spec env (Subterm (Strict, tree)) p with
+	     | Dead_code -> assert false
+	     | Subterm (_, tree') -> tree'
+	     | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c))
+	     in
+               if (noccur_with_meta n nbfix p) then
+		 if (noccur_with_meta n nbfix tm) then
+		   if (List.for_all (noccur_with_meta n nbfix) args) then
+		     let vlra = dest_subterms tree in
+		     Array.iter (check_rec_call env alreadygrd n tree vlra) vrest
+		   else
+		     raise (CoFixGuardError (env,RecCallInCaseFun c))
+		 else
+		   raise (CoFixGuardError (env,RecCallInCaseArg c))
+               else
+		 raise (CoFixGuardError (env,RecCallInCasePred c))
+	   end
 
 	| Meta _ -> ()
         | Evar _ ->
-	    List.iter (check_rec_call env alreadygrd n vlra) args
+	    List.iter (check_rec_call env alreadygrd n tree vlra) args
 
 	| _    -> raise (CoFixGuardError (env,NotGuardedForm t)) in
 
-  let (mind, _) = codomain_is_coind env deftype in
+  let ((mind, _),_) = codomain_is_coind env deftype in
   let vlra = lookup_subterms env mind in
-  check_rec_call env false 1 (dest_subterms vlra) def
+  check_rec_call env false 1 vlra (dest_subterms vlra) def
 
 (* The  function which checks that the whole block of definitions
    satisfies the guarded condition *)
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index c507fe92..5847d25f 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -1,14 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Univ
 open Term
+open Context
+open Univ
 open Declarations
 open Environ
 
@@ -20,9 +21,9 @@ open Environ
    only a coinductive type.
    They raise [Not_found] if not convertible to a recursive type. *)
 
-val find_rectype     : env -> types -> inductive * constr list
-val find_inductive   : env -> types -> inductive * constr list
-val find_coinductive : env -> types -> inductive * constr list
+val find_rectype     : env -> types -> pinductive * constr list
+val find_inductive   : env -> types -> pinductive * constr list
+val find_coinductive : env -> types -> pinductive * constr list
 
 type mind_specif = mutual_inductive_body * one_inductive_body
 
@@ -32,23 +33,40 @@ type mind_specif = mutual_inductive_body * one_inductive_body
 val lookup_mind_specif : env -> inductive -> mind_specif
 
 (** {6 Functions to build standard types related to inductive } *)
-val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list
+val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list
+
+val inductive_paramdecls : mutual_inductive_body puniverses -> rel_context
+
+val instantiate_inductive_constraints : 
+  mutual_inductive_body -> universe_instance -> constraints
+
+val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained
+val constrained_type_of_inductive_knowing_parameters : 
+  env -> mind_specif puniverses -> types Lazy.t array -> types constrained
 
-val type_of_inductive : env -> mind_specif -> types
+val type_of_inductive : env -> mind_specif puniverses -> types
+
+val type_of_inductive_knowing_parameters : 
+  env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types
 
 val elim_sorts : mind_specif -> sorts_family list
 
+val is_private : mind_specif -> bool
+val is_primitive_record : mind_specif -> bool
+
 (** Return type as quoted by the user *)
-val type_of_constructor : constructor -> mind_specif -> types
+
+val constrained_type_of_constructor : pconstructor -> mind_specif -> types constrained
+val type_of_constructor : pconstructor -> mind_specif -> types
 
 (** Return constructor types in normal form *)
-val arities_of_constructors : inductive -> mind_specif -> types array
+val arities_of_constructors : pinductive -> mind_specif -> types array
 
 (** Return constructor types in user form *)
-val type_of_constructors : inductive -> mind_specif -> types array
+val type_of_constructors : pinductive -> mind_specif -> types array
 
 (** Transforms inductive specification into types (in nf) *)
-val arities_of_specif : mutual_inductive -> mind_specif -> types array
+val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array
 
 val inductive_params : mind_specif -> int
 
@@ -60,11 +78,11 @@ val inductive_params : mind_specif -> int
    the universe constraints generated.
  *)
 val type_case_branches :
-  env -> inductive * constr list -> unsafe_judgment -> constr
-    -> types array * types * constraints
+  env -> pinductive * constr list -> unsafe_judgment -> constr
+    -> types array * types
 
 val build_branches_type :
-  inductive -> mutual_inductive_body * one_inductive_body ->
+  pinductive -> mutual_inductive_body * one_inductive_body ->
     constr list -> constr -> types array
 
 (** Return the arity of an inductive type *)
@@ -74,7 +92,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 -> inductive -> case_info -> unit
+val check_case_info : env -> pinductive -> case_info -> unit
 
 (** {6 Guard conditions for fix and cofix-points. } *)
 val check_fix : env -> fixpoint -> unit
@@ -82,22 +100,19 @@ val check_cofix : env -> cofixpoint -> unit
 
 (** {6 Support for sort-polymorphic inductive types } *)
 
-(** The "polyprop" optional argument below allows to control
+(** The "polyprop" optional argument below controls
     the "Prop-polymorphism". By default, it is allowed.
     But when "polyprop=false", the following exception is raised
     when a polymorphic singleton inductive type becomes Prop due to
     parameter instantiation. This is used by the Ocaml extraction,
     which cannot handle (yet?) Prop-polymorphism. *)
 
-exception SingletonInductiveBecomesProp of identifier
-
-val type_of_inductive_knowing_parameters : ?polyprop:bool ->
-  env -> one_inductive_body -> types array -> types
+exception SingletonInductiveBecomesProp of Id.t
 
 val max_inductive_sort : sorts array -> universe
 
 val instantiate_universes : env -> rel_context ->
-    polymorphic_arity -> types array -> rel_context * sorts
+  template_arity -> constr Lazy.t array -> rel_context * sorts
 
 (** {6 Debug} *)
 
@@ -118,3 +133,6 @@ type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
 
 val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec
 
+val lambda_implicit_lift : int -> Constr.constr -> Term.constr
+
+val abstract_mind_lc : int -> Int.t -> Constr.constr array -> Constr.constr array
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 8c1dd53a..29fe887d 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -1,32 +1,45 @@
 Names
+Uint31
 Univ
 Esubst
+Sorts
+Evar
+Constr
+Context
+Vars
 Term
 Mod_subst
-Sign
 Cbytecodes
 Copcodes
 Cemitcodes
-Declarations
+Nativevalues
+Primitives
+Nativeinstr
+Opaqueproof
+Declareops
 Retroknowledge
+Conv_oracle
 Pre_env
 Cbytegen
+Nativelambda
+Nativecode
+Nativelib
 Environ
-Conv_oracle
 Closure
 Reduction
+Nativeconv
 Type_errors
-Entries
 Modops
 Inductive
 Typeops
+Fast_typeops
 Indtypes
 Cooking
 Term_typing
 Subtyping
 Mod_typing
+Nativelibrary
 Safe_typing
-
 Vm
 Csymtable
 Vconv
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index d46833db..f7ae30e7 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -19,7 +19,7 @@ open Names
 open Term
 
 (* For Inline, the int is an inlining level, and the constr (if present)
-   is the term into which we should inline *)
+   is the term into which we should inline. *)
 
 type delta_hint =
   | Inline of int * constr option
@@ -31,28 +31,26 @@ type delta_hint =
 module Deltamap = struct
   type t = module_path MPmap.t * delta_hint KNmap.t
   let empty = MPmap.empty, KNmap.empty
+  let is_empty (mm, km) =
+    MPmap.is_empty mm && KNmap.is_empty km
   let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km)
   let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km)
   let find_mp mp map = MPmap.find mp (fst map)
   let find_kn kn map = KNmap.find kn (snd map)
   let mem_mp mp map = MPmap.mem mp (fst map)
-  let mem_kn kn map = KNmap.mem kn (snd map)
   let fold_kn f map i = KNmap.fold f (snd map) i
   let fold fmp fkn (mm,km) i =
     MPmap.fold fmp mm (KNmap.fold fkn km i)
   let join map1 map2 = fold add_mp add_kn map1 map2
 end
 
+(* Invariant: in the [delta_hint] map, an [Equiv] should only
+   relate [kernel_name] with the same label (and section dirpath). *)
+
 type delta_resolver = Deltamap.t
 
 let empty_delta_resolver = Deltamap.empty
 
-module MBImap = Map.Make
-  (struct
-    type t = mod_bound_id
-    let compare = Pervasives.compare
-   end)
-
 module Umap = struct
   type 'a t = 'a MPmap.t * 'a MBImap.t
   let empty = MPmap.empty, MBImap.empty
@@ -61,8 +59,6 @@ module Umap = struct
   let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2)
   let find_mp mp map = MPmap.find mp (fst map)
   let find_mbi mbi map = MBImap.find mbi (snd map)
-  let mem_mp mp map = MPmap.mem mp (fst map)
-  let mem_mbi mbi map = MBImap.mem mbi (snd map)
   let iter_mbi f map = MBImap.iter f (snd map)
   let fold fmp fmbi (m1,m2) i =
     MPmap.fold fmp m1 (MBImap.fold fmbi m2 i)
@@ -95,7 +91,7 @@ let debug_string_of_delta resolve =
 let list_contents sub =
   let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in
   let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in
-  let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in
+  let mbi_one_pair mbi p l = (MBId.debug_to_string mbi, one_pair p)::l in
   Umap.fold mp_one_pair mbi_one_pair sub []
 
 let debug_string_of_subst sub =
@@ -120,11 +116,13 @@ let debug_pr_subst sub =
 
 let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc))
 
-let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn')
+let add_kn_delta_resolver kn kn' =
+  assert (Label.equal (label kn) (label kn'));
+  Deltamap.add_kn kn (Equiv kn')
 
 let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2
 
-(** Extending a [substitution *)
+(** Extending a [substitution] *)
 
 let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s
 let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s
@@ -141,13 +139,13 @@ let kn_in_delta kn resolver =
       | Inline _ -> false
   with Not_found -> false
 
-let con_in_delta con resolver = kn_in_delta (user_con con) resolver
-let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver
+let con_in_delta con resolver = kn_in_delta (Constant.user con) resolver
+let mind_in_delta mind resolver = kn_in_delta (MutInd.user mind) resolver
 
 let mp_of_delta resolve mp =
  try Deltamap.find_mp mp resolve with Not_found -> mp
 
-let rec find_prefix resolve mp =
+let find_prefix resolve mp =
   let rec sub_mp = function
     | MPdot(mp,l) as mp_sup ->
 	(try Deltamap.find_mp mp_sup resolve
@@ -156,6 +154,8 @@ let rec find_prefix resolve mp =
   in
   try sub_mp mp with Not_found -> mp
 
+(** Applying a resolver to a kernel name *)
+
 exception Change_equiv_to_inline of (int * constr)
 
 let solve_delta_kn resolve kn =
@@ -174,35 +174,25 @@ let solve_delta_kn resolve kn =
 
 let kn_of_delta resolve kn =
   try solve_delta_kn resolve kn
-  with e when Errors.noncritical e -> kn
+  with Change_equiv_to_inline _ -> kn
 
-let constant_of_delta_kn resolve kn =
-  constant_of_kn_equiv kn (kn_of_delta resolve kn)
+(** Try a 1st resolver, and then a 2nd in case it had no effect *)
 
-let gen_of_delta resolve x kn fix_can =
-  try
-    let new_kn = solve_delta_kn resolve kn in
-    if kn == new_kn then x else fix_can new_kn
-  with e when Errors.noncritical e -> x
+let kn_of_deltas resolve1 resolve2 kn =
+  let kn' = kn_of_delta resolve1 kn in
+  if kn' == kn then kn_of_delta resolve2 kn else kn'
 
-let constant_of_delta resolve con =
-  let kn = user_con con in
-  gen_of_delta resolve con kn (constant_of_kn_equiv kn)
+let constant_of_delta_kn resolve kn =
+  Constant.make kn (kn_of_delta resolve kn)
 
-let constant_of_delta2 resolve con =
-  let kn, kn' = canonical_con con, user_con con in
-  gen_of_delta resolve con kn (constant_of_kn_equiv kn')
+let constant_of_deltas_kn resolve1 resolve2 kn =
+  Constant.make kn (kn_of_deltas resolve1 resolve2 kn)
 
 let mind_of_delta_kn resolve kn =
-  mind_of_kn_equiv kn (kn_of_delta resolve kn)
+  MutInd.make kn (kn_of_delta resolve kn)
 
-let mind_of_delta resolve mind =
-  let kn = user_mind mind in
-  gen_of_delta resolve mind kn (mind_of_kn_equiv kn)
-
-let mind_of_delta2 resolve mind =
-  let kn, kn' = canonical_mind mind, user_mind mind in
-  gen_of_delta resolve mind kn (mind_of_kn_equiv kn')
+let mind_of_deltas_kn resolve1 resolve2 kn =
+  MutInd.make kn (kn_of_deltas resolve1 resolve2 kn)
 
 let inline_of_delta inline resolver =
   match inline with
@@ -215,18 +205,16 @@ let inline_of_delta inline resolver =
       in
       Deltamap.fold_kn extract resolver []
 
-let find_inline_of_delta kn resolve =
-  match Deltamap.find_kn kn resolve with
+let search_delta_inline resolve kn1 kn2 =
+  let find kn = match Deltamap.find_kn kn resolve with
     | Inline (_,o) -> o
-    | _ -> raise Not_found
-
-let constant_of_delta_with_inline resolve con =
-  let kn1,kn2 = canonical_con con,user_con con in
-  try find_inline_of_delta kn2 resolve
+    | Equiv _ -> raise Not_found
+  in
+  try find kn1
   with Not_found ->
     if kn1 == kn2 then None
     else
-      try find_inline_of_delta kn1 resolve
+      try find kn2
       with Not_found -> None
 
 let subst_mp0 sub mp = (* 's like subst *)
@@ -270,52 +258,76 @@ let subst_kn sub kn =
 
 exception No_subst
 
-type sideconstantsubst =
-  | User
-  | Canonical
-
-let gen_subst_mp f sub mp1 mp2 =
+let subst_dual_mp sub mp1 mp2 =
   let o1 = subst_mp0 sub mp1 in
   let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in
   match o1, o2 with
     | None, None -> raise No_subst
-    | Some (mp',resolve), None -> User, (f mp' mp2), resolve
-    | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
-    | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
-
-let subst_ind sub mind =
-  let kn1,kn2 = user_mind mind, canonical_mind mind in
-  let mp1,dir,l = repr_kn kn1 in
-  let mp2,_,_ = repr_kn kn2 in
-  let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
+    | Some (mp1',resolve), None -> mp1', mp2, resolve, true
+    | None, Some (mp2',resolve) -> mp1, mp2', resolve, false
+    | Some (mp1',_), Some (mp2',resolve) -> mp1', mp2', resolve, false
+
+let progress f x ~orelse =
+  let y = f x in
+  if y != x then y else orelse
+
+let subst_mind sub mind =
+  let mpu,dir,l = MutInd.repr3 mind in
+  let mpc = KerName.modpath (MutInd.canonical mind) in
   try
-    let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
-    match side with
-      | User -> mind_of_delta resolve mind'
-      | Canonical -> mind_of_delta2 resolve mind'
+    let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in
+    let knu = KerName.make mpu dir l in
+    let knc = if mpu == mpc then knu else KerName.make mpc dir l in
+    let knc' =
+      progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc
+    in
+    MutInd.make knu knc'
   with No_subst -> mind
 
-let subst_con0 sub con =
-  let kn1,kn2 = user_con con,canonical_con con in
-  let mp1,dir,l = repr_kn kn1 in
-  let mp2,_,_ = repr_kn kn2 in
-  let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
-  let dup con = con, mkConst con in
-  let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
-  match constant_of_delta_with_inline resolve con' with
+let subst_ind sub (ind,i as indi) =
+  let ind' = subst_mind sub ind in
+    if ind' == ind then indi else ind',i
+
+let subst_pind sub (ind,u) =
+  (subst_ind sub ind, u)
+
+let subst_con0 sub (cst,u) =
+  let mpu,dir,l = Constant.repr3 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 dir l in
+  let knc = if mpu == mpc then knu else KerName.make mpc dir l in
+  match search_delta_inline resolve knu knc with
     | Some t ->
       (* In case of inlining, discard the canonical part (cf #2608) *)
-      constant_of_kn (user_con con'), t
+      Constant.make1 knu, t
     | None ->
-      let con'' = match side with
-	| User -> constant_of_delta resolve con'
-	| Canonical -> constant_of_delta2 resolve con'
+      let knc' =
+        progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc
       in
-      if con'' == con then raise No_subst else dup con''
+      let cst' = Constant.make knu knc' in
+      cst', mkConstU (cst',u)
+
+let subst_con sub cst =
+  try subst_con0 sub cst
+  with No_subst -> fst cst, mkConstU cst
+
+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 
+	con',u
+  with No_subst -> pcon
 
-let subst_con sub con =
-  try subst_con0 sub con
-  with No_subst -> con, mkConst con
+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))
+  with No_subst -> con
 
 (* Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
@@ -324,18 +336,27 @@ let subst_con sub con =
    interpretation (i.e. an evaluable reference is never expanded). *)
 let subst_evaluable_reference subst = function
   | EvalVarRef id -> EvalVarRef id
-  | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
+  | EvalConstRef kn -> EvalConstRef (subst_constant subst kn)
 
 let rec map_kn f f' c =
   let func = map_kn f f' in
     match kind_of_term c with
       | Const kn -> (try snd (f' kn) with No_subst -> c)
-      | Ind (kn,i) ->
+      | Proj (p,t) -> 
+          let p' = 
+	    try
+	      Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p
+	    with No_subst -> p
+	  in
+	  let t' = func t in
+	    if p' == p && t' == t then c
+	    else mkProj (p', t')
+      | Ind ((kn,i),u) ->
 	  let kn' = f kn in
-	  if kn'==kn then c else mkInd (kn',i)
-      | Construct ((kn,i),j) ->
+	  if kn'==kn then c else mkIndU ((kn',i),u)
+      | Construct (((kn,i),j),u) ->
 	  let kn' = f kn in
-	  if kn'==kn then c else mkConstruct ((kn',i),j)
+	  if kn'==kn then c else mkConstructU (((kn',i),j),u)
       | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
@@ -344,7 +365,7 @@ let rec map_kn f f' c =
 	  in
 	  let p' = func p in
 	  let ct' = func ct in
-	  let l' = array_smartmap func l in
+	  let l' = Array.smartmap func l in
 	    if (ci.ci_ind==ci_ind && p'==p
 		&& l'==l && ct'==ct)then c
 	    else
@@ -373,35 +394,35 @@ let rec map_kn f f' c =
 	    else mkLetIn (na, b', t', ct')
       | App (ct,l) ->
 	  let ct' = func ct in
-	  let l' = array_smartmap func l in
+	  let l' = Array.smartmap func l in
 	    if (ct'== ct && l'==l) then c
 	    else mkApp (ct',l')
       | Evar (e,l) ->
-	  let l' = array_smartmap func l in
+	  let l' = Array.smartmap func l in
 	    if (l'==l) then c
 	    else mkEvar (e,l')
       | Fix (ln,(lna,tl,bl)) ->
-	  let tl' = array_smartmap func tl in
-	  let bl' = array_smartmap func bl in
+	  let tl' = Array.smartmap func tl in
+	  let bl' = Array.smartmap func bl in
 	    if (bl == bl'&& tl == tl') then c
 	    else mkFix (ln,(lna,tl',bl'))
       | CoFix(ln,(lna,tl,bl)) ->
-	  let tl' = array_smartmap func tl in
-	  let bl' = array_smartmap func bl in
+	  let tl' = Array.smartmap func tl in
+	  let bl' = Array.smartmap func bl in
 	    if (bl == bl'&& tl == tl') then c
 	    else mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
 
 let subst_mps sub c =
   if is_empty_subst sub then c
-  else map_kn (subst_ind sub) (subst_con0 sub) c
+  else map_kn (subst_mind sub) (subst_con0 sub) c
 
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
-    | _ when mp = mpfrom -> mpto
+    | _ when mp_eq mp mpfrom -> mpto
     | MPdot (mp1,l) ->
 	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
-	  if mp1==mp1' then mp
+	  if mp1 == mp1' then mp
 	  else MPdot (mp1',l)
     | _ -> mp
 
@@ -413,7 +434,7 @@ let replace_mp_in_kn mpfrom mpto kn =
 
 let rec mp_in_mp mp mp1 =
   match mp1 with
-    | _ when mp1 = mp -> true
+    | _ when mp_eq mp1 mp -> true
     | MPdot (mp2,l) -> mp_in_mp mp mp2
     | _ -> false
 
@@ -471,33 +492,30 @@ let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true
 
 let update_delta_resolver resolver1 resolver2 =
   let mp_apply_rslv mkey mequ rslv =
-    if Deltamap.mem_mp mkey resolver2 then rslv
-    else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
+    Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
   in
-  let kn_apply_rslv kkey hint rslv =
-    if Deltamap.mem_kn kkey resolver2 then rslv
-    else
-      let hint' = match hint with
-	| Equiv kequ ->
-	  (try Equiv (solve_delta_kn resolver2 kequ)
-	   with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
-	| _ -> hint
-      in
-      Deltamap.add_kn kkey hint' rslv
+  let kn_apply_rslv kkey hint1 rslv =
+    let hint = match hint1 with
+      | Equiv kequ ->
+	(try Equiv (solve_delta_kn resolver2 kequ)
+	 with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
+      | Inline (_,Some _) -> hint1
+      | Inline (_,None) ->
+        (try Deltamap.find_kn kkey resolver2 with Not_found -> hint1)
+    in
+    Deltamap.add_kn kkey hint rslv
   in
-  Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver
+  Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 resolver2
 
 let add_delta_resolver resolver1 resolver2 =
-  if resolver1 == resolver2 then
-    resolver2
-  else if resolver2 = empty_delta_resolver then
+  if Deltamap.is_empty resolver2 then
     resolver1
   else
-    Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2
+    update_delta_resolver resolver1 resolver2
 
 let substition_prefixed_by k mp subst =
   let mp_prefixmp kmp (mp_to,reso) sub =
-    if mp_in_mp mp kmp && mp <> kmp then
+    if mp_in_mp mp kmp && not (mp_eq mp kmp) then
       let new_key = replace_mp_in_mp mp k kmp in
       Umap.add_mp new_key (mp_to,reso) sub
     else sub
@@ -529,44 +547,41 @@ let join subst1 subst2 =
   Umap.join subst2 subst
 
 let rec occur_in_path mbi = function
-  | MPbound bid' -> mbi = bid'
+  | MPbound bid' -> MBId.equal mbi bid'
   | MPdot (mp1,_) -> occur_in_path mbi mp1
   | _ -> false
 
 let occur_mbid mbi sub =
   let check_one mbi' (mp,_) =
-    if mbi = mbi' || occur_in_path mbi mp then raise Exit
+    if MBId.equal mbi mbi' || occur_in_path mbi mp then raise Exit
   in
   try
     Umap.iter_mbi check_one sub;
     false
   with Exit -> true
 
-type 'a lazy_subst =
-  | LSval of 'a
-  | LSlazy of substitution list * 'a
+type 'a substituted = {
+  mutable subst_value : 'a;
+  mutable subst_subst : substitution list;
+}
 
-type 'a substituted = 'a lazy_subst ref
+let from_val x = { subst_value = x; subst_subst = []; }
 
-let from_val a = ref (LSval a)
+let force fsubst r = match r.subst_subst with
+| [] -> r.subst_value
+| s ->
+  let subst = List.fold_left join empty_subst (List.rev s) in
+  let x = fsubst subst r.subst_value in
+  let () = r.subst_subst <- [] in
+  let () = r.subst_value <- x in
+  x
 
-let force fsubst r =
-  match !r with
-  | LSval a -> a
-  | LSlazy(s,a) ->
-      let subst = List.fold_left join empty_subst (List.rev s) in
-      let a' = fsubst subst a in
-      r := LSval a';
-      a'
+let subst_substituted s r = { r with subst_subst = s :: r.subst_subst; }
 
-let subst_substituted s r =
-  match !r with
-    | LSval a -> ref (LSlazy([s],a))
-    | LSlazy(s',a) ->
-	  ref (LSlazy(s::s',a))
+let force_constr = force subst_mps
+let subst_constr = subst_substituted
 
 (* debug *)
-let repr_substituted r =
-  match !r with
-    | LSval a -> None, a
-    | LSlazy(s,a) -> Some s, a
+let repr_substituted r = match r.subst_subst with
+| [] -> None, r.subst_value
+| s -> Some s, r.subst_value
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index d29b4c9a..fc2b0441 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -30,16 +30,25 @@ val add_inline_delta_resolver :
 
 val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver
 
-(** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *)
+(** Effect of a [delta_resolver] on a module path, on a kernel name *)
 
+val mp_of_delta : delta_resolver -> module_path -> module_path
 val kn_of_delta : delta_resolver -> kernel_name -> kernel_name
+
+(** Build a constant whose canonical part is obtained via a resolver *)
+
 val constant_of_delta_kn : delta_resolver -> kernel_name -> constant
-val constant_of_delta : delta_resolver -> constant -> constant
 
-val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
-val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
+(** Same, but a 2nd resolver is tried if the 1st one had no effect *)
 
-val mp_of_delta : delta_resolver -> module_path -> module_path
+val constant_of_deltas_kn :
+  delta_resolver -> delta_resolver -> kernel_name -> constant
+
+(** Same for inductive names *)
+
+val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
+val mind_of_deltas_kn :
+  delta_resolver -> delta_resolver -> kernel_name -> mutual_inductive
 
 (** Extract the set of inlined constant in the resolver *)
 val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list
@@ -62,13 +71,13 @@ val is_empty_subst : substitution -> bool
 (** add_* add [arg2/arg1]\{arg3\} to the substitution with no
    sequential composition  *)
 val add_mbid :
-  mod_bound_id -> module_path -> delta_resolver  -> substitution -> substitution
+  MBId.t -> module_path -> delta_resolver  -> substitution -> substitution
 val add_mp :
   module_path -> module_path -> delta_resolver -> substitution -> substitution
 
 (** map_* create a new substitution [arg2/arg1]\{arg3\} *)
 val map_mbid :
-  mod_bound_id -> module_path -> delta_resolver -> substitution
+  MBId.t -> module_path -> delta_resolver -> substitution
 val map_mp :
   module_path -> module_path -> delta_resolver -> substitution
 
@@ -109,15 +118,32 @@ val debug_pr_delta : delta_resolver -> Pp.std_ppcmds
 val subst_mp :
   substitution -> module_path -> module_path
 
-val subst_ind :
+val subst_mind :
   substitution -> mutual_inductive -> mutual_inductive
 
+val subst_ind :
+  substitution -> inductive -> inductive
+
+val subst_pind : substitution -> pinductive -> pinductive
+
 val subst_kn :
   substitution -> kernel_name -> kernel_name
 
 val subst_con :
+  substitution -> pconstant -> constant * constr
+
+val subst_pcon :
+  substitution -> pconstant -> pconstant
+
+val subst_pcon_term :
+  substitution -> pconstant -> pconstant * constr
+
+val subst_con_kn :
   substitution -> constant -> constant * constr
 
+val subst_constant : 
+  substitution -> constant -> constant
+
 (** 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"
@@ -136,10 +162,14 @@ val subst_mps : substitution -> constr -> constr
 (** [occur_*id id sub] returns true iff [id] occurs in [sub]
    on either side *)
 
-val occur_mbid : mod_bound_id -> substitution -> bool
+val occur_mbid : MBId.t -> substitution -> bool
 
 (** [repr_substituted r] dumps the representation of a substituted:
     - [None, a] when r is a value
     - [Some s, a] when r is a delayed substitution [s] applied to [a] *)
 
 val repr_substituted : 'a substituted -> substitution list option * 'a
+
+val force_constr : Term.constr substituted -> Term.constr
+val subst_constr :
+  substitution -> Term.constr substituted -> Term.constr substituted
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 55fdf1ab..97c1d1fd 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,432 +14,313 @@
 
 open Util
 open Names
-open Univ
 open Declarations
 open Entries
 open Environ
-open Term_typing
 open Modops
-open Subtyping
 open Mod_subst
 
-exception Not_path
-
-let path_of_mexpr = function
-  | MSEident mp -> mp
-  | _ -> raise Not_path
+type 'alg translation =
+  module_signature * 'alg option * delta_resolver * Univ.constraints
 
 let rec mp_from_mexpr = function
-  | MSEident mp -> mp
-  | MSEapply (expr,_) -> mp_from_mexpr expr
-  | MSEfunctor (_,_,expr) -> mp_from_mexpr expr
-  | MSEwith (expr,_) -> mp_from_mexpr expr
+  | MEident mp -> mp
+  | MEapply (expr,_) -> mp_from_mexpr expr
+  | MEwith (expr,_) -> mp_from_mexpr expr
 
 let is_modular = function
   | SFBmodule _ | SFBmodtype _ -> true
   | SFBconst _ | SFBmind _ -> false
 
-let rec list_split_assoc ((k,m) as km) rev_before = function
-  | [] -> raise Not_found
-  | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after
-  | h::tail -> list_split_assoc km (h::rev_before) tail
+(** Split a [structure_body] at some label corresponding to
+    a modular definition or not. *)
 
-let discr_resolver env mtb =
-     match mtb.typ_expr with
-	SEBstruct _ -> 
-	  mtb.typ_delta
-      | _ -> (*case mp is a functor *)
-	  empty_delta_resolver
-	
-let rec rebuild_mp mp l =
-  match l with
-      []-> mp
-    | i::r -> rebuild_mp (MPdot(mp,i)) r 
-	
-let rec check_with env sign with_decl alg_sign mp equiv = 
-  let sign,wd,equiv,cst= match with_decl with
-    | With_Definition (idl,c) ->
-	let sign,cb,cst = check_with_def env sign (idl,c) mp equiv in
-	sign,With_definition_body(idl,cb),equiv,cst
-    | With_Module (idl,mp1) ->
-	let sign,equiv,cst = check_with_mod env sign (idl,mp1) mp equiv in
-	sign,With_module_body(idl,mp1),equiv,cst
-  in
-    if alg_sign = None then
-      sign,None,equiv,cst
-    else
-      sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst
-	    
-and check_with_def env sign (idl,c) mp equiv =
-  let sig_b = match sign with 
-    | SEBstruct(sig_b) -> sig_b
-    | _ -> error_signature_expected sign
-  in
-  let id,idl = match idl with
-    | [] -> assert false
-    | id::idl -> id,idl
-  in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in
-      let before = List.rev rev_before in
-      let env' = Modops.add_signature mp before equiv env in
-      if idl = [] then
-	      (* Toplevel definition *)
-	      let cb = match spec with
-		| SFBconst cb -> cb
-		| _ -> error_not_a_constant l
-	      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 *)
-	      let def,cst = match cb.const_body with
-		| Undef _ | OpaqueDef _ ->
-		    let (j,cst1) = Typeops.infer env' c in
-		    let typ = Typeops.type_of_constant_type env' cb.const_type in
-		    let cst2 = Reduction.conv_leq env' j.uj_type typ in
-		    let cst =
-		      union_constraints
-			(union_constraints cb.const_constraints cst1)
-			cst2
-		    in
-		    let def = Def (Declarations.from_val j.uj_val) in
-		    def,cst
-		| Def cs ->
-		    let cst1 = Reduction.conv env' c (Declarations.force cs) in
-		    let cst = union_constraints cb.const_constraints cst1 in
-		    let def = Def (Declarations.from_val c) in
-		    def,cst
-	      in
-	      let cb' =
-		{ cb with
-		  const_body = def;
-		  const_body_code =
-		    Cemitcodes.from_val (compile_constant_body env' def);
-		  const_constraints = cst }
-	      in
-	      SEBstruct(before@(l,SFBconst(cb'))::after),cb',cst
-      else
-	      (* Definition inside a sub-module *)
-	      let old = match spec with
-		| SFBmodule msb -> msb
-		| _ -> error_not_a_module (string_of_label l)
-	      in
-		begin
-		  match old.mod_expr with
-                    | None ->
-			let sign,cb,cst = 
-			  check_with_def env' old.mod_type (idl,c)
-			    (MPdot(mp,l)) old.mod_delta in
-			let new_spec = SFBmodule({old with
-						    mod_type = sign;
-						    mod_type_alg = None}) in
-			  SEBstruct(before@(l,new_spec)::after),cb,cst
-                    | Some msb ->
-			error_generative_module_expected l
-		end
-    with
-      | Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_incorrect_with_constraint l
+let split_struc k m struc =
+  let rec split rev_before = function
+    | [] -> raise Not_found
+    | (k',b)::after when Label.equal k k' && (is_modular b) == (m : bool) ->
+      List.rev rev_before,b,after
+    | h::tail -> split (h::rev_before) tail
+  in split [] struc
 
-and check_with_mod env sign (idl,mp1) mp equiv = 
-  let sig_b = match sign with 
-    | SEBstruct(sig_b) ->sig_b
-    | _ -> error_signature_expected sign
-  in
-  let id,idl = match idl with
-    | [] -> assert false
-    | id::idl -> id,idl
-  in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc (l,true) [] sig_b in
-      let before = List.rev rev_before in
-      let env' = Modops.add_signature mp before equiv env in
-      if idl = [] then
-	      (* Toplevel module definition *)
-	      let old = match spec with
-		  SFBmodule msb -> msb
-		| _ -> error_not_a_module (string_of_label l)
-	      in
-	      let mb_mp1 = (lookup_module mp1 env) in
-	      let mtb_mp1 = 
-		module_type_of_module None mb_mp1  in
-	      let cst =
-		match old.mod_expr with
-		    None ->
-		      begin
-			try union_constraints
-			  (check_subtypes env' mtb_mp1 
-			     (module_type_of_module None old))
-			  old.mod_constraints
-			with Failure _ -> error_incorrect_with_constraint (label_of_id id)
-		      end
-		  | Some (SEBident(mp')) ->
-		      check_modpath_equiv env' mp1 mp';
-		      old.mod_constraints
-		  | _ ->  error_generative_module_expected l
-	      in
-	      let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false
-	      in
-	      let new_spec = SFBmodule {new_mb with 
-					  mod_mp = MPdot(mp,l);
-					  mod_expr = Some (SEBident mp1);
-					  mod_constraints = cst} in
-		(* we propagate the new equality in the rest of the signature
-		   with the identity substitution accompagned by the new resolver*)
-	      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in
-		SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
-	      add_delta_resolver equiv new_mb.mod_delta,cst
-      else
-	      (* Module definition of a sub-module *)
-	      let old = match spec with
-		  SFBmodule msb -> msb
-		| _ -> error_not_a_module (string_of_label l)
-	      in
-	      begin
-		match old.mod_expr with
-		    None ->
-		      let sign,equiv',cst =
-			check_with_mod env'
-			  old.mod_type (idl,mp1) (MPdot(mp,l)) old.mod_delta in
-		      let new_equiv = add_delta_resolver equiv equiv' in
-		      let new_spec = SFBmodule {old with 
-						  mod_type = sign;
-						  mod_type_alg = None;
-						  mod_delta = equiv'}
-		      in
-		      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) equiv' in
-			SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
-		      new_equiv,cst
-		  | Some (SEBident(mp')) ->
-		      let mpnew = rebuild_mp mp' (List.map label_of_id idl) in
-			check_modpath_equiv env' mpnew mp;
-			  SEBstruct(before@(l,spec)::after)
-			    ,equiv,empty_constraint
-		  | _ ->
-		      error_generative_module_expected l
-              end
-    with
-	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_incorrect_with_constraint l
+let discr_resolver mtb = match mtb.mod_type with
+  | NoFunctor _ -> mtb.mod_delta
+  | MoreFunctor _ -> empty_delta_resolver
 
-and translate_module env mp inl me =
-  match me.mod_entry_expr, me.mod_entry_type with
-    | None, None ->
-	anomaly "Mod_typing.translate_module: empty type and expr in module entry"
-    | None, Some mte ->
-	let mtb = translate_module_type env mp inl mte in
-	  { mod_mp = mp;
-	    mod_expr = None;
-	    mod_type = mtb.typ_expr;
-	    mod_type_alg = mtb.typ_expr_alg;
-	    mod_delta = mtb.typ_delta;
-	    mod_constraints = mtb.typ_constraints; 
-	    mod_retroknowledge = []}
-   | Some mexpr, _ ->
-	let sign,alg_implem,resolver,cst1 =
-	  translate_struct_module_entry env mp inl mexpr in
-	let sign,alg1,resolver,cst2 =
-	  match me.mod_entry_type with
-	    | None ->
-		sign,None,resolver,empty_constraint
-	    | Some mte ->
-		let mtb = translate_module_type env mp inl mte in
-                let cst = check_subtypes env
-		  {typ_mp = mp;
-		   typ_expr = sign;
-		   typ_expr_alg = None;
-		   typ_constraints = empty_constraint;
-		   typ_delta = resolver;}
-		  mtb
-		in
-		  mtb.typ_expr,mtb.typ_expr_alg,mtb.typ_delta,cst
-	in
-	  { mod_mp = mp;
-	    mod_type = sign;
-	    mod_expr = alg_implem;
-	    mod_type_alg = alg1;
-	    mod_constraints = Univ.union_constraints cst1 cst2;
-	    mod_delta = resolver;
-	    mod_retroknowledge = []} 
-	    (* spiwack: not so sure about that. It may
-	       cause a bug when closing nested modules.
-	       If it does, I don't really know how to
-	       fix the bug.*)
+let rec rebuild_mp mp l =
+  match l with
+  | []-> mp
+  | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r
 
-and translate_apply env inl ftrans mexpr mkalg =
-  let sign,alg,resolver,cst1 = ftrans in
-  let farg_id, farg_b, fbody_b = destr_functor env sign in
-  let mp1 =
-    try path_of_mexpr mexpr
-    with Not_path -> error_application_to_not_path mexpr
-  in
-  let mtb = module_type_of_module None (lookup_module mp1 env) in
-  let cst2 = check_subtypes env mtb farg_b in
-  let mp_delta = discr_resolver env mtb in
-  let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
-  let subst = map_mbid farg_id mp1 mp_delta
-  in
-  subst_struct_expr subst fbody_b,
-  mkalg alg mp1 cst2,
-  subst_codom_delta_resolver subst resolver,
-  Univ.union_constraints cst1 cst2
+let (+++) = Univ.Constraint.union
 
-and translate_functor env inl arg_id arg_e trans mkalg =
-  let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
-  let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
-  let sign,alg,resolver,cst = trans env'
+let rec check_with_def env struc (idl,c) mp equiv =
+  let lab,idl = match idl with
+    | [] -> assert false
+    | id::idl -> Label.of_id id, idl
   in
-  SEBfunctor (arg_id, mtb, sign),
-  mkalg alg arg_id mtb,
-  resolver,
-  Univ.union_constraints cst mtb.typ_constraints
-
-and translate_struct_module_entry env mp inl = function
-  | MSEident mp1 ->
-      let mb = lookup_module mp1 env in
-      let mb' = strengthen_and_subst_mb mb mp false in
-      mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint
-  | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let trans env' = translate_struct_module_entry env' mp inl body_expr in
-      let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in
-      translate_functor env inl arg_id arg_e trans mkalg
-  | MSEapply (fexpr,mexpr) ->
-      let trans = translate_struct_module_entry env mp inl fexpr in
-      let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in
-      translate_apply env inl trans mexpr mkalg
-  | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,cst1 =
-	translate_struct_module_entry env mp inl mte in
-      let sign,alg,resolve,cst2 =
-	check_with env sign with_decl alg mp resolve in
-      sign,alg,resolve,Univ.union_constraints cst1 cst2
-
-and translate_struct_type_entry env inl = function
-  | MSEident mp1 ->
-      let mtb = lookup_modtype mp1 env in
-      mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint
-  | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let trans env' = translate_struct_type_entry env' inl body_expr in
-      translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None)
-  | MSEapply (fexpr,mexpr) ->
-      let trans = translate_struct_type_entry env inl fexpr in
-      translate_apply env inl trans mexpr (fun _ _ _ -> None)
-  | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in
-      let sign,alg,resolve,cst2 =
-	check_with env sign with_decl alg (mp_from_mexpr mte) resolve
+  try
+    let modular = not (List.is_empty idl) in
+    let before,spec,after = split_struc lab modular struc in
+    let env' = Modops.add_structure mp before equiv env in
+    if List.is_empty idl then
+      (* Toplevel definition *)
+      let cb = match spec with
+	| SFBconst cb -> cb
+	| _ -> error_not_a_constant lab
       in
-      sign,alg,resolve,Univ.union_constraints cst1 cst2
-
-and translate_module_type env mp inl mte =
-  let mp_from = mp_from_mexpr mte in
-  let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in
-  let mtb = subst_modtype_and_resolver
-    {typ_mp = mp_from;
-     typ_expr = sign;
-     typ_expr_alg = None;
-     typ_constraints = cst;
-     typ_delta = resolve} mp
-  in {mtb with typ_expr_alg = alg}
-
-let rec translate_struct_include_module_entry env mp inl = function
-  | MSEident mp1 ->
-      let mb = lookup_module mp1 env in
-      let mb' = strengthen_and_subst_mb mb mp true in
-      let mb_typ = clean_bounded_mod_expr mb'.mod_type in
-      mb_typ,None,mb'.mod_delta,Univ.empty_constraint
-  | MSEapply (fexpr,mexpr) ->
-      let ftrans = translate_struct_include_module_entry env mp inl fexpr in
-      translate_apply env inl ftrans mexpr (fun _ _ _ -> None)
-  | _ -> error ("You cannot Include a high-order structure.")
-
-let rec add_struct_expr_constraints env = function
-  | SEBident _ -> env
-
-  | SEBfunctor (_,mtb,meb) ->
-      add_struct_expr_constraints
-	(add_modtype_constraints env mtb) meb
-
-  | SEBstruct (structure_body) ->
-      List.fold_left
-        (fun env (_,item) -> add_struct_elem_constraints env item)
-        env
-        structure_body
-
-  | SEBapply (meb1,meb2,cst) ->
-      Environ.add_constraints cst
-        (add_struct_expr_constraints
-	  (add_struct_expr_constraints env meb1)
-	  meb2)
-  | SEBwith(meb,With_definition_body(_,cb))->
-      Environ.add_constraints cb.const_constraints
-	(add_struct_expr_constraints env meb)
-  | SEBwith(meb,With_module_body(_,_))->
-      add_struct_expr_constraints env meb
-		
-and add_struct_elem_constraints env = function 
-  | SFBconst cb -> Environ.add_constraints cb.const_constraints env
-  | SFBmind mib -> Environ.add_constraints mib.mind_constraints env
-  | SFBmodule mb -> add_module_constraints env mb
-  | SFBmodtype mtb -> add_modtype_constraints env mtb
-
-and add_module_constraints env mb =
-  let env = match mb.mod_expr with
-    | None -> env
-    | Some meb -> add_struct_expr_constraints env meb
-  in
-  let env =
-    add_struct_expr_constraints env mb.mod_type
+      (* In the spirit of subtyping.check_constant, we accept
+         any implementations of parameters and opaques terms,
+	 as long as they have the right type *)
+      let ccst = Declareops.constraints_of_constant (opaque_tables env) cb in
+      let env' = Environ.add_constraints ccst env' in
+      let c',cst = match cb.const_body with
+	| Undef _ | OpaqueDef _ ->
+	  let j = Typeops.infer env' c in
+	  let typ = Typeops.type_of_constant_type env' cb.const_type in
+	  let cst = Reduction.infer_conv_leq env' (Environ.universes env')
+	    j.uj_type typ in
+	  j.uj_val,cst
+	| Def cs ->
+	  let cst = Reduction.infer_conv env' (Environ.universes env') c
+	    (Mod_subst.force_constr cs) in
+	  let cst = (*FIXME MS: what to check here? subtyping of polymorphic constants... *)
+	    if cb.const_polymorphic then cst
+	    else ccst +++ cst 
+	  in
+            c, cst
+      in
+      let def = Def (Mod_subst.from_val c') in
+      let cb' =
+	{ cb with
+	  const_body = def;
+	  const_body_code = Cemitcodes.from_val (compile_constant_body env' def) }
+	  (* const_universes = Future.from_val cst } *)
+      in
+      before@(lab,SFBconst(cb'))::after, c', cst
+    else
+      (* Definition inside a sub-module *)
+      let mb = match spec with
+	| 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) (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
+  | Reduction.NotConvertible -> error_incorrect_with_constraint lab
+
+let rec check_with_mod env struc (idl,mp1) mp equiv =
+  let lab,idl = match idl with
+    | [] -> assert false
+    | id::idl -> Label.of_id id, idl
   in
-    Environ.add_constraints mb.mod_constraints env
-
-and add_modtype_constraints env mtb =
-  Environ.add_constraints mtb.typ_constraints
-    (add_struct_expr_constraints env mtb.typ_expr)
-
-
-let rec struct_expr_constraints cst = function
-  | SEBident _ -> cst
-
-  | SEBfunctor (_,mtb,meb) ->
-      struct_expr_constraints
-	(modtype_constraints cst mtb) meb
-
-  | SEBstruct (structure_body) ->
-      List.fold_left
-        (fun cst (_,item) -> struct_elem_constraints cst item)
-        cst
-        structure_body
-
-  | SEBapply (meb1,meb2,cst1) ->
-      struct_expr_constraints
-	(struct_expr_constraints (Univ.union_constraints cst1 cst) meb1)
-	meb2
-  | SEBwith(meb,With_definition_body(_,cb))->
-      struct_expr_constraints
-        (Univ.union_constraints cb.const_constraints cst) meb
-  | SEBwith(meb,With_module_body(_,_))->
-      struct_expr_constraints  cst meb	
-		
-and struct_elem_constraints cst = function 
-  | SFBconst cb -> cst
-  | SFBmind mib -> cst
-  | SFBmodule mb -> module_constraints cst mb
-  | SFBmodtype mtb -> modtype_constraints cst mtb
-
-and module_constraints cst mb =
-  let cst = match mb.mod_expr with
-    | None -> cst
-    | Some meb -> struct_expr_constraints cst meb in
-  let cst = 
-      struct_expr_constraints cst mb.mod_type in
-  Univ.union_constraints mb.mod_constraints cst
-
-and modtype_constraints cst mtb =
-  struct_expr_constraints  (Univ.union_constraints mtb.typ_constraints cst) mtb.typ_expr
-
-
-let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint
-let module_constraints = module_constraints Univ.empty_constraint
+  try
+    let before,spec,after = split_struc lab true struc in
+    let env' = Modops.add_structure mp before equiv env in
+    let old = match spec with
+      | SFBmodule mb -> mb
+      | _ -> error_not_a_module (Label.to_string lab)
+    in
+    if List.is_empty idl then
+      (* Toplevel module definition *)
+      let mb_mp1 = lookup_module mp1 env in
+      let mtb_mp1 = module_type_of_module mb_mp1 in
+      let cst = match old.mod_expr with
+	| Abstract ->
+	  begin
+            try
+              let mtb_old = module_type_of_module old in
+              Subtyping.check_subtypes env' mtb_mp1 mtb_old
+                +++ old.mod_constraints
+	    with Failure _ -> error_incorrect_with_constraint lab
+	  end
+	| Algebraic (NoFunctor (MEident(mp'))) ->
+	  check_modpath_equiv env' mp1 mp';
+	  old.mod_constraints
+	| _ -> error_generative_module_expected lab
+      in
+      let mp' = MPdot (mp,lab) in
+      let new_mb = strengthen_and_subst_mb mb_mp1 mp' false in
+      let new_mb' =
+        { new_mb with
+          mod_mp = mp';
+          mod_expr = Algebraic (NoFunctor (MEident mp1));
+          mod_constraints = cst }
+      in
+      let new_equiv = add_delta_resolver equiv new_mb.mod_delta in
+      (* we propagate the new equality in the rest of the signature
+	 with the identity substitution accompagned by the new resolver*)
+      let id_subst = map_mp mp' mp' new_mb.mod_delta in
+      let new_after = subst_structure id_subst after in
+      before@(lab,SFBmodule new_mb')::new_after, new_equiv, cst
+    else
+      (* Module definition of a sub-module *)
+      let mp' = MPdot (mp,lab) in
+      let old = match spec with
+        | SFBmodule msb -> msb
+	| _ -> error_not_a_module (Label.to_string lab)
+      in
+      begin match old.mod_expr with
+      | Abstract ->
+        let struc = destr_nofunctor old.mod_type in
+	let struc',equiv',cst =
+          check_with_mod env' struc (idl,mp1) mp' old.mod_delta
+        in
+	let new_mb =
+          { old with
+            mod_type = NoFunctor struc';
+            mod_type_alg = None;
+            mod_delta = equiv' }
+        in
+	let new_equiv = add_delta_resolver equiv equiv' in
+	let id_subst = map_mp mp' mp' equiv' in
+        let new_after = subst_structure id_subst after in
+	before@(lab,SFBmodule new_mb)::new_after, new_equiv, cst
+      | Algebraic (NoFunctor (MEident mp0)) ->
+	let mpnew = rebuild_mp mp0 idl in
+	check_modpath_equiv env' mpnew mp;
+	before@(lab,spec)::after, equiv, Univ.Constraint.empty
+      | _ -> error_generative_module_expected lab
+      end
+  with
+  | Not_found -> error_no_such_label lab
+  | Reduction.NotConvertible -> error_incorrect_with_constraint lab
+
+let mk_alg_with alg wd = Option.map (fun a -> MEwith (a,wd)) alg
+
+let check_with env mp (sign,alg,reso,cst) = function
+  |WithDef(idl,c) ->
+    let struc = destr_nofunctor sign in
+    let struc',c',cst' = check_with_def env struc (idl,c) mp reso in
+    let alg' = mk_alg_with alg (WithDef (idl,c')) in
+    (NoFunctor struc'),alg',reso, cst+++cst'
+  |WithMod(idl,mp1) as wd ->
+    let struc = destr_nofunctor sign in
+    let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in
+    let alg' = mk_alg_with alg wd in
+    (NoFunctor struc'),alg',reso', cst+++cst'
+
+let mk_alg_app mpo alg arg = match mpo, alg with
+  | Some _, Some alg -> Some (MEapply (alg,arg))
+  | _ -> None
+
+(** Translation of a module struct entry :
+    - We translate to a module when a [module_path] is given,
+      otherwise to a module type.
+    - The first output is the expanded signature
+    - The second output is the algebraic expression, kept for the extraction.
+      It is never None when translating to a module, but for module type
+      it could not be contain [SEBapply] or [SEBfunctor].
+*)
+
+let rec translate_mse env mpo inl = function
+  |MEident mp1 ->
+    let sign,reso = match mpo with
+      |Some mp ->
+        let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp false in
+        mb.mod_type, mb.mod_delta
+      |None ->
+        let mtb = lookup_modtype mp1 env in
+        mtb.mod_type, mtb.mod_delta
+    in
+    sign,Some (MEident mp1),reso,Univ.Constraint.empty
+  |MEapply (fe,mp1) ->
+    translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo)
+  |MEwith(me, with_decl) ->
+    assert (mpo == None); (* No 'with' syntax for modules *)
+    let mp = mp_from_mexpr me in
+    check_with env mp (translate_mse env None inl me) with_decl
+
+and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg =
+  let farg_id, farg_b, fbody_b = destr_functor sign in
+  let mtb = module_type_of_module (lookup_module mp1 env) in
+  let cst2 = Subtyping.check_subtypes env mtb farg_b in
+  let mp_delta = discr_resolver mtb in
+  let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
+  let subst = map_mbid farg_id mp1 mp_delta in
+  let body = subst_signature subst fbody_b in
+  let alg' = mkalg alg mp1 in
+  let reso' = subst_codom_delta_resolver subst reso in
+  body,alg',reso', cst1 +++ cst2
+
+let mk_alg_funct mpo mbid mtb alg = match mpo, alg with
+  | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg))
+  | _ -> None
+
+let mk_mod mp e ty ty' cst reso =
+  { mod_mp = mp;
+    mod_expr = e;
+    mod_type = ty;
+    mod_type_alg = ty';
+    mod_constraints = cst;
+    mod_delta = reso;
+    mod_retroknowledge = [] }
+
+let mk_modtype mp ty cst reso = mk_mod mp Abstract ty None cst reso
+
+let rec translate_mse_funct env mpo inl mse = function
+  |[] ->
+    let sign,alg,reso,cst = translate_mse env mpo inl mse in
+    sign, Option.map (fun a -> NoFunctor a) alg, reso, cst
+  |(mbid, ty) :: params ->
+    let mp_id = MPbound mbid in
+    let mtb = translate_modtype env mp_id inl ([],ty) in
+    let env' = add_module_type mp_id mtb env in
+    let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in
+    let alg' = mk_alg_funct mpo mbid mtb alg in
+    MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints
+
+and translate_modtype env mp inl (params,mte) =
+  let sign,alg,reso,cst = translate_mse_funct env None inl mte params in
+  let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in
+  let mtb' = subst_modtype_and_resolver mtb mp in
+  { mtb' with mod_type_alg = alg }
+
+(** [finalize_module] :
+    from an already-translated (or interactive) implementation
+    and a signature entry, produce a final [module_expr] *)
+
+let finalize_module env mp (sign,alg,reso,cst) restype = match restype with
+  |None ->
+    let impl = match alg with Some e -> Algebraic e | None -> FullStruct in
+    mk_mod mp impl sign None cst reso
+  |Some (params_mte,inl) ->
+    let res_mtb = translate_modtype env mp inl params_mte in
+    let auto_mtb = mk_modtype mp sign Univ.Constraint.empty reso in
+    let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in
+    let impl = match alg with Some e -> Algebraic e | None -> Struct sign in
+    { res_mtb with
+      mod_mp = mp;
+      mod_expr = impl;
+      mod_constraints = cst +++ cst' }
+
+let translate_module env mp inl = function
+  |MType (params,ty) ->
+    let mtb = translate_modtype env mp inl (params,ty) in
+    module_body_of_type mp mtb
+  |MExpr (params,mse,oty) ->
+    let t = translate_mse_funct env (Some mp) inl mse params in
+    let restype = Option.map (fun ty -> ((params,ty),inl)) oty in
+    finalize_module env mp t restype
+
+let rec translate_mse_incl env mp inl = function
+  |MEident mp1 ->
+    let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in
+    let sign = clean_bounded_mod_expr mb.mod_type in
+    sign,None,mb.mod_delta,Univ.Constraint.empty
+  |MEapply (fe,arg) ->
+    let ftrans = translate_mse_incl env mp inl fe in
+    translate_apply env inl ftrans arg (fun _ _ -> None)
+  |_ -> Modops.error_higher_order_include ()
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index e868aec2..b39e8212 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,40 +12,35 @@ open Entries
 open Mod_subst
 open Names
 
+(** Main functions for translating module entries *)
 
 val translate_module :
   env -> module_path -> inline -> module_entry -> module_body
 
-val translate_module_type :
-  env -> module_path -> inline -> module_struct_entry -> module_type_body
+val translate_modtype :
+  env -> module_path -> inline -> module_type_entry -> module_type_body
 
-val translate_struct_module_entry :
-  env -> module_path -> inline -> module_struct_entry ->
-  struct_expr_body (* Signature *)
-  * struct_expr_body option  (* Algebraic expr, in fact never None *)
-  * delta_resolver
-  * Univ.constraints
-
-val translate_struct_type_entry :
-  env -> inline -> module_struct_entry ->
-  struct_expr_body
-  * struct_expr_body option
-  * delta_resolver
-  * Univ.constraints
-
-val translate_struct_include_module_entry :
-  env -> module_path -> inline -> module_struct_entry ->
-  struct_expr_body
-  * struct_expr_body option (* Algebraic expr, always None *)
-  * delta_resolver
-  * Univ.constraints
+(** Low-level function for translating a module struct entry :
+    - We translate to a module when a [module_path] is given,
+      otherwise to a module type.
+    - The first output is the expanded signature
+    - The second output is the algebraic expression, kept for the extraction.
+      It is never None when translating to a module, but for module type
+      it could not be contain applications or functors.
+*)
 
-val add_modtype_constraints : env -> module_type_body -> env
+type 'alg translation =
+  module_signature * 'alg option * delta_resolver * Univ.constraints
 
-val add_module_constraints : env -> module_body -> env
+val translate_mse :
+  env -> module_path option -> inline -> module_struct_entry ->
+    module_alg_expr translation
 
-val add_struct_expr_constraints : env -> struct_expr_body -> env
-
-val struct_expr_constraints : struct_expr_body -> Univ.constraints
+val translate_mse_incl :
+  env -> module_path -> inline -> module_struct_entry ->
+    module_alg_expr translation
 
-val module_constraints : module_body -> Univ.constraints
+val finalize_module :
+  env -> module_path -> module_expression translation ->
+  (module_type_entry * inline) option ->
+  module_body
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 3a914477..392e667b 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,53 +16,58 @@
 (* This file provides with various operations on modules and module types *)
 
 open Util
-open Pp
 open Names
-open Univ
 open Term
 open Declarations
+open Declareops
 open Environ
 open Entries
 open Mod_subst
 
+(** {6 Errors } *)
+
 type signature_mismatch_error =
   | InductiveFieldExpected of mutual_inductive_body
   | DefinitionFieldExpected
   | ModuleFieldExpected
   | ModuleTypeFieldExpected
-  | NotConvertibleInductiveField of identifier
-  | NotConvertibleConstructorField of identifier
+  | NotConvertibleInductiveField of Id.t
+  | NotConvertibleConstructorField of Id.t
   | NotConvertibleBodyField
   | NotConvertibleTypeField of env * types * types
+  | PolymorphicStatusExpected of bool
   | NotSameConstructorNamesField
   | NotSameInductiveNameInBlockField
   | FiniteInductiveFieldExpected of bool
   | InductiveNumbersFieldExpected of int
   | InductiveParamsNumberField of int
   | RecordFieldExpected of bool
-  | RecordProjectionsExpected of name list
+  | RecordProjectionsExpected of Name.t list
   | NotEqualInductiveAliases
   | NoTypeConstraintExpected
+  | IncompatibleInstances
+  | IncompatibleUniverses of Univ.univ_inconsistency
+  | IncompatiblePolymorphism of env * types * types
+  | IncompatibleConstraints of Univ.constraints
 
 type module_typing_error =
-  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
-  | LabelAlreadyDeclared of label
+  | SignatureMismatch of
+      Label.t * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of Label.t
   | ApplicationToNotPath of module_struct_entry
-  | NotAFunctor of struct_expr_body
+  | NotAFunctor
+  | IsAFunctor
   | IncompatibleModuleTypes of module_type_body * module_type_body
   | NotEqualModulePaths of module_path * module_path
-  | NoSuchLabel of label
-  | IncompatibleLabels of label * label
-  | SignatureExpected of struct_expr_body
-  | NoModuleToEnd
-  | NoModuleTypeToEnd
+  | NoSuchLabel of Label.t
+  | IncompatibleLabels of Label.t * Label.t
   | NotAModule of string
   | NotAModuleType of string
-  | NotAConstant of label
-  | IncorrectWithConstraint of label
-  | GenerativeModuleExpected of label
-  | NonEmptyLocalContect of label option
-  | LabelMissing of label * string
+  | NotAConstant of Label.t
+  | IncorrectWithConstraint of Label.t
+  | GenerativeModuleExpected of Label.t
+  | LabelMissing of Label.t * string
+  | HigherOrderInclude
 
 exception ModuleTypingError of module_typing_error
 
@@ -72,8 +77,11 @@ let error_existing_label l =
 let error_application_to_not_path mexpr =
   raise (ModuleTypingError (ApplicationToNotPath mexpr))
 
-let error_not_a_functor mtb =
-  raise (ModuleTypingError (NotAFunctor mtb))
+let error_not_a_functor () =
+  raise (ModuleTypingError NotAFunctor)
+
+let error_is_a_functor () =
+  raise (ModuleTypingError IsAFunctor)
 
 let error_incompatible_modtypes mexpr1 mexpr2 =
   raise (ModuleTypingError (IncompatibleModuleTypes (mexpr1,mexpr2)))
@@ -90,18 +98,6 @@ let error_no_such_label l =
 let error_incompatible_labels l l' =
   raise (ModuleTypingError (IncompatibleLabels (l,l')))
 
-let error_signature_expected mtb =
-  raise (ModuleTypingError (SignatureExpected mtb))
-
-let error_no_module_to_end _ =
-  raise (ModuleTypingError NoModuleToEnd)
-
-let error_no_modtype_to_end _ =
-  raise (ModuleTypingError NoModuleTypeToEnd)
-
-let error_not_a_modtype s =
-  raise (ModuleTypingError (NotAModuleType s))
-
 let error_not_a_module s =
   raise (ModuleTypingError (NotAModule s))
 
@@ -114,141 +110,165 @@ let error_incorrect_with_constraint l =
 let error_generative_module_expected l =
   raise (ModuleTypingError (GenerativeModuleExpected l))
 
-let error_non_empty_local_context lo =
-  raise (ModuleTypingError (NonEmptyLocalContect lo))
-
 let error_no_such_label_sub l l1 =
   raise (ModuleTypingError (LabelMissing (l,l1)))
 
-(************************)
+let error_higher_order_include () =
+  raise (ModuleTypingError HigherOrderInclude)
 
-let destr_functor env mtb =
-  match mtb with
-  | SEBfunctor (arg_id,arg_t,body_t) ->
-      	    (arg_id,arg_t,body_t)
-  | _ -> error_not_a_functor mtb
+(** {6 Operations on functors } *)
 
 let is_functor = function
- | SEBfunctor (arg_id,arg_t,body_t) -> true
- | _ -> false
-
-let module_body_of_type mp mtb = 
-  { mod_mp = mp;
-    mod_type = mtb.typ_expr;
-    mod_type_alg = mtb.typ_expr_alg;
-    mod_expr = None;
-    mod_constraints = mtb.typ_constraints;
-    mod_delta = mtb.typ_delta;
-    mod_retroknowledge = []}
-
-let check_modpath_equiv env mp1 mp2 = 
-  if mp1=mp2 then () else
-    let mb1=lookup_module  mp1 env in
-    let mb2=lookup_module mp2 env in
-      if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2)
-      then ()
-      else error_not_equal_modpaths mp1 mp2
-	
-let rec subst_with_body sub = function
-  | With_module_body(id,mp) ->
-      With_module_body(id,subst_mp sub mp)
-  | With_definition_body(id,cb) ->
-      With_definition_body( id,subst_const_body sub cb)
-
-and subst_modtype sub do_delta mtb=
-  let mp = subst_mp sub mtb.typ_mp in
-  let sub = add_mp mtb.typ_mp mp empty_delta_resolver sub in
-  let typ_expr' = subst_struct_expr sub do_delta mtb.typ_expr in
-  let typ_alg' = 
-    Option.smartmap 
-      (subst_struct_expr sub (fun x y-> x)) mtb.typ_expr_alg in
-  let mtb_delta = do_delta mtb.typ_delta sub in
-    if typ_expr'==mtb.typ_expr && 
-      typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then
-	mtb
-    else
-      {mtb with 
-	 typ_mp = mp;
-	 typ_expr = typ_expr';
-	 typ_expr_alg = typ_alg';
-	 typ_delta = mtb_delta}
-	
-and subst_structure sub do_delta sign = 
-  let subst_body = function
-      SFBconst cb -> 
-	SFBconst (subst_const_body sub cb)
-    | SFBmind mib -> 
-	SFBmind (subst_mind sub mib)
-    | SFBmodule mb -> 
-	SFBmodule (subst_module sub do_delta mb)
-    | SFBmodtype mtb -> 
-	SFBmodtype (subst_modtype sub do_delta mtb)
+  |NoFunctor _ -> false
+  |MoreFunctor _ -> true
+
+let destr_functor = function
+  |NoFunctor _ -> error_not_a_functor ()
+  |MoreFunctor (mbid,ty,x) -> (mbid,ty,x)
+
+let destr_nofunctor = function
+  |NoFunctor a -> a
+  |MoreFunctor _ -> error_is_a_functor ()
+
+let rec functor_smartmap fty f0 funct = match funct with
+  |MoreFunctor (mbid,ty,e) ->
+    let ty' = fty ty in
+    let e' = functor_smartmap fty f0 e in
+    if ty==ty' && e==e' then funct else MoreFunctor (mbid,ty',e')
+  |NoFunctor a ->
+    let a' = f0 a in if a==a' then funct else NoFunctor a'
+
+let rec functor_iter fty f0 = function
+  |MoreFunctor (mbid,ty,e) -> fty ty; functor_iter fty f0 e
+  |NoFunctor a -> f0 a
+
+(** {6 Misc operations } *)
+
+let module_type_of_module mb =
+  { mb with mod_expr = Abstract; mod_type_alg = None }
+
+let module_body_of_type mp mtb =
+  assert (mtb.mod_expr == Abstract);
+  { mtb with mod_mp = mp }
+
+let check_modpath_equiv env mp1 mp2 =
+  if ModPath.equal mp1 mp2 then ()
+  else
+    let mp1' = mp_of_delta (lookup_module mp1 env).mod_delta mp1 in
+    let mp2' = mp_of_delta (lookup_module mp2 env).mod_delta mp2 in
+    if ModPath.equal mp1' mp2' then ()
+    else error_not_equal_modpaths mp1 mp2
+
+let implem_smartmap fs fa impl = match impl with
+  |Struct e -> let e' = fs e in if e==e' then impl else Struct e'
+  |Algebraic a -> let a' = fa a in if a==a' then impl else Algebraic a'
+  |Abstract|FullStruct -> impl
+
+let implem_iter fs fa impl = match impl with
+  |Struct e -> fs e
+  |Algebraic a -> fa a
+  |Abstract|FullStruct -> ()
+
+(** {6 Substitutions of modular structures } *)
+
+let id_delta x y = x
+
+let subst_with_body sub = function
+  |WithMod(id,mp) as orig ->
+    let mp' = subst_mp sub mp in
+    if mp==mp' then orig else WithMod(id,mp')
+  |WithDef(id,c) as orig ->
+    let c' = subst_mps sub c in
+    if c==c' then orig else WithDef(id,c')
+
+let rec subst_structure sub do_delta sign =
+  let subst_body ((l,body) as orig) = match body with
+    |SFBconst cb ->
+      let cb' = subst_const_body sub cb in
+      if cb==cb' then orig else (l,SFBconst cb')
+    |SFBmind mib ->
+      let mib' = subst_mind_body sub mib in
+      if mib==mib' then orig else (l,SFBmind mib')
+    |SFBmodule mb ->
+      let mb' = subst_module sub do_delta mb in
+      if mb==mb' then orig else (l,SFBmodule mb')
+    |SFBmodtype mtb ->
+      let mtb' = subst_modtype sub do_delta mtb in
+      if mtb==mtb' then orig else (l,SFBmodtype mtb')
   in
-    List.map (fun (l,b) -> (l,subst_body b)) sign
-
-and subst_module sub do_delta mb =
-  let mp = subst_mp sub mb.mod_mp in
-  let sub = if is_functor mb.mod_type && not(mp=mb.mod_mp) then
-    add_mp mb.mod_mp mp
-      empty_delta_resolver sub else sub in 
-  let id_delta = (fun x y-> x) in
-  let mtb',me' = 
-    let mtb = subst_struct_expr sub do_delta mb.mod_type in 
-      match mb.mod_expr with
-	  None -> mtb,None
-	| Some me -> if me==mb.mod_type then
-	    mtb,Some mtb
-	  else mtb,Option.smartmap 
-	    (subst_struct_expr sub id_delta) mb.mod_expr
+  List.smartmap subst_body sign
+
+and subst_body is_mod sub do_delta mb =
+  let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in
+  let mp' = subst_mp sub mp in
+  let sub =
+    if ModPath.equal mp mp' then sub
+    else if is_mod && not (is_functor ty) then sub
+    else add_mp mp mp' empty_delta_resolver sub
   in
-  let typ_alg' = Option.smartmap 
-    (subst_struct_expr sub id_delta) mb.mod_type_alg in
-  let mb_delta = do_delta mb.mod_delta sub in
-    if mtb'==mb.mod_type && mb.mod_expr == me' 
-      && mb_delta == mb.mod_delta && mp == mb.mod_mp
-    then mb else
-      { mb with
-	  mod_mp = mp;
-	  mod_expr = me';
-	  mod_type_alg = typ_alg';
-	  mod_type=mtb'; 
-	  mod_delta = mb_delta}
-
-and subst_struct_expr sub do_delta = function
-    | SEBident mp -> SEBident (subst_mp sub mp)
-    | SEBfunctor (mbid, mtb, meb') -> 
-	SEBfunctor(mbid,subst_modtype sub do_delta mtb
-		     ,subst_struct_expr sub do_delta meb')
-    | SEBstruct (str)->
-	SEBstruct( subst_structure sub do_delta str)
-    | SEBapply (meb1,meb2,cst)->
-	SEBapply(subst_struct_expr sub do_delta meb1,
-		 subst_struct_expr sub do_delta meb2,
-		 cst)
-    | SEBwith (meb,wdb)-> 
-	SEBwith(subst_struct_expr sub do_delta meb,
-		subst_with_body sub wdb)
-
-let subst_signature subst =
-  subst_structure subst 
-    (fun resolver subst-> subst_codom_delta_resolver subst resolver)
-
-let subst_struct_expr subst = 
-  subst_struct_expr subst
-    (fun resolver subst-> subst_codom_delta_resolver subst resolver)
-
-(* spiwack: here comes the function which takes care of importing 
+  let ty' = subst_signature sub do_delta ty in
+  let me' =
+    implem_smartmap
+      (subst_signature sub id_delta) (subst_expression sub id_delta) me
+  in
+  let aty' = Option.smartmap (subst_expression sub id_delta) aty in
+  let delta' = do_delta mb.mod_delta sub in
+  if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta
+  then mb
+  else
+    { mb with
+      mod_mp = mp';
+      mod_expr = me';
+      mod_type = ty';
+      mod_type_alg = aty';
+      mod_delta = delta' }
+
+and subst_module sub do_delta mb = subst_body true sub do_delta mb
+
+and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb
+
+and subst_expr sub do_delta seb = match seb with
+  |MEident mp ->
+    let mp' = subst_mp sub mp in
+    if mp==mp' then seb else MEident mp'
+  |MEapply (meb1,mp2) ->
+    let meb1' = subst_expr sub do_delta meb1 in
+    let mp2' = subst_mp sub mp2 in
+    if meb1==meb1' && mp2==mp2' then seb else MEapply(meb1',mp2')
+  |MEwith (meb,wdb) ->
+    let meb' = subst_expr sub do_delta meb in
+    let wdb' = subst_with_body sub wdb in
+    if meb==meb' && wdb==wdb' then seb else MEwith(meb',wdb')
+
+and subst_expression sub do_delta =
+  functor_smartmap
+    (subst_modtype sub do_delta)
+    (subst_expr sub do_delta)
+
+and subst_signature sub do_delta =
+  functor_smartmap
+    (subst_modtype sub do_delta)
+    (subst_structure sub do_delta)
+
+let do_delta_dom reso sub = subst_dom_delta_resolver sub reso
+let do_delta_codom reso sub = subst_codom_delta_resolver sub reso
+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 mp =
-  let perform rkaction env =
-    match rkaction with
-      | Retroknowledge.RKRegister (f, e) ->
-	  Environ.register env f 
-	  (match e with 
-	    | Const kn -> kind_of_term (mkConst kn)
-	    | Ind ind -> kind_of_term (mkInd ind)
-	    | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term")
+  let perform rkaction env = match rkaction with
+    |Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) ->
+      Environ.register env f e
+    |_ ->
+      Errors.anomaly ~label:"Modops.add_retroknowledge"
+        (Pp.str "had to import an unsupported kind of term")
   in
   fun lclrk env ->
   (* The order of the declaration matters, for instance (and it's at the
@@ -256,120 +276,117 @@ let add_retroknowledge mp =
      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 
+     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
 
-let rec add_signature mp sign resolver env = 
-  let add_one env (l,elem) =
-    let kn = make_kn mp empty_dirpath l in
-    match elem with
-      | SFBconst cb ->
-	Environ.add_constant (constant_of_delta_kn resolver kn) cb env
-      | SFBmind mib ->
-	Environ.add_mind (mind_of_delta_kn resolver kn) mib env
-      | SFBmodule mb -> add_module mb env (* adds components as well *)
-      | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
+(** {6 Adding a module in the environment } *)
+
+let rec add_structure mp sign resolver linkinfo env =
+  let add_one env (l,elem) = match elem with
+    |SFBconst cb ->
+      let c = constant_of_delta_kn resolver (KerName.make2 mp l) in
+      Environ.add_constant_key c cb linkinfo env
+    |SFBmind mib ->
+      let mind = mind_of_delta_kn resolver (KerName.make2 mp l) in
+      let mib = 
+	if mib.mind_private != None then 
+	  { mib with mind_private = Some true }
+	else mib
+      in
+      Environ.add_mind_key mind (mib,ref linkinfo) env
+    |SFBmodule mb -> add_module mb linkinfo env (* adds components as well *)
+    |SFBmodtype mtb -> Environ.add_modtype mtb env
   in
-    List.fold_left add_one env sign
+  List.fold_left add_one env sign
 
-and add_module mb env = 
+and add_module mb linkinfo env =
   let mp = mb.mod_mp in
-  let env = Environ.shallow_add_module mp mb env in
-    match mb.mod_type with
-      | SEBstruct (sign) -> 
-	  add_retroknowledge mp mb.mod_retroknowledge 
-	    (add_signature mp sign mb.mod_delta env)
-      | SEBfunctor _ -> env
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
+  let env = Environ.shallow_add_module mb env in
+  match mb.mod_type with
+  |NoFunctor struc ->
+    add_retroknowledge mp mb.mod_retroknowledge
+      (add_structure mp struc mb.mod_delta linkinfo env)
+  |MoreFunctor _ -> env
+
+let add_linked_module mb linkinfo env =
+  add_module mb linkinfo env
+
+let add_structure mp sign resolver env =
+  add_structure mp sign resolver no_link_info env
+
+let add_module mb env =
+  add_module mb no_link_info env
+
+let add_module_type mp mtb env =
+  add_module (module_body_of_type mp mtb) env
+
+(** {6 Strengtening } *)
 
 let strengthen_const mp_from l cb resolver =
   match cb.const_body with
-    | Def _ -> cb
-    | _ ->
-      let kn = make_kn mp_from empty_dirpath l in
-      let con = constant_of_delta_kn resolver kn in
+  |Def _ -> cb
+  |_ ->
+    let kn = KerName.make2 mp_from l in
+    let con = constant_of_delta_kn resolver kn in
+    let u = 
+      if cb.const_polymorphic then 
+	Univ.UContext.instance cb.const_universes
+      else Univ.Instance.empty
+    in
       { cb with
-	const_body = Def (Declarations.from_val (mkConst con));
-	const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con)
-      }
+	const_body = Def (Mod_subst.from_val (mkConstU (con,u)));
+	const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias (con,u)) }
 
 let rec strengthen_mod mp_from mp_to mb =
-  if mp_in_delta mb.mod_mp mb.mod_delta then
-    mb
-  else
-    match mb.mod_type with
-     | SEBstruct (sign) ->
-	 let resolve_out,sign_out =
-	   strengthen_sig mp_from sign mp_to mb.mod_delta in
-	   { mb with
-	       mod_expr = Some (SEBident mp_to);
-	       mod_type = SEBstruct(sign_out);
-	       mod_type_alg = mb.mod_type_alg;
-	       mod_constraints = mb.mod_constraints;
-	       mod_delta = add_mp_delta_resolver mp_from mp_to
-	       (add_delta_resolver mb.mod_delta resolve_out);
-	       mod_retroknowledge = mb.mod_retroknowledge}
-     | SEBfunctor _ -> mb
-     | _ -> anomaly "Modops:the evaluation of the structure failed "
-
-and strengthen_sig mp_from sign mp_to resolver =
-  match sign with
-    | [] -> empty_delta_resolver,[]
-    | (l,SFBconst cb) :: rest ->
-	let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item'::rest'
-    | (_,SFBmind _ as item):: rest ->
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item::rest'
-    | (l,SFBmodule mb) :: rest ->
-	let mp_from' = MPdot (mp_from,l) in
-	let mp_to' = MPdot(mp_to,l) in
-	let mb_out = strengthen_mod mp_from' mp_to' mb in
-	let item' = l,SFBmodule (mb_out) in
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	add_delta_resolver resolve_out mb.mod_delta, item':: rest'
-    | (l,SFBmodtype mty as item) :: rest ->
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item::rest'
+  if mp_in_delta mb.mod_mp mb.mod_delta then mb
+  else match mb.mod_type with
+  |NoFunctor struc ->
+    let reso,struc' = strengthen_sig mp_from struc mp_to mb.mod_delta in
+    { mb with
+      mod_expr = Algebraic (NoFunctor (MEident mp_to));
+      mod_type = NoFunctor struc';
+      mod_delta =
+        add_mp_delta_resolver mp_from mp_to
+	  (add_delta_resolver mb.mod_delta reso) }
+  |MoreFunctor _ -> mb
+
+and strengthen_sig mp_from struc mp_to reso = match struc with
+  |[] -> empty_delta_resolver,[]
+  |(l,SFBconst cb) :: rest ->
+    let item' = l,SFBconst (strengthen_const mp_from l cb reso) in
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    reso',item'::rest'
+  |(_,SFBmind _ as item):: rest ->
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    reso',item::rest'
+  |(l,SFBmodule mb) :: rest ->
+    let mp_from' = MPdot (mp_from,l) in
+    let mp_to' = MPdot(mp_to,l) in
+    let mb' = strengthen_mod mp_from' mp_to' mb in
+    let item' = l,SFBmodule mb' in
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    add_delta_resolver reso' mb.mod_delta, item':: rest'
+  |(l,SFBmodtype mty as item) :: rest ->
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    reso',item::rest'
 
 let strengthen mtb mp =
-  if mp_in_delta mtb.typ_mp mtb.typ_delta then
-    (* in this case mtb has already been strengthened*)
-    mtb
-  else
-    match mtb.typ_expr with
-      | SEBstruct (sign) ->
-	  let resolve_out,sign_out =
-	    strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in
-	    {mtb with
-	       typ_expr = SEBstruct(sign_out);
-	       typ_delta = add_delta_resolver mtb.typ_delta
-		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)}
-      | SEBfunctor _ -> mtb
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
-
-let module_type_of_module mp mb =
-  match mp with
-      Some mp ->
-	strengthen {
-	  typ_mp = mp;
-	  typ_expr = mb.mod_type;
-	  typ_expr_alg = None;
-	  typ_constraints = mb.mod_constraints;
-	  typ_delta = mb.mod_delta} mp
-
-    | None ->
-	{typ_mp = mb.mod_mp;
-	 typ_expr = mb.mod_type;
-	 typ_expr_alg = None;
-	 typ_constraints = mb.mod_constraints;
-	 typ_delta = mb.mod_delta}
+  (* Has mtb already been strengthened ? *)
+  if mp_in_delta mtb.mod_mp mtb.mod_delta then mtb
+  else match mtb.mod_type with
+  |NoFunctor struc ->
+    let reso',struc' = strengthen_sig mtb.mod_mp struc mp mtb.mod_delta in
+    { mtb with
+      mod_type = NoFunctor struc';
+      mod_delta =
+        add_delta_resolver mtb.mod_delta
+	  (add_mp_delta_resolver mtb.mod_mp mp reso') }
+  |MoreFunctor _ -> mtb
 
 let inline_delta_resolver env inl mp mbid mtb delta =
-  let constants = inline_of_delta inl mtb.typ_delta in
+  let constants = inline_of_delta inl mtb.mod_delta in
   let rec make_inline delta = function
     | [] -> delta
     | (lev,kn)::r ->
@@ -381,7 +398,7 @@ let inline_delta_resolver env inl mp mbid mtb delta =
 	  match constant.const_body with
 	    | Undef _ | OpaqueDef _ -> l
 	    | Def body ->
-	      let constr = Declarations.force body in
+	      let constr = Mod_subst.force_constr body in
 	      add_inline_delta_resolver kn (lev, Some constr) l
 	with Not_found ->
 	  error_no_such_label_sub (con_label con)
@@ -389,198 +406,209 @@ let inline_delta_resolver env inl mp mbid mtb delta =
   in
   make_inline delta constants
 
-let rec strengthen_and_subst_mod
-    mb subst mp_from mp_to resolver =
-     match mb.mod_type with
-	 SEBstruct(str) ->
-	   let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
-	   if mb_is_an_alias then 
-	     subst_module subst 
-	       (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb 
-	   else
-	     let resolver,new_sig = 
-	       strengthen_and_subst_struct str subst
-		 mp_from mp_from mp_to false false mb.mod_delta 
-	     in
-	       {mb with 
-		  mod_mp = mp_to;
-		  mod_expr = Some (SEBident mp_from);
-		  mod_type = SEBstruct(new_sig);
-		  mod_delta = add_mp_delta_resolver mp_to mp_from resolver}
-       | SEBfunctor(arg_id,arg_b,body) ->
-	   let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in
-	   subst_module subst 
-	     (fun resolver subst-> subst_dom_codom_delta_resolver subst resolver) mb  
-	
-       | _ -> anomaly "Modops:the evaluation of the structure failed "
-	   
-and strengthen_and_subst_struct 
-    str subst mp_alias mp_from mp_to alias incl resolver =
+let rec strengthen_and_subst_mod mb subst mp_from mp_to =
+  match mb.mod_type with
+  |NoFunctor struc ->
+    let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
+    if mb_is_an_alias then subst_module subst do_delta_dom mb
+    else
+      let reso',struc' =
+	strengthen_and_subst_struct struc subst
+	  mp_from mp_to false false mb.mod_delta
+      in
+      { mb with
+	mod_mp = mp_to;
+	mod_expr = Algebraic (NoFunctor (MEident mp_from));
+	mod_type = NoFunctor struc';
+	mod_delta = add_mp_delta_resolver mp_to mp_from reso' }
+  |MoreFunctor _ ->
+    let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in
+    subst_module subst do_delta_dom mb
+
+and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso =
   match str with
     | [] -> empty_delta_resolver,[]
     | (l,SFBconst cb) :: rest ->
-	let item' = if alias then 
-	  (* case alias no strengthening needed*)
-	  l,SFBconst (subst_const_body subst cb) 
-	else 
-	  l,SFBconst (strengthen_const mp_from l
-			(subst_const_body subst cb) resolver)
-	in
-	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
+        let cb' = subst_const_body subst cb in
+        let cb'' =
+          if alias then cb'
+          else strengthen_const mp_from l cb' reso
+        in
+        let item' = l, SFBconst cb'' in
+	let reso',rest' =
+	  strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
 	if incl then
-	    (* If we are performing an inclusion we need to add
-	       the fact that the constant mp_to.l is \Delta-equivalent
-	       to resolver(mp_from.l) *)
-	  let kn_from = make_kn mp_from empty_dirpath l in
-	  let kn_to = make_kn mp_to empty_dirpath l in
-	  let old_name = kn_of_delta resolver kn_from in
-	  (add_kn_delta_resolver kn_to old_name resolve_out),
-	  item'::rest'
+          (* If we are performing an inclusion we need to add
+             the fact that the constant mp_to.l is \Delta-equivalent
+             to reso(mp_from.l) *)
+          let kn_from = KerName.make2 mp_from l in
+          let kn_to = KerName.make2 mp_to l in
+          let old_name = kn_of_delta reso kn_from in
+	  add_kn_delta_resolver kn_to old_name reso', item'::rest'
 	else
-	    (*In this case the fact that the constant mp_to.l is 
-	      \Delta-equivalent to resolver(mp_from.l) is already known
-	       because resolve_out contains mp_to maps to resolver(mp_from)*)
-	  resolve_out,item'::rest'
+	  (* In this case the fact that the constant mp_to.l is
+	     \Delta-equivalent to resolver(mp_from.l) is already known
+	     because reso' contains mp_to maps to reso(mp_from) *)
+	  reso', item'::rest'
     | (l,SFBmind mib) :: rest ->
-	(*Same as constant*)
-	let item' = l,SFBmind (subst_mind subst mib) in
-	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
+	let item' = l,SFBmind (subst_mind_body subst mib) in
+	let reso',rest' =
+	  strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
+	(* Same as constant *)
 	if incl then
-	  let kn_from = make_kn mp_from empty_dirpath l in
-	  let kn_to = make_kn mp_to empty_dirpath l in
-	  let old_name = kn_of_delta resolver kn_from in
-	  (add_kn_delta_resolver kn_to old_name resolve_out),
-	  item'::rest'
+	  let kn_from = KerName.make2 mp_from l in
+	  let kn_to = KerName.make2 mp_to l in
+	  let old_name = kn_of_delta reso kn_from in
+	  add_kn_delta_resolver kn_to old_name reso', item'::rest'
 	else
-	  resolve_out,item'::rest'
+	  reso', item'::rest'
     | (l,SFBmodule mb) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
-	let mp_to' = MPdot(mp_to,l) in
-	let mb_out = if alias then 
-	  subst_module subst 
-	  (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb 
+	let mp_to' = MPdot (mp_to,l) in
+	let mb' = if alias then
+	  subst_module subst do_delta_dom mb
 	else
-	  strengthen_and_subst_mod
-	    mb subst mp_from' mp_to' resolver
+	  strengthen_and_subst_mod mb subst mp_from' mp_to'
 	in
-	let item' = l,SFBmodule (mb_out) in
-	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
-	  (* if mb is a functor we should not derive new equivalences
-	     on names, hence we add the fact that the functor can only
-	     be equivalent to itself. If we adopt an applicative
-	     semantic for functor this should be changed.*)
-	  if is_functor mb_out.mod_type then 
-	    (add_mp_delta_resolver 
-	       mp_to' mp_to' resolve_out),item':: rest' 
-	  else
-	    add_delta_resolver resolve_out mb_out.mod_delta,
-	item':: rest'
-    | (l,SFBmodtype mty) :: rest -> 
+	let item' = l,SFBmodule mb' in
+	let reso',rest' =
+	  strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
+        (* if mb is a functor we should not derive new equivalences
+           on names, hence we add the fact that the functor can only
+           be equivalent to itself. If we adopt an applicative
+           semantic for functor this should be changed.*)
+	if is_functor mb'.mod_type then
+	  add_mp_delta_resolver mp_to' mp_to' reso', item':: rest'
+	else
+	  add_delta_resolver reso' mb'.mod_delta, item':: rest'
+    | (l,SFBmodtype mty) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
 	let mp_to' = MPdot(mp_to,l) in
 	let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in
-	let mty = subst_modtype subst' 
-	  (fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in
-	let resolve_out,rest' = strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
-	  (add_mp_delta_resolver 
-	     mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest'
-    
-
-(* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M."
-   we need to perform two operations to compute the body of M. The first one is applying
-   the substitution {P <- M} on the type of P and the second one is strenghtening. *)
-let strengthen_and_subst_mb mb mp include_b =
-    match mb.mod_type with
-	SEBstruct str ->
-	  let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
-	    (*if mb.mod_mp is an alias then the strengthening is useless 
-	      (i.e. it is already done)*)
-	  let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
-	  let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
-	  let new_resolver = 
-	    add_mp_delta_resolver mp mp_alias
-	      (subst_dom_delta_resolver subst_resolver mb.mod_delta) in
-	  let subst = map_mp mb.mod_mp mp new_resolver in 
-	  let resolver_out,new_sig = 
-	    strengthen_and_subst_struct str subst
-	     mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta 
-	  in
-	    {mb with 
-	       mod_mp = mp;
-	       mod_type = SEBstruct(new_sig);
-	       mod_expr = Some (SEBident mb.mod_mp);
-	       mod_delta = if include_b then resolver_out 
-	       else add_delta_resolver new_resolver resolver_out}
-      | SEBfunctor(arg_id,argb,body) ->
-	  let subst = map_mp mb.mod_mp mp empty_delta_resolver in
-	  subst_module subst 
-	    (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mb 
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
-
+	let mty = subst_modtype subst'
+	  (fun resolver _ -> subst_dom_codom_delta_resolver subst' resolver)
+          mty
+        in
+        let item' = l,SFBmodtype mty in
+	let reso',rest' =
+          strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
+	add_mp_delta_resolver mp_to' mp_to' reso', item'::rest'
+
+
+(** Let P be a module path when we write:
+     "Module M:=P." or "Module M. Include P. End M."
+    We need to perform two operations to compute the body of M.
+    - The first one is applying the substitution {P <- M} on the type of P
+    - The second one is strenghtening. *)
+
+let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with
+  |NoFunctor struc ->
+    let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
+    (* if mb.mod_mp is an alias then the strengthening is useless
+       (i.e. it is already done)*)
+    let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
+    let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
+    let new_resolver =
+      add_mp_delta_resolver mp mp_alias
+	(subst_dom_delta_resolver subst_resolver mb.mod_delta)
+    in
+    let subst = map_mp mb.mod_mp mp new_resolver in
+    let reso',struc' =
+      strengthen_and_subst_struct struc subst
+	mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta
+    in
+    { mb with
+      mod_mp = mp;
+      mod_type = NoFunctor struc';
+      mod_expr = Algebraic (NoFunctor (MEident mb.mod_mp));
+      mod_delta =
+        if include_b then reso'
+	else add_delta_resolver new_resolver reso' }
+  |MoreFunctor _ ->
+    let subst = map_mp mb.mod_mp mp empty_delta_resolver in
+    subst_module subst do_delta_dom_codom mb
 
 let subst_modtype_and_resolver mtb mp =
-  let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in
-  let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in 
-  let full_subst = (map_mp mtb.typ_mp mp new_delta) in
-    subst_modtype full_subst
-      (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mtb
+  let subst = map_mp mtb.mod_mp mp empty_delta_resolver in
+  let new_delta = subst_dom_codom_delta_resolver subst mtb.mod_delta in
+  let full_subst = map_mp mtb.mod_mp mp new_delta in
+  subst_modtype full_subst do_delta_dom_codom mtb
+
+(** {6 Cleaning a module expression from bounded parts }
+
+     For instance:
+       functor(X:T)->struct module M:=X end)
+     becomes:
+       functor(X:T)->struct module M:=<content of T> end)
+*)
 
 let rec is_bounded_expr l = function
-  | SEBident mp -> List.mem mp l
-  | SEBapply (fexpr,mexpr,_) ->  
-      is_bounded_expr l mexpr || is_bounded_expr l fexpr
+  | MEident (MPbound mbid) -> MBIset.mem mbid l
+  | MEapply (fexpr,mp) ->
+      is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr
   | _ -> false
 
-let rec clean_struct l = function
-  | (lab,SFBmodule mb) as field -> 
-      let clean_typ = clean_expr l mb.mod_type in 
-      let clean_impl = 
-	begin try
-	  if (is_bounded_expr l (Option.get mb.mod_expr)) then
-	    Some clean_typ
-	  else  Some (clean_expr l (Option.get mb.mod_expr))
-	with
-	    Option.IsNone -> None 
-	end in
-	  if clean_typ==mb.mod_type && clean_impl==mb.mod_expr then
-	    field 
-	  else 
-	    (lab,SFBmodule {mb with 
-			      mod_type=clean_typ;
-			      mod_expr=clean_impl})
-  | field -> field
-      
-and clean_expr l = function
- | SEBfunctor (mbid,sigt,str) as s->
-     let str_clean = clean_expr l str in
-     let sig_clean = clean_expr l sigt.typ_expr in 
-       if  str_clean == str && sig_clean = sigt.typ_expr then
-	 s else SEBfunctor (mbid,{sigt with typ_expr=sig_clean},str_clean)
-  | SEBstruct str as s->
-      let str_clean = Util.list_smartmap (clean_struct l) str in 
-	if  str_clean == str then s else SEBstruct(str_clean)
-  |  str -> str 
-
-let rec collect_mbid l = function
-  | SEBfunctor (mbid,sigt,str) as s->
-      let str_clean = collect_mbid ((MPbound mbid)::l) str in 
-	if  str_clean == str then s else 
-      SEBfunctor (mbid,sigt,str_clean)
-  | SEBstruct str as s->
-      let str_clean = Util.list_smartmap (clean_struct l) str in 
-	if  str_clean == str then s else SEBstruct(str_clean)
-  |  _ -> anomaly "Modops:the evaluation of the structure failed "
-       
-       
-let clean_bounded_mod_expr = function
-  | SEBfunctor _ as str -> 
-      let str_clean = collect_mbid [] str in 
-	if  str_clean == str then str else str_clean
-  | str -> str
+let rec clean_module l mb =
+  let impl, typ = mb.mod_expr, mb.mod_type in
+  let typ' = clean_signature l typ in
+  let impl' = match impl with
+    | Algebraic (NoFunctor m) when is_bounded_expr l m -> FullStruct
+    | _ -> implem_smartmap (clean_signature l) (clean_expression l) impl
+  in
+  if typ==typ' && impl==impl' then mb
+  else { mb with mod_type=typ'; mod_expr=impl' }
+
+and clean_field l field = match field with
+  |(lab,SFBmodule mb) ->
+    let mb' = clean_module l mb in
+    if mb==mb' then field else (lab,SFBmodule mb')
+  |_ -> field
+
+and clean_structure l = List.smartmap (clean_field l)
+
+and clean_signature l =
+  functor_smartmap (clean_module l) (clean_structure l)
+
+and clean_expression l =
+  functor_smartmap (clean_module l) (fun me -> me)
+
+let rec collect_mbid l sign =  match sign with
+  |MoreFunctor (mbid,ty,m) ->
+    let m' = collect_mbid (MBIset.add mbid l) m in
+    if m==m' then sign else MoreFunctor (mbid,ty,m')
+  |NoFunctor struc ->
+    let struc' = clean_structure l struc in
+    if struc==struc' then sign else NoFunctor struc'
+
+let clean_bounded_mod_expr sign =
+  if is_functor sign then collect_mbid MBIset.empty sign else sign
+
+(** {6 Stm machinery } *)
+let join_constant_body except otab cb =
+  match cb.const_body with
+  | OpaqueDef o ->
+      (match Opaqueproof.uuid_opaque otab o with
+      | Some uuid when not(Future.UUIDSet.mem uuid except) ->
+          Opaqueproof.join_opaque otab o
+      | _ -> ())
+  | _ -> ()
+
+let join_structure except otab s =
+  let rec join_module mb =
+    implem_iter join_signature join_expression mb.mod_expr;
+    Option.iter join_expression mb.mod_type_alg;
+    join_signature mb.mod_type
+  and join_field (l,body) = match body with
+    |SFBconst sb -> join_constant_body except otab sb
+    |SFBmind _ -> ()
+    |SFBmodule m |SFBmodtype m -> join_module m
+  and join_structure struc = List.iter join_field struc
+  and join_signature sign =
+    functor_iter join_module join_structure sign
+  and join_expression me = functor_iter join_module (fun _ -> ()) me in
+  join_structure s
+
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 1519df4d..6fbcd81d 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -1,47 +1,66 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
 open Names
-open Univ
 open Term
 open Environ
 open Declarations
 open Entries
 open Mod_subst
 
-(** Various operations on modules and module types *)
+(** {6 Various operations on modules and module types } *)
 
+(** Functors *)
 
-val module_body_of_type : module_path -> module_type_body  -> module_body 
+val is_functor : ('ty,'a) functorize -> bool
 
-val module_type_of_module : module_path option -> module_body ->
-  module_type_body
+val destr_functor : ('ty,'a) functorize -> MBId.t * 'ty * ('ty,'a) functorize
+
+val destr_nofunctor : ('ty,'a) functorize -> 'a
+
+(** Conversions between [module_body] and [module_type_body] *)
 
-val destr_functor :
-  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
+val module_type_of_module : module_body -> module_type_body
+val module_body_of_type : module_path -> module_type_body -> module_body
+
+val check_modpath_equiv : env -> module_path -> module_path -> unit
 
-val subst_struct_expr :  substitution -> struct_expr_body -> struct_expr_body
+val implem_smartmap :
+  (module_signature -> module_signature) ->
+  (module_expression -> module_expression) ->
+  (module_implementation -> module_implementation)
 
-val subst_signature : substitution -> structure_body -> structure_body
+(** {6 Substitutions } *)
 
-val add_signature :
+val subst_signature : substitution -> module_signature -> module_signature
+val subst_structure : substitution -> structure_body -> structure_body
+
+(** {6 Adding to an environment } *)
+
+val add_structure :
   module_path -> structure_body -> delta_resolver -> env -> env
 
 (** adds a module and its components, but not the constraints *)
 val add_module : module_body -> env -> env
 
-val check_modpath_equiv : env -> module_path -> module_path -> unit
+(** same as add_module, but for a module whose native code has been linked by
+the native compiler. The linking information is updated. *)
+val add_linked_module : module_body -> Pre_env.link_info -> env -> env
+
+(** same, for a module type *)
+val add_module_type : module_path -> module_type_body -> env -> env
+
+(** {6 Strengthening } *)
 
 val strengthen : module_type_body -> module_path -> module_type_body
 
 val inline_delta_resolver :
-  env -> inline -> module_path -> mod_bound_id -> module_type_body ->
+  env -> inline -> module_path -> MBId.t -> module_type_body ->
   delta_resolver -> delta_resolver
 
 val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
@@ -49,52 +68,69 @@ val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
 val subst_modtype_and_resolver : module_type_body -> module_path ->
   module_type_body
 
-val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body
+(** {6 Cleaning a module expression from bounded parts }
+
+     For instance:
+       functor(X:T)->struct module M:=X end)
+     becomes:
+       functor(X:T)->struct module M:=<content of T> end)
+*)
+
+val clean_bounded_mod_expr : module_signature -> module_signature
+
+(** {6 Stm machinery } *)
 
-(** Errors *)
+val join_structure :
+  Future.UUIDSet.t -> Opaqueproof.opaquetab -> structure_body -> unit
+
+(** {6 Errors } *)
 
 type signature_mismatch_error =
   | InductiveFieldExpected of mutual_inductive_body
   | DefinitionFieldExpected
   | ModuleFieldExpected
   | ModuleTypeFieldExpected
-  | NotConvertibleInductiveField of identifier
-  | NotConvertibleConstructorField of identifier
+  | NotConvertibleInductiveField of Id.t
+  | NotConvertibleConstructorField of Id.t
   | NotConvertibleBodyField
   | NotConvertibleTypeField of env * types * types
+  | PolymorphicStatusExpected of bool
   | NotSameConstructorNamesField
   | NotSameInductiveNameInBlockField
   | FiniteInductiveFieldExpected of bool
   | InductiveNumbersFieldExpected of int
   | InductiveParamsNumberField of int
   | RecordFieldExpected of bool
-  | RecordProjectionsExpected of name list
+  | RecordProjectionsExpected of Name.t list
   | NotEqualInductiveAliases
   | NoTypeConstraintExpected
+  | IncompatibleInstances
+  | IncompatibleUniverses of Univ.univ_inconsistency
+  | IncompatiblePolymorphism of env * types * types
+  | IncompatibleConstraints of Univ.constraints
 
 type module_typing_error =
-  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
-  | LabelAlreadyDeclared of label
+  | SignatureMismatch of
+      Label.t * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of Label.t
   | ApplicationToNotPath of module_struct_entry
-  | NotAFunctor of struct_expr_body
+  | NotAFunctor
+  | IsAFunctor
   | IncompatibleModuleTypes of module_type_body * module_type_body
   | NotEqualModulePaths of module_path * module_path
-  | NoSuchLabel of label
-  | IncompatibleLabels of label * label
-  | SignatureExpected of struct_expr_body
-  | NoModuleToEnd
-  | NoModuleTypeToEnd
+  | NoSuchLabel of Label.t
+  | IncompatibleLabels of Label.t * Label.t
   | NotAModule of string
   | NotAModuleType of string
-  | NotAConstant of label
-  | IncorrectWithConstraint of label
-  | GenerativeModuleExpected of label
-  | NonEmptyLocalContect of label option
-  | LabelMissing of label * string
+  | NotAConstant of Label.t
+  | IncorrectWithConstraint of Label.t
+  | GenerativeModuleExpected of Label.t
+  | LabelMissing of Label.t * string
+  | HigherOrderInclude
 
 exception ModuleTypingError of module_typing_error
 
-val error_existing_label : label -> 'a
+val error_existing_label : Label.t -> 'a
 
 val error_application_to_not_path : module_struct_entry -> 'a
 
@@ -102,26 +138,20 @@ val error_incompatible_modtypes :
   module_type_body -> module_type_body -> 'a
 
 val error_signature_mismatch :
-  label -> structure_field_body -> signature_mismatch_error -> 'a
-
-val error_incompatible_labels : label -> label -> 'a
-
-val error_no_such_label : label -> 'a
-
-val error_signature_expected : struct_expr_body -> 'a
+  Label.t -> structure_field_body -> signature_mismatch_error -> 'a
 
-val error_no_module_to_end : unit -> 'a
+val error_incompatible_labels : Label.t -> Label.t -> 'a
 
-val error_no_modtype_to_end : unit -> 'a
+val error_no_such_label : Label.t -> 'a
 
 val error_not_a_module : string -> 'a
 
-val error_not_a_constant : label -> 'a
+val error_not_a_constant : Label.t -> 'a
 
-val error_incorrect_with_constraint : label -> 'a
+val error_incorrect_with_constraint : Label.t -> 'a
 
-val error_generative_module_expected : label -> 'a
+val error_generative_module_expected : Label.t -> 'a
 
-val error_non_empty_local_context : label option -> 'a
+val error_no_such_label_sub : Label.t->string->'a
 
-val error_no_such_label_sub : label->string->'a
+val error_higher_order_include : unit -> 'a
diff --git a/kernel/names.ml b/kernel/names.ml
index c20f75a9..b349ccb0 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -23,35 +23,106 @@ open Util
 
 (** {6 Identifiers } *)
 
-type identifier = string
+module Id =
+struct
+  type t = string
+
+  let equal = String.equal
+
+  let compare = String.compare
+
+  let hash = String.hash
+
+  let check_soft x =
+    let iter (fatal, x) =
+      if fatal then Errors.error x else Pp.msg_warning (str x)
+    in
+    Option.iter iter (Unicode.ident_refutation x)
 
-let id_of_string s = check_ident_soft s; String.copy s
-let string_of_id id = String.copy id
+  let is_valid s = match Unicode.ident_refutation s with
+  | None -> true
+  | Some _ -> false
 
-let id_ord = Pervasives.compare
+  let of_string s =
+    let () = check_soft s in
+    let s = String.copy s in
+    String.hcons s
 
-module IdOrdered =
+  let to_string id = String.copy id
+
+  let print id = str id
+
+  module Self =
   struct
-    type t = identifier
-    let compare = id_ord
+    type t = string
+    let compare = compare
   end
 
-module Idset = Set.Make(IdOrdered)
-module Idmap =
+  module Set = Set.Make(Self)
+  module Map = CMap.Make(Self)
+
+  module Pred = Predicate.Make(Self)
+
+  module List = String.List
+
+  let hcons = String.hcons
+
+end
+
+
+module Name =
 struct
-  include Map.Make(IdOrdered)
-  exception Finded
-  let exists f m =
-    try iter (fun a b -> if f a b then raise Finded) m ; false
-    with |Finded -> true
-  let singleton k v = add k v empty
+  type t = Name of Id.t | Anonymous
+
+  let compare n1 n2 = match n1, n2 with
+    | Anonymous, Anonymous -> 0
+    | Name id1, Name id2 -> Id.compare id1 id2
+    | Anonymous, Name _ -> -1
+    | Name _, Anonymous -> 1
+
+  let equal n1 n2 = match n1, n2 with
+    | Anonymous, Anonymous -> true
+    | Name id1, Name id2 -> String.equal id1 id2
+    | _ -> false
+
+  let hash = function
+  | Anonymous -> 0
+  | Name id -> Id.hash id
+
+  module Self_Hashcons =
+    struct
+      type _t = t
+      type t = _t
+      type u = Id.t -> Id.t
+      let hashcons hident = function
+        | Name id -> Name (hident id)
+        | n -> n
+      let equal n1 n2 =
+        n1 == n2 ||
+        match (n1,n2) with
+          | (Name id1, Name id2) -> id1 == id2
+          | (Anonymous,Anonymous) -> true
+          | _ -> false
+      let hash = hash
+    end
+
+  module Hname = Hashcons.Make(Self_Hashcons)
+
+  let hcons = Hashcons.simple_hcons Hname.generate Hname.hcons Id.hcons
+
 end
-module Idpred = Predicate.Make(IdOrdered)
+
+type name = Name.t = Name of Id.t | Anonymous
+(** Alias, to import constructors. *)
 
 (** {6 Various types based on identifiers } *)
 
-type name = Name of identifier | Anonymous
-type variable = identifier
+type variable = Id.t
+
+type module_ident = Id.t
+
+module ModIdset = Id.Set
+module ModIdmap = Id.Map
 
 (** {6 Directory paths = section names paths } *)
 
@@ -59,250 +130,491 @@ type variable = identifier
     The actual representation is reversed to optimise sharing:
     Coq.A.B is ["B";"A";"Coq"] *)
 
-type module_ident = identifier
-type dir_path = module_ident list
+let default_module_name = "If you see this, it's a bug"
+
+module DirPath =
+struct
+  type t = module_ident list
+
+  let rec compare (p1 : t) (p2 : t) =
+    if p1 == p2 then 0
+    else begin match p1, p2 with
+    | [], [] -> 0
+    | [], _ -> -1
+    | _, [] -> 1
+    | id1 :: p1, id2 :: p2 ->
+      let c = Id.compare id1 id2 in
+      if Int.equal c 0 then compare p1 p2 else c
+    end
+
+  let rec equal p1 p2 = p1 == p2 || match p1, p2 with
+  | [], [] -> true
+  | id1 :: p1, id2 :: p2 -> Id.equal id1 id2 && equal p1 p2
+  | _ -> false
+
+  let rec hash accu = function
+  | [] -> accu
+  | id :: dp ->
+    let accu = Hashset.Combine.combine (Id.hash id) accu in
+    hash accu dp
+
+  let hash dp = hash 0 dp
+
+  let make x = x
+  let repr x = x
+
+  let empty = []
 
-module ModIdmap = Idmap
+  let is_empty d = match d with [] -> true | _ -> false
 
-let make_dirpath x = x
-let repr_dirpath x = x
+  let to_string = function
+    | [] -> "<>"
+    | sl -> String.concat "." (List.rev_map Id.to_string sl)
 
-let empty_dirpath = []
+  let initial = [default_module_name]
 
-(** Printing of directory paths as ["coq_root.module.submodule"] *)
+  module Hdir = Hashcons.Hlist(Id)
 
-let string_of_dirpath = function
-  | [] -> "<>"
-  | sl -> String.concat "." (List.map string_of_id (List.rev sl))
+  let hcons = Hashcons.recursive_hcons Hdir.generate Hdir.hcons Id.hcons
+
+end
 
 (** {6 Unique names for bound modules } *)
 
-let u_number = ref 0
-type uniq_ident = int * identifier * dir_path
-let make_uid dir s = incr u_number;(!u_number,s,dir)
- let debug_string_of_uid (i,s,p) =
- "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
-let string_of_uid (i,s,p) =
-  string_of_dirpath p ^"."^s
-
-module Umap = Map.Make(struct
-			 type t = uniq_ident
-			 let compare = Pervasives.compare
-		       end)
-
-type mod_bound_id = uniq_ident
-let make_mbid = make_uid
-let repr_mbid (n, id, dp) = (n, id, dp)
-let debug_string_of_mbid = debug_string_of_uid
-let string_of_mbid = string_of_uid
-let id_of_mbid (_,s,_) = s
+module MBId =
+struct
+  type t = int * Id.t * DirPath.t
 
-(** {6 Names of structure elements } *)
+  let gen =
+    let seed = ref 0 in fun () ->
+      let ans = !seed in
+      let () = incr seed in
+      ans
 
-type label = identifier
+  let make dir s = (gen(), s, dir)
 
-let mk_label = id_of_string
-let string_of_label = string_of_id
-let pr_label l = str (string_of_label l)
-let id_of_label l = l
-let label_of_id id = id
+  let repr mbid = mbid
 
-module Labset = Idset
-module Labmap = Idmap
+  let to_string (i, s, p) =
+    DirPath.to_string p ^ "." ^ s
 
-(** {6 The module part of the kernel name } *)
+  let debug_to_string (i, s, p) =
+    "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+
+  let compare (x : t) (y : t) =
+    if x == y then 0
+    else match (x, y) with
+    | (nl, idl, dpl), (nr, idr, dpr) ->
+      let ans = Int.compare nl nr in
+      if not (Int.equal ans 0) then ans
+      else
+        let ans = Id.compare idl idr in
+        if not (Int.equal ans 0) then ans
+        else
+          DirPath.compare dpl dpr
 
-type module_path =
-  | MPfile of dir_path
-  | MPbound of mod_bound_id
-  | MPdot of module_path * label
+  let equal x y = x == y ||
+    let (i1, id1, p1) = x in
+    let (i2, id2, p2) = y in
+    Int.equal i1 i2 && Id.equal id1 id2 && DirPath.equal p1 p2
 
-let rec check_bound_mp = function
-  | MPbound _ -> true
-  | MPdot(mp,_) ->check_bound_mp mp
-  | _ -> false
+  let to_id (_, s, _) = s
+
+  open Hashset.Combine
+
+  let hash (i, id, dp) =
+    combine3 (Int.hash i) (Id.hash id) (DirPath.hash dp)
+
+  module Self_Hashcons =
+    struct
+      type _t = t
+      type t = _t
+      type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t)
+      let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
+      let equal ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) =
+        (x == y) ||
+        (Int.equal n1 n2 && s1 == s2 && dir1 == dir2)
+      let hash = hash
+    end
+
+  module HashMBId = Hashcons.Make(Self_Hashcons)
+
+  let hcons = Hashcons.simple_hcons HashMBId.generate HashMBId.hcons (Id.hcons, DirPath.hcons)
 
-let rec string_of_mp = function
-  | MPfile sl -> string_of_dirpath sl
-  | MPbound uid -> string_of_uid uid
-  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
-
-(** we compare labels first if both are MPdots *)
-let rec mp_ord mp1 mp2 = match (mp1,mp2) with
-    MPdot(mp1,l1), MPdot(mp2,l2) ->
-      let c = Pervasives.compare l1 l2 in
-	if c<>0 then
-	  c
-	else
-	  mp_ord mp1 mp2
-  |  _,_ -> Pervasives.compare mp1 mp2
-
-module MPord = struct
-  type t = module_path
-  let compare = mp_ord
 end
 
-module MPset = Set.Make(MPord)
-module MPmap = Map.Make(MPord)
+module MBImap = CMap.Make(MBId)
+module MBIset = Set.Make(MBId)
 
-let default_module_name = "If you see this, it's a bug"
+(** {6 Names of structure elements } *)
+
+module Label =
+struct
+  include Id
+  let make = Id.of_string
+  let of_id id = id
+  let to_id id = id
+end
+
+(** {6 The module part of the kernel name } *)
+
+module ModPath = struct
+
+  type t =
+    | MPfile of DirPath.t
+    | MPbound of MBId.t
+    | MPdot of t * Label.t
+
+  type module_path = t
+
+  let rec is_bound = function
+    | MPbound _ -> true
+    | MPdot(mp,_) -> is_bound mp
+    | _ -> false
+
+  let rec to_string = function
+    | MPfile sl -> DirPath.to_string sl
+    | MPbound uid -> MBId.to_string uid
+    | MPdot (mp,l) -> to_string mp ^ "." ^ Label.to_string l
+
+  (** we compare labels first if both are MPdots *)
+  let rec compare mp1 mp2 =
+    if mp1 == mp2 then 0
+    else match mp1, mp2 with
+      | MPfile p1, MPfile p2 -> DirPath.compare p1 p2
+      | MPbound id1, MPbound id2 -> MBId.compare id1 id2
+      | MPdot (mp1, l1), MPdot (mp2, l2) ->
+        let c = String.compare l1 l2 in
+        if not (Int.equal c 0) then c
+        else compare mp1 mp2
+      | MPfile _, _ -> -1
+      | MPbound _, MPfile _ -> 1
+      | MPbound _, MPdot _ -> -1
+      | MPdot _, _ -> 1
+
+  let rec equal mp1 mp2 = mp1 == mp2 ||
+    match mp1, mp2 with
+    | MPfile p1, MPfile p2 -> DirPath.equal p1 p2
+    | MPbound id1, MPbound id2 -> MBId.equal id1 id2
+    | MPdot (mp1, l1), MPdot (mp2, l2) -> String.equal l1 l2 && equal mp1 mp2
+    | (MPfile _ | MPbound _ | MPdot _), _ -> false
+
+  open Hashset.Combine
+
+  let rec hash = function
+  | MPfile dp -> combinesmall 1 (DirPath.hash dp)
+  | MPbound id -> combinesmall 2 (MBId.hash id)
+  | MPdot (mp, lbl) ->
+    combinesmall 3 (combine (hash mp) (Label.hash lbl))
+
+  let initial = MPfile DirPath.initial
+
+  let rec dp = function
+  | MPfile sl -> sl
+  | MPbound (_,_,dp) -> dp
+  | MPdot (mp,l) -> dp mp
+
+  module Self_Hashcons = struct
+    type t = module_path
+    type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) *
+	(string -> string)
+    let rec hashcons (hdir,huniqid,hstr as hfuns) = function
+      | MPfile dir -> MPfile (hdir dir)
+      | MPbound m -> MPbound (huniqid m)
+      | MPdot (md,l) -> MPdot (hashcons hfuns md, hstr l)
+    let rec equal d1 d2 =
+      d1 == d2 ||
+      match d1,d2 with
+      | MPfile dir1, MPfile dir2 -> dir1 == dir2
+      | MPbound m1, MPbound m2 -> m1 == m2
+      | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
+      | _ -> false
+    let hash = hash
+  end
+
+  module HashMP = Hashcons.Make(Self_Hashcons)
+
+  let hcons =
+    Hashcons.simple_hcons HashMP.generate HashMP.hcons
+      (DirPath.hcons,MBId.hcons,String.hcons)
+
+end
 
-let initial_dir = make_dirpath [default_module_name]
-let initial_path = MPfile initial_dir
+module MPset = Set.Make(ModPath)
+module MPmap = CMap.Make(ModPath)
 
 (** {6 Kernel names } *)
 
-type kernel_name = module_path * dir_path * label
+module KerName = struct
 
-let make_kn mp dir l = (mp,dir,l)
-let repr_kn kn = kn
+  type t = {
+    canary : Canary.t;
+    modpath : ModPath.t;
+    dirpath : DirPath.t;
+    knlabel : Label.t;
+    mutable refhash : int;
+    (** Lazily computed hash. If unset, it is set to negative values. *)
+  }
 
-let modpath kn =
-  let mp,_,_ = repr_kn kn in mp
+  let canary = Canary.obj
 
-let label kn =
-  let _,_,l = repr_kn kn in l
+  type kernel_name = t
 
-let string_of_kn (mp,dir,l) =
-  let str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#"
-  in
-  string_of_mp mp ^ str_dir ^ string_of_label l
+  let make modpath dirpath knlabel =
+    { modpath; dirpath; knlabel; refhash = -1; canary; }
+  let repr kn = (kn.modpath, kn.dirpath, kn.knlabel)
 
-let pr_kn kn = str (string_of_kn kn)
+  let make2 modpath knlabel =
+    { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; canary; }
 
-let kn_ord kn1 kn2 =
-    let mp1,dir1,l1 = kn1 in
-    let mp2,dir2,l2 = kn2 in
-    let c = Pervasives.compare l1 l2 in
-      if c <> 0 then
-	c
+  let modpath kn = kn.modpath
+  let label kn = kn.knlabel
+
+  let to_string kn =
+    let dp =
+      if DirPath.is_empty kn.dirpath then "."
+      else "#" ^ DirPath.to_string kn.dirpath ^ "#"
+    in
+    ModPath.to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel
+
+  let print kn = str (to_string kn)
+
+  let compare (kn1 : kernel_name) (kn2 : kernel_name) =
+    if kn1 == kn2 then 0
+    else
+      let c = String.compare kn1.knlabel kn2.knlabel in
+      if not (Int.equal c 0) then c
       else
-	let c = Pervasives.compare dir1 dir2 in
-	  if c<>0 then
-	    c
-	  else
-	    MPord.compare mp1 mp2
-
-module KNord = struct
-  type t = kernel_name
-  let compare = kn_ord
-end
+        let c = DirPath.compare kn1.dirpath kn2.dirpath in
+        if not (Int.equal c 0) then c
+        else ModPath.compare kn1.modpath kn2.modpath
+
+  let equal kn1 kn2 =
+    let h1 = kn1.refhash in
+    let h2 = kn2.refhash in
+    if 0 <= h1 && 0 <= h2 && not (Int.equal h1 h2) then false
+    else
+      Label.equal kn1.knlabel kn2.knlabel &&
+      DirPath.equal kn1.dirpath kn2.dirpath &&
+      ModPath.equal kn1.modpath kn2.modpath
+
+  open Hashset.Combine
+
+  let hash kn =
+    let h = kn.refhash in
+    if h < 0 then
+      let { modpath = mp; dirpath = dp; knlabel = lbl; } = kn in
+      let h = combine3 (ModPath.hash mp) (DirPath.hash dp) (Label.hash lbl) in
+      (* Ensure positivity on all platforms. *)
+      let h = h land 0x3FFFFFFF in
+      let () = kn.refhash <- h in
+      h
+    else h
+
+  module Self_Hashcons = struct
+    type t = kernel_name
+    type u = (ModPath.t -> ModPath.t) * (DirPath.t -> DirPath.t)
+        * (string -> string)
+    let hashcons (hmod,hdir,hstr) kn =
+      let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in
+      { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; }
+    let equal kn1 kn2 =
+      kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath &&
+        kn1.knlabel == kn2.knlabel
+    let hash = hash
+  end
 
-module KNmap = Map.Make(KNord)
-module KNpred = Predicate.Make(KNord)
-module KNset = Set.Make(KNord)
-
-(** {6 Constant names } *)
-
-(** a constant name is a kernel name couple (kn1,kn2)
-   where kn1 corresponds to the name used at toplevel
-   (i.e. what the user see)
-   and kn2 corresponds to the canonical kernel name
-   i.e. in the environment we have
-   kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *)
-type constant = kernel_name*kernel_name
-
-let constant_of_kn kn = (kn,kn)
-let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_con mp dir l = constant_of_kn (mp,dir,l)
-let make_con_equiv mp1 mp2 dir l =
-  if mp1 == mp2 then make_con mp1 dir l
-  else ((mp1,dir,l),(mp2,dir,l))
-let canonical_con con = snd con
-let user_con con = fst con
-let repr_con con = fst con
-
-let eq_constant (_,kn1) (_,kn2) = kn1=kn2
-
-let con_label con = label (fst con)
-let con_modpath con = modpath (fst con)
-
-let string_of_con con = string_of_kn (fst con)
-let pr_con con = str (string_of_con con)
-let debug_string_of_con con =
-  "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")"
-let debug_pr_con con = str (debug_string_of_con con)
-
-let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
-  if lbl = l1 && lbl = l2 then con
-  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
-
-(** For the environment we distinguish constants by their user part*)
-module User_ord = struct
-  type t = kernel_name*kernel_name
-  let compare x y= kn_ord (fst x) (fst y)
+  module HashKN = Hashcons.Make(Self_Hashcons)
+
+  let hcons =
+    Hashcons.simple_hcons HashKN.generate HashKN.hcons
+      (ModPath.hcons,DirPath.hcons,String.hcons)
 end
 
-(** For other uses (ex: non-logical things) it is enough
-    to deal with the canonical part *)
-module Canonical_ord = struct
-  type t = kernel_name*kernel_name
-  let compare x y= kn_ord (snd x) (snd y)
+module KNmap = HMap.Make(KerName)
+module KNpred = Predicate.Make(KerName)
+module KNset = KNmap.Set
+
+(** {6 Kernel pairs } *)
+
+(** For constant and inductive names, we use a kernel name couple (kn1,kn2)
+   where kn1 corresponds to the name used at toplevel (i.e. what the user see)
+   and kn2 corresponds to the canonical kernel name i.e. in the environment
+   we have {% kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t %}
+
+   Invariants :
+    - the user and canonical kn may differ only on their [module_path],
+      the dirpaths and labels should be the same
+    - when user and canonical parts differ, we cannot be in a section
+      anymore, hence the dirpath must be empty
+    - two pairs with the same user part should have the same canonical part
+
+   Note: since most of the time the canonical and user parts are equal,
+   we handle this case with a particular constructor to spare some memory *)
+
+module KerPair = struct
+
+  type t =
+    | Same of KerName.t (** user = canonical *)
+    | Dual of KerName.t * KerName.t (** user then canonical *)
+
+  type kernel_pair = t
+
+  let canonical = function
+    | Same kn -> kn
+    | Dual (_,kn) -> kn
+
+  let user = function
+    | Same kn -> kn
+    | Dual (kn,_) -> kn
+
+  let same kn = Same kn
+  let make knu knc = if knu == knc then Same knc else Dual (knu,knc)
+
+  let make1 = same
+  let make2 mp l = same (KerName.make2 mp l)
+  let make3 mp dir l = same (KerName.make mp dir l)
+  let repr3 kp = KerName.repr (user kp)
+  let label kp = KerName.label (user kp)
+  let modpath kp = KerName.modpath (user kp)
+
+  let change_label kp lbl =
+    let (mp1,dp1,l1) = KerName.repr (user kp)
+    and (mp2,dp2,l2) = KerName.repr (canonical kp) in
+    assert (String.equal l1 l2 && DirPath.equal dp1 dp2);
+    if String.equal lbl l1 then kp
+    else
+      let kn = KerName.make mp1 dp1 lbl in
+      if mp1 == mp2 then same kn
+      else make kn (KerName.make mp2 dp2 lbl)
+
+  let to_string kp = KerName.to_string (user kp)
+  let print kp = str (to_string kp)
+
+  let debug_to_string = function
+    | Same kn -> "(" ^ KerName.to_string kn ^ ")"
+    | Dual (knu,knc) ->
+      "(" ^ KerName.to_string knu ^ "," ^ KerName.to_string knc ^ ")"
+
+  let debug_print kp = str (debug_to_string kp)
+
+  (** For ordering kernel pairs, both user or canonical parts may make
+      sense, according to your needs : user for the environments, canonical
+      for other uses (ex: non-logical things). *)
+
+  module UserOrd = struct
+    type t = kernel_pair
+    let compare x y = KerName.compare (user x) (user y)
+    let equal x y = x == y || KerName.equal (user x) (user y)
+    let hash x = KerName.hash (user x)
+  end
+
+  module CanOrd = struct
+    type t = kernel_pair
+    let compare x y = KerName.compare (canonical x) (canonical y)
+    let equal x y = x == y || KerName.equal (canonical x) (canonical y)
+    let hash x = KerName.hash (canonical x)
+  end
+
+  (** Default comparison is on the canonical part *)
+  let equal = CanOrd.equal
+
+  (** Hash-consing : we discriminate only on the user part, since having
+      the same user part implies having the same canonical part
+      (invariant of the system). *)
+
+  let hash = function
+  | Same kn -> KerName.hash kn
+  | Dual (kn, _) -> KerName.hash kn
+
+  module Self_Hashcons =
+    struct
+      type t = kernel_pair
+      type u = KerName.t -> KerName.t
+      let hashcons hkn = function
+        | Same kn -> Same (hkn kn)
+        | Dual (knu,knc) -> make (hkn knu) (hkn knc)
+      let equal x y = (user x) == (user y)
+      let hash = hash
+    end
+
+  module HashKP = Hashcons.Make(Self_Hashcons)
+
 end
 
-module Cmap = Map.Make(Canonical_ord)
-module Cmap_env = Map.Make(User_ord)
-module Cpred = Predicate.Make(Canonical_ord)
-module Cset = Set.Make(Canonical_ord)
-module Cset_env = Set.Make(User_ord)
+(** {6 Constant Names} *)
+
+module Constant = KerPair
 
+module Cmap = HMap.Make(Constant.CanOrd)
+module Cmap_env = HMap.Make(Constant.UserOrd)
+module Cpred = Predicate.Make(Constant.CanOrd)
+module Cset = Cmap.Set
+module Cset_env = Cmap_env.Set
 
 (** {6 Names of mutual inductive types } *)
 
-(** The same thing is done for mutual inductive names
-    it replaces also the old mind_equiv field of mutual
-    inductive types *)
+module MutInd = KerPair
+
+module Mindmap = HMap.Make(MutInd.CanOrd)
+module Mindset = Mindmap.Set
+module Mindmap_env = HMap.Make(MutInd.UserOrd)
+
 (** Beware: first inductive has index 0 *)
 (** Beware: first constructor has index 1 *)
 
-type mutual_inductive = kernel_name*kernel_name
-type inductive = mutual_inductive * int
+type inductive = MutInd.t * int
 type constructor = inductive * int
 
-let mind_modpath mind = modpath (fst mind)
-let ind_modpath ind = mind_modpath (fst ind)
-let constr_modpath c = ind_modpath (fst c)
-
-let mind_of_kn kn = (kn,kn)
-let mind_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_mind mp dir l = mind_of_kn (mp,dir,l)
-let make_mind_equiv mp1 mp2 dir l =
-  if mp1 == mp2 then make_mind mp1 dir l
-  else ((mp1,dir,l),(mp2,dir,l))
-let canonical_mind mind = snd mind
-let user_mind mind = fst mind
-let repr_mind mind = fst mind
-let mind_label mind= label (fst mind)
-
-let eq_mind (_,kn1) (_,kn2) = kn1=kn2
-
-let string_of_mind mind = string_of_kn (fst mind)
-let pr_mind mind = str (string_of_mind mind)
-let debug_string_of_mind mind =
-  "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")"
-let debug_pr_mind con = str (debug_string_of_mind con)
-
-let ith_mutual_inductive (kn,_) i = (kn,i)
-let ith_constructor_of_inductive ind i = (ind,i)
-let inductive_of_constructor (ind,i) = ind
-let index_of_constructor (ind,i) = i
-let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2
-let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2
-
-module Mindmap = Map.Make(Canonical_ord)
-module Mindset = Set.Make(Canonical_ord)
-module Mindmap_env = Map.Make(User_ord)
+let ind_modpath (mind,_) = MutInd.modpath mind
+let constr_modpath (ind,_) = ind_modpath ind
+
+let ith_mutual_inductive (mind, _) i = (mind, i)
+let ith_constructor_of_inductive ind i = (ind, i)
+let ith_constructor_of_pinductive (ind,u) i = ((ind,i),u)
+let inductive_of_constructor (ind, i) = ind
+let index_of_constructor (ind, i) = i
+
+let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2
+let eq_user_ind (m1, i1) (m2, i2) =
+  Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2
+
+let ind_ord (m1, i1) (m2, i2) =
+  let c = Int.compare i1 i2 in
+  if Int.equal c 0 then MutInd.CanOrd.compare m1 m2 else c
+let ind_user_ord (m1, i1) (m2, i2) =
+  let c = Int.compare i1 i2 in
+  if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c
+
+let ind_hash (m, i) =
+  Hashset.Combine.combine (MutInd.hash m) (Int.hash i)
+let ind_user_hash (m, i) =
+  Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i)
+
+let eq_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_ind ind1 ind2
+let eq_user_constructor (ind1, j1) (ind2, j2) =
+  Int.equal j1 j2 && eq_user_ind ind1 ind2
+
+let constructor_ord (ind1, j1) (ind2, j2) =
+  let c = Int.compare j1 j2 in
+  if Int.equal c 0 then ind_ord ind1 ind2 else c
+let constructor_user_ord (ind1, j1) (ind2, j2) =
+  let c = Int.compare j1 j2 in
+  if Int.equal c 0 then ind_user_ord ind1 ind2 else c
+
+let constructor_hash (ind, i) =
+  Hashset.Combine.combine (ind_hash ind) (Int.hash i)
+let constructor_user_hash (ind, i) =
+  Hashset.Combine.combine (ind_user_hash ind) (Int.hash i)
 
 module InductiveOrdered = struct
   type t = inductive
-  let compare (spx,ix) (spy,iy) =
-    let c = ix - iy in if c = 0 then Canonical_ord.compare spx spy else c
+  let compare = ind_ord
 end
 
 module InductiveOrdered_env = struct
   type t = inductive
-  let compare (spx,ix) (spy,iy) =
-    let c = ix - iy in if c = 0 then User_ord.compare spx spy else c
+  let compare = ind_user_ord
 end
 
 module Indmap = Map.Make(InductiveOrdered)
@@ -310,14 +622,12 @@ module Indmap_env = Map.Make(InductiveOrdered_env)
 
 module ConstructorOrdered = struct
   type t = constructor
-  let compare (indx,ix) (indy,iy) =
-    let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c
+  let compare = constructor_ord
 end
 
 module ConstructorOrdered_env = struct
   type t = constructor
-  let compare (indx,ix) (indy,iy) =
-    let c = ix - iy in if c = 0 then InductiveOrdered_env.compare indx indy else c
+  let compare = constructor_user_ord
 end
 
 module Constrmap = Map.Make(ConstructorOrdered)
@@ -325,152 +635,223 @@ module Constrmap_env = Map.Make(ConstructorOrdered_env)
 
 (* Better to have it here that in closure, since used in grammar.cma *)
 type evaluable_global_reference =
-  | EvalVarRef of identifier
-  | EvalConstRef of constant
+  | EvalVarRef of Id.t
+  | EvalConstRef of Constant.t
 
-let eq_egr e1 e2 = match e1,e2 with
-    EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2
-  | _,_ -> e1 = e2
+let eq_egr e1 e2 = match e1, e2 with
+    EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2
+  | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2
+  | _, _ -> false
 
 (** {6 Hash-consing of name objects } *)
 
-module Hname = Hashcons.Make(
-  struct
-    type t = name
-    type u = identifier -> identifier
-    let hash_sub hident = function
-      | Name id -> Name (hident id)
-      | n -> n
-    let equal n1 n2 =
-      match (n1,n2) with
-	| (Name id1, Name id2) -> id1 == id2
-        | (Anonymous,Anonymous) -> true
-        | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-module Hdir = Hashcons.Make(
-  struct
-    type t = dir_path
-    type u = identifier -> identifier
-    let hash_sub hident d = list_smartmap hident d
-    let rec equal d1 d2 = match (d1,d2) with
-      | [],[] -> true
-      | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
-      | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-module Huniqid = Hashcons.Make(
-  struct
-    type t = uniq_ident
-    type u = (identifier -> identifier) * (dir_path -> dir_path)
-    let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
-    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2
-    let hash = Hashtbl.hash
-  end)
-
-module Hmod = Hashcons.Make(
-  struct
-    type t = module_path
-    type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) *
-	(string -> string)
-    let rec hash_sub (hdir,huniqid,hstr as hfuns) = function
-      | MPfile dir -> MPfile (hdir dir)
-      | MPbound m -> MPbound (huniqid m)
-      | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l)
-    let rec equal d1 d2 = match (d1,d2) with
-      | MPfile dir1, MPfile dir2 -> dir1 == dir2
-      | MPbound m1, MPbound m2 -> m1 == m2
-      | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
-      | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-module Hkn = Hashcons.Make(
-  struct
-    type t = kernel_name
-    type u = (module_path -> module_path)
-	* (dir_path -> dir_path) * (string -> string)
-    let hash_sub (hmod,hdir,hstr) (md,dir,l) =
-      (hmod md, hdir dir, hstr l)
-    let equal (mod1,dir1,l1) (mod2,dir2,l2) =
-      mod1 == mod2 && dir1 == dir2 && l1 == l2
-    let hash = Hashtbl.hash
-  end)
-
-(** For [constant] and [mutual_inductive], we discriminate only on
-    the user part : having the same user part implies having the
-    same canonical part (invariant of the system). *)
-
-module Hcn = Hashcons.Make(
-  struct
-    type t = kernel_name*kernel_name
-    type u = kernel_name -> kernel_name
-    let hash_sub hkn (user,can) = (hkn user, hkn can)
-    let equal (user1,_) (user2,_) = user1 == user2
-    let hash (user,_) = Hashtbl.hash user
-  end)
-
 module Hind = Hashcons.Make(
   struct
     type t = inductive
-    type u = mutual_inductive -> mutual_inductive
-    let hash_sub hmind (mind, i) = (hmind mind, i)
-    let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2
-    let hash = Hashtbl.hash
+    type u = MutInd.t -> MutInd.t
+    let hashcons hmind (mind, i) = (hmind mind, i)
+    let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2
+    let hash = ind_hash
   end)
 
 module Hconstruct = Hashcons.Make(
   struct
     type t = constructor
     type u = inductive -> inductive
-    let hash_sub hind (ind, j) = (hind ind, j)
-    let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2
-    let hash = Hashtbl.hash
+    let hashcons hind (ind, j) = (hind ind, j)
+    let equal (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2
+    let hash = constructor_hash
   end)
 
-let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f ()
-let hcons_ident = hcons_string
-let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident
-let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident
-let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath)
-let hcons_mp =
-  Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string)
-let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string)
-let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn
-let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn
-let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind
-let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind
-
+let hcons_con = Hashcons.simple_hcons Constant.HashKP.generate Constant.HashKP.hcons KerName.hcons
+let hcons_mind = Hashcons.simple_hcons MutInd.HashKP.generate MutInd.HashKP.hcons KerName.hcons
+let hcons_ind = Hashcons.simple_hcons Hind.generate Hind.hcons hcons_mind
+let hcons_construct = Hashcons.simple_hcons Hconstruct.generate Hconstruct.hcons hcons_ind
 
-(*******)
+(*****************)
 
-type transparent_state = Idpred.t * Cpred.t
+type transparent_state = Id.Pred.t * Cpred.t
 
-let empty_transparent_state = (Idpred.empty, Cpred.empty)
-let full_transparent_state = (Idpred.full, Cpred.full)
-let var_full_transparent_state = (Idpred.full, Cpred.empty)
-let cst_full_transparent_state = (Idpred.empty, Cpred.full)
+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 constant
-  | VarKey of identifier
-  | RelKey of 'a
-
+  | ConstKey of 'a
+  | VarKey of Id.t
+  | RelKey of Int.t
 
 type inv_rel_key = int (* index in the [rel_context] part of environment
 			  starting by the end, {\em inverse}
 			  of de Bruijn indice *)
 
-type id_key = inv_rel_key tableKey
+let eq_table_key f ik1 ik2 =
+  if ik1 == ik2 then true
+  else match ik1,ik2 with
+  | ConstKey c1, ConstKey c2 -> f c1 c2
+  | VarKey id1, VarKey id2 -> Id.equal id1 id2
+  | RelKey k1, RelKey k2 -> Int.equal k1 k2
+  | _ -> false
+
+let eq_con_chk = Constant.UserOrd.equal
+let eq_mind_chk = MutInd.UserOrd.equal
+let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2
+
+
+(*******************************************************************)
+(** Compatibility layers *)
+
+(** Backward compatibility for [Id] *)
+
+type identifier = Id.t
+
+let id_eq = Id.equal
+let id_ord = Id.compare
+let string_of_id = Id.to_string
+let id_of_string = Id.of_string
+
+module Idset = Id.Set
+module Idmap = Id.Map
+module Idpred = Id.Pred
+
+(** Compatibility layer for [Name] *)
+
+let name_eq = Name.equal
 
-let eq_id_key ik1 ik2 =
-  match ik1,ik2 with
-    ConstKey (_,kn1),
-      ConstKey (_,kn2) -> kn1=kn2
-    | a,b -> a=b
+(** Compatibility layer for [DirPath] *)
+
+type dir_path = DirPath.t
+let dir_path_ord = DirPath.compare
+let dir_path_eq = DirPath.equal
+let make_dirpath = DirPath.make
+let repr_dirpath = DirPath.repr
+let empty_dirpath = DirPath.empty
+let is_empty_dirpath = DirPath.is_empty
+let string_of_dirpath = DirPath.to_string
+let initial_dir = DirPath.initial
+
+(** Compatibility layer for [MBId] *)
+
+type mod_bound_id = MBId.t
+let mod_bound_id_ord = MBId.compare
+let mod_bound_id_eq = MBId.equal
+let make_mbid = MBId.make
+let repr_mbid = MBId.repr
+let debug_string_of_mbid = MBId.debug_to_string
+let string_of_mbid = MBId.to_string
+let id_of_mbid = MBId.to_id
+
+(** Compatibility layer for [Label] *)
+
+type label = Id.t
+let mk_label = Label.make
+let string_of_label = Label.to_string
+let pr_label = Label.print
+let id_of_label = Label.to_id
+let label_of_id = Label.of_id
+let eq_label = Label.equal
+
+(** Compatibility layer for [ModPath] *)
+
+type module_path = ModPath.t =
+  | MPfile of DirPath.t
+  | MPbound of MBId.t
+  | MPdot of module_path * Label.t
+let check_bound_mp = ModPath.is_bound
+let string_of_mp = ModPath.to_string
+let mp_ord = ModPath.compare
+let mp_eq = ModPath.equal
+let initial_path = ModPath.initial
+
+(** Compatibility layer for [KerName] *)
+
+type kernel_name = KerName.t
+let make_kn = KerName.make
+let repr_kn = KerName.repr
+let modpath = KerName.modpath
+let label = KerName.label
+let string_of_kn = KerName.to_string
+let pr_kn = KerName.print
+let kn_ord = KerName.compare
+
+(** Compatibility layer for [Constant] *)
+
+type constant = Constant.t
+
+
+module Projection = 
+struct 
+  type t = constant * bool
+    
+  let make c b = (c, b)
+
+  let constant = fst
+  let unfolded = snd
+  let unfold (c, b as p) = if b then p else (c, true)
+  let equal (c, b) (c', b') = Constant.equal c c' && b == b'
+
+  let hash (c, b) = (if b then 0 else 1) + Constant.hash c
+
+  module Self_Hashcons =
+    struct
+      type _t = t
+      type t = _t
+      type u = Constant.t -> Constant.t
+      let hashcons hc (c,b) = (hc c,b)
+      let equal ((c,b) as x) ((c',b') as y) =
+        x == y || (c == c' && b == b')
+      let hash = hash
+    end
+
+  module HashProjection = Hashcons.Make(Self_Hashcons)
+
+  let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con
+
+  let compare (c, b) (c', b') =
+    if b == b' then Constant.CanOrd.compare c c'
+    else if b then 1 else -1
+
+  let map f (c, b as x) =
+    let c' = f c in
+      if c' == c then x else (c', b)
+end
 
-let eq_con_chk (kn1,_) (kn2,_) = kn1=kn2
-let eq_mind_chk (kn1,_) (kn2,_) = kn1=kn2
-let eq_ind_chk (kn1,i1) (kn2,i2) = i1=i2&&eq_mind_chk kn1 kn2
+type projection = Projection.t
+
+let constant_of_kn = Constant.make1
+let constant_of_kn_equiv = Constant.make
+let make_con = Constant.make3
+let repr_con = Constant.repr3
+let canonical_con = Constant.canonical
+let user_con = Constant.user
+let con_label = Constant.label
+let con_modpath = Constant.modpath
+let eq_constant = Constant.equal
+let eq_constant_key = Constant.UserOrd.equal
+let con_ord = Constant.CanOrd.compare
+let con_user_ord = Constant.UserOrd.compare
+let string_of_con = Constant.to_string
+let pr_con = Constant.print
+let debug_string_of_con = Constant.debug_to_string
+let debug_pr_con = Constant.debug_print
+let con_with_label = Constant.change_label
+
+(** Compatibility layer for [MutInd] *)
+
+type mutual_inductive = MutInd.t
+let mind_of_kn = MutInd.make1
+let mind_of_kn_equiv = MutInd.make
+let make_mind = MutInd.make3
+let canonical_mind = MutInd.canonical
+let user_mind = MutInd.user
+let repr_mind = MutInd.repr3
+let mind_label = MutInd.label
+let mind_modpath = MutInd.modpath
+let eq_mind = MutInd.equal
+let mind_ord = MutInd.CanOrd.compare
+let mind_user_ord = MutInd.UserOrd.compare
+let string_of_mind = MutInd.to_string
+let pr_mind = MutInd.print
+let debug_string_of_mind = MutInd.debug_to_string
+let debug_pr_mind = MutInd.debug_print
diff --git a/kernel/names.mli b/kernel/names.mli
index c23f526d..d82043da 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -1,222 +1,453 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Util
+
 (** {6 Identifiers } *)
 
-type identifier
+module Id :
+sig
+  type t
+  (** Type of identifiers *)
 
-(** Parsing and printing of identifiers *)
-val string_of_id : identifier -> string
-val id_of_string : string -> identifier
+  val equal : t -> t -> bool
+  (** Equality over identifiers *)
 
-val id_ord : identifier -> identifier -> int
+  val compare : t -> t -> int
+  (** Comparison over identifiers *)
+
+  val hash : t -> int
+  (** Hash over identifiers *)
+
+  val is_valid : string -> bool
+  (** Check that a string may be converted to an identifier. *)
+
+  val of_string : string -> t
+  (** Converts a string into an identifier. May raise [UserError _] if the
+      string is not valid. *)
+
+  val to_string : t -> string
+  (** Converts a identifier into an string. *)
+
+  val print : t -> Pp.std_ppcmds
+  (** Pretty-printer. *)
+
+  module Set : Set.S with type elt = t
+  (** Finite sets of identifiers. *)
+
+  module Map : Map.ExtS with type key = t and module Set := Set
+  (** Finite maps of identifiers. *)
+
+  module Pred : Predicate.S with type elt = t
+  (** Predicates over identifiers. *)
+
+  module List : List.MonoS with type elt = t
+  (** Operations over lists of identifiers. *)
+
+  val hcons : t -> t
+  (** Hashconsing of identifiers. *)
+
+end
+
+module Name :
+sig
+  type t = Name of Id.t | Anonymous
+  (** A name is either undefined, either an identifier. *)
+
+  val compare : t -> t -> int
+  (** Comparison over names. *)
+
+  val equal : t -> t -> bool
+  (** Equality over names. *)
+
+  val hash : t -> int
+  (** Hash over names. *)
+
+  val hcons : t -> t
+  (** Hashconsing over names. *)
 
-(** Identifiers sets and maps *)
-module Idset  : Set.S with type elt = identifier
-module Idpred : Predicate.S with type elt = identifier
-module Idmap  : sig
-  include Map.S with type key = identifier
-  val exists : (identifier -> 'a -> bool) -> 'a t -> bool
-  val singleton : key -> 'a -> 'a t
 end
 
-(** {6 Various types based on identifiers } *)
+(** {6 Type aliases} *)
+
+type name = Name.t = Name of Id.t | Anonymous
+type variable = Id.t
+type module_ident = Id.t
 
-type name = Name of identifier | Anonymous
-type variable = identifier
+module ModIdset : Set.S with type elt = module_ident
+module ModIdmap : Map.ExtS with type key = module_ident and module Set := ModIdset
 
 (** {6 Directory paths = section names paths } *)
 
-type module_ident = identifier
-module ModIdmap : Map.S with type key = module_ident
+module DirPath :
+sig
+  type t
+  (** Type of directory paths. Essentially a list of module identifiers. The
+      order is reversed to improve sharing. E.g. A.B.C is ["C";"B";"A"] *)
 
-type dir_path
+  val equal : t -> t -> bool
+  (** Equality over directory paths. *)
 
-(** Inner modules idents on top of list (to improve sharing).
-   For instance: A.B.C is ["C";"B";"A"] *)
-val make_dirpath : module_ident list -> dir_path
-val repr_dirpath : dir_path -> module_ident list
+  val compare : t -> t -> int
+  (** Comparison over directory paths. *)
 
-val empty_dirpath : dir_path
+  val hash : t -> int
+  (** Hash over directory paths. *)
 
-(** Printing of directory paths as ["coq_root.module.submodule"] *)
-val string_of_dirpath : dir_path -> string
+  val make : module_ident list -> t
+  (** Create a directory path. (The list must be reversed). *)
+
+  val repr : t -> module_ident list
+  (** Represent a directory path. (The result list is reversed). *)
+
+  val empty : t
+  (** The empty directory path. *)
+
+  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. *)
+
+end
 
 (** {6 Names of structure elements } *)
 
-type label
+module Label :
+sig
+  type t
+  (** Type of labels *)
 
-val mk_label : string -> label
-val string_of_label : label -> string
-val pr_label : label -> Pp.std_ppcmds
+  val equal : t -> t -> bool
+  (** Equality over labels *)
 
-val label_of_id : identifier -> label
-val id_of_label : label -> identifier
+  val compare : t -> t -> int
+  (** Comparison over labels. *)
 
-module Labset : Set.S with type elt = label
-module Labmap : Map.S with type key = label
+  val hash : t -> int
+  (** Hash over labels. *)
 
-(** {6 Unique names for bound modules } *)
+  val make : string -> t
+  (** Create a label out of a string. *)
 
-type mod_bound_id
+  val to_string : t -> string
+  (** Conversion to string. *)
 
-(** The first argument is a file name - to prevent conflict between
-   different files *)
+  val of_id : Id.t -> t
+  (** Conversion from an identifier. *)
 
-val make_mbid : dir_path -> identifier -> mod_bound_id
-val repr_mbid : mod_bound_id -> int * identifier * dir_path
-val id_of_mbid : mod_bound_id -> identifier
-val debug_string_of_mbid : mod_bound_id -> string
-val string_of_mbid : mod_bound_id -> string
+  val to_id : t -> Id.t
+  (** Conversion to an identifier. *)
+
+  val print : t -> Pp.std_ppcmds
+  (** Pretty-printer. *)
+
+  module Set : Set.S with type elt = t
+  module Map : Map.ExtS with type key = t and module Set := Set
+
+end
+
+(** {6 Unique names for bound modules} *)
+
+module MBId :
+sig
+  type t
+  (** Unique names for bound modules. Each call to [make] constructs a fresh
+      unique identifier. *)
+
+  val equal : t -> t -> bool
+  (** Equality over unique bound names. *)
+
+  val compare : t -> t -> int
+  (** Comparison over unique bound names. *)
+
+  val hash : t -> int
+  (** Hash over unique bound names. *)
+
+  val make : DirPath.t -> Id.t -> t
+  (** The first argument is a file name, to prevent conflict between different
+      files. *)
+
+  val repr : t -> int * Id.t * DirPath.t
+  (** Reverse of [make]. *)
+
+  val to_id : t -> Id.t
+  (** Return the identifier contained in the argument. *)
+
+  val to_string : t -> string
+  (** Conversion to a string. *)
+
+  val debug_to_string : t -> string
+  (** Same as [to_string], but outputs information related to debug. *)
+
+end
+
+module MBIset : Set.S with type elt = MBId.t
+module MBImap : Map.ExtS with type key = MBId.t and module Set := MBIset
 
 (** {6 The module part of the kernel name } *)
 
-type module_path =
-  | MPfile of dir_path
-  | MPbound of mod_bound_id
-  | MPdot of module_path * label
+module ModPath :
+sig
+  type t =
+    | MPfile of DirPath.t
+    | MPbound of MBId.t
+    | MPdot of t * Label.t
 
-val check_bound_mp : module_path -> bool
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
 
-val string_of_mp : module_path -> string
+  val is_bound : t -> bool
 
-module MPset : Set.S with type elt = module_path
-module MPmap : Map.S with type key = module_path
+  val to_string : t -> string
 
-(** Initial "seed" of the unique identifier generator *)
-val initial_dir : dir_path
+  val initial : t
+  (** Name of the toplevel structure ([= MPfile initial_dir]) *)
 
-(** Name of the toplevel structure *)
-val initial_path : module_path (** [= MPfile initial_dir] *)
+  val dp : t -> DirPath.t
+
+end
+
+module MPset : Set.S with type elt = ModPath.t
+module MPmap : Map.ExtS with type key = ModPath.t and module Set := MPset
 
 (** {6 The absolute names of objects seen by kernel } *)
 
-type kernel_name
+module KerName :
+sig
+  type t
 
-(** Constructor and destructor *)
-val make_kn : module_path -> dir_path -> label -> kernel_name
-val repr_kn : kernel_name -> module_path * dir_path * label
+  (** Constructor and destructor *)
+  val make : ModPath.t -> DirPath.t -> Label.t -> t
+  val make2 : ModPath.t -> Label.t -> t
+  val repr : t -> ModPath.t * DirPath.t * Label.t
 
-val modpath : kernel_name -> module_path
-val label : kernel_name -> label
+  (** Projections *)
+  val modpath : t -> ModPath.t
+  val label : t -> Label.t
 
-val string_of_kn : kernel_name -> string
-val pr_kn : kernel_name -> Pp.std_ppcmds
+  (** Display *)
+  val to_string : t -> string
+  val print : t -> Pp.std_ppcmds
 
-val kn_ord : kernel_name -> kernel_name -> int
+  (** Comparisons *)
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
 
-module KNset  : Set.S with type elt = kernel_name
-module KNpred : Predicate.S with type elt = kernel_name
-module KNmap  : Map.S with type key = kernel_name
+module KNset  : CSig.SetS with type elt = KerName.t
+module KNpred : Predicate.S with type elt = KerName.t
+module KNmap  : Map.ExtS with type key = KerName.t and module Set := KNset
 
 
-(** {6 Specific paths for declarations } *)
+(** {6 Constant Names } *)
 
-type constant
-type mutual_inductive
+module Constant:
+sig
+  type t
 
-(** Beware: first inductive has index 0 *)
-type inductive = mutual_inductive * int
+  (** Constructors *)
 
-(** Beware: first constructor has index 1 *)
-type constructor = inductive * int
+  val make : KerName.t -> KerName.t -> t
+  (** Builds a constant name from a user and a canonical kernel name. *)
+
+  val make1 : KerName.t -> t
+  (** Special case of [make] where the user name is canonical.  *)
+
+  val make2 : ModPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make2 ...))] *)
+
+  val make3 : ModPath.t -> DirPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make ...))] *)
+
+  (** Projections *)
+
+  val user : t -> KerName.t
+  val canonical : t -> KerName.t
+
+  val repr3 : t -> ModPath.t * DirPath.t * Label.t
+  (** Shortcut for [KerName.repr (user ...)] *)
+
+  val modpath : t -> ModPath.t
+  (** Shortcut for [KerName.modpath (user ...)] *)
+
+  val label : t -> Label.t
+  (** Shortcut for [KerName.label (user ...)] *)
+
+  (** Comparisons *)
+
+  module CanOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
 
-(** *_env modules consider an order on user part of names
+  module UserOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
+  val equal : t -> t -> bool
+  (** Default comparison, alias for [CanOrd.equal] *)
+
+  val hash : t -> int
+  (** Hashing function *)
+
+  val change_label : t -> Label.t -> t
+  (** Builds a new constant name with a different label *)
+
+  (** Displaying *)
+
+  val to_string : t -> string
+  val print : t -> Pp.std_ppcmds
+  val debug_to_string : t -> string
+  val debug_print : t -> Pp.std_ppcmds
+
+end
+
+(** The [*_env] modules consider an order on user part of names
    the others consider an order on canonical part of names*)
-module Cmap  : Map.S with type key = constant
-module Cmap_env  : Map.S with type key = constant
-module Cpred  : Predicate.S with type elt = constant
-module Cset  : Set.S with type elt = constant
-module Cset_env  : Set.S with type elt = constant
-module Mindmap : Map.S with type key = mutual_inductive
-module Mindmap_env : Map.S with type key = mutual_inductive
-module Mindset : Set.S with type elt = mutual_inductive
-module Indmap : Map.S with type key = inductive
-module Constrmap : Map.S with type key = constructor
-module Indmap_env : Map.S with type key = inductive
-module Constrmap_env : Map.S with type key = constructor
+module Cpred : Predicate.S with type elt = Constant.t
+module Cset : CSig.SetS with type elt = Constant.t
+module Cset_env  : CSig.SetS with type elt = Constant.t
+module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset
+module Cmap_env : Map.ExtS with type key = Constant.t  and module Set := Cset_env
 
-val constant_of_kn : kernel_name -> constant
-val constant_of_kn_equiv : kernel_name -> kernel_name -> constant
-val make_con : module_path -> dir_path -> label -> constant
-val make_con_equiv : module_path -> module_path -> dir_path 
-  -> label -> constant
-val user_con : constant -> kernel_name
-val canonical_con : constant -> kernel_name
-val repr_con : constant -> module_path * dir_path * label
-val eq_constant : constant -> constant -> bool
-val con_with_label : constant -> label -> constant
+(** {6 Inductive names} *)
 
-val string_of_con : constant -> string
-val con_label : constant -> label
-val con_modpath : constant -> module_path
-val pr_con : constant -> Pp.std_ppcmds
-val debug_pr_con : constant -> Pp.std_ppcmds
-val debug_string_of_con : constant -> string
+module MutInd :
+sig
+  type t
 
+  (** Constructors *)
 
+  val make : KerName.t -> KerName.t -> t
+  (** Builds a mutual inductive name from a user and a canonical kernel name. *)
 
-val mind_of_kn : kernel_name -> mutual_inductive
-val mind_of_kn_equiv : kernel_name -> kernel_name -> mutual_inductive
-val make_mind : module_path -> dir_path -> label -> mutual_inductive
-val make_mind_equiv : module_path -> module_path -> dir_path 
-  -> label -> mutual_inductive
-val user_mind : mutual_inductive -> kernel_name
-val canonical_mind : mutual_inductive -> kernel_name
-val repr_mind : mutual_inductive -> module_path * dir_path * label
-val eq_mind : mutual_inductive -> mutual_inductive -> bool
+  val make1 : KerName.t -> t
+  (** Special case of [make] where the user name is canonical.  *)
 
-val string_of_mind : mutual_inductive -> string
-val mind_label : mutual_inductive -> label
-val mind_modpath : mutual_inductive -> module_path
-val pr_mind : mutual_inductive -> Pp.std_ppcmds
-val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds
-val debug_string_of_mind : mutual_inductive -> string
+  val make2 : ModPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make2 ...))] *)
+
+  val make3 : ModPath.t -> DirPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make ...))] *)
+
+  (** Projections *)
+
+  val user : t -> KerName.t
+  val canonical : t -> KerName.t
+
+  val repr3 : t -> ModPath.t * DirPath.t * Label.t
+  (** Shortcut for [KerName.repr (user ...)] *)
+
+  val modpath : t -> ModPath.t
+  (** Shortcut for [KerName.modpath (user ...)] *)
+
+  val label : t -> Label.t
+  (** Shortcut for [KerName.label (user ...)] *)
+
+  (** Comparisons *)
+
+  module CanOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
+  module UserOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
 
+  val equal : t -> t -> bool
+  (** Default comparison, alias for [CanOrd.equal] *)
 
+  val hash : t -> int
+
+  (** Displaying *)
+
+  val to_string : t -> string
+  val print : t -> Pp.std_ppcmds
+  val debug_to_string : t -> string
+  val debug_print : t -> Pp.std_ppcmds
+
+end
+
+module Mindset : CSig.SetS with type elt = MutInd.t
+module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset
+module Mindmap_env : Map.S with type key = MutInd.t
+
+(** Beware: first inductive has index 0 *)
+type inductive = MutInd.t * int
+
+(** Beware: first constructor has index 1 *)
+type constructor = inductive * int
+
+module Indmap : Map.S with type key = inductive
+module Constrmap : Map.S with type key = constructor
+module Indmap_env : Map.S with type key = inductive
+module Constrmap_env : Map.S with type key = constructor
 
-val ind_modpath : inductive -> module_path
-val constr_modpath : constructor -> module_path
+val ind_modpath : inductive -> ModPath.t
+val constr_modpath : constructor -> ModPath.t
 
 val ith_mutual_inductive : inductive -> int -> inductive
 val ith_constructor_of_inductive : inductive -> int -> constructor
 val inductive_of_constructor : constructor -> inductive
 val index_of_constructor : constructor -> int
 val eq_ind : inductive -> inductive -> bool
+val eq_user_ind : inductive -> inductive -> bool
+val ind_ord : inductive -> inductive -> int
+val ind_hash : inductive -> int
+val ind_user_ord : inductive -> inductive -> int
+val ind_user_hash : inductive -> int
 val eq_constructor : constructor -> constructor -> bool
+val eq_user_constructor : constructor -> constructor -> bool
+val constructor_ord : constructor -> constructor -> int
+val constructor_user_ord : constructor -> constructor -> int
+val constructor_hash : constructor -> int
+val constructor_user_hash : constructor -> int
 
 (** Better to have it here that in Closure, since required in grammar.cma *)
 type evaluable_global_reference =
-  | EvalVarRef of identifier
-  | EvalConstRef of constant
+  | EvalVarRef of Id.t
+  | EvalConstRef of Constant.t
 
 val eq_egr : evaluable_global_reference ->  evaluable_global_reference
   -> bool
 
 (** {6 Hash-consing } *)
 
-val hcons_string : string -> string
-val hcons_ident : identifier -> identifier
-val hcons_name : name -> name
-val hcons_dirpath : dir_path -> dir_path
-val hcons_con : constant -> constant
-val hcons_mind : mutual_inductive -> mutual_inductive
+val hcons_con : Constant.t -> Constant.t
+val hcons_mind : MutInd.t -> MutInd.t
 val hcons_ind : inductive -> inductive
 val hcons_construct : constructor -> constructor
 
 (******)
 
 type 'a tableKey =
-  | ConstKey of constant
-  | VarKey of identifier
-  | RelKey of 'a
+  | ConstKey of 'a
+  | VarKey of Id.t
+  | RelKey of Int.t
 
-type transparent_state = Idpred.t * Cpred.t
+(** Sets of names *)
+type transparent_state = Id.Pred.t * Cpred.t
 
 val empty_transparent_state : transparent_state
 val full_transparent_state : transparent_state
@@ -227,13 +458,294 @@ type inv_rel_key = int (** index in the [rel_context] part of environment
 			  starting by the end, {e inverse}
 			  of de Bruijn indice *)
 
-type id_key = inv_rel_key tableKey
+val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool
+val eq_constant_key : Constant.t -> Constant.t -> bool
 
-val eq_id_key : id_key -> id_key -> bool
+(** equalities on constant and inductive names (for the checker) *)
 
-(*equalities on constant and inductive 
-  names for the checker*)
-
-val eq_con_chk : constant -> constant -> bool
+val eq_con_chk : Constant.t -> Constant.t -> bool
 val eq_ind_chk : inductive -> inductive -> bool
 
+(** {6 Deprecated functions. For backward compatibility.} *)
+
+(** {5 Identifiers} *)
+
+type identifier = Id.t
+(** @deprecated Alias for [Id.t] *)
+
+val string_of_id : identifier -> string
+(** @deprecated Same as [Id.to_string]. *)
+
+val id_of_string : string -> identifier
+(** @deprecated Same as [Id.of_string]. *)
+
+val id_ord : identifier -> identifier -> int
+(** @deprecated Same as [Id.compare]. *)
+
+val id_eq : identifier -> identifier -> bool
+(** @deprecated Same as [Id.equal]. *)
+
+module Idset  : Set.S with type elt = identifier and type t = Id.Set.t
+(** @deprecated Same as [Id.Set]. *)
+
+module Idpred : Predicate.S with type elt = identifier and type t = Id.Pred.t
+(** @deprecated Same as [Id.Pred]. *)
+
+module Idmap : module type of Id.Map
+(** @deprecated Same as [Id.Map]. *)
+
+(** {5 Directory paths} *)
+
+type dir_path = DirPath.t
+(** @deprecated Alias for [DirPath.t]. *)
+
+val dir_path_ord : dir_path -> dir_path -> int
+(** @deprecated Same as [DirPath.compare]. *)
+
+val dir_path_eq : dir_path -> dir_path -> bool
+(** @deprecated Same as [DirPath.equal]. *)
+
+val make_dirpath : module_ident list -> dir_path
+(** @deprecated Same as [DirPath.make]. *)
+
+val repr_dirpath : dir_path -> module_ident list
+(** @deprecated Same as [DirPath.repr]. *)
+
+val empty_dirpath : dir_path
+(** @deprecated Same as [DirPath.empty]. *)
+
+val is_empty_dirpath : dir_path -> bool
+(** @deprecated Same as [DirPath.is_empty]. *)
+
+val string_of_dirpath : dir_path -> string
+(** @deprecated Same as [DirPath.to_string]. *)
+
+val initial_dir : DirPath.t
+(** @deprecated Same as [DirPath.initial]. *)
+
+(** {5 Labels} *)
+
+type label = Label.t
+(** Alias type *)
+
+val mk_label : string -> label
+(** @deprecated Same as [Label.make]. *)
+
+val string_of_label : label -> string
+(** @deprecated Same as [Label.to_string]. *)
+
+val pr_label : label -> Pp.std_ppcmds
+(** @deprecated Same as [Label.print]. *)
+
+val label_of_id : Id.t -> label
+(** @deprecated Same as [Label.of_id]. *)
+
+val id_of_label : label -> Id.t
+(** @deprecated Same as [Label.to_id]. *)
+
+val eq_label : label -> label -> bool
+(** @deprecated Same as [Label.equal]. *)
+
+(** {5 Unique bound module names} *)
+
+type mod_bound_id = MBId.t
+(** Alias type. *)
+
+val mod_bound_id_ord : mod_bound_id -> mod_bound_id -> int
+(** @deprecated Same as [MBId.compare]. *)
+
+val mod_bound_id_eq : mod_bound_id -> mod_bound_id -> bool
+(** @deprecated Same as [MBId.equal]. *)
+
+val make_mbid : DirPath.t -> Id.t -> mod_bound_id
+(** @deprecated Same as [MBId.make]. *)
+
+val repr_mbid : mod_bound_id -> int * Id.t * DirPath.t
+(** @deprecated Same as [MBId.repr]. *)
+
+val id_of_mbid : mod_bound_id -> Id.t
+(** @deprecated Same as [MBId.to_id]. *)
+
+val string_of_mbid : mod_bound_id -> string
+(** @deprecated Same as [MBId.to_string]. *)
+
+val debug_string_of_mbid : mod_bound_id -> string
+(** @deprecated Same as [MBId.debug_to_string]. *)
+
+(** {5 Names} *)
+
+val name_eq : name -> name -> bool
+(** @deprecated Same as [Name.equal]. *)
+
+(** {5 Module paths} *)
+
+type module_path = ModPath.t =
+  | MPfile of DirPath.t
+  | MPbound of MBId.t
+  | MPdot of module_path * Label.t
+(** @deprecated Alias type *)
+
+val mp_ord : module_path -> module_path -> int
+(** @deprecated Same as [ModPath.compare]. *)
+
+val mp_eq : module_path -> module_path -> bool
+(** @deprecated Same as [ModPath.equal]. *)
+
+val check_bound_mp : module_path -> bool
+(** @deprecated Same as [ModPath.is_bound]. *)
+
+val string_of_mp : module_path -> string
+(** @deprecated Same as [ModPath.to_string]. *)
+
+val initial_path : module_path
+(** @deprecated Same as [ModPath.initial]. *)
+
+(** {5 Kernel names} *)
+
+type kernel_name = KerName.t
+(** @deprecated Alias type *)
+
+val make_kn : ModPath.t -> DirPath.t -> Label.t -> kernel_name
+(** @deprecated Same as [KerName.make]. *)
+
+val repr_kn : kernel_name -> module_path * DirPath.t * Label.t
+(** @deprecated Same as [KerName.repr]. *)
+
+val modpath : kernel_name -> module_path
+(** @deprecated Same as [KerName.modpath]. *)
+
+val label : kernel_name -> Label.t
+(** @deprecated Same as [KerName.label]. *)
+
+val string_of_kn : kernel_name -> string
+(** @deprecated Same as [KerName.to_string]. *)
+
+val pr_kn : kernel_name -> Pp.std_ppcmds
+(** @deprecated Same as [KerName.print]. *)
+
+val kn_ord : kernel_name -> kernel_name -> int
+(** @deprecated Same as [KerName.compare]. *)
+
+(** {5 Constant names} *)
+
+type constant = Constant.t
+(** @deprecated Alias type *)
+
+module Projection : sig
+  type t
+    
+  val make : constant -> bool -> t
+
+  val constant : t -> constant
+  val unfolded : t -> bool
+  val unfold : t -> t
+
+  val equal : t -> t -> bool
+  val hash : t -> int
+  val hcons : t -> t
+  (** Hashconsing of projections. *)
+
+  val compare : t -> t -> int
+    
+  val map : (constant -> constant) -> t -> t
+end
+
+type projection = Projection.t
+
+val constant_of_kn_equiv : KerName.t -> KerName.t -> constant
+(** @deprecated Same as [Constant.make] *)
+
+val constant_of_kn : KerName.t -> constant
+(** @deprecated Same as [Constant.make1] *)
+
+val make_con : ModPath.t -> DirPath.t -> Label.t -> constant
+(** @deprecated Same as [Constant.make3] *)
+
+val repr_con : constant -> ModPath.t * DirPath.t * Label.t
+(** @deprecated Same as [Constant.repr3] *)
+
+val user_con : constant -> KerName.t
+(** @deprecated Same as [Constant.user] *)
+
+val canonical_con : constant -> KerName.t
+(** @deprecated Same as [Constant.canonical] *)
+
+val con_modpath : constant -> ModPath.t
+(** @deprecated Same as [Constant.modpath] *)
+
+val con_label : constant -> Label.t
+(** @deprecated Same as [Constant.label] *)
+
+val eq_constant : constant -> constant -> bool
+(** @deprecated Same as [Constant.equal] *)
+
+val con_ord : constant -> constant -> int
+(** @deprecated Same as [Constant.CanOrd.compare] *)
+
+val con_user_ord : constant -> constant -> int
+(** @deprecated Same as [Constant.UserOrd.compare] *)
+
+val con_with_label : constant -> Label.t -> constant
+(** @deprecated Same as [Constant.change_label] *)
+
+val string_of_con : constant -> string
+(** @deprecated Same as [Constant.to_string] *)
+
+val pr_con : constant -> Pp.std_ppcmds
+(** @deprecated Same as [Constant.print] *)
+
+val debug_pr_con : constant -> Pp.std_ppcmds
+(** @deprecated Same as [Constant.debug_print] *)
+
+val debug_string_of_con : constant -> string
+(** @deprecated Same as [Constant.debug_to_string] *)
+
+(** {5 Mutual Inductive names} *)
+
+type mutual_inductive = MutInd.t
+(** @deprecated Alias type *)
+
+val mind_of_kn : KerName.t -> mutual_inductive
+(** @deprecated Same as [MutInd.make1] *)
+
+val mind_of_kn_equiv : KerName.t -> KerName.t -> mutual_inductive
+(** @deprecated Same as [MutInd.make2] *)
+
+val make_mind : ModPath.t -> DirPath.t -> Label.t -> mutual_inductive
+(** @deprecated Same as [MutInd.make3] *)
+
+val user_mind : mutual_inductive -> KerName.t
+(** @deprecated Same as [MutInd.user] *)
+
+val canonical_mind : mutual_inductive -> KerName.t
+(** @deprecated Same as [MutInd.canonical] *)
+
+val repr_mind : mutual_inductive -> ModPath.t * DirPath.t * Label.t
+(** @deprecated Same as [MutInd.repr3] *)
+
+val eq_mind : mutual_inductive -> mutual_inductive -> bool
+(** @deprecated Same as [MutInd.equal] *)
+
+val mind_ord : mutual_inductive -> mutual_inductive -> int
+(** @deprecated Same as [MutInd.CanOrd.compare] *)
+
+val mind_user_ord : mutual_inductive -> mutual_inductive -> int
+(** @deprecated Same as [MutInd.UserOrd.compare] *)
+
+val mind_label : mutual_inductive -> Label.t
+(** @deprecated Same as [MutInd.label] *)
+
+val mind_modpath : mutual_inductive -> ModPath.t
+(** @deprecated Same as [MutInd.modpath] *)
+
+val string_of_mind : mutual_inductive -> string
+(** @deprecated Same as [MutInd.to_string] *)
+
+val pr_mind : mutual_inductive -> Pp.std_ppcmds
+(** @deprecated Same as [MutInd.print] *)
+
+val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds
+(** @deprecated Same as [MutInd.debug_print] *)
+
+val debug_string_of_mind : mutual_inductive -> string
+(** @deprecated Same as [MutInd.debug_to_string] *)
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
new file mode 100644
index 00000000..1a4a4b54
--- /dev/null
+++ b/kernel/nativecode.ml
@@ -0,0 +1,2117 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Errors
+open Names
+open Term
+open Context
+open Declarations
+open Util
+open Nativevalues
+open Primitives
+open Nativeinstr
+open Nativelambda
+open Pre_env
+
+(** This file defines the mllambda code generation phase of the native
+compiler. mllambda represents a fragment of ML, and can easily be printed
+to OCaml code. *)
+
+(** Local names **)
+
+type lname = { lname : name; luid : int }
+
+let dummy_lname = { lname = Anonymous; luid = -1 }
+
+module LNord = 
+  struct 
+    type t = lname 
+    let compare l1 l2 = l1.luid - l2.luid
+  end
+module LNmap = Map.Make(LNord)
+module LNset = Set.Make(LNord)
+
+let lname_ctr = ref (-1)
+
+let reset_lname = lname_ctr := -1
+
+let fresh_lname n = 
+  incr lname_ctr;
+  { lname = n; luid = !lname_ctr }
+
+(** Global names **)
+type gname = 
+  | Gind of string * pinductive (* prefix, inductive name *)
+  | Gconstruct of string * pconstructor (* prefix, constructor name *)
+  | Gconstant of string * pconstant (* prefix, constant name *)
+  | Gproj of string * constant (* prefix, constant name *)
+  | Gcase of label option * int
+  | Gpred of label option * int
+  | Gfixtype of label option * int
+  | Gnorm of label option * int
+  | Gnormtbl of label option * int
+  | Ginternal of string
+  | Grel of int
+  | Gnamed of identifier
+
+let eq_gname gn1 gn2 =
+  match gn1, gn2 with
+  | Gind (s1, ind1), Gind (s2, ind2) ->
+     String.equal s1 s2 && Univ.eq_puniverses eq_ind ind1 ind2
+  | Gconstruct (s1, c1), Gconstruct (s2, c2) ->
+      String.equal s1 s2 && Univ.eq_puniverses eq_constructor c1 c2
+  | Gconstant (s1, c1), Gconstant (s2, c2) ->
+      String.equal s1 s2 && Univ.eq_puniverses Constant.equal c1 c2
+  | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2
+  | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
+  | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2
+  | Gpred (Some l1, i1), Gpred (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
+  | Gfixtype (None, i1), Gfixtype (None, i2) -> Int.equal i1 i2
+  | Gfixtype (Some l1, i1), Gfixtype (Some l2, i2) ->
+      Int.equal i1 i2 && Label.equal l1 l2
+  | Gnorm (None, i1), Gnorm (None, i2) -> Int.equal i1 i2
+  | Gnorm (Some l1, i1), Gnorm (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
+  | Gnormtbl (None, i1), Gnormtbl (None, i2) -> Int.equal i1 i2
+  | Gnormtbl (Some l1, i1), Gnormtbl (Some l2, i2) ->
+      Int.equal i1 i2 && Label.equal l1 l2
+  | Ginternal s1, Ginternal s2 -> String.equal s1 s2
+  | Grel i1, Grel i2 -> Int.equal i1 i2
+  | Gnamed id1, Gnamed id2 -> Id.equal id1 id2
+  | _ -> false
+
+open Hashset.Combine
+
+let gname_hash gn = match gn with
+| Gind (s, (ind,u)) ->
+   combinesmall 1 (combine3 (String.hash s) (ind_hash ind) (Univ.Instance.hash u))
+| Gconstruct (s, (c,u)) ->
+   combinesmall 2 (combine3 (String.hash s) (constructor_hash c) (Univ.Instance.hash u))
+| Gconstant (s, (c,u)) ->
+   combinesmall 3 (combine3 (String.hash s) (Constant.hash c) (Univ.Instance.hash u))
+| Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gnorm (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gnormtbl (l, i) -> combinesmall 8 (combine (Option.hash Label.hash l) (Int.hash i))
+| Ginternal s -> combinesmall 9 (String.hash s)
+| Grel i -> combinesmall 10 (Int.hash i)
+| Gnamed id -> combinesmall 11 (Id.hash id)
+| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p))
+
+let case_ctr = ref (-1)
+
+let reset_gcase () = case_ctr := -1
+
+let fresh_gcase l =
+  incr case_ctr;
+  Gcase (l,!case_ctr)
+
+let pred_ctr = ref (-1)
+
+let reset_gpred () = pred_ctr := -1
+
+let fresh_gpred l = 
+  incr pred_ctr;
+  Gpred (l,!pred_ctr)
+
+let fixtype_ctr = ref (-1)
+
+let reset_gfixtype () = fixtype_ctr := -1
+
+let fresh_gfixtype l =
+  incr fixtype_ctr;
+  Gfixtype (l,!fixtype_ctr)
+
+let norm_ctr = ref (-1)
+
+let reset_norm () = norm_ctr := -1
+
+let fresh_gnorm l =
+  incr norm_ctr;
+  Gnorm (l,!norm_ctr)
+
+let normtbl_ctr = ref (-1)
+
+let reset_normtbl () = normtbl_ctr := -1
+
+let fresh_gnormtbl l =
+  incr normtbl_ctr;
+  Gnormtbl (l,!normtbl_ctr)
+
+(** Symbols (pre-computed values) **)
+
+type symbol =
+  | SymbValue of Nativevalues.t
+  | SymbSort of sorts
+  | SymbName of name
+  | SymbConst of constant
+  | SymbMatch of annot_sw
+  | SymbInd of inductive
+  | SymbMeta of metavariable
+  | SymbEvar of existential
+  | SymbLevel of Univ.Level.t
+
+let dummy_symb = SymbValue (dummy_value ())
+
+let eq_symbol sy1 sy2 =
+  match sy1, sy2 with
+  | SymbValue v1, SymbValue v2 -> Pervasives.(=) v1 v2 (** FIXME: how is this even valid? *)
+  | SymbSort s1, SymbSort s2 -> Sorts.equal s1 s2
+  | SymbName n1, SymbName n2 -> Name.equal n1 n2
+  | SymbConst kn1, SymbConst kn2 -> Constant.equal kn1 kn2
+  | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2
+  | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2
+  | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2
+  | SymbEvar (evk1,args1), SymbEvar (evk2,args2) ->
+     Evar.equal evk1 evk2 && Array.for_all2 eq_constr args1 args2
+  | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2
+  | _, _ -> false
+
+let hash_symbol symb =
+  match symb with
+  | SymbValue v -> combinesmall 1 (Hashtbl.hash v) (** FIXME *)
+  | SymbSort s -> combinesmall 2 (Sorts.hash s)
+  | SymbName name -> combinesmall 3 (Name.hash name)
+  | SymbConst c -> combinesmall 4 (Constant.hash c)
+  | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw)
+  | SymbInd ind -> combinesmall 6 (ind_hash ind)
+  | SymbMeta m -> combinesmall 7 m
+  | SymbEvar (evk,args) ->
+     let evh = Evar.hash evk in
+     let hl = Array.fold_left (fun h t -> combine h (Constr.hash t)) evh args in
+     combinesmall 8 hl
+  | SymbLevel l -> combinesmall 9 (Univ.Level.hash l)
+
+module HashedTypeSymbol = struct
+  type t = symbol
+  let equal = eq_symbol
+  let hash = hash_symbol
+end
+
+module HashtblSymbol = Hashtbl.Make(HashedTypeSymbol)
+
+let symb_tbl = HashtblSymbol.create 211
+
+let clear_symb_tbl () = HashtblSymbol.clear symb_tbl
+
+let get_value tbl i =
+  match tbl.(i) with
+    | SymbValue v -> v
+    | _ -> anomaly (Pp.str "get_value failed")
+
+let get_sort tbl i =
+  match tbl.(i) with
+    | SymbSort s -> s
+    | _ -> anomaly (Pp.str "get_sort failed")
+
+let get_name tbl i =
+  match tbl.(i) with
+    | SymbName id -> id
+    | _ -> anomaly (Pp.str "get_name failed")
+
+let get_const tbl i =
+  match tbl.(i) with
+    | SymbConst kn -> kn
+    | _ -> anomaly (Pp.str "get_const failed")
+
+let get_match tbl i =
+  match tbl.(i) with
+    | SymbMatch case_info -> case_info
+    | _ -> anomaly (Pp.str "get_match failed")
+
+let get_ind tbl i =
+  match tbl.(i) with
+    | SymbInd ind -> ind
+    | _ -> anomaly (Pp.str "get_ind failed")
+
+let get_meta tbl i =
+  match tbl.(i) with
+    | SymbMeta m -> m
+    | _ -> anomaly (Pp.str "get_meta failed")
+
+let get_evar tbl i =
+  match tbl.(i) with
+    | SymbEvar ev -> ev
+    | _ -> anomaly (Pp.str "get_evar failed")
+
+let get_level tbl i =
+  match tbl.(i) with
+    | SymbLevel u -> u
+    | _ -> anomaly (Pp.str "get_level failed")
+
+let push_symbol x =
+  try HashtblSymbol.find symb_tbl x
+  with Not_found ->
+    let i = HashtblSymbol.length symb_tbl in
+    HashtblSymbol.add symb_tbl x i; i
+
+let symbols_tbl_name = Ginternal "symbols_tbl"
+
+let get_symbols_tbl () =
+  let tbl = Array.make (HashtblSymbol.length symb_tbl) dummy_symb in
+  HashtblSymbol.iter (fun x i -> tbl.(i) <- x) symb_tbl; tbl
+
+(** Lambda to Mllambda **)
+
+type primitive =
+  | Mk_prod
+  | Mk_sort
+  | Mk_ind
+  | Mk_const
+  | Mk_sw
+  | Mk_fix of rec_pos * int 
+  | Mk_cofix of int
+  | Mk_rel of int
+  | Mk_var of identifier
+  | Mk_proj
+  | Is_accu
+  | Is_int
+  | Cast_accu
+  | Upd_cofix
+  | Force_cofix
+  | Mk_uint
+  | Mk_int
+  | Mk_bool
+  | Val_to_int
+  | Mk_I31_accu
+  | Decomp_uint
+  | Mk_meta
+  | Mk_evar
+  | MLand
+  | MLle
+  | MLlt
+  | MLinteq
+  | MLlsl
+  | MLlsr
+  | MLland
+  | MLlor
+  | MLlxor
+  | MLadd
+  | MLsub
+  | MLmul
+  | MLmagic
+  | MLarrayget
+  | Mk_empty_instance
+  | Coq_primitive of Primitives.t * (prefix * constant) option
+
+let eq_primitive p1 p2 =
+  match p1, p2 with
+  | Mk_prod, Mk_prod -> true
+  | Mk_sort, Mk_sort -> true
+  | Mk_ind, Mk_ind -> true
+  | Mk_const, Mk_const -> true
+  | Mk_sw, Mk_sw -> true
+  | Mk_fix (rp1, i1), Mk_fix (rp2, i2) -> Int.equal i1 i2 && eq_rec_pos rp1 rp2
+  | Mk_cofix i1, Mk_cofix i2 -> Int.equal i1 i2
+  | Mk_rel i1, Mk_rel i2 -> Int.equal i1 i2
+  | Mk_var id1, Mk_var id2 -> Id.equal id1 id2
+  | Is_accu, Is_accu -> true
+  | Cast_accu, Cast_accu -> true
+  | Upd_cofix, Upd_cofix -> true
+  | Force_cofix, Force_cofix -> true
+  | Mk_meta, Mk_meta -> true
+  | Mk_evar, Mk_evar -> true
+  | Mk_proj, Mk_proj -> true
+  | MLarrayget, MLarrayget -> true
+
+  | _ -> false
+
+let primitive_hash = function
+  | Mk_prod -> 1
+  | Mk_sort -> 2
+  | Mk_ind -> 3
+  | Mk_const -> 4
+  | Mk_sw -> 5
+  | Mk_fix (r, i) ->
+     let h = Array.fold_left (fun h i -> combine h (Int.hash i)) 0 r in
+     combinesmall 6 (combine h (Int.hash i))
+  | Mk_cofix i ->
+     combinesmall 7 (Int.hash i)
+  | Mk_rel i ->
+     combinesmall 8 (Int.hash i)
+  | Mk_var id ->
+     combinesmall 9 (Id.hash id)
+  | Is_accu -> 10
+  | Is_int -> 11
+  | Cast_accu -> 12
+  | Upd_cofix -> 13
+  | Force_cofix -> 14
+  | Mk_uint -> 15
+  | 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 (Primitives.hash prim)
+  | Coq_primitive (prim, Some (prefix,kn)) ->
+     combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim))
+  | Mk_proj -> 38
+  | MLarrayget -> 39
+  | Mk_empty_instance -> 40
+
+type mllambda =
+  | MLlocal        of lname 
+  | MLglobal       of gname 
+  | MLprimitive    of primitive
+  | MLlam          of lname array * mllambda 
+  | MLletrec       of (lname * lname array * mllambda) array * mllambda
+  | MLlet          of lname * mllambda * mllambda
+  | MLapp          of mllambda * mllambda array
+  | MLif           of mllambda * mllambda * mllambda
+  | MLmatch        of annot_sw * mllambda * mllambda * mllam_branches
+                              (* argument, prefix, accu branch, branches *)
+  | MLconstruct    of string * constructor * mllambda array
+                   (* prefix, constructor name, arguments *)
+  | MLint          of int
+  | MLuint         of Uint31.t
+  | MLsetref       of string * mllambda
+  | MLsequence     of mllambda * mllambda
+  | MLarray        of mllambda array
+
+and mllam_branches = ((constructor * lname option array) list * mllambda) array
+
+let push_lnames n env lns =
+  snd (Array.fold_left (fun (i,r) x -> (i+1, LNmap.add x i r)) (n,env) lns)
+
+let opush_lnames n env lns =
+  let oadd x i r = match x with Some ln -> LNmap.add ln i r | None -> r in
+  snd (Array.fold_left (fun (i,r) x -> (i+1, oadd x i r)) (n,env) lns)
+
+(* Alpha-equivalence on mllambda *)
+(* eq_mllambda gn1 gn2 n env1 env2 t1 t2 tests if t1 = t2 modulo gn1 = gn2 *)
+let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 =
+  match t1, t2 with
+  | MLlocal ln1, MLlocal ln2 ->
+      Int.equal (LNmap.find ln1 env1) (LNmap.find ln2 env2)
+  | MLglobal gn1', MLglobal gn2' ->
+      eq_gname gn1' gn2' || (eq_gname gn1 gn1' && eq_gname gn2 gn2')
+  | MLprimitive prim1, MLprimitive prim2 -> eq_primitive prim1 prim2
+  | MLlam (lns1, ml1), MLlam (lns2, ml2) ->
+      Int.equal (Array.length lns1) (Array.length lns2) &&
+      let env1 = push_lnames n env1 lns1 in
+      let env2 = push_lnames n env2 lns2 in
+      eq_mllambda gn1 gn2 (n+Array.length lns1) env1 env2 ml1 ml2
+  | MLletrec (defs1, body1), MLletrec (defs2, body2) ->
+      Int.equal (Array.length defs1) (Array.length defs2) &&
+      let lns1 = Array.map (fun (x,_,_) -> x) defs1 in
+      let lns2 = Array.map (fun (x,_,_) -> x) defs2 in
+      let env1 = push_lnames n env1 lns1 in
+      let env2 = push_lnames n env2 lns2 in
+      let n = n + Array.length defs1 in
+      eq_letrec gn1 gn2 n env1 env2 defs1 defs2 &&
+      eq_mllambda gn1 gn2 n env1 env2 body1 body2
+  | MLlet (ln1, def1, body1), MLlet (ln2, def2, body2) ->
+      eq_mllambda gn1 gn2 n env1 env2 def1 def2 &&
+      let env1 = LNmap.add ln1 n env1 in
+      let env2 = LNmap.add ln2 n env2 in
+      eq_mllambda gn1 gn2 (n+1) env1 env2 body1 body2
+  | MLapp (ml1, args1), MLapp (ml2, args2) ->
+      eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 &&
+      Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2
+  | MLif (cond1,br1,br'1), MLif (cond2,br2,br'2) ->
+      eq_mllambda gn1 gn2 n env1 env2 cond1 cond2 &&
+      eq_mllambda gn1 gn2 n env1 env2 br1 br2 &&
+      eq_mllambda gn1 gn2 n env1 env2 br'1 br'2
+  | MLmatch (annot1, c1, accu1, br1), MLmatch (annot2, c2, accu2, br2) ->
+      eq_annot_sw annot1 annot2 &&
+      eq_mllambda gn1 gn2 n env1 env2 c1 c2 &&
+      eq_mllambda gn1 gn2 n env1 env2 accu1 accu2 &&
+      eq_mllam_branches gn1 gn2 n env1 env2 br1 br2
+  | MLconstruct (pf1, cs1, args1), MLconstruct (pf2, cs2, args2) ->
+      String.equal pf1 pf2 &&
+      eq_constructor cs1 cs2 &&
+      Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2
+  | MLint i1, MLint i2 ->
+      Int.equal i1 i2
+  | MLuint i1, MLuint i2 ->
+      Uint31.equal i1 i2
+  | MLsetref (id1, ml1), MLsetref (id2, ml2) ->
+      String.equal id1 id2 &&
+      eq_mllambda gn1 gn2 n env1 env2 ml1 ml2
+  | MLsequence (ml1, ml'1), MLsequence (ml2, ml'2) ->
+      eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 &&
+      eq_mllambda gn1 gn2 n env1 env2 ml'1 ml'2
+  | MLarray arr1, MLarray arr2 ->
+      Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2
+
+  | _, _ -> false
+
+and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 =
+  let eq_def (_,args1,ml1) (_,args2,ml2) =
+    Int.equal (Array.length args1) (Array.length args2) &&
+    let env1 = push_lnames n env1 args1 in
+    let env2 = push_lnames n env2 args2 in
+    eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 ml1 ml2
+  in
+  Array.equal eq_def defs1 defs2
+
+(* we require here that patterns have the same order, which may be too strong *)
+and eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 =
+  let eq_cargs (cs1, args1) (cs2, args2) body1 body2 =
+    Int.equal (Array.length args1) (Array.length args2) &&
+    eq_constructor cs1 cs2 &&
+    let env1 = opush_lnames n env1 args1 in
+    let env2 = opush_lnames n env2 args2 in
+    eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 body1 body2
+  in
+  let eq_branch (ptl1,body1) (ptl2,body2) =
+   List.equal (fun pt1 pt2 -> eq_cargs pt1 pt2 body1 body2) ptl1 ptl2
+  in
+  Array.equal eq_branch br1 br2
+
+(* hash_mllambda gn n env t computes the hash for t ignoring occurences of gn *)
+let rec hash_mllambda gn n env t =
+  match t with
+  | MLlocal ln -> combinesmall 1 (LNmap.find ln env)
+  | MLglobal gn' -> combinesmall 2 (if eq_gname gn gn' then 0 else gname_hash gn')
+  | MLprimitive prim -> combinesmall 3 (primitive_hash prim)
+  | MLlam (lns, ml) ->
+      let env = push_lnames n env lns in
+      combinesmall 4 (combine (Array.length lns) (hash_mllambda gn (n+1) env ml))
+  | MLletrec (defs, body) ->
+      let lns = Array.map (fun (x,_,_) -> x) defs in
+      let env = push_lnames n env lns in
+      let n = n + Array.length defs in
+      let h = combine (hash_mllambda gn n env body) (Array.length defs) in
+      combinesmall 5 (hash_mllambda_letrec gn n env h defs)
+  | MLlet (ln, def, body) ->
+      let hdef = hash_mllambda gn n env def in
+      let env = LNmap.add ln n env in
+      combinesmall 6 (combine hdef (hash_mllambda gn (n+1) env body))
+  | MLapp (ml, args) ->
+      let h = hash_mllambda gn n env ml in
+      combinesmall 7 (hash_mllambda_array gn n env h args)
+  | MLif (cond,br,br') ->
+      let hcond = hash_mllambda gn n env cond in
+      let hbr = hash_mllambda gn n env br in
+      let hbr' = hash_mllambda gn n env br' in
+      combinesmall 8 (combine3 hcond hbr hbr')
+  | MLmatch (annot, c, accu, br) ->
+      let hannot = hash_annot_sw annot in
+      let hc = hash_mllambda gn n env c in
+      let haccu = hash_mllambda gn n env accu in
+      combinesmall 9 (hash_mllam_branches gn n env (combine3 hannot hc haccu) br)
+  | MLconstruct (pf, cs, args) ->
+      let hpf = String.hash pf in
+      let hcs = constructor_hash cs in
+      combinesmall 10 (hash_mllambda_array gn n env (combine hpf hcs) args)
+  | MLint i ->
+      combinesmall 11 i
+  | MLuint i ->
+      combinesmall 12 (Uint31.to_int i)
+  | MLsetref (id, ml) ->
+      let hid = String.hash id in
+      let hml = hash_mllambda gn n env ml in
+      combinesmall 13 (combine hid hml)
+  | MLsequence (ml, ml') ->
+      let hml = hash_mllambda gn n env ml in
+      let hml' = hash_mllambda gn n env ml' in
+      combinesmall 14 (combine hml hml')
+  | MLarray arr ->
+      combinesmall 15 (hash_mllambda_array gn n env 1 arr)
+
+and hash_mllambda_letrec gn n env init defs =
+  let hash_def (_,args,ml) =
+    let env = push_lnames n env args in
+    let nargs = Array.length args in
+    combine nargs (hash_mllambda gn (n + nargs) env ml)
+  in
+  Array.fold_left (fun acc t -> combine (hash_def t) acc) init defs
+
+and hash_mllambda_array gn n env init arr =
+  Array.fold_left (fun acc t -> combine (hash_mllambda gn n env t) acc) init arr
+
+and hash_mllam_branches gn n env init br =
+  let hash_cargs (cs, args) body =
+    let nargs = Array.length args in
+    let hcs = constructor_hash cs in
+    let env = opush_lnames n env args in
+    let hbody = hash_mllambda gn (n + nargs) env body in
+    combine3 nargs hcs hbody
+  in
+  let hash_branch acc (ptl,body) =
+    List.fold_left (fun acc t -> combine (hash_cargs t body) acc) acc ptl
+  in
+  Array.fold_left hash_branch init br
+
+let fv_lam l =
+  let rec aux l bind fv =
+    match l with
+    | MLlocal l ->
+	if LNset.mem l bind then fv else LNset.add l fv
+    | MLglobal _ | MLprimitive _  | MLint _ | MLuint _ -> fv
+    | MLlam (ln,body) ->
+	let bind = Array.fold_right LNset.add ln bind in
+	aux body bind fv
+    | MLletrec(bodies,def) ->
+	let bind = 
+	  Array.fold_right (fun (id,_,_) b -> LNset.add id b) bodies bind in
+	let fv_body (_,ln,body) fv =
+	  let bind = Array.fold_right LNset.add ln bind in
+	  aux body bind fv in
+	Array.fold_right fv_body bodies (aux def bind fv)
+    | MLlet(l,def,body) ->
+	aux body (LNset.add l bind) (aux def bind fv)
+    | MLapp(f,args) ->
+	let fv_arg arg fv = aux arg bind fv in
+	Array.fold_right fv_arg args (aux f bind fv)
+    | MLif(t,b1,b2) ->
+	aux t bind (aux b1 bind (aux b2 bind fv))
+    | MLmatch(_,a,p,bs) ->
+      let fv = aux a bind (aux p bind fv) in
+      let fv_bs (cargs, body) fv =
+	let bind = 
+	  List.fold_right (fun (_,args) bind ->
+	    Array.fold_right 
+	      (fun o bind -> match o with 
+	      | Some l -> LNset.add l bind 
+	      | _ -> bind) args bind) 
+	    cargs bind in
+	aux body bind fv in
+      Array.fold_right fv_bs bs fv
+          (* argument, accu branch, branches *)
+    | MLconstruct (_,_,p) ->
+	Array.fold_right (fun a fv -> aux a bind fv) p fv
+    | MLsetref(_,l) -> aux l bind fv
+    | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv)
+    | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv
+  in
+  aux l LNset.empty LNset.empty
+
+
+let mkMLlam params body =
+  if Array.is_empty params then body 
+  else
+    match body with
+    | MLlam (params', body) -> MLlam(Array.append params params', body)
+    | _ -> MLlam(params,body)
+
+let mkMLapp f args =
+  if Array.is_empty args then f
+  else
+    match f with
+    | MLapp(f,args') -> MLapp(f,Array.append args' args)
+    | _ -> MLapp(f,args)
+
+let empty_params = [||]
+
+let decompose_MLlam c =
+  match c with
+  | MLlam(ids,c) -> ids,c
+  | _ -> empty_params,c
+
+(*s Global declaration *)
+type global =
+(*  | Gtblname of gname * identifier array *)
+  | Gtblnorm of gname * lname array * mllambda array 
+  | Gtblfixtype of gname * lname array * mllambda array
+  | Glet of gname * mllambda
+  | Gletcase of 
+      gname * lname array * annot_sw * mllambda * mllambda * mllam_branches
+  | Gopen of string
+  | Gtype of inductive * int array
+    (* ind name, arities of constructors *)
+  | Gcomment of string
+
+(* Alpha-equivalence on globals *)
+let eq_global g1 g2 =
+  match g1, g2 with
+  | Gtblnorm (gn1,lns1,mls1), Gtblnorm (gn2,lns2,mls2)
+  | Gtblfixtype (gn1,lns1,mls1), Gtblfixtype (gn2,lns2,mls2) ->
+      Int.equal (Array.length lns1) (Array.length lns2) &&
+      Int.equal (Array.length mls1) (Array.length mls2) &&
+      let env1 = push_lnames 0 LNmap.empty lns1 in
+      let env2 = push_lnames 0 LNmap.empty lns2 in
+      Array.for_all2 (eq_mllambda gn1 gn2 (Array.length lns1) env1 env2) mls1 mls2
+  | Glet (gn1, def1), Glet (gn2, def2) ->
+      eq_mllambda gn1 gn2 0 LNmap.empty LNmap.empty def1 def2
+  | Gletcase (gn1,lns1,annot1,c1,accu1,br1),
+      Gletcase (gn2,lns2,annot2,c2,accu2,br2) ->
+      Int.equal (Array.length lns1) (Array.length lns2) &&
+      let env1 = push_lnames 0 LNmap.empty lns1 in
+      let env2 = push_lnames 0 LNmap.empty lns2 in
+      let t1 = MLmatch (annot1,c1,accu1,br1) in
+      let t2 = MLmatch (annot2,c2,accu2,br2) in
+      eq_mllambda gn1 gn2 (Array.length lns1) env1 env2 t1 t2
+  | Gopen s1, Gopen s2 -> String.equal s1 s2
+  | Gtype (ind1, arr1), Gtype (ind2, arr2) ->
+      eq_ind ind1 ind2 && Array.equal Int.equal arr1 arr2
+  | Gcomment s1, Gcomment s2 -> String.equal s1 s2
+  | _, _ -> false
+
+let hash_global g =
+  match g with
+  | Gtblnorm (gn,lns,mls) ->
+      let nlns = Array.length lns in
+      let nmls = Array.length mls in
+      let env = push_lnames 0 LNmap.empty lns in
+      let hmls = hash_mllambda_array gn nlns env (combine nlns nmls) mls in
+      combinesmall 1 hmls
+  | Gtblfixtype (gn,lns,mls) ->
+      let nlns = Array.length lns in
+      let nmls = Array.length mls in
+      let env = push_lnames 0 LNmap.empty lns in
+      let hmls = hash_mllambda_array gn nlns env (combine nlns nmls) mls in
+      combinesmall 2 hmls
+  | Glet (gn, def) ->
+      combinesmall 3 (hash_mllambda gn 0 LNmap.empty def)
+  | Gletcase (gn,lns,annot,c,accu,br) ->
+      let nlns = Array.length lns in
+      let env = push_lnames 0 LNmap.empty lns in
+      let t = MLmatch (annot,c,accu,br) in
+      combinesmall 4 (combine nlns (hash_mllambda gn nlns env t))
+  | Gopen s -> combinesmall 5 (String.hash s)
+  | Gtype (ind, arr) ->
+      combinesmall 6 (combine (ind_hash ind) (Array.fold_left combine 0 arr))
+  | Gcomment s -> combinesmall 7 (String.hash s)
+  
+let global_stack = ref ([] : global list)
+
+module HashedTypeGlobal = struct
+  type t = global
+  let equal = eq_global
+  let hash = hash_global
+end
+
+module HashtblGlobal = Hashtbl.Make(HashedTypeGlobal)
+
+let global_tbl = HashtblGlobal.create 19991
+
+let clear_global_tbl () = HashtblGlobal.clear global_tbl
+
+let push_global gn t =
+  try HashtblGlobal.find global_tbl t
+  with Not_found ->
+    (global_stack := t :: !global_stack;
+    HashtblGlobal.add global_tbl t gn; gn)
+
+let push_global_let gn body =
+  push_global gn (Glet (gn,body))
+
+let push_global_fixtype gn params body =
+  push_global gn (Gtblfixtype (gn,params,body))
+
+let push_global_norm gn params body =
+  push_global gn (Gtblnorm (gn, params, body))
+
+let push_global_case gn params annot a accu bs =
+  push_global gn (Gletcase (gn, params, annot, a, accu, bs))
+
+(*s Compilation environment *)
+
+type env =
+    { env_rel : mllambda list; (* (MLlocal lname) list *)
+      env_bound : int; (* length of env_rel *)
+      (* free variables *)
+      env_urel : (int * mllambda) list ref; (* list of unbound rel *)
+      env_named : (identifier * mllambda) list ref;
+      env_univ : lname option}
+
+let empty_env univ () =
+  { env_rel = [];
+    env_bound = 0;
+    env_urel = ref [];
+    env_named = ref [];
+    env_univ = univ
+  }
+
+let push_rel env id = 
+  let local = fresh_lname id in
+  local, { env with 
+	   env_rel = MLlocal local :: env.env_rel;
+	   env_bound = env.env_bound + 1
+	 }
+
+let push_rels env ids =
+  let lnames, env_rel = 
+    Array.fold_left (fun (names,env_rel) id ->
+      let local = fresh_lname id in
+      (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in
+  Array.of_list (List.rev lnames), { env with 
+			  env_rel = env_rel;
+			  env_bound = env.env_bound + Array.length ids
+			}
+
+let get_rel env id i =
+  if i <= env.env_bound then
+    List.nth env.env_rel (i-1)
+  else 
+    let i = i - env.env_bound in
+    try Int.List.assoc i !(env.env_urel)
+    with Not_found ->
+      let local = MLlocal (fresh_lname id) in
+      env.env_urel := (i,local) :: !(env.env_urel);
+      local
+
+let get_var env id =
+  try Id.List.assoc id !(env.env_named)
+  with Not_found ->
+    let local = MLlocal (fresh_lname (Name id)) in
+    env.env_named := (id, local)::!(env.env_named);
+    local
+
+let fresh_univ () =
+  fresh_lname (Name (Id.of_string "univ"))
+
+(*s Traduction of lambda to mllambda *)
+
+let get_prod_name codom = 
+  match codom with
+  | MLlam(ids,_) -> ids.(0).lname
+  | _ -> assert false
+
+let get_lname (_,l) = 
+  match l with
+  | MLlocal id -> id
+  | _ -> invalid_arg "Nativecode.get_lname"
+
+(* Collects free variables from env in an array of local names *)
+let fv_params env = 
+  let fvn, fvr = !(env.env_named), !(env.env_urel) in 
+  let size = List.length fvn + List.length fvr in
+  let start,params = match env.env_univ with
+    | None -> 0, Array.make size dummy_lname
+    | Some u -> 1, let t = Array.make (size + 1) dummy_lname in t.(0) <- u; t
+  in
+  if Array.is_empty params then empty_params
+  else begin
+    let fvn = ref fvn in
+    let i = ref start in
+    while not (List.is_empty !fvn) do
+      params.(!i) <- get_lname (List.hd !fvn);
+      fvn := List.tl !fvn;
+      incr i
+    done;
+    let fvr = ref fvr in
+    while not (List.is_empty !fvr) do
+      params.(!i) <- get_lname (List.hd !fvr);
+      fvr := List.tl !fvr;
+      incr i
+    done;
+    params
+  end
+
+let generalize_fv env body = 
+  mkMLlam (fv_params env) body
+
+let empty_args = [||]
+
+let fv_args env fvn fvr =
+  let size = List.length fvn + List.length fvr in
+  let start,args = match env.env_univ with
+    | None -> 0, Array.make size (MLint 0)
+    | Some u -> 1, let t = Array.make (size + 1) (MLint 0) in t.(0) <- MLlocal u; t
+  in
+  if Array.is_empty args then empty_args
+  else 
+    begin
+      let fvn = ref fvn in
+      let i = ref start in
+      while not (List.is_empty !fvn) do
+	args.(!i) <- get_var env (fst (List.hd !fvn));
+	fvn := List.tl !fvn;
+	incr i
+      done;
+      let fvr = ref fvr in
+      while not (List.is_empty !fvr) do
+	let (k,_ as kml) = List.hd !fvr in
+	let n = get_lname kml in 
+	args.(!i) <- get_rel env n.lname k;
+	fvr := List.tl !fvr;
+	incr i
+      done;
+      args
+    end
+
+let get_value_code i =
+  MLapp (MLglobal (Ginternal "get_value"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_sort_code i =
+  MLapp (MLglobal (Ginternal "get_sort"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_name_code i =
+  MLapp (MLglobal (Ginternal "get_name"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_const_code i =
+  MLapp (MLglobal (Ginternal "get_const"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_match_code i =
+  MLapp (MLglobal (Ginternal "get_match"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_ind_code i =
+  MLapp (MLglobal (Ginternal "get_ind"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_meta_code i =
+  MLapp (MLglobal (Ginternal "get_meta"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_evar_code i =
+  MLapp (MLglobal (Ginternal "get_evar"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_level_code i =
+  MLapp (MLglobal (Ginternal "get_level"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+type rlist =
+  | Rnil 
+  | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' 
+and rlist' = rlist ref
+
+let rm_params fv params = 
+  Array.map (fun l -> if LNset.mem l fv then Some l else None) params 
+
+let rec insert cargs body rl =
+ match !rl with
+ | Rnil ->
+     let fv = fv_lam body in
+     let (c,params) = cargs in
+     let params = rm_params fv params in
+     rl:= Rcons(ref [(c,params)], fv, body, ref Rnil)
+ | Rcons(l,fv,body',rl) ->
+    (** ppedrot: It seems we only want to factorize common branches. It should
+        not matter to do so with a subapproximation by (==). *)
+     if body == body' then
+       let (c,params) = cargs in
+       let params = rm_params fv params in
+       l := (c,params)::!l
+     else insert cargs body rl
+
+let rec to_list rl =
+  match !rl with
+  | Rnil -> []
+  | Rcons(l,_,body,tl) -> (!l,body)::to_list tl
+
+let merge_branches t =
+  let newt = ref Rnil in
+  Array.iter (fun (c,args,body) -> insert (c,args) body newt) t;
+  Array.of_list (to_list newt)
+
+
+type prim_aux = 
+  | PAprim of string * constant * Primitives.t * prim_aux array
+  | PAml of mllambda
+
+let add_check cond args =
+  let aux cond a = 
+    match a with
+    | PAml(MLint _) -> cond
+    | PAml ml ->
+       (* FIXME: use explicit equality function *)
+       if List.mem ml cond then cond else ml::cond 
+    | _ -> 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 = 
+    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)
+    | 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 res = aux l in
+  (!decl, !cond, res)
+
+let app_prim p args = MLapp(MLprimitive p, args)
+
+let 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|]) 
+
+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 inling 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 (Primitives.Int31lt,None)) args
+        | Int31le ->
+           if Sys.word_size = 64 then
+             app_prim Mk_bool [|(app_prim MLle (args_to_int args))|]
+           else app_prim (Coq_primitive (Primitives.Int31le, None)) args
+	| 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 = 
+    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
+
+  let compile_cond cond paux = 
+    match cond with
+    | [] -> opt_prim_aux paux 
+    | [c1] ->
+        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 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)
+
+let ml_of_instance instance u =
+  let ml_of_level l =
+    match Univ.Level.var_index l with
+    | Some i ->
+       let univ = MLapp(MLprimitive MLmagic, [|MLlocal (Option.get instance)|]) in
+       mkMLapp (MLprimitive MLarrayget) [|univ; MLint i|]
+    | None -> let i = push_symbol (SymbLevel l) in get_level_code i
+  in
+  let u = Univ.Instance.to_array u in
+  if Array.is_empty u then [||]
+  else let u = Array.map ml_of_level u in
+       [|MLapp (MLprimitive MLmagic, [|MLarray u|])|]
+
+ let rec ml_of_lam env l t =
+  match t with
+  | Lrel(id ,i) -> get_rel env id i
+  | Lvar id -> get_var env id
+  | Lmeta(mv,ty) ->
+     let tyn = fresh_lname Anonymous in
+     let i = push_symbol (SymbMeta mv) in
+     MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|])
+  | Levar(ev,ty) ->
+     let tyn = fresh_lname Anonymous in
+     let i = push_symbol (SymbEvar ev) in
+     MLlet(tyn, ml_of_lam env l ty,
+       MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn|]))
+  | Lprod(dom,codom) ->
+      let dom = ml_of_lam env l dom in
+      let codom = ml_of_lam env l codom in
+      let n = get_prod_name codom in
+      let i = push_symbol (SymbName n) in
+      MLapp(MLprimitive Mk_prod, [|get_name_code i;dom;codom|])
+  | Llam(ids,body) ->
+    let lnames,env = push_rels env ids in
+    MLlam(lnames, ml_of_lam env l body)
+  | Llet(id,def,body) ->
+      let def = ml_of_lam env l def in
+      let lname, env = push_rel env id in
+      let body = ml_of_lam env l body in
+      MLlet(lname,def,body)
+  | Lapp(f,args) ->
+      MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args)
+  | Lconst (prefix,c) ->
+     let args = ml_of_instance env.env_univ (snd c) in
+     mkMLapp (MLglobal(Gconstant (prefix,c))) args
+  | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c))
+  | Lprim _ ->
+      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 = 
+           match a_uid with
+           | Accu _ => mk_sw (predicate_uid fv_pred) (case_uid fv) a_uid
+           | Ci argsi => compilation of branches 
+         compile case = case_uid fv (compilation of a) *)
+      (* Compilation of the predicate *)
+         (* Remark: if we do not want to compile the predicate we 
+            should a least compute the fv, then store the lambda representation
+            of the predicate (not the mllambda) *)
+      let env_p = empty_env env.env_univ () in
+      let pn = fresh_gpred l in
+      let mlp = ml_of_lam env_p l p in
+      let mlp = generalize_fv env_p mlp in
+      let (pfvn,pfvr) = !(env_p.env_named), !(env_p.env_urel) in
+      let pn = push_global_let pn mlp in
+      (* Compilation of the case *)
+      let env_c = empty_env env.env_univ () in
+      let a_uid = fresh_lname Anonymous in
+      let la_uid = MLlocal a_uid in
+      (* compilation of branches *)
+      let ml_br (c,params, body) = 
+	let lnames, env_c = push_rels env_c params in
+	(c, lnames, ml_of_lam env_c l body)
+      in
+      let bs = Array.map ml_br bs in
+      let cn = fresh_gcase l in
+      (* Compilation of accu branch *)
+      let pred = MLapp(MLglobal pn, fv_args env_c pfvn pfvr) in  
+      let (fvn, fvr) = !(env_c.env_named), !(env_c.env_urel) in
+      let cn_fv = mkMLapp (MLglobal cn) (fv_args env_c fvn fvr) in
+         (* remark : the call to fv_args does not add free variables in env_c *)
+      let i = push_symbol (SymbMatch annot) in
+      let accu =
+	MLapp(MLprimitive Mk_sw,
+	      [| get_match_code i; MLapp (MLprimitive Cast_accu, [|la_uid|]);
+		 pred;
+		 cn_fv |]) in
+(*      let body = MLlam([|a_uid|], MLmatch(annot, la_uid, accu, bs)) in
+      let case = generalize_fv env_c body in *)
+      let cn = push_global_case cn (Array.append (fv_params env_c) [|a_uid|])
+        annot la_uid accu (merge_branches bs)
+      in
+      (* Final result *)
+      let arg = ml_of_lam env l a in
+      let force =
+	if annot.asw_finite then arg
+	else MLapp(MLprimitive Force_cofix, [|arg|]) in
+      mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|]
+  | Lif(t,bt,bf) -> 
+      MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf)
+  | Lfix ((rec_pos,start), (ids, tt, tb)) ->
+      (* let type_f fvt = [| type fix |] 
+         let norm_f1 fv f1 .. fn params1 = body1
+	 ..
+         let norm_fn fv f1 .. fn paramsn = bodyn
+         let norm fv f1 .. fn = 
+	    [|norm_f1 fv f1 .. fn; ..; norm_fn fv f1 .. fn|]
+         compile fix = 
+	   let rec f1 params1 = 
+             if is_accu rec_pos.(1) then mk_fix (type_f fvt) (norm fv) params1
+	     else norm_f1 fv f1 .. fn params1
+           and .. and fn paramsn = 
+	     if is_accu rec_pos.(n) then mk_fix (type_f fvt) (norm fv) paramsn
+             else norm_fn fv f1 .. fv paramsn in
+	   start
+      *)
+      (* Compilation of type *)
+      let env_t = empty_env env.env_univ () in
+      let ml_t = Array.map (ml_of_lam env_t l) tt in
+      let params_t = fv_params env_t in
+      let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in
+      let gft = fresh_gfixtype l in
+      let gft = push_global_fixtype gft params_t ml_t in
+      let mk_type = MLapp(MLglobal gft, args_t) in
+      (* Compilation of norm_i *)
+      let ndef = Array.length ids in
+      let lf,env_n = push_rels (empty_env env.env_univ ()) ids in
+      let t_params = Array.make ndef [||] in
+      let t_norm_f = Array.make ndef (Gnorm (l,-1)) in
+      let mk_let envi (id,def) t = MLlet (id,def,t) in
+      let mk_lam_or_let (params,lets,env) (id,def) =
+        let ln,env' = push_rel env id in
+        match def with
+        | None -> (ln::params,lets,env')
+        | Some lam -> (params, (ln,ml_of_lam env l lam)::lets,env')
+      in
+      let ml_of_fix i body =
+        let varsi, bodyi = decompose_Llam_Llet body in
+        let paramsi,letsi,envi = 
+          Array.fold_left mk_lam_or_let ([],[],env_n) varsi
+        in
+        let paramsi,letsi =
+          Array.of_list (List.rev paramsi), Array.of_list (List.rev letsi)
+        in
+        t_norm_f.(i) <- fresh_gnorm l;
+        let bodyi = ml_of_lam envi l bodyi in
+        t_params.(i) <- paramsi;
+        let bodyi = Array.fold_right (mk_let envi) letsi bodyi in
+        mkMLlam paramsi bodyi
+      in
+      let tnorm = Array.mapi ml_of_fix tb in
+      let fvn,fvr = !(env_n.env_named), !(env_n.env_urel) in
+      let fv_params = fv_params env_n in
+      let fv_args' = Array.map (fun id -> MLlocal id) fv_params in
+      let norm_params = Array.append fv_params lf in
+      let t_norm_f = Array.mapi (fun i body ->
+	push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in
+      let norm = fresh_gnormtbl l in
+      let norm = push_global_norm norm fv_params 
+         (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in
+      (* Compilation of fix *)
+      let fv_args = fv_args env fvn fvr in      
+      let lf, env = push_rels env ids in
+      let lf_args = Array.map (fun id -> MLlocal id) lf in
+      let mk_norm = MLapp(MLglobal norm, fv_args) in
+      let mkrec i lname = 
+	let paramsi = t_params.(i) in
+	let reci = MLlocal (paramsi.(rec_pos.(i))) in
+	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+	let body = 
+	  MLif(MLapp(MLprimitive Is_accu,[|reci|]),
+	       mkMLapp 
+		 (MLapp(MLprimitive (Mk_fix(rec_pos,i)), 
+			[|mk_type; mk_norm|]))
+		 pargsi,
+	       MLapp(MLglobal t_norm_f.(i), 
+		     Array.concat [fv_args;lf_args;pargsi])) 
+	in
+	(lname, paramsi, body) in
+      MLletrec(Array.mapi mkrec lf, lf_args.(start))
+  | Lcofix (start, (ids, tt, tb)) -> 
+      (* Compilation of type *)
+      let env_t = empty_env env.env_univ () in
+      let ml_t = Array.map (ml_of_lam env_t l) tt in
+      let params_t = fv_params env_t in
+      let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in
+      let gft = fresh_gfixtype l in
+      let gft = push_global_fixtype gft params_t ml_t in
+      let mk_type = MLapp(MLglobal gft, args_t) in
+      (* Compilation of norm_i *) 
+      let ndef = Array.length ids in
+      let lf,env_n = push_rels (empty_env env.env_univ ()) ids in
+      let t_params = Array.make ndef [||] in
+      let t_norm_f = Array.make ndef (Gnorm (l,-1)) in
+      let ml_of_fix i body =
+        let idsi,bodyi = decompose_Llam body in
+        let paramsi, envi = push_rels env_n idsi in
+        t_norm_f.(i) <- fresh_gnorm l;
+        let bodyi = ml_of_lam envi l bodyi in
+        t_params.(i) <- paramsi;
+        mkMLlam paramsi bodyi in
+      let tnorm = Array.mapi ml_of_fix tb in
+      let fvn,fvr = !(env_n.env_named), !(env_n.env_urel) in
+      let fv_params = fv_params env_n in
+      let fv_args' = Array.map (fun id -> MLlocal id) fv_params in
+      let norm_params = Array.append fv_params lf in
+      let t_norm_f = Array.mapi (fun i body ->
+	push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in
+      let norm = fresh_gnormtbl l in
+      let norm = push_global_norm norm fv_params
+        (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in
+      (* Compilation of fix *)
+      let fv_args = fv_args env fvn fvr in      
+      let mk_norm = MLapp(MLglobal norm, fv_args) in
+      let lnorm = fresh_lname Anonymous in
+      let ltype = fresh_lname Anonymous in
+      let lf, env = push_rels env ids in
+      let lf_args = Array.map (fun id -> MLlocal id) lf in
+      let upd i lname cont =
+	let paramsi = t_params.(i) in
+	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+	let uniti = fresh_lname Anonymous in
+	let body =
+	  MLlam(Array.append paramsi [|uniti|],
+		MLapp(MLglobal t_norm_f.(i),
+		      Array.concat [fv_args;lf_args;pargsi])) in
+	MLsequence(MLapp(MLprimitive Upd_cofix, [|lf_args.(i);body|]),
+		   cont) in
+      let upd = Array.fold_right_i upd lf lf_args.(start) in
+      let mk_let i lname cont =
+	MLlet(lname,
+	      MLapp(MLprimitive(Mk_cofix i),[| MLlocal ltype; MLlocal lnorm|]),
+	      cont) in
+      let init = Array.fold_right_i mk_let lf upd in 
+      MLlet(lnorm, mk_norm, MLlet(ltype, mk_type, init))
+  (*    	    
+      let mkrec i lname = 
+	let paramsi = t_params.(i) in
+	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+	let uniti = fresh_lname Anonymous in
+	let body = 
+	  MLapp( MLprimitive(Mk_cofix i),
+		 [|mk_type;mk_norm; 
+		   MLlam([|uniti|],
+			 MLapp(MLglobal t_norm_f.(i),
+			       Array.concat [fv_args;lf_args;pargsi]))|]) in
+	(lname, paramsi, body) in
+      MLletrec(Array.mapi mkrec lf, lf_args.(start)) *)
+
+  | Lmakeblock (prefix,(cn,u),_,args) ->
+     let args = Array.map (ml_of_lam env l) args in
+     MLconstruct(prefix,cn,args)
+  | Lconstruct (prefix, (cn,u)) ->
+     let uargs = ml_of_instance env.env_univ u in
+      mkMLapp (MLglobal (Gconstruct (prefix, (cn,u)))) uargs
+  | Luint v ->
+     (match v with
+     | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|])
+     | UintDigits (prefix,cn,ds) ->
+	let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in
+	let ds = Array.map (ml_of_lam env l) ds in
+	let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in
+	MLapp(i31, ds)
+     | UintDecomp (prefix,cn,t) ->
+	let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in
+	let t = ml_of_lam env l t in
+	MLapp (MLprimitive Decomp_uint, [|c;t|]))
+  | Lval v ->
+      let i = push_symbol (SymbValue v) in get_value_code i
+  | Lsort s ->
+    let i = push_symbol (SymbSort s) in
+    let uarg = match env.env_univ with
+      | None -> MLarray [||]
+      | Some u -> MLlocal u
+    in
+    let uarg = MLapp(MLprimitive MLmagic, [|uarg|]) in
+    MLapp(MLprimitive Mk_sort, [|get_sort_code i; uarg|])
+  | Lind (prefix, pind) ->
+     let uargs = ml_of_instance env.env_univ (snd pind) in
+     mkMLapp (MLglobal (Gind (prefix, pind))) uargs
+  | Llazy -> MLglobal (Ginternal "lazy")
+  | Lforce -> MLglobal (Ginternal "Lazy.force")
+
+let mllambda_of_lambda univ auxdefs l t =
+  let env = empty_env univ () in
+  global_stack := auxdefs;
+  let ml = ml_of_lam env l t in
+  let fv_rel = !(env.env_urel) in
+  let fv_named = !(env.env_named) in
+  (* build the free variables *)
+  let get_lname (_,t) = 
+   match t with
+   | MLlocal x -> x
+   | _ -> assert false in
+  let params = 
+    List.append (List.map get_lname fv_rel) (List.map get_lname fv_named) in
+  if List.is_empty params then
+    (!global_stack, ([],[]), ml)
+  (* final result : global list, fv, ml *)
+  else
+    (!global_stack, (fv_named, fv_rel), mkMLlam (Array.of_list params) ml)
+
+(** Code optimization **)
+
+(** Optimization of match and fix *)
+
+let can_subst l = 
+  match l with
+  | MLlocal _ | MLint _ | MLuint _ | MLglobal _ -> true
+  | _ -> false
+
+let subst s l =
+  if LNmap.is_empty s then l 
+  else
+    let rec aux l =
+      match l with
+      | MLlocal id -> (try LNmap.find id s with Not_found -> l)
+      | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l
+      | MLlam(params,body) -> MLlam(params, aux body)
+      | MLletrec(defs,body) ->
+	let arec (f,params,body) = (f,params,aux body) in
+	MLletrec(Array.map arec defs, aux body)
+      | MLlet(id,def,body) -> MLlet(id,aux def, aux body)
+      | MLapp(f,args) -> MLapp(aux f, Array.map aux args)
+      | MLif(t,b1,b2) -> MLif(aux t, aux b1, aux b2)
+      | MLmatch(annot,a,accu,bs) ->
+	  let auxb (cargs,body) = (cargs,aux body) in
+	  MLmatch(annot,a,aux accu, Array.map auxb bs)
+      | MLconstruct(prefix,c,args) -> MLconstruct(prefix,c,Array.map aux args)
+      | MLsetref(s,l1) -> MLsetref(s,aux l1) 
+      | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2)
+      | MLarray arr -> MLarray (Array.map aux arr)
+    in
+    aux l
+
+let add_subst id v s =
+  match v with
+  | MLlocal id' when Int.equal id.luid id'.luid -> s
+  | _ -> LNmap.add id v s
+
+let subst_norm params args s =
+  let len = Array.length params in
+  assert (Int.equal (Array.length args) len && Array.for_all can_subst args);
+  let s = ref s in
+  for i = 0 to len - 1 do
+    s := add_subst params.(i) args.(i) !s
+  done;
+  !s
+
+let subst_case params args s =
+  let len = Array.length params in
+  assert (len > 0 && 
+	  Int.equal (Array.length args) len && 
+	  let r = ref true and i = ref 0 in
+	  (* we test all arguments excepted the last *)
+	  while !i < len - 1  && !r do r := can_subst args.(!i); incr i done;
+	  !r);
+  let s = ref s in
+  for i = 0 to len - 2 do
+    s := add_subst params.(i) args.(i) !s
+  done;
+  !s, params.(len-1), args.(len-1)
+    
+let empty_gdef = Int.Map.empty, Int.Map.empty
+let get_norm (gnorm, _) i = Int.Map.find i gnorm
+let get_case (_, gcase) i = Int.Map.find i gcase
+
+let all_lam n bs = 
+  let f (_, l) = 
+    match l with
+    | MLlam(params, _) -> Int.equal (Array.length params) n
+    | _ -> false in
+  Array.for_all f bs
+
+let commutative_cut annot a accu bs args =
+  let mkb (c,b) =
+     match b with
+     | MLlam(params, body) -> 
+         (c, Array.fold_left2 (fun body x v -> MLlet(x,v,body)) body params args)
+     | _ -> assert false in
+  MLmatch(annot, a, mkMLapp accu args, Array.map mkb bs)
+
+let optimize gdef l =   
+  let rec optimize s l =
+    match l with
+    | MLlocal id -> (try LNmap.find id s with Not_found -> l)
+    | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l
+    | MLlam(params,body) -> 
+	MLlam(params, optimize s body)
+    | MLletrec(decls,body) ->
+	let opt_rec (f,params,body) = (f,params,optimize s body ) in 
+	MLletrec(Array.map opt_rec decls, optimize s body)
+    | MLlet(id,def,body) ->
+	let def = optimize s def in
+	if can_subst def then optimize (add_subst id def s) body 
+	else MLlet(id,def,optimize s body)
+    | MLapp(f, args) ->
+	let args = Array.map (optimize s) args in
+	begin match f with
+	| MLglobal (Gnorm (_,i)) ->
+	    (try
+	      let params,body = get_norm gdef i in
+	      let s = subst_norm params args s in
+	      optimize s body	    
+	    with Not_found -> MLapp(optimize s f, args))
+	| MLglobal (Gcase (_,i)) ->
+	    (try 
+	      let params,body = get_case gdef i in
+	      let s, id, arg = subst_case params args s in
+	      if can_subst arg then optimize (add_subst id arg s) body
+	      else MLlet(id, arg, optimize s body)
+	    with Not_found ->  MLapp(optimize s f, args))
+	| _ -> 
+            let f = optimize s f in
+            match f with
+            | MLmatch (annot,a,accu,bs) ->
+              if all_lam (Array.length args) bs then  
+                commutative_cut annot a accu bs args 
+              else MLapp(f, args)
+            | _ -> MLapp(f, args)
+
+	end
+    | MLif(t,b1,b2) ->
+	let t = optimize s t in
+	let b1 = optimize s b1 in
+	let b2 = optimize s b2 in
+	begin match t, b2 with
+	| MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs)
+	    when l1 == l2 -> MLmatch(annot, l1, b1, bs) (** approximation *)
+        | _, _ -> MLif(t, b1, b2)
+	end
+    | MLmatch(annot,a,accu,bs) ->
+	let opt_b (cargs,body) = (cargs,optimize s body) in
+	MLmatch(annot, optimize s a, subst s accu, Array.map opt_b bs)
+    | MLconstruct(prefix,c,args) ->
+        MLconstruct(prefix,c,Array.map (optimize s) args)
+    | MLsetref(r,l) -> MLsetref(r, optimize s l) 
+    | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2)
+    | MLarray arr -> MLarray (Array.map (optimize s) arr)
+  in
+  optimize LNmap.empty l
+
+let optimize_stk stk =
+  let add_global gdef g =
+    match g with
+    | Glet (Gnorm (_,i), body) ->
+	let (gnorm, gcase) = gdef in
+	(Int.Map.add i (decompose_MLlam body) gnorm, gcase)
+    | Gletcase(Gcase (_,i), params, annot,a,accu,bs) ->
+	let (gnorm,gcase) = gdef in
+	(gnorm, Int.Map.add i (params,MLmatch(annot,a,accu,bs)) gcase)
+    | Gletcase _ -> assert false
+    | _ -> gdef in
+  let gdef = List.fold_left add_global empty_gdef stk in
+  let optimize_global g = 
+    match g with
+    | Glet(Gconstant (prefix, c), body) ->
+        Glet(Gconstant (prefix, c), optimize gdef body)
+    | _ -> g in
+  List.map optimize_global stk
+
+(** Printing to ocaml **)
+(* Redefine a bunch of functions in module Names to generate names
+   acceptable to OCaml. *)
+let string_of_id s = Unicode.ascii_of_ident (string_of_id s)
+let string_of_label l = Unicode.ascii_of_ident (string_of_label l)
+
+let string_of_dirpath = function
+  | [] -> "_"
+  | sl -> String.concat "_" (List.rev_map string_of_id sl)
+
+(* The first letter of the file name has to be a capital to be accepted by *)
+(* OCaml as a module identifier.                                           *)
+let string_of_dirpath s = "N"^string_of_dirpath s
+
+let mod_uid_of_dirpath dir = string_of_dirpath (repr_dirpath dir)
+
+let link_info_of_dirpath dir =
+  Linked (mod_uid_of_dirpath dir ^ ".")
+
+let string_of_name x =
+  match x with
+    | Anonymous -> "anonymous" (* assert false *)
+    | Name id -> string_of_id id
+
+let string_of_label_def l =
+  match l with
+    | None -> ""
+    | Some l -> string_of_label l
+
+(* Relativization of module paths *)
+let rec list_of_mp acc = function
+  | MPdot (mp,l) -> list_of_mp (string_of_label l::acc) mp
+  | MPfile dp ->
+      let dp = repr_dirpath dp in
+      string_of_dirpath dp :: acc
+  | MPbound mbid -> ("X"^string_of_id (id_of_mbid mbid))::acc
+
+let list_of_mp mp = list_of_mp [] mp
+
+let string_of_kn kn =
+  let (mp,dp,l) = repr_kn kn in
+  let mp = list_of_mp mp in
+  String.concat "_" mp ^ "_" ^ string_of_label l
+
+let string_of_con c = string_of_kn (user_con c)
+let string_of_mind mind = string_of_kn (user_mind mind)
+
+let string_of_gname g =
+  match g with
+  | Gind (prefix, ((mind,i), _)) ->
+      Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i
+  | Gconstruct (prefix, (((mind, i), j), _)) ->
+      Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1)
+  | Gconstant (prefix, (c,_)) ->
+      Format.sprintf "%sconst_%s" prefix (string_of_con c)
+  | Gproj (prefix, c) ->
+      Format.sprintf "%sproj_%s" prefix (string_of_con c)
+  | Gcase (l,i) ->
+      Format.sprintf "case_%s_%i" (string_of_label_def l) i
+  | Gpred (l,i) ->
+      Format.sprintf "pred_%s_%i" (string_of_label_def l) i
+  | Gfixtype (l,i) ->
+      Format.sprintf "fixtype_%s_%i" (string_of_label_def l) i
+  | Gnorm (l,i) ->
+      Format.sprintf "norm_%s_%i" (string_of_label_def l) i
+  | Ginternal s -> Format.sprintf "%s" s
+  | Gnormtbl (l,i) -> 
+      Format.sprintf "normtbl_%s_%i" (string_of_label_def l) i
+  | Grel i ->
+      Format.sprintf "rel_%i" i
+  | Gnamed id ->
+      Format.sprintf "named_%s" (string_of_id id)
+
+let pp_gname fmt g =
+  Format.fprintf fmt "%s" (string_of_gname g)
+
+let pp_lname fmt ln =
+  let s = Unicode.ascii_of_ident (string_of_name ln.lname) in
+  Format.fprintf fmt "x_%s_%i" s ln.luid
+
+let pp_ldecls fmt ids =
+  let len = Array.length ids in
+  for i = 0 to len - 1 do
+    Format.fprintf fmt " (%a : Nativevalues.t)" pp_lname ids.(i)
+  done
+
+let string_of_construct prefix ((mind,i),j) =
+  let id = Format.sprintf "Construct_%s_%i_%i" (string_of_mind mind) i (j-1) in
+  prefix ^ id
+   
+let pp_int fmt i =
+  if i < 0 then Format.fprintf fmt "(%i)" i else Format.fprintf fmt "%i" i
+
+let pp_mllam fmt l =
+
+  let rec pp_mllam fmt l =
+    match l with
+    | MLlocal ln -> Format.fprintf fmt "@[%a@]" pp_lname ln
+    | MLglobal g -> Format.fprintf fmt "@[%a@]" pp_gname g
+    | MLprimitive p -> Format.fprintf fmt "@[%a@]" pp_primitive p
+    | MLlam(ids,body) ->
+	Format.fprintf fmt "@[(fun%a@ ->@\n %a)@]"
+	  pp_ldecls ids pp_mllam body
+    | MLletrec(defs, body) ->
+	Format.fprintf fmt "@[%a@ in@\n%a@]" pp_letrec defs 
+	  pp_mllam body
+    | MLlet(id,def,body) ->
+	Format.fprintf fmt "@[(let@ %a@ =@\n %a@ in@\n%a)@]"
+          pp_lname id pp_mllam def pp_mllam body
+    | MLapp(f, args) ->
+	Format.fprintf fmt "@[%a@ %a@]" pp_mllam f (pp_args true) args
+    | MLif(t,l1,l2) ->
+	Format.fprintf fmt "@[(if %a then@\n  %a@\nelse@\n  %a)@]"
+	  pp_mllam t pp_mllam l1 pp_mllam l2 
+    | MLmatch (annot, c, accu_br, br) ->
+	  let mind,i = annot.asw_ind in
+      let prefix = annot.asw_prefix in
+	  let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in
+	  Format.fprintf fmt 
+	    "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n  %a@\n%aend@]"
+	  pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br
+	  
+    | MLconstruct(prefix,c,args) ->
+        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)
+    | MLsetref (s, body) ->
+	Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body
+    | MLsequence(l1,l2) ->
+	Format.fprintf fmt "@[%a;@\n%a@]" pp_mllam l1 pp_mllam l2
+    | MLarray arr ->
+       let len = Array.length arr in
+       Format.fprintf fmt "@[[|";
+       if 0 < len then begin
+	 for i = 0 to len - 2 do
+           Format.fprintf fmt "%a;" pp_mllam arr.(i)
+	 done;
+         pp_mllam fmt arr.(len-1)
+       end;
+       Format.fprintf fmt "|]@]"
+
+
+  and pp_letrec fmt defs =
+    let len = Array.length defs in
+    let pp_one_rec i (fn, argsn, body) =
+      Format.fprintf fmt "%a%a =@\n  %a"
+	pp_lname fn 
+	pp_ldecls argsn pp_mllam body in
+    Format.fprintf fmt "@[let rec ";
+    pp_one_rec 0 defs.(0);
+    for i = 1 to len - 1 do
+      Format.fprintf fmt "@\nand ";
+      pp_one_rec i defs.(i)
+    done;
+
+  and pp_blam fmt l =
+    match l with
+    | MLprimitive (Mk_prod | Mk_sort) (* FIXME: why this special case? *)
+    | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ ->
+	Format.fprintf fmt "(%a)" pp_mllam l
+    | MLconstruct(_,_,args) when Array.length args > 0 ->
+	Format.fprintf fmt "(%a)" pp_mllam l
+    | _ -> pp_mllam fmt l
+
+  and pp_args sep fmt args =
+    let sep = if sep then " " else "," in
+    let len = Array.length args in
+    if len > 0 then begin
+      Format.fprintf fmt "%a" pp_blam args.(0);
+      for i = 1 to len - 1 do
+	Format.fprintf fmt "%s%a" sep pp_blam args.(i)
+      done
+    end
+
+  and pp_cargs fmt args =
+    let len = Array.length args in
+    match len with
+    | 0 -> ()
+    | 1 -> Format.fprintf fmt " %a" pp_blam args.(0)
+    | _ -> Format.fprintf fmt "(%a)" (pp_args false) args
+
+  and pp_cparam fmt param = 
+    match param with
+    | Some l -> pp_mllam fmt (MLlocal l)
+    | None -> Format.fprintf fmt "_"
+
+  and pp_cparams fmt params =
+    let len = Array.length params in
+    match len with
+    | 0 -> ()
+    | 1 -> Format.fprintf fmt " %a" pp_cparam params.(0)
+    | _ -> 
+	let aux fmt params =
+	  Format.fprintf fmt "%a" pp_cparam params.(0);
+	  for i = 1 to len - 1 do
+	    Format.fprintf fmt ",%a" pp_cparam params.(i)
+	  done in 
+	Format.fprintf fmt "(%a)" aux params
+
+  and pp_branches prefix fmt bs =
+    let pp_branch (cargs,body) =
+      let pp_c fmt (cn,args) = 
+        Format.fprintf fmt "| %s%a " 
+      (string_of_construct prefix cn) pp_cparams args in
+      let rec pp_cargs fmt cargs =
+        match cargs with
+    | [] -> ()
+    | cargs::cargs' -> 
+        Format.fprintf fmt "%a%a" pp_c cargs pp_cargs cargs' in
+      Format.fprintf fmt "%a ->@\n  %a@\n" 
+    pp_cargs cargs pp_mllam body
+      in
+    Array.iter pp_branch bs
+
+  and pp_primitive fmt = function
+    | Mk_prod -> Format.fprintf fmt "mk_prod_accu" 
+    | Mk_sort -> Format.fprintf fmt "mk_sort_accu"
+    | Mk_ind -> Format.fprintf fmt "mk_ind_accu"
+    | Mk_const -> Format.fprintf fmt "mk_constant_accu"
+    | Mk_sw -> Format.fprintf fmt "mk_sw_accu"
+    | Mk_fix(rec_pos,start) -> 
+	let pp_rec_pos fmt rec_pos = 
+	  Format.fprintf fmt "@[[| %i" rec_pos.(0);
+	  for i = 1 to Array.length rec_pos - 1 do
+	    Format.fprintf fmt "; %i" rec_pos.(i) 
+	  done;
+	  Format.fprintf fmt " |]@]" in
+	Format.fprintf fmt "mk_fix_accu %a %i" pp_rec_pos rec_pos start
+    | Mk_cofix(start) -> Format.fprintf fmt "mk_cofix_accu %i" start
+    | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i
+    | Mk_var id ->
+        Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id)
+    | Mk_proj -> Format.fprintf fmt "mk_proj_accu"
+    | Is_accu -> Format.fprintf fmt "is_accu"
+    | Is_int -> Format.fprintf fmt "is_int"
+    | Cast_accu -> Format.fprintf fmt "cast_accu"
+    | Upd_cofix -> Format.fprintf fmt "upd_cofix"
+    | Force_cofix -> Format.fprintf fmt "force_cofix"
+    | Mk_uint -> Format.fprintf fmt "mk_uint"
+    | 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 "(&&)"
+    | MLle -> Format.fprintf fmt "(<=)"
+    | MLlt -> Format.fprintf fmt "(<)"
+    | MLinteq -> Format.fprintf fmt "(==)"
+    | MLlsl -> Format.fprintf fmt "(lsl)"
+    | MLlsr -> Format.fprintf fmt "(lsr)"
+    | MLland -> Format.fprintf fmt "(land)"
+    | MLlor -> Format.fprintf fmt "(lor)"
+    | MLlxor -> Format.fprintf fmt "(lxor)"
+    | MLadd -> Format.fprintf fmt "(+)"
+    | MLsub -> Format.fprintf fmt "(-)"
+    | MLmul -> Format.fprintf fmt "( * )"
+    | MLmagic -> Format.fprintf fmt "Obj.magic"
+    | MLarrayget -> Format.fprintf fmt "Array.get"
+    | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty"
+    | Coq_primitive (op,None) ->
+       Format.fprintf fmt "no_check_%s" (Primitives.to_string op)
+    | Coq_primitive (op, Some (prefix,kn)) ->
+       let u = Univ.Instance.empty in
+        Format.fprintf fmt "%s %a" (Primitives.to_string op)
+		       pp_mllam (MLglobal (Gconstant (prefix,(kn,u))))
+  in
+  Format.fprintf fmt "@[%a@]" pp_mllam l
+  
+let pp_array fmt t =
+  let len = Array.length t in
+  Format.fprintf fmt "@[[|";
+  for i = 0 to len - 2 do
+    Format.fprintf fmt "%a; " pp_mllam t.(i)
+  done;
+  if len > 0 then
+    Format.fprintf fmt "%a" pp_mllam t.(len - 1);
+  Format.fprintf fmt "|]@]"
+  
+let pp_global fmt g =
+  match g with
+  | Glet (gn, c) ->
+      let ids, c = decompose_MLlam c in
+      Format.fprintf fmt "@[let %a%a =@\n  %a@]@\n@." pp_gname gn 
+	pp_ldecls ids
+	pp_mllam c
+  | Gopen s ->
+      Format.fprintf fmt "@[open %s@]@." s
+  | Gtype ((mind, i), lar) ->
+      let l = string_of_mind mind in
+      let rec aux s ar = 
+	if Int.equal ar 0 then s else aux (s^" * Nativevalues.t") (ar-1) in
+      let pp_const_sig i fmt j ar =
+        let sig_str = if ar > 0 then aux "of Nativevalues.t" (ar-1) else "" in
+        Format.fprintf fmt "  | Construct_%s_%i_%i %s@\n" l i j sig_str
+      in
+      let pp_const_sigs i fmt lar =
+        Format.fprintf fmt "  | Accu_%s_%i of Nativevalues.t@\n" l i;
+        Array.iteri (pp_const_sig i fmt) lar
+      in
+      Format.fprintf fmt "@[type ind_%s_%i =@\n%a@]@\n@." l i (pp_const_sigs i) lar
+  | Gtblfixtype (g, params, t) ->
+      Format.fprintf fmt "@[let %a %a =@\n  %a@]@\n@." pp_gname g
+	pp_ldecls params pp_array t
+  | Gtblnorm (g, params, t) ->
+      Format.fprintf fmt "@[let %a %a =@\n  %a@]@\n@." pp_gname g
+	pp_ldecls params pp_array t 
+  | Gletcase(gn,params,annot,a,accu,bs) ->
+      Format.fprintf fmt "@[(* Hash = %i *)@\nlet rec %a %a =@\n  %a@]@\n@."
+      (hash_global g)
+	pp_gname gn pp_ldecls params 
+	pp_mllam (MLmatch(annot,a,accu,bs))
+  | Gcomment s ->
+      Format.fprintf fmt "@[(* %s *)@]@." s
+
+(** Compilation of elements in environment **)
+let rec compile_with_fv env sigma univ auxdefs l t =
+  let (auxdefs,(fv_named,fv_rel),ml) = mllambda_of_lambda univ auxdefs l t in
+  if List.is_empty fv_named && List.is_empty fv_rel then (auxdefs,ml)
+  else apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml
+
+and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
+  let get_rel_val (n,_) auxdefs =
+    (*
+    match !(lookup_rel_native_val n env) with
+    | NVKnone ->
+    *)
+        compile_rel env sigma univ auxdefs n
+(*    | NVKvalue (v,d) -> assert false *)
+  in
+  let get_named_val (id,_) auxdefs =
+    (*
+    match !(lookup_named_native_val id env) with
+    | NVKnone ->
+        *)
+        compile_named env sigma univ auxdefs id
+(*    | NVKvalue (v,d) -> assert false *)
+  in
+  let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in
+  let auxdefs = List.fold_right get_named_val fv_named auxdefs in
+  let lvl = rel_context_length env.env_rel_context in
+  let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in
+  let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in
+  let aux_name = fresh_lname Anonymous in
+  auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named)))
+
+and compile_rel env sigma univ auxdefs n =
+  let (_,body,_) = lookup_rel n env.env_rel_context in
+  let n = rel_context_length env.env_rel_context - n in
+  match body with
+  | Some t ->
+      let code = lambda_of_constr env sigma t in
+      let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in
+      Glet(Grel n, code)::auxdefs
+  | None -> 
+      Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs
+
+and compile_named env sigma univ auxdefs id =
+  let (_,body,_) = lookup_named id env.env_named_context in
+  match body with
+  | Some t ->
+      let code = lambda_of_constr env sigma t in
+      let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in
+      Glet(Gnamed id, code)::auxdefs
+  | None -> 
+      Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs
+
+let compile_constant env sigma prefix ~interactive con cb =
+  match cb.const_proj with
+  | None ->
+     let u =
+       if cb.const_polymorphic then Univ.UContext.instance cb.const_universes
+       else Univ.Instance.empty
+     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 Pp.msg_debug (Pp.str "Generated lambda code");
+      let is_lazy = is_lazy prefix t in
+      let code = if is_lazy then mk_lazy code else code in
+      let name =
+        if interactive then LinkedInteractive prefix
+        else Linked prefix
+      in
+      let l = con_label con in
+      let auxdefs,code =
+	if Univ.Instance.is_empty u then compile_with_fv env sigma None [] (Some l) code
+	else
+	  let univ = fresh_univ () in
+	  let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in
+          (auxdefs,mkMLlam [|univ|] code)
+      in
+      if !Flags.debug then Pp.msg_debug (Pp.str "Generated mllambda code");
+      let code =
+        optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs)
+      in
+      if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code");
+      code, name
+    | _ -> 
+        let i = push_symbol (SymbConst con) in
+	let args =
+	  if Univ.Instance.is_empty u then [|get_const_code i; MLarray [||]|]
+	  else [|get_const_code i|]
+	in
+	(*
+	let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const)
+	 *)
+        [Glet(Gconstant ("",(con,u)), mkMLapp (MLprimitive Mk_const) args)],
+	  if interactive then LinkedInteractive prefix
+	  else Linked prefix
+    end
+  | Some pb ->
+      let u = Univ.Instance.empty in
+      let mind = pb.proj_ind in
+      let ind = (mind,0) in
+      let mib = lookup_mind mind env in
+      let oib = mib.mind_packets.(0) in
+      let tbl = oib.mind_reloc_tbl in 
+      (* Building info *)
+      let prefix = get_mind_prefix env mind in
+      let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; 
+		 ci_cstr_nargs = [|0|];
+		 ci_cstr_ndecls = [||] (*FIXME*);
+		 ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in
+      let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci;
+		  asw_reloc = tbl; asw_finite = true } in
+      let c_uid = fresh_lname Anonymous in
+      let _, arity = tbl.(0) in
+      let ci_uid = fresh_lname Anonymous in
+      let cargs = Array.init arity
+        (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None)
+      in
+      let i = push_symbol (SymbConst con) in
+      let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in
+      let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in
+      let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in
+      let gn = Gproj ("",con) in
+      let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in
+      let arg = fargs.(pb.proj_npars) in
+        Glet(Gconstant ("",(con,u)), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal
+          arg|])))::
+            [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix
+
+let loaded_native_files = ref ([] : string list)
+
+let is_loaded_native_file s = String.List.mem s !loaded_native_files
+
+let register_native_file s =
+  if not (is_loaded_native_file s) then
+    loaded_native_files := s :: !loaded_native_files
+
+let is_code_loaded ~interactive name =
+  match !name with
+  | NotLinked -> false
+  | LinkedInteractive s ->
+      if (interactive && is_loaded_native_file s) then true
+      else (name := NotLinked; false)
+  | Linked s ->
+      if is_loaded_native_file s then true
+      else (name := NotLinked; false)
+
+let param_name = Name (id_of_string "params")
+let arg_name = Name (id_of_string "arg")
+
+let compile_mind prefix ~interactive mb mind stack =
+  let u = Declareops.inductive_instance mb in
+  let f i stack ob =
+    let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in
+    let j = push_symbol (SymbInd (mind,i)) in
+    let name = Gind ("", ((mind, i), u)) in
+    let accu =
+      let args =
+	if Univ.Instance.is_empty u then
+	  [|get_ind_code j; MLarray [||]|]
+	else [|get_ind_code j|]
+      in
+      Glet(name, MLapp (MLprimitive Mk_ind, args))
+    in
+    let nparams = mb.mind_nparams in
+    let params = 
+      Array.init nparams (fun i -> {lname = param_name; luid = i}) in
+    let add_construct j acc (_,arity) = 
+      let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in 
+      let c = (mind,i), (j+1) in
+	  Glet(Gconstruct ("",(c,u)),
+	     mkMLlam (Array.append params args)
+	       (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc
+    in
+    Array.fold_left_i add_construct (gtype::accu::stack) ob.mind_reloc_tbl
+  in
+  Array.fold_left_i f stack mb.mind_packets
+
+type code_location_update =
+    link_info ref * link_info
+type code_location_updates =
+  code_location_update Mindmap_env.t * code_location_update Cmap_env.t
+
+type linkable_code = global list * code_location_updates
+
+let empty_updates = Mindmap_env.empty, Cmap_env.empty
+
+let compile_mind_deps env prefix ~interactive
+    (comp_stack, (mind_updates, const_updates) as init) mind =
+  let mib,nameref = lookup_mind_key mind env in
+  if is_code_loaded ~interactive nameref
+    || Mindmap_env.mem mind mind_updates
+  then init
+  else
+    let comp_stack =
+      compile_mind prefix ~interactive mib mind comp_stack
+    in
+    let name =
+      if interactive then LinkedInteractive prefix
+      else Linked prefix
+    in
+    let upd = (nameref, name) in
+    let mind_updates = Mindmap_env.add mind upd mind_updates in
+    (comp_stack, (mind_updates, const_updates))
+
+(* This function compiles all necessary dependencies of t, and generates code in
+   reverse order, as well as linking information updates *)
+let rec compile_deps env sigma prefix ~interactive init t =
+  match kind_of_term t with
+  | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind
+  | Const c ->
+      let c,u = get_allias env c in
+      let cb,(nameref,_) = lookup_constant_key c env in
+      let (_, (_, const_updates)) = init in
+      if is_code_loaded ~interactive nameref
+        || (Cmap_env.mem c const_updates)
+      then init
+      else
+      let comp_stack, (mind_updates, const_updates) = match cb.const_body with
+        | Def t ->
+	   compile_deps env sigma prefix ~interactive init (Mod_subst.force_constr t)
+        | _ -> init
+      in
+      let code, name =
+	compile_constant env sigma prefix ~interactive c cb
+      in
+      let comp_stack = code@comp_stack in
+      let const_updates = Cmap_env.add c (nameref, name) const_updates in
+      comp_stack, (mind_updates, const_updates)
+  | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind
+  | Proj (p,c) ->
+    let term = mkApp (mkConst (Projection.constant p), [|c|]) in
+      compile_deps env sigma prefix ~interactive init term
+  | Case (ci, p, c, ac) ->
+      let mind = fst ci.ci_ind in
+      let init = compile_mind_deps env prefix ~interactive init mind in
+      fold_constr (compile_deps env sigma prefix ~interactive) init t
+  | _ -> fold_constr (compile_deps env sigma prefix ~interactive) init t
+
+let compile_constant_field env prefix con acc cb =
+    let (gl, _) =
+      compile_constant ~interactive:false env empty_evars prefix
+        con cb
+    in
+    gl@acc
+
+let compile_mind_field prefix mp l acc mb =
+  let mind = MutInd.make2 mp l in
+  compile_mind prefix ~interactive:false mb mind acc
+
+let mk_open s = Gopen s
+
+let mk_internal_let s code =
+  Glet(Ginternal s, code)
+
+(* ML Code for conversion function *)
+let mk_conv_code env sigma prefix t1 t2 =
+  clear_symb_tbl ();
+  clear_global_tbl ();
+  let gl, (mind_updates, const_updates) =
+    let init = ([], empty_updates) in
+    compile_deps env sigma prefix ~interactive:true init t1
+  in
+  let gl, (mind_updates, const_updates) =
+    let init = (gl, (mind_updates, const_updates)) in
+    compile_deps env sigma prefix ~interactive:true init t2
+  in
+  let code1 = lambda_of_constr env sigma t1 in
+  let code2 = lambda_of_constr env sigma t2 in
+  let (gl,code1) = compile_with_fv env sigma None gl None code1 in
+  let (gl,code2) = compile_with_fv env sigma None gl None code2 in
+  let t1 = mk_internal_let "t1" code1 in
+  let t2 = mk_internal_let "t2" code2 in
+  let g1 = MLglobal (Ginternal "t1") in
+  let g2 = MLglobal (Ginternal "t2") in
+  let setref1 = Glet(Ginternal "_", MLsetref("rt1",g1)) in
+  let setref2 = Glet(Ginternal "_", MLsetref("rt2",g2)) in
+  let gl = List.rev (setref2 :: setref1 :: t2 :: t1 :: gl) in
+  let header = Glet(Ginternal "symbols_tbl",
+    MLapp (MLglobal (Ginternal "get_symbols_tbl"),
+      [|MLglobal (Ginternal "()")|])) in
+  header::gl, (mind_updates, const_updates)
+
+let mk_norm_code env sigma prefix t =
+  clear_symb_tbl ();
+  clear_global_tbl ();
+  let gl, (mind_updates, const_updates) =
+    let init = ([], empty_updates) in
+    compile_deps env sigma prefix ~interactive:true init t
+  in
+  let code = lambda_of_constr env sigma t in
+  let (gl,code) = compile_with_fv env sigma None gl None code in
+  let t1 = mk_internal_let "t1" code in
+  let g1 = MLglobal (Ginternal "t1") in
+  let setref = Glet(Ginternal "_", MLsetref("rt1",g1)) in
+  let gl = List.rev (setref :: t1 :: gl) in
+  let header = Glet(Ginternal "symbols_tbl",
+    MLapp (MLglobal (Ginternal "get_symbols_tbl"),
+      [|MLglobal (Ginternal "()")|])) in
+  header::gl, (mind_updates, const_updates)
+
+let mk_library_header dir =
+  let libname = Format.sprintf "(str_decode \"%s\")" (str_encode dir) in
+  [Glet(Ginternal "symbols_tbl",
+    MLapp (MLglobal (Ginternal "get_library_symbols_tbl"),
+    [|MLglobal (Ginternal libname)|]))]
+
+let update_location (r,v) = r := v
+
+let update_locations (ind_updates,const_updates) =
+  Mindmap_env.iter (fun _ -> update_location) ind_updates;
+  Cmap_env.iter (fun _ -> update_location) const_updates
+
+let add_header_comment mlcode s =
+  Gcomment s :: mlcode
+
+(* vim: set filetype=ocaml foldmethod=marker: *)
diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli
new file mode 100644
index 00000000..893db92d
--- /dev/null
+++ b/kernel/nativecode.mli
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Term
+open Names
+open Declarations
+open Pre_env
+open Nativelambda
+
+(** This file defines the mllambda code generation phase of the native
+compiler. mllambda represents a fragment of ML, and can easily be printed
+to OCaml code. *)
+
+type mllambda
+type global
+
+val pp_global : Format.formatter -> global -> unit
+
+val mk_open : string -> global
+
+type symbol
+
+val clear_symb_tbl : unit -> unit
+
+val get_value : symbol array -> int -> Nativevalues.t
+
+val get_sort : symbol array -> int -> sorts
+
+val get_name : symbol array -> int -> name
+
+val get_const : symbol array -> int -> constant
+
+val get_match : symbol array -> int -> Nativevalues.annot_sw
+
+val get_ind : symbol array -> int -> inductive
+
+val get_meta : symbol array -> int -> metavariable
+
+val get_evar : symbol array -> int -> existential
+
+val get_level : symbol array -> int -> Univ.Level.t
+
+val get_symbols_tbl : unit -> symbol array
+
+type code_location_update
+type code_location_updates
+type linkable_code = global list * code_location_updates
+
+val clear_global_tbl : unit -> unit
+
+val empty_updates : code_location_updates
+
+val register_native_file : string -> unit
+
+val compile_constant_field : env -> string -> constant ->
+  global list -> constant_body -> global list
+
+val compile_mind_field : string -> module_path -> label ->
+  global list -> mutual_inductive_body -> global list
+
+val mk_conv_code : env -> evars -> string -> constr -> constr -> linkable_code
+val mk_norm_code : env -> evars -> string -> constr -> linkable_code
+
+val mk_library_header : dir_path -> global list
+
+val mod_uid_of_dirpath : dir_path -> string
+
+val link_info_of_dirpath : dir_path -> link_info
+
+val update_locations : code_location_updates -> unit
+
+val add_header_comment : global list -> string -> global list
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
new file mode 100644
index 00000000..75a3fc45
--- /dev/null
+++ b/kernel/nativeconv.ml
@@ -0,0 +1,148 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Errors
+open Names
+open Univ
+open Nativelib
+open Reduction
+open Util
+open Nativevalues
+open Nativecode 
+
+(** This module implements the conversion test by compiling to OCaml code *)
+
+let rec conv_val env pb lvl cu v1 v2 = 
+  if v1 == v2 then ()
+  else
+    match kind_of_value v1, kind_of_value v2 with
+    | Vaccu k1, Vaccu k2 ->
+	conv_accu env pb lvl cu k1 k2
+    | Vfun f1, Vfun f2 ->
+	let v = mk_rel_accu lvl in
+	conv_val env CONV (lvl+1) cu (f1 v) (f2 v)
+    | Vconst i1, Vconst i2 -> 
+	if not (Int.equal i1 i2) then raise NotConvertible
+    | Vblock b1, Vblock b2 ->
+	let n1 = block_size b1 in
+        let n2 = block_size b2 in
+	if not (Int.equal (block_tag b1) (block_tag b2)) || not (Int.equal n1 n2) then
+	  raise NotConvertible;
+	let rec aux lvl max b1 b2 i cu =
+	  if Int.equal i max then 
+	    conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i)
+	  else
+	      (conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i);
+	    aux lvl max b1 b2 (i+1) cu)
+	in
+	aux lvl (n1-1) b1 b2 0 cu
+    | Vfun f1, _ -> 
+	conv_val env CONV lvl cu v1 (fun x -> v2 x)
+    | _, Vfun f2 ->
+	conv_val env CONV lvl cu (fun x -> v1 x) v2
+    | _, _ -> raise NotConvertible
+
+and conv_accu env pb lvl cu k1 k2 = 
+  let n1 = accu_nargs k1 in
+  let n2 = accu_nargs k2 in
+  if not (Int.equal n1 n2) then raise NotConvertible;
+  if Int.equal n1 0 then 
+    conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu
+  else
+    (conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu;
+    List.iter2 (conv_val env CONV lvl cu) (args_of_accu k1) (args_of_accu k2))
+
+and conv_atom env pb lvl a1 a2 cu =
+  if a1 == a2 then ()
+  else
+    match a1, a2 with
+    | Arel i1, Arel i2 -> 
+	if not (Int.equal i1 i2) then raise NotConvertible
+    | Aind ind1, Aind ind2 ->
+	if not (eq_puniverses eq_ind ind1 ind2) then raise NotConvertible
+    | Aconstant c1, Aconstant c2 ->
+	if not (eq_puniverses eq_constant c1 c2) then raise NotConvertible
+    | Asort s1, Asort s2 -> 
+        check_sort_cmp_universes env pb s1 s2 cu
+    | Avar id1, Avar id2 ->
+	if not (Id.equal id1 id2) then raise NotConvertible
+    | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) ->
+	if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible;
+	conv_accu env CONV lvl cu ac1 ac2;
+	let tbl = a1.asw_reloc in
+	let len = Array.length tbl in
+	if Int.equal len 0 then conv_val env CONV lvl cu p1 p2
+	else begin
+	  conv_val env CONV lvl cu p1 p2;
+	  let max = len - 1 in
+	  let rec aux i =
+	    let tag,arity = tbl.(i) in
+	    let ci = 
+	      if Int.equal arity 0 then mk_const tag
+	      else mk_block tag (mk_rels_accu lvl arity) in
+	    let bi1 = bs1 ci and bi2 = bs2 ci in
+	    if Int.equal i max then conv_val env CONV (lvl + arity) cu bi1 bi2
+	    else (conv_val env CONV (lvl + arity) cu bi1 bi2; aux (i+1)) in
+	  aux 0
+	  end
+    | Afix(t1,f1,rp1,s1), Afix(t2,f2,rp2,s2) ->
+	if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible;
+	if f1 == f2 then ()
+	else conv_fix env lvl t1 f1 t2 f2 cu
+    | (Acofix(t1,f1,s1,_) | Acofixe(t1,f1,s1,_)),
+      (Acofix(t2,f2,s2,_) | Acofixe(t2,f2,s2,_)) ->
+	if not (Int.equal s1 s2) then raise NotConvertible;
+	if f1 == f2 then ()
+	else
+	  if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible
+	  else conv_fix env lvl t1 f1 t2 f2 cu 
+    | Aprod(_,d1,c1), Aprod(_,d2,c2) ->
+	conv_val env CONV lvl cu d1 d2;
+	let v = mk_rel_accu lvl in
+	conv_val env pb (lvl + 1) cu (d1 v) (d2 v)
+    | _, _ -> raise NotConvertible
+
+(* Precondition length t1 = length f1 = length f2 = length t2 *)
+and conv_fix env lvl t1 f1 t2 f2 cu =
+  let len = Array.length f1 in
+  let max = len - 1 in
+  let fargs = mk_rels_accu lvl len in
+  let flvl = lvl + len in
+  let rec aux i =
+    conv_val env CONV lvl cu t1.(i) t2.(i);
+    let fi1 = napply f1.(i) fargs in
+    let fi2 = napply f2.(i) fargs in
+    if Int.equal i max then conv_val env CONV flvl cu fi1 fi2
+    else (conv_val env CONV flvl cu fi1 fi2; aux (i+1)) in
+  aux 0
+
+let native_conv pb sigma env t1 t2 =
+  if !Flags.no_native_compiler then begin
+    let msg = "Native compiler is disabled, "^
+    "falling back to VM conversion test." in
+    Pp.msg_warning (Pp.str msg);
+    vm_conv pb env t1 t2
+  end
+  else
+  let penv = Environ.pre_env env in 
+  let ml_filename, prefix = get_ml_filename () in
+  let code, upds = mk_conv_code penv sigma prefix t1 t2 in
+  match compile ml_filename code with
+  | (true, fn) ->
+      begin
+        if !Flags.debug then Pp.msg_debug (Pp.str "Running test...");
+        let t0 = Sys.time () in
+        call_linker ~fatal:true prefix fn (Some upds);
+        let t1 = Sys.time () in
+        let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in
+        if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+        (* TODO change 0 when we can have deBruijn *)
+        conv_val env pb 0 (Environ.universes env) !rt1 !rt2
+      end
+  | _ -> anomaly (Pp.str "Compilation failure") 
+
+let _ = set_nat_conv native_conv
diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli
new file mode 100644
index 00000000..318a7d83
--- /dev/null
+++ b/kernel/nativeconv.mli
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Term
+open Reduction
+open Nativelambda
+
+(** This module implements the conversion test by compiling to OCaml code *)
+
+val native_conv : conv_pb -> evars -> types conversion_function
diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli
new file mode 100644
index 00000000..b7d3dadc
--- /dev/null
+++ b/kernel/nativeinstr.mli
@@ -0,0 +1,53 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Names
+open Term
+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 * int 
+  | Lvar          of identifier
+  | Lmeta         of metavariable * lambda (* type *)
+  | Levar         of existential * lambda (* type *)
+  | Lprod         of lambda * lambda 
+  | Llam          of name array * lambda  
+  | Llet          of name * lambda * lambda
+  | Lapp          of lambda * lambda array
+  | Lconst        of prefix * pconstant
+  | Lproj         of prefix * constant (* prefix, projection name *)
+  | Lprim         of prefix * constant * Primitives.t * lambda array
+  | Lcase         of annot_sw * lambda * lambda * lam_branches 
+                  (* annotations, term being matched, accu, branches *)
+  | Lif           of lambda * lambda * lambda
+  | Lfix          of (int array * int) * fix_decl 
+  | Lcofix        of int * fix_decl 
+  | 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
+  | Lind          of prefix * pinductive
+  | Llazy
+  | Lforce
+
+and lam_branches = (constructor * name array * lambda) array 
+
+and fix_decl =  name array * lambda array * lambda array
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
new file mode 100644
index 00000000..543397df
--- /dev/null
+++ b/kernel/nativelambda.ml
@@ -0,0 +1,779 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Util
+open Names
+open Esubst
+open Term
+open Declarations
+open Pre_env
+open Nativevalues
+open Nativeinstr
+
+(** This file defines the lambda code generation phase of the native compiler *)
+
+exception NotClosed
+
+type evars =
+    { evars_val : existential -> constr option;
+      evars_typ : existential -> types;
+      evars_metas : metavariable -> types }
+
+(*s Constructors *)
+
+let mkLapp f args =
+  if Array.is_empty args then f
+  else
+    match f with
+    | Lapp(f', args') -> Lapp (f', Array.append args' args)
+    | _ -> Lapp(f, args)
+
+let mkLlam ids body =
+  if Array.is_empty ids then body
+  else 
+    match body with
+    | Llam(ids', body) -> Llam(Array.append ids ids', body)
+    | _ -> Llam(ids, body)
+
+let decompose_Llam lam =
+  match lam with
+  | Llam(ids,body) -> ids, body
+  | _ -> [||], lam
+
+let rec decompose_Llam_Llet lam =
+  match lam with
+  | Llam(ids,body) ->
+      let vars, body = decompose_Llam_Llet body in
+      Array.fold_right (fun x l -> (x, None) :: l) ids vars, body
+  | Llet(id,def,body) ->
+      let vars, body = decompose_Llam_Llet body in
+      (id,Some def) :: vars, body
+  | _ -> [], lam
+
+let decompose_Llam_Llet lam =
+  let vars, body = decompose_Llam_Llet lam in
+  Array.of_list vars, body
+
+(*s Operators on substitution *)
+let subst_id = subs_id 0
+let lift = subs_lift 
+let liftn = subs_liftn
+let cons v subst = subs_cons([|v|], subst)
+let shift subst = subs_shft (1, subst)
+
+(* Linked code location utilities *)
+let get_mind_prefix env mind =
+   let _,name = lookup_mind_key mind env in
+   match !name with
+   | NotLinked -> ""
+   | Linked s -> s
+   | LinkedInteractive s -> s
+
+let get_const_prefix env c =
+   let _,(nameref,_) = lookup_constant_key c env in
+   match !nameref with
+   | NotLinked -> ""
+   | Linked s -> s
+   | LinkedInteractive s -> s
+
+(* A generic map function *)
+
+let map_lam_with_binders g f n lam =
+  match lam with
+  | Lrel _ | Lvar _  | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _
+  | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam
+  | Lprod(dom,codom) -> 
+      let dom' = f n dom in
+      let codom' = f n codom in
+      if dom == dom' && codom == codom' then lam else Lprod(dom',codom')
+  | Llam(ids,body) ->
+      let body' = f (g (Array.length ids) n) body in
+      if body == body' then lam else mkLlam ids body'
+  | Llet(id,def,body) ->
+      let def' = f n def in
+      let body' = f (g 1 n) body in
+      if body == body' && def == def' then lam else Llet(id,def',body')
+  | Lapp(fct,args) ->
+      let fct' = f n fct in
+      let args' = Array.smartmap (f n) args in
+      if fct == fct' && args == args' then lam else mkLapp fct' args'
+  | Lprim(prefix,kn,op,args) ->
+      let args' = Array.smartmap (f n) args in
+      if args == args' then lam else Lprim(prefix,kn,op,args')
+  | Lcase(annot,t,a,br) ->
+      let t' = f n t in
+      let a' = f n a in
+      let on_b b = 
+	let (cn,ids,body) = b in
+	let body' = 
+	  if Array.is_empty ids then f n body 
+	  else f (g (Array.length ids) n) body in
+	if body == body' then b else (cn,ids,body') in
+      let br' = Array.smartmap on_b br in
+      if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br')
+  | Lif(t,bt,bf) ->
+      let t' = f n t in
+      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.smartmap (f n) ltypes in
+      let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+      if ltypes == ltypes' && lbodies == lbodies' then lam
+      else Lfix(init,(ids,ltypes',lbodies'))
+  | Lcofix(init,(ids,ltypes,lbodies)) ->
+      let ltypes' = Array.smartmap (f n) ltypes in
+      let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+      if ltypes == ltypes' && lbodies == lbodies' then lam
+      else Lcofix(init,(ids,ltypes',lbodies'))
+  | Lmakeblock(prefix,cn,tag,args) ->
+      let args' = Array.smartmap (f n) args in
+      if args == args' then lam else Lmakeblock(prefix,cn,tag,args')
+
+(*s Lift and substitution *)
+ 
+let rec lam_exlift el lam =
+  match lam with
+  | Lrel(id,i) -> 
+      let i' = reloc_rel i el in
+      if i == i' then lam else Lrel(id,i')
+  | _ -> map_lam_with_binders el_liftn lam_exlift el lam
+
+let lam_lift k lam =
+  if Int.equal k 0 then lam
+  else lam_exlift (el_shft k el_id) lam
+
+let lam_subst_rel lam id n subst =
+  match expand_rel n subst with
+  | Inl(k,v) -> lam_lift k v
+  | Inr(n',_) -> 
+      if n == n' then lam
+      else Lrel(id, n') 
+
+let rec lam_exsubst subst lam =
+  match lam with
+  | Lrel(id,i) -> lam_subst_rel lam id i subst
+  | _ -> map_lam_with_binders liftn lam_exsubst subst lam
+
+let lam_subst subst lam =
+  if is_subs_id subst then lam
+  else lam_exsubst subst lam
+
+let lam_subst_args subst args =
+  if is_subs_id subst then args 
+  else Array.smartmap (lam_exsubst subst) args
+  
+(** Simplification of lambda expression *)
+      
+(* [simplify subst lam] simplify the expression [lam_subst subst lam] *)
+(* that is :                                                          *)
+(* - Reduce [let] is the definition can be substituted i.e:           *)
+(*    - a variable (rel or identifier)                                *)
+ (*    - a constant                                                    *)
+(*    - a structured constant                                         *)
+(*    - a function                                                    *)
+(* - Transform beta redex into [let] expression                       *)
+(* - Move arguments under [let]                                       *) 
+(* Invariant : Terms in [subst] are already simplified and can be     *)
+(*             substituted                                            *)
+  
+let can_subst lam = 
+  match lam with
+  | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _
+  | Lconstruct _ | Lmeta _ | Levar _ -> 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 Int.equal 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')
+
+  | Lapp(f,args) ->
+      begin match simplify_app subst f subst args with
+      | Lapp(f',args') when f == f' && args == args' -> lam
+      | lam' -> lam'
+      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 =
+  match f with
+  | Lrel(id, i) ->
+      begin match lam_subst_rel f id i substf with
+      | Llam(ids, body) ->
+	  reduce_lapp 
+	    subst_id (Array.to_list ids) body  
+	    substa (Array.to_list args)
+      | f' -> mkLapp f' (simplify_args substa args)
+      end
+  | Llam(ids, body) ->
+      reduce_lapp substf (Array.to_list ids) body substa (Array.to_list args)
+  | Llet(id, def, body) ->
+      let def' = simplify substf def in
+      if can_subst def' then
+	simplify_app (cons def' substf) body substa args
+      else 
+	Llet(id, def', simplify_app (lift substf) body (shift substa) args)
+  | Lapp(f, args') ->
+      let args = Array.append 
+	  (lam_subst_args substf args') (lam_subst_args substa args) in
+      simplify_app substf f subst_id args
+  (* TODO | Lproj -> simplify if the argument is known or a known global *)
+  | _ -> mkLapp (simplify substf f) (simplify_args substa args)
+  
+and simplify_args subst args = Array.smartmap (simplify subst) args
+
+and reduce_lapp substf lids body substa largs =
+  match lids, largs with
+  | id::lids, a::largs ->
+      let a = simplify substa a in
+      if can_subst a then
+	reduce_lapp (cons a substf) lids body substa largs
+      else
+	let body = reduce_lapp (lift substf) lids body (shift substa) largs in
+	Llet(id, a, body)
+  | [], [] -> simplify substf body
+  | _::_, _ -> 
+      Llam(Array.of_list lids,  simplify (liftn (List.length lids) substf) body)
+  | [], _::_ -> simplify_app substf body substa (Array.of_list largs)
+
+
+(* [occurence kind k lam]:
+   If [kind] is [true] return [true] if the variable [k] does not appear in 
+   [lam], return [false] if the variable appear one time and not
+   under a lambda, a fixpoint, a cofixpoint; else raise Not_found.
+   If [kind] is [false] return [false] if the variable does not appear in [lam]
+   else raise [Not_found]
+*)
+
+let rec occurence k kind lam =   
+  match lam with
+  | Lrel (_,n) -> 
+      if Int.equal n k then 
+	if kind then false else raise Not_found
+      else kind
+  | Lvar _  | Lconst _  | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _
+  | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind
+  | Lprod(dom, codom) ->
+      occurence k (occurence k kind dom) codom
+  | Llam(ids,body) ->
+      let _ = occurence (k+Array.length ids) false body in kind
+  | Llet(_,def,body) ->
+      occurence (k+1) (occurence k kind def) body
+  | Lapp(f, args) ->
+      occurence_args k (occurence k kind f) args
+  | Lprim(_,_,_,args) | Lmakeblock(_,_,_,args) ->
+      occurence_args k kind args
+  | Lcase(_,t,a,br) ->
+      let kind = occurence k (occurence k kind t) a in
+      let r = ref kind in
+      Array.iter (fun (_,ids,c) -> 
+	r := occurence (k+Array.length ids) kind c && !r) br;
+      !r 
+  | Lif (t, bt, bf) ->
+      let kind = occurence k kind t in
+      kind && occurence k kind bt && occurence k kind bf
+  | Lfix(_,(ids,ltypes,lbodies)) 
+  | Lcofix(_,(ids,ltypes,lbodies)) ->
+      let kind = occurence_args k kind ltypes in
+      let _ = occurence_args (k+Array.length ids) false lbodies in
+      kind 
+
+and occurence_args k kind args = 
+  Array.fold_left (occurence k) kind args
+    
+let occur_once lam = 
+  try let _ = occurence 1 true lam in true
+  with Not_found -> false
+      
+(* [remove_let lam] remove let expression in [lam] if the variable is *)
+(* used at most once time in the body, and does not appear under      *)
+(* a lambda or a fix or a cofix                                       *)
+      
+let rec remove_let subst lam =
+  match lam with
+  | Lrel(id,i) -> lam_subst_rel lam id i subst 
+  | Llet(id,def,body) ->
+      let def' = remove_let subst def in
+      if occur_once body then remove_let (cons def' subst) body
+      else 
+	let body' = remove_let (lift subst) body in
+	if def == def' && body == body' then lam else Llet(id,def',body')
+  | _ -> map_lam_with_binders liftn remove_let subst lam
+
+
+(*s Translation from [constr] to [lambda] *)
+
+(* Translation of constructor *)
+
+let is_value lc =
+  match lc with
+  | Lval _ -> true
+  | Lmakeblock(_,_,_,args) when Array.is_empty args -> true
+  | _ -> false
+	
+let get_value lc =
+  match lc with
+  | Lval v -> v
+  | Lmakeblock(_,_,tag,args) when Array.is_empty args -> 
+      Nativevalues.mk_int tag
+  | _ -> raise Not_found
+	
+let make_args start _end =
+  Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i))
+    
+(* Translation of constructors *)	
+
+let makeblock env cn u tag args =
+  if Array.for_all is_value args && Array.length args > 0 then
+    let args = Array.map get_value args in
+    Lval (Nativevalues.mk_block tag args)
+  else
+    let prefix = get_mind_prefix env (fst (fst cn)) in
+    Lmakeblock(prefix, (cn,u), tag, args)
+
+(* Translation of constants *)
+
+let rec get_allias env (kn, u as p) =
+  let tps = (lookup_constant kn env).const_body_code in
+  match Cemitcodes.force tps with
+  |  Cemitcodes.BCallias kn' -> get_allias env kn'
+  | _ -> p
+
+(*i Global environment *)
+
+let global_env = ref empty_env 
+
+let set_global_env env = global_env := env
+
+let get_names decl = 
+  let decl = Array.of_list decl in
+  Array.map fst decl
+
+(* Rel Environment *)
+module Vect = 
+  struct
+    type 'a t = {
+	mutable elems : 'a array;
+	mutable size : int;
+      }
+
+    let make n a = {
+      elems = Array.make n a;
+      size = 0;
+    }
+
+    let length v = v.size
+
+    let extend v =
+      if Int.equal v.size (Array.length v.elems) then 
+	let new_size = min (2*v.size) Sys.max_array_length in
+	if new_size <= v.size then invalid_arg "Vect.extend";
+	let new_elems = Array.make new_size v.elems.(0) in
+	Array.blit v.elems 0 new_elems 0 (v.size);
+	v.elems <- new_elems
+
+    let push v a = 
+      extend v;
+      v.elems.(v.size) <- a;
+      v.size <- v.size + 1
+
+    let push_pos v a =
+      let pos = v.size in
+      push v a;
+      pos
+
+    let popn v n =
+      v.size <- max 0 (v.size - n)
+
+    let pop v = popn v 1
+	
+    let get v n =
+      if v.size <= n then invalid_arg "Vect.get:index out of bounds";
+      v.elems.(n)
+
+    let get_last v n =
+      if v.size <= n then invalid_arg "Vect.get:index out of bounds";
+      v.elems.(v.size - n - 1)
+
+
+    let last v =
+      if Int.equal v.size 0 then invalid_arg "Vect.last:index out of bounds";
+      v.elems.(v.size - 1)
+
+    let clear v = v.size <- 0
+
+    let to_array v = Array.sub v.elems 0 v.size
+      
+  end
+
+let empty_args = [||]
+
+module Renv = 
+  struct
+
+    module ConstrHash =
+    struct
+      type t = constructor
+      let equal = eq_constructor
+      let hash = constructor_hash
+    end
+
+    module ConstrTable = Hashtbl.Make(ConstrHash)
+
+    type constructor_info = tag * int * int (* nparam nrealargs *)
+
+    type t = {
+	name_rel : name Vect.t;
+	construct_tbl : constructor_info ConstrTable.t;
+
+       }
+
+
+    let make () = {
+      name_rel = Vect.make 16 Anonymous;
+      construct_tbl = ConstrTable.create 111
+    }
+
+    let push_rel env id = Vect.push env.name_rel id
+
+    let push_rels env ids = 
+      Array.iter (push_rel env) ids
+
+    let pop env = Vect.pop env.name_rel
+	    
+    let popn env n =
+      for i = 1 to n do pop env done
+
+    let get env n =
+      Lrel (Vect.get_last env.name_rel (n-1), n)
+
+    let get_construct_info env c =
+      try ConstrTable.find env.construct_tbl c
+      with Not_found -> 
+	let ((mind,j), i) = c in
+	let oib = lookup_mind mind !global_env in
+	let oip = oib.mind_packets.(j) in
+	let tag,arity = oip.mind_reloc_tbl.(i-1) in
+	let nparams = oib.mind_nparams in
+	let r = (tag, nparams, arity) in
+	ConstrTable.add env.construct_tbl c r;
+	r
+  end
+
+(* What about pattern matching ?*)
+let is_lazy prefix t =
+  match kind_of_term t with
+  | App (f,args) ->
+     begin match kind_of_term f with
+     | Construct (c,_) ->
+	let entry = mkInd (fst c) in
+	(try
+	    let _ =
+	      Retroknowledge.get_native_before_match_info (!global_env).retroknowledge
+							  entry prefix c Llazy;
+	    in
+	    false
+	  with Not_found -> true)
+     | _ -> true
+     end
+  | LetIn _ -> true
+  | _ -> false
+
+let evar_value sigma ev = sigma.evars_val ev
+
+let evar_type sigma ev = sigma.evars_typ ev
+
+let meta_type sigma mv = sigma.evars_metas mv
+
+let empty_evars =
+  { evars_val = (fun _ -> None);
+    evars_typ = (fun _ -> assert false);
+    evars_metas = (fun _ -> assert false) }
+
+let empty_ids = [||]
+
+let rec lambda_of_constr env sigma c =
+  match kind_of_term c with
+  | Meta mv ->
+     let ty = meta_type sigma mv in
+     Lmeta (mv, lambda_of_constr env sigma ty)
+
+  | Evar ev ->
+     (match evar_value sigma ev with
+     | None ->
+	let ty = evar_type sigma ev in
+	Levar(ev, lambda_of_constr env sigma ty)
+     | Some t -> lambda_of_constr env sigma t)
+
+  | Cast (c, _, _) -> lambda_of_constr env sigma c
+
+  | Rel i -> Renv.get env i
+
+  | Var id -> Lvar id
+
+  | Sort s -> Lsort s
+
+  | Ind (ind,u as pind) ->
+      let prefix = get_mind_prefix !global_env (fst ind) in
+      Lind (prefix, pind)
+
+  | Prod(id, dom, codom) ->
+      let ld = lambda_of_constr env sigma dom in
+      Renv.push_rel env id;
+      let lc = lambda_of_constr env sigma codom in
+      Renv.pop env;
+      Lprod(ld,  Llam([|id|], lc))
+
+  | Lambda _ ->
+      let params, body = decompose_lam c in
+      let ids = get_names (List.rev params) in
+      Renv.push_rels env ids;
+      let lb = lambda_of_constr env sigma body in
+      Renv.popn env (Array.length ids);
+      mkLlam ids lb
+
+  | LetIn(id, def, _, body) ->
+      let ld = lambda_of_constr env sigma def in
+      Renv.push_rel env id;
+      let lb = lambda_of_constr env sigma body in
+      Renv.pop env;
+      Llet(id, ld, lb)
+
+  | App(f, args) -> lambda_of_app env sigma f args
+
+  | Const _ -> lambda_of_app env sigma c empty_args
+
+  | Construct _ ->  lambda_of_app env sigma c empty_args
+
+  | Proj (p, c) ->
+    let kn = Projection.constant p in
+      mkLapp (Lproj (get_const_prefix !global_env kn, kn)) [|lambda_of_constr env sigma c|]
+
+  | Case(ci,t,a,branches) ->  
+      let (mind,i as ind) = ci.ci_ind in
+      let mib = lookup_mind mind !global_env in
+      let oib = mib.mind_packets.(i) in
+      let tbl = oib.mind_reloc_tbl in 
+      (* Building info *)
+      let prefix = get_mind_prefix !global_env mind in
+      let annot_sw = 
+	    { asw_ind = ind;
+          asw_ci = ci;
+          asw_reloc = tbl; 
+          asw_finite = mib.mind_finite <> Decl_kinds.CoFinite;
+          asw_prefix = prefix}
+      in
+      (* translation of the argument *)
+      let la = lambda_of_constr env sigma a in
+      let entry = mkInd ind in
+      let la =
+	try
+	  Retroknowledge.get_native_before_match_info (!global_env).retroknowledge
+						      entry prefix (ind,1) la
+	with Not_found -> la
+      in
+      (* translation of the type *)
+      let lt = lambda_of_constr env sigma t in
+      (* translation of branches *)
+      let mk_branch i b =
+	let cn = (ind,i+1) in
+	let _, arity = tbl.(i) in
+	let b = lambda_of_constr env sigma b in
+	if Int.equal arity 0 then (cn, empty_ids, b)
+	else 
+	  match b with
+	  | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body)
+	  | _ -> 
+	      let ids = Array.make arity Anonymous in
+	      let args = make_args arity 1 in
+	      let ll = lam_lift arity b in
+	      (cn, ids, mkLapp  ll args) in
+      let bs = Array.mapi mk_branch branches in
+      Lcase(annot_sw, lt, la, bs)
+	
+  | Fix(rec_init,(names,type_bodies,rec_bodies)) ->
+      let ltypes = lambda_of_args env sigma 0 type_bodies in
+      Renv.push_rels env names;
+      let lbodies = lambda_of_args env sigma 0 rec_bodies in
+      Renv.popn env (Array.length names);
+      Lfix(rec_init, (names, ltypes, lbodies))
+	
+  | CoFix(init,(names,type_bodies,rec_bodies)) ->
+      let ltypes = lambda_of_args env sigma 0 type_bodies in 
+      Renv.push_rels env names;
+      let lbodies = lambda_of_args env sigma 0 rec_bodies in
+      Renv.popn env (Array.length names);
+      Lcofix(init, (names, ltypes, lbodies))
+
+and lambda_of_app env sigma f args =
+  match kind_of_term f with
+  | Const (kn,u as c) ->
+      let kn,u = get_allias !global_env c in
+      let cb = lookup_constant kn !global_env in
+      (try
+          let prefix = get_const_prefix !global_env kn in
+	  (* We delay the compilation of arguments to avoid an exponential behavior *)
+	  let f = Retroknowledge.get_native_compiling_info
+		    (!global_env).retroknowledge (mkConst kn) prefix in
+	  let args = lambda_of_args env sigma 0 args in
+	  f args
+      with Not_found ->
+      begin match cb.const_body with
+      | Def csubst -> (* TODO optimize if f is a proj and argument is known *)
+          if cb.const_inline_code then
+            lambda_of_app env sigma (Mod_subst.force_constr csubst) args
+          else
+          let prefix = get_const_prefix !global_env kn in
+          let t =
+            if is_lazy prefix (Mod_subst.force_constr csubst) then
+              mkLapp Lforce [|Lconst (prefix, (kn,u))|]
+            else Lconst (prefix, (kn,u))
+          in
+        mkLapp t (lambda_of_args env sigma 0 args)
+      | OpaqueDef _ | Undef _ ->
+          let prefix = get_const_prefix !global_env kn in
+          mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args env sigma 0 args)
+      end)
+  | Construct (c,u) ->
+      let tag, nparams, arity = Renv.get_construct_info env c in
+      let expected = nparams + arity in
+      let nargs = Array.length args in
+      let prefix = get_mind_prefix !global_env (fst (fst c)) in
+      if Int.equal nargs expected then 
+      try
+	try
+	  Retroknowledge.get_native_constant_static_info
+                         (!global_env).retroknowledge
+                         f args
+          with NotClosed ->
+	    assert (Int.equal nparams 0); (* should be fine for int31 *)
+	    let args = lambda_of_args env sigma nparams args in
+	    Retroknowledge.get_native_constant_dynamic_info
+                           (!global_env).retroknowledge f prefix c args
+        with Not_found ->
+	  let args = lambda_of_args env sigma nparams args in
+	  makeblock !global_env c u tag args
+      else
+	let args = lambda_of_args env sigma 0 args in
+	(try
+	    Retroknowledge.get_native_constant_dynamic_info
+              (!global_env).retroknowledge f prefix c args
+	  with Not_found ->
+            mkLapp (Lconstruct (prefix, (c,u))) args)
+  | _ -> 
+      let f = lambda_of_constr env sigma f in
+      let args = lambda_of_args env sigma 0 args in
+      mkLapp f args
+	
+and lambda_of_args env sigma start args =
+  let nargs = Array.length args in
+  if start < nargs then
+    Array.init (nargs - start) 
+      (fun i -> lambda_of_constr env sigma args.(start + i))
+  else empty_args
+
+let optimize lam =
+  let lam = simplify subst_id lam in
+(*  if Flags.vm_draw_opt () then 
+    (msgerrnl (str "Simplify = \n" ++ pp_lam lam);flush_all()); 
+  let lam = remove_let subst_id lam in
+  if Flags.vm_draw_opt () then 
+    (msgerrnl (str "Remove let = \n" ++ pp_lam lam);flush_all()); *)
+  lam
+
+let lambda_of_constr env sigma c =
+  set_global_env env;
+  let env = Renv.make () in
+  let ids = List.rev_map (fun (id, _, _) -> id) !global_env.env_rel_context in
+  Renv.push_rels env (Array.of_list ids);
+  let lam = lambda_of_constr env sigma c in
+(*  if Flags.vm_draw_opt () then begin
+    (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); 
+    (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); 
+  end; *)
+  optimize lam
+
+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_of_term 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
new file mode 100644
index 00000000..6a97edc4
--- /dev/null
+++ b/kernel/nativelambda.mli
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Names
+open Term
+open Pre_env
+open Nativevalues
+open Nativeinstr
+
+(** This file defines the lambda code generation phase of the native compiler *)
+type evars =
+    { evars_val : existential -> constr option;
+      evars_typ : existential -> types;
+      evars_metas : metavariable -> types }
+
+val empty_evars : evars
+
+val decompose_Llam : lambda -> Names.name array * lambda
+val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda
+
+val is_lazy : prefix -> constr -> bool
+val mk_lazy : lambda -> lambda
+
+val get_mind_prefix : env -> mutual_inductive -> string
+
+val get_allias : 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 : Primitives.t -> constant -> bool -> prefix -> lambda array ->
+		   lambda
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
new file mode 100644
index 00000000..dd47bc06
--- /dev/null
+++ b/kernel/nativelib.ml
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Util
+open Nativevalues
+open Nativecode
+open Errors
+open Envars
+
+(** This file provides facilities to access OCaml compiler and dynamic linker,
+used by the native compiler. *)
+
+let get_load_paths =
+  ref (fun _ -> anomaly (Pp.str "get_load_paths not initialized") : unit -> string list)
+
+let open_header = ["Nativevalues";
+                   "Nativecode";
+                   "Nativelib";
+		   "Nativeconv";
+                   "Declaremods"]
+let open_header = List.map mk_open open_header
+
+(* Directory where compiled files are stored *)
+let output_dir = ".coq-native"
+
+(* Extension of genereted ml files, stored for debugging purposes *)
+let source_ext = ".native"
+
+(* Global settings and utilies for interface with OCaml *)
+let compiler_name =
+  if Dynlink.is_native then ocamlopt () else ocamlc ()
+
+let ( / ) = Filename.concat
+
+(* We have to delay evaluation of include_dirs because coqlib cannot be guessed
+until flags have been properly initialized *)
+let include_dirs () =
+  [Filename.temp_dir_name; coqlib () / "kernel"; coqlib () / "library"]
+
+(* Pointer to the function linking an ML object into coq's toplevel *)
+let load_obj = ref (fun x -> () : string -> unit)
+
+let rt1 = ref (dummy_value ())
+let rt2 = ref (dummy_value ())
+
+let get_ml_filename () =
+  let filename = Filename.temp_file "Coq_native" source_ext in
+  let prefix = Filename.chop_extension (Filename.basename filename) ^ "." in
+  filename, prefix
+
+let write_ml_code fn ?(header=[]) code =
+  let header = open_header@header in
+  let ch_out = open_out fn in
+  let fmt = Format.formatter_of_out_channel ch_out in
+  List.iter (pp_global fmt) (header@code);
+  close_out ch_out
+
+let call_compiler ml_filename =
+  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
+  let f = Filename.chop_extension ml_filename in
+  let link_filename = f ^ ".cmo" in
+  let link_filename = Dynlink.adapt_filename link_filename in
+  let remove f = if Sys.file_exists f then Sys.remove f in
+  remove link_filename;
+  remove (f ^ ".cmi");
+  let args =
+    (if Dynlink.is_native then "-shared" else "-c")
+    ::"-o"::link_filename
+    ::"-rectypes"
+    ::"-w"::"a"
+    ::include_dirs
+    @ ["-impl"; ml_filename] in
+  if !Flags.debug then Pp.msg_debug (Pp.str (compiler_name ^ " " ^ (String.concat " " args)));
+  CUnix.sys_command compiler_name args = Unix.WEXITED 0, link_filename
+
+let compile fn code =
+  write_ml_code fn code;
+  let r = call_compiler fn in
+  if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn;
+  r
+
+let compile_library dir code fn =
+  let header = mk_library_header dir in
+  let fn = fn ^ source_ext in
+  let basename = Filename.basename fn in
+  let dirname = Filename.dirname fn in
+  let dirname = dirname / output_dir in
+  if not (Sys.file_exists dirname) then Unix.mkdir dirname 0o755;
+  let fn = dirname / basename in
+  write_ml_code fn ~header code;
+  let r = fst (call_compiler fn) in
+  if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn;
+  r
+
+(* call_linker links dynamically the code for constants in environment or a  *)
+(* conversion test. Silently fails if the file does not exist in bytecode    *)
+(* mode, since the standard library is not compiled to bytecode with default *)
+(* settings.                                                                 *)
+let call_linker ?(fatal=true) prefix f upds =
+  rt1 := dummy_value ();
+  rt2 := dummy_value ();
+  if Dynlink.is_native || Sys.file_exists f then
+  (try
+    if Dynlink.is_native then Dynlink.loadfile f else !load_obj f;
+    register_native_file prefix
+   with | Dynlink.Error e ->
+          let msg = "Dynlink error, " ^ Dynlink.error_message e in
+          if fatal then anomaly (Pp.str msg) else Pp.msg_warning (Pp.str msg)
+        | e when Errors.noncritical e ->
+          if fatal then anomaly (Errors.print e)
+	  else Pp.msg_warning (Errors.print_no_report e));
+  match upds with Some upds -> update_locations upds | _ -> ()
+
+let link_library ~prefix ~dirname ~basename =
+  let f = dirname / output_dir / basename in
+  call_linker ~fatal:false prefix f None
diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli
new file mode 100644
index 00000000..0941dc56
--- /dev/null
+++ b/kernel/nativelib.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Nativecode
+
+(** This file provides facilities to access OCaml compiler and dynamic linker,
+used by the native compiler. *)
+
+(* Directory where compiled files are stored *)
+val output_dir : string
+
+val get_load_paths : (unit -> string list) ref
+
+val load_obj : (string -> unit) ref
+
+val get_ml_filename : unit -> string * string
+
+val compile : string -> global list -> bool * string
+
+val compile_library : Names.dir_path -> global list -> string -> bool
+
+val call_linker :
+  ?fatal:bool -> string -> string -> code_location_updates option -> unit
+
+val link_library : prefix:string -> dirname:string -> basename:string -> unit
+
+val rt1 : Nativevalues.t ref
+val rt2 : Nativevalues.t ref
diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml
new file mode 100644
index 00000000..914f577e
--- /dev/null
+++ b/kernel/nativelibrary.ml
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Declarations
+open Environ
+open Mod_subst
+open Modops
+open Nativecode
+open Nativelib
+
+(** This file implements separate compilation for libraries in the native
+compiler *)
+
+let rec translate_mod prefix mp env mod_expr acc =
+  match mod_expr with
+  | NoFunctor struc ->
+      let env' = add_structure mp struc empty_delta_resolver env in
+      List.fold_left (translate_field prefix mp env') acc struc
+  | MoreFunctor _ -> acc
+
+and translate_field prefix mp env acc (l,x) =
+  match x with
+  | SFBconst cb ->
+     let con = make_con mp empty_dirpath l in
+     (if !Flags.debug then
+	let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in
+	Pp.msg_debug (Pp.str msg));
+     compile_constant_field (pre_env env) prefix con acc cb
+  | SFBmind mb ->
+     (if !Flags.debug then
+	let id = mb.mind_packets.(0).mind_typename in
+	let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in
+	Pp.msg_debug (Pp.str msg));
+     compile_mind_field prefix mp l acc mb
+  | SFBmodule md ->
+     let mp = md.mod_mp in
+     (if !Flags.debug then
+	let msg =
+	  Printf.sprintf "Compiling module %s..." (ModPath.to_string mp)
+	in
+	Pp.msg_debug (Pp.str msg));
+     translate_mod prefix mp env md.mod_type acc
+  | SFBmodtype mdtyp ->
+     let mp = mdtyp.mod_mp in
+     (if !Flags.debug then
+	let msg =
+	  Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp)
+	in
+	Pp.msg_debug (Pp.str msg));
+     translate_mod prefix mp env mdtyp.mod_type acc
+
+let dump_library mp dp env mod_expr =
+  if !Flags.debug then Pp.msg_debug (Pp.str "Compiling library...");
+  match mod_expr with
+  | NoFunctor struc ->
+      let env = add_structure mp struc empty_delta_resolver env in
+      let prefix = mod_uid_of_dirpath dp ^ "." in
+      let t0 = Sys.time () in
+      clear_global_tbl ();
+      clear_symb_tbl ();
+      let mlcode =
+        List.fold_left (translate_field prefix mp env) [] struc
+      in
+      let t1 = Sys.time () in
+      let time_info = Format.sprintf "Time spent generating this code: %.5fs" (t1-.t0) in
+      let mlcode = add_header_comment (List.rev mlcode) time_info in
+      mlcode, get_symbols_tbl ()
+  | _ -> assert false
diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli
new file mode 100644
index 00000000..a66fb715
--- /dev/null
+++ b/kernel/nativelibrary.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Names
+open Declarations
+open Environ
+open Nativecode
+
+(** This file implements separate compilation for libraries in the native
+compiler *)
+
+val dump_library : module_path -> dir_path -> env -> module_signature ->
+  global list * symbol array
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
new file mode 100644
index 00000000..d7a21950
--- /dev/null
+++ b/kernel/nativevalues.ml
@@ -0,0 +1,576 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Term
+open Names
+open Errors
+open Util
+
+(** This modules defines the representation of values internally used by
+the native compiler *)
+
+type t = t -> t
+    
+type accumulator (* = t (* a block [0:code;atom;arguments] *) *)
+
+type tag = int
+ 
+type arity = int
+
+type reloc_table = (tag * arity) array
+
+type annot_sw = {
+    asw_ind : inductive;
+    asw_ci : case_info;
+    asw_reloc : reloc_table;
+    asw_finite : bool;
+    asw_prefix : string
+  }
+
+(* We compare only what is relevant for generation of ml code *)
+let eq_annot_sw asw1 asw2 =
+  eq_ind asw1.asw_ind asw2.asw_ind &&
+  String.equal asw1.asw_prefix asw2.asw_prefix
+
+open Hashset.Combine
+
+let hash_annot_sw asw =
+  combine (ind_hash asw.asw_ind) (String.hash asw.asw_prefix)
+
+type sort_annot = string * int
+
+type rec_pos = int array
+
+let eq_rec_pos = Array.equal Int.equal
+
+type atom = 
+  | Arel of int
+  | Aconstant of pconstant
+  | Aind of pinductive
+  | Asort of sorts
+  | Avar of identifier
+  | Acase of annot_sw * accumulator * t * (t -> t)
+  | Afix of t array * t array * rec_pos * int
+            (* types, bodies, rec_pos, pos *)
+  | Acofix of t array * t array * int * t
+  | Acofixe of t array * t array * int * t
+  | Aprod of name * t * (t -> t)
+  | Ameta of metavariable * t
+  | Aevar of existential * t
+  | Aproj of constant * accumulator
+
+let accumulate_tag = 0
+
+let accumulate_code (k:accumulator) (x:t) =
+  let o = Obj.repr k in
+  let osize = Obj.size o in
+  let r = Obj.new_block accumulate_tag (osize + 1) in
+  for i = 0 to osize - 1 do
+    Obj.set_field r i (Obj.field o i)
+  done;
+  Obj.set_field r osize (Obj.repr x);
+  (Obj.obj r:t)
+
+let rec accumulate (x:t) =
+  accumulate_code (Obj.magic accumulate) x
+
+let raccumulate = ref accumulate
+
+let mk_accu_gen rcode (a:atom) =
+(*  Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *)
+  let r = Obj.new_block 0 3 in
+  Obj.set_field r 0 (Obj.field (Obj.magic rcode) 0);
+  Obj.set_field r 1 (Obj.field (Obj.magic rcode) 1);
+  Obj.set_field r 2 (Obj.magic a);
+  (Obj.magic r:t);;
+
+let mk_accu (a:atom) = mk_accu_gen accumulate a
+
+let mk_rel_accu i = 
+  mk_accu (Arel i)
+
+let rel_tbl_size = 100 
+let rel_tbl = Array.init rel_tbl_size mk_rel_accu
+
+let mk_rel_accu i = 
+  if i < rel_tbl_size then rel_tbl.(i)
+  else mk_rel_accu i
+
+let mk_rels_accu lvl len =
+  Array.init len (fun i -> mk_rel_accu (lvl + i))
+
+let napply (f:t) (args: t array) =
+  Array.fold_left (fun f a -> f a) f args
+
+let mk_constant_accu kn u = 
+  mk_accu (Aconstant (kn,Univ.Instance.of_array u))
+
+let mk_ind_accu ind u = 
+  mk_accu (Aind (ind,Univ.Instance.of_array u))
+
+let mk_sort_accu s u =
+  match s with
+  | Prop _ -> 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 mk_var_accu id = 
+  mk_accu (Avar id)
+
+let mk_sw_accu annot c p ac = 
+  mk_accu (Acase(annot,c,p,ac))
+
+let mk_prod_accu s dom codom =
+  mk_accu (Aprod (s,dom,codom))
+
+let mk_meta_accu mv ty =
+  mk_accu (Ameta (mv,ty))
+
+let mk_evar_accu ev ty =
+  mk_accu (Aevar (ev,ty))
+
+let mk_proj_accu kn c = 
+  mk_accu (Aproj (kn,c))
+
+let atom_of_accu (k:accumulator) =
+  (Obj.magic (Obj.field (Obj.magic k) 2) : atom)
+
+let set_atom_of_accu (k:accumulator) (a:atom) =
+  Obj.set_field (Obj.magic k) 2 (Obj.magic a)
+
+let accu_nargs (k:accumulator) =
+  let nargs = Obj.size (Obj.magic k) - 3 in
+(*  if nargs < 0 then Format.eprintf "nargs = %i\n" nargs; *)
+  assert (nargs >= 0);
+  nargs
+
+let args_of_accu (k:accumulator) =
+  let nargs = accu_nargs k in
+  let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in
+  let t = Array.init nargs f in
+  Array.to_list t
+
+let is_accu x =
+  let o = Obj.repr x in
+  Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag
+
+(*let accumulate_fix_code (k:accumulator) (a:t) =
+  match atom_of_accu k with
+  | Afix(frec,_,rec_pos,_,_) ->
+      let nargs = accu_nargs k in
+      if nargs <> rec_pos || is_accu a then
+	accumulate_code k a
+      else
+        let r = ref frec in
+        for i = 0 to nargs - 1 do
+	  r := !r (arg_of_accu k i)
+        done;
+        !r a
+  | _ -> assert false
+
+
+let rec accumulate_fix (x:t) =
+  accumulate_fix_code (Obj.magic accumulate_fix) x
+
+let raccumulate_fix = ref accumulate_fix *)
+
+let is_atom_fix (a:atom) =
+  match a with
+  | Afix _ -> true
+  | _ -> false
+
+let mk_fix_accu rec_pos pos types bodies =
+  mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos))
+
+let mk_cofix_accu pos types norm =
+  mk_accu_gen accumulate (Acofix(types,norm,pos,(Obj.magic 0 : t)))
+
+let upd_cofix (cofix :t) (cofix_fun : t) =
+  let atom = atom_of_accu (Obj.magic cofix) in
+  match atom with
+  | Acofix (typ,norm,pos,_) ->
+      set_atom_of_accu (Obj.magic cofix) (Acofix(typ,norm,pos,cofix_fun))
+  | _ -> assert false
+  
+let force_cofix (cofix : t) = 
+  if is_accu cofix then
+    let accu = (Obj.magic cofix : accumulator) in
+    let atom = atom_of_accu accu in
+    match atom with
+    | Acofix(typ,norm,pos,f) ->
+	let f = ref f in
+    let args = List.rev (args_of_accu accu) in
+    List.iter (fun x -> f := !f x) args;
+	let v = !f (Obj.magic ()) in
+	set_atom_of_accu accu (Acofixe(typ,norm,pos,v));
+	v
+    | Acofixe(_,_,_,v) -> v 
+    | _ -> cofix
+  else cofix
+
+let mk_const tag = Obj.magic tag
+
+let mk_block tag args =
+  let nargs = Array.length args in
+  let r = Obj.new_block tag nargs in
+  for i = 0 to nargs - 1 do
+    Obj.set_field r i (Obj.magic args.(i))
+  done;
+  (Obj.magic r : t)
+
+(* Two instances of dummy_value should not be pointer equal, otherwise
+ comparing them as terms would succeed *)
+let dummy_value : unit -> t =
+  fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed")
+
+let cast_accu v = (Obj.magic v:accumulator)
+
+let mk_int (x : int) = (Obj.magic x : t)
+(* 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)
+
+type block
+
+let block_size (b:block) =
+  Obj.size (Obj.magic b)
+
+let block_field (b:block) i = (Obj.magic (Obj.field (Obj.magic b) i) : t)
+
+let block_tag (b:block) = 
+  Obj.tag (Obj.magic b)
+
+type kind_of_value =
+  | Vaccu of accumulator
+  | Vfun of (t -> t)
+  | Vconst of int
+  | 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)
+  else
+    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
+        (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); 
+           or ??? what is 1002*)
+        Vfun v
+
+(** Support for machine integers *)
+
+let is_int (x:t) =
+  let o = Obj.repr x in
+  Obj.is_int o
+
+let val_to_int (x:t) = (Obj.magic x : int)
+
+let to_uint (x:t) = (Obj.magic x : Uint31.t)
+let of_uint (x: Uint31.t) = (Obj.magic x : t)
+
+let no_check_head0 x =
+ of_uint (Uint31.head0 (to_uint x))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+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))
+
+let l_or accu x y =
+  if is_int x && is_int y then no_check_l_or x y
+  else accu x y
+
+type coq_carry = 
+  | Caccu of t
+  | C0 of t
+  | C1 of t
+
+type coq_pair = 
+  | Paccu of t
+  | PPair 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)
+
+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 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 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 s = 
+    Uint31.add (Uint31.add (to_uint x) (to_uint y))
+      (Uint31.of_int 1) in
+  mkCarry (Uint31.le s (to_uint x)) s
+
+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 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
+
+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 no_check_mulc x y =
+    of_pair(Uint31.mulc (to_uint x) (to_uint y))
+
+let mulc accu x y =
+  if is_int x && is_int y then no_check_mulc x y
+  else 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)
+
+let diveucl accu x y =
+  if is_int x && is_int y then no_check_diveucl x y
+  else 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)
+
+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 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'))))
+
+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
+
+
+type coq_bool =
+  | Baccu of t
+  | Btrue
+  | Bfalse
+
+type coq_cmp =
+  | CmpAccu of t
+  | CmpEq 
+  | CmpLt
+  | CmpGt
+
+let no_check_eq x y =     
+  mk_bool (Uint31.equal (to_uint x) (to_uint y))
+
+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))
+
+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))
+
+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
+  | x when x < 0 -> (Obj.magic CmpLt:t)
+  | 0 -> (Obj.magic CmpEq:t)
+  | _ -> (Obj.magic CmpGt:t)
+
+let compare accu x y =
+  if is_int x && is_int y then no_check_compare x y
+  else accu x y
+
+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) -
+                                      (if 0x41 <= i then 0x7 else 0) -
+                                      (if 0x61 <= i then 0x20 else 0))
+
+let hex_of_bin ch = hobcnv.(int_of_char ch)
+let bin_of_hex s = char_of_int (bohcnv.(int_of_char s.[0]) * 16 + bohcnv.(int_of_char s.[1]))
+
+let str_encode expr =
+  let mshl_expr = Marshal.to_string expr [] in
+  let payload = Buffer.create (String.length mshl_expr * 2) in
+  String.iter (fun c -> Buffer.add_string payload (hex_of_bin c)) mshl_expr;
+  Buffer.contents payload
+
+let str_decode s =
+  let mshl_expr_len = String.length s / 2 in
+  let mshl_expr = Buffer.create mshl_expr_len in
+  let buf = String.create 2 in
+  for i = 0 to mshl_expr_len - 1 do
+    String.blit s (2*i) buf 0 2;
+    Buffer.add_char mshl_expr (bin_of_hex buf)
+  done;
+  Marshal.from_string (Buffer.contents 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
new file mode 100644
index 00000000..79e35d4a
--- /dev/null
+++ b/kernel/nativevalues.mli
@@ -0,0 +1,187 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+open Term
+open Names
+
+(** This modules defines the representation of values internally used by
+the native compiler. Be careful when removing apparently dead code from this
+interface, as it may be used by programs generated at runtime. *)
+
+type t = t -> t
+
+type accumulator
+
+type tag = int
+type arity = int
+
+type reloc_table = (tag * arity) array
+
+type annot_sw = {
+    asw_ind : inductive;
+    asw_ci : case_info;
+    asw_reloc : reloc_table;
+    asw_finite : bool;
+    asw_prefix : string
+  }
+
+val eq_annot_sw : annot_sw -> annot_sw -> bool
+
+val hash_annot_sw : annot_sw -> int
+
+type sort_annot = string * int
+      
+type rec_pos = int array
+
+val eq_rec_pos : rec_pos -> rec_pos -> bool
+
+type atom =
+  | Arel of int
+  | Aconstant of pconstant
+  | Aind of pinductive
+  | Asort of sorts
+  | Avar of identifier
+  | Acase of annot_sw * accumulator * t * (t -> t) 
+  | Afix of t array * t array * rec_pos * int 
+  | Acofix of t array * t array * int * t
+  | Acofixe of t array * t array * int * t
+  | Aprod of name * t * (t -> t)
+  | Ameta of metavariable * t
+  | Aevar of existential * t
+  | Aproj of constant * accumulator
+
+(* Constructors *)
+
+val mk_accu : atom -> t
+val mk_rel_accu : int -> t
+val mk_rels_accu : int -> int -> t array
+val mk_constant_accu : constant -> Univ.Level.t array -> t
+val mk_ind_accu : inductive -> Univ.Level.t array -> t
+val mk_sort_accu : sorts -> Univ.Level.t array -> t
+val mk_var_accu : identifier -> t
+val mk_sw_accu : annot_sw -> accumulator -> t -> (t -> t)
+val mk_prod_accu : name -> t -> t -> t
+val mk_fix_accu : rec_pos  -> int -> t array -> t array -> t
+val mk_cofix_accu : int -> t array -> t array -> t
+val mk_meta_accu : metavariable -> t
+val mk_evar_accu : existential -> t -> t
+val mk_proj_accu : constant -> accumulator -> t
+val upd_cofix : t -> t -> unit
+val force_cofix : t -> t 
+val mk_const : tag -> t
+val mk_block : tag -> t array -> t
+
+val mk_bool : bool -> t
+val mk_int : int -> t
+val mk_uint : Uint31.t -> t
+
+val napply : t -> t array -> t
+(* Functions over accumulators *)
+
+val dummy_value : unit -> t
+val atom_of_accu : accumulator -> atom
+val args_of_accu : accumulator -> t list
+val accu_nargs : accumulator -> int
+
+val cast_accu : t -> accumulator
+(* Functions over block: i.e constructors *)
+    
+type block
+      
+val block_size : block -> int
+val block_field : block -> int -> t
+val block_tag : block -> int
+
+
+
+(* kind_of_value *)
+
+type kind_of_value =
+  | Vaccu of accumulator
+  | Vfun of (t -> t)
+  | Vconst of int
+  | Vblock of block
+
+val kind_of_value : t -> kind_of_value
+
+(* *)
+val is_accu : t -> bool
+
+val str_encode : 'a -> string
+val str_decode : string -> 'a
+
+(** Support for machine integers *)
+
+val val_to_int : t -> int
+val is_int : t -> bool
+
+(* function with check *)
+val head0 : t -> t -> t
+val tail0 : t -> t -> t
+
+val add : t -> t -> t -> t
+val sub : t -> t -> t -> t
+val mul : t -> t -> t -> t
+val div : t -> t -> t -> t
+val rem : t -> t -> t -> t
+
+val l_sr  : t -> t -> t -> t
+val l_sl  : t -> t -> t -> t
+val l_and : t -> t -> t -> t
+val l_xor : t -> t -> t -> t
+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 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 eq      : t -> t -> t -> t
+val lt      : t -> t -> t -> t
+val le      : t -> t -> t -> t
+val compare : t -> t -> t -> t 
+
+(* Function without check *)
+val no_check_head0 : t -> t
+val no_check_tail0 : t -> t
+
+val no_check_add : t -> t -> t
+val no_check_sub : t -> t -> t
+val no_check_mul : t -> t -> t
+val no_check_div : t -> t -> t
+val no_check_rem : t -> t -> t
+
+val no_check_l_sr  : t -> t -> t
+val no_check_l_sl  : t -> t -> t
+val no_check_l_and : t -> t -> t
+val no_check_l_xor : t -> t -> t
+val no_check_l_or  : t -> t -> t
+
+val no_check_addc      : t -> t -> t
+val no_check_subc      : t -> t -> t
+val no_check_addcarryc : t -> t -> t
+val no_check_subcarryc : t -> t -> t
+
+val no_check_mulc    : t -> t -> t
+val no_check_diveucl : t -> t -> t
+
+val no_check_div21     : t -> t -> t -> t
+val no_check_addmuldiv : t -> t -> t -> t
+
+val no_check_eq      : t -> t -> t
+val no_check_lt      : t -> t -> t
+val no_check_le      : t -> t -> t
+val no_check_compare : t -> t -> t 
+
+val mk_I31_accu : t
+val decomp_uint : t -> t -> t
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
new file mode 100644
index 00000000..9f4361f4
--- /dev/null
+++ b/kernel/opaqueproof.ml
@@ -0,0 +1,144 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Univ
+open Term
+open Mod_subst
+
+type work_list = (Instance.t * Id.t array) Cmap.t * 
+  (Instance.t * Id.t array) Mindmap.t
+
+type cooking_info = { 
+  modlist : work_list; 
+  abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } 
+type proofterm = (constr * Univ.universe_context_set) Future.computation
+type opaque =
+  | Indirect of substitution list * DirPath.t * int (* subst, lib, index *)
+  | Direct of cooking_info list * proofterm
+type opaquetab = (cooking_info list * proofterm) Int.Map.t * DirPath.t
+let empty_opaquetab = Int.Map.empty, DirPath.initial
+
+(* hooks *)
+let default_get_opaque dp _ =
+  Errors.error
+    ("Cannot access opaque proofs in library " ^ DirPath.to_string dp)
+let default_get_univ dp _ =
+  Errors.error
+    ("Cannot access universe constraints of opaque proofs in library " ^
+    DirPath.to_string dp)
+
+let get_opaque = ref default_get_opaque
+let get_univ = ref default_get_univ
+
+let set_indirect_opaque_accessor f = (get_opaque := f)
+let set_indirect_univ_accessor f = (get_univ := f)
+(* /hooks *)
+
+let create cu = Direct ([],cu)
+
+let turn_indirect dp o (prfs,odp) = match o with
+  | Indirect _ -> Errors.anomaly (Pp.str "Already an indirect opaque")
+  | Direct (d,cu) ->
+      let cu = Future.chain ~pure:true cu (fun (c, u) -> hcons_constr c, u) in
+      let id = Int.Map.cardinal prfs in
+      let prfs = Int.Map.add id (d,cu) prfs in
+      let ndp =
+        if DirPath.equal dp odp then odp
+        else if DirPath.equal odp DirPath.initial then dp
+        else Errors.anomaly
+          (Pp.str "Using the same opaque table for multiple dirpaths") in
+      Indirect ([],dp,id), (prfs, ndp)
+
+let subst_opaque sub = function
+  | Indirect (s,dp,i) -> Indirect (sub::s,dp,i)
+  | Direct _ -> Errors.anomaly (Pp.str "Substituting a Direct opaque")
+
+let iter_direct_opaque f = function
+  | Indirect _ -> Errors.anomaly (Pp.str "Not a direct opaque")
+  | Direct (d,cu) ->
+      Direct (d,Future.chain ~pure:true cu (fun (c, u) -> f c; c, u))
+
+let discharge_direct_opaque ~cook_constr ci = function
+  | Indirect _ -> Errors.anomaly (Pp.str "Not a direct opaque")
+  | Direct (d,cu) ->
+      Direct (ci::d,Future.chain ~pure:true cu (fun (c, u) -> cook_constr c, u))
+
+let join_opaque (prfs,odp) = function
+  | Direct (_,cu) -> ignore(Future.join cu)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp then
+        let fp = snd (Int.Map.find i prfs) in
+        ignore(Future.join fp)
+
+let uuid_opaque (prfs,odp) = function
+  | Direct (_,cu) -> Some (Future.uuid cu)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp
+      then Some (Future.uuid (snd (Int.Map.find i prfs)))
+      else None
+
+let force_proof (prfs,odp) = function
+  | Direct (_,cu) ->
+      fst(Future.force cu)
+  | Indirect (l,dp,i) ->
+      let pt =
+        if DirPath.equal dp odp
+        then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst
+        else !get_opaque dp i in
+      let c = Future.force pt in
+      force_constr (List.fold_right subst_substituted l (from_val c))
+
+let force_constraints (prfs,odp) = function
+  | Direct (_,cu) -> snd(Future.force cu)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp
+      then snd (Future.force (snd (Int.Map.find i prfs)))
+      else match !get_univ dp i with
+        | None -> Univ.ContextSet.empty
+        | Some u -> Future.force u
+
+let get_constraints (prfs,odp) = function
+  | Direct (_,cu) -> Some(Future.chain ~pure:true cu snd)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp
+      then Some(Future.chain ~pure:true (snd (Int.Map.find i prfs)) snd)
+      else !get_univ dp i
+
+let get_proof (prfs,odp) = function
+  | Direct (_,cu) -> Future.chain ~pure:true cu fst
+  | Indirect (l,dp,i) ->
+      let pt =
+        if DirPath.equal dp odp
+        then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst
+        else !get_opaque dp i in
+      Future.chain ~pure:true pt (fun c ->
+        force_constr (List.fold_right subst_substituted l (from_val c)))
+ 
+module FMap = Future.UUIDMap
+
+let a_constr = Future.from_val (Term.mkRel 1)
+let a_univ = Future.from_val Univ.ContextSet.empty
+let a_discharge : cooking_info list = []
+
+let dump (otab,_) =
+  let n = Int.Map.cardinal otab in
+  let opaque_table = Array.make n a_constr in
+  let univ_table = Array.make n a_univ in
+  let disch_table = Array.make n a_discharge in
+  let f2t_map = ref FMap.empty in
+  Int.Map.iter (fun n (d,cu) ->
+    let c, u = Future.split2 ~greedy:true cu in
+    Future.sink u;
+    Future.sink c;
+    opaque_table.(n) <- c;
+    univ_table.(n) <- u;
+    disch_table.(n) <- d;
+    f2t_map := FMap.add (Future.uuid cu) n !f2t_map)
+  otab;
+  opaque_table, univ_table, disch_table, !f2t_map
diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli
new file mode 100644
index 00000000..87cebd62
--- /dev/null
+++ b/kernel/opaqueproof.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Term
+open Mod_subst
+open Int
+
+(** This module implements the handling of opaque proof terms.
+    Opauqe proof terms are special since:
+    - they can be lazily computed and substituted
+    - they are stoked in an optionally loaded segment of .vo files
+    An [opaque] proof terms holds the real data until fully discharged.
+    In this case it is called [direct].
+    When it is [turn_indirect] the data is relocated to an opaque table
+    and the [opaque] is turned into an index. *)
+
+type proofterm = (constr * Univ.universe_context_set) Future.computation
+type opaquetab
+type opaque
+
+val empty_opaquetab : opaquetab
+
+(** From a [proofterm] to some [opaque]. *)
+val create : proofterm -> opaque
+
+(** Turn a direct [opaque] into an indirect one, also hashconses constr.
+ *  The integer is an hint of the maximum id used so far *)
+val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab
+
+(** From a [opaque] back to a [constr]. This might use the
+    indirect opaque accessor configured below. *)
+val force_proof : opaquetab -> opaque -> constr
+val force_constraints : opaquetab -> opaque -> Univ.universe_context_set
+val get_proof : opaquetab -> opaque -> Term.constr Future.computation
+val get_constraints :
+  opaquetab -> opaque -> Univ.universe_context_set Future.computation option
+
+val subst_opaque : substitution -> opaque -> opaque
+val iter_direct_opaque : (constr -> unit) -> opaque -> opaque
+
+type work_list = (Univ.Instance.t * Id.t array) Cmap.t * 
+  (Univ.Instance.t * Id.t array) Mindmap.t
+
+type cooking_info = { 
+  modlist : work_list; 
+  abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } 
+
+(* The type has two caveats:
+   1) cook_constr is defined after
+   2) we have to store the input in the [opaque] in order to be able to
+      discharge it when turning a .vi into a .vo *)
+val discharge_direct_opaque :
+  cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque
+
+val uuid_opaque : opaquetab -> opaque -> Future.UUID.t option
+val join_opaque : opaquetab -> opaque -> unit
+
+val dump : opaquetab ->
+  Constr.t Future.computation array *
+  Univ.universe_context_set Future.computation array *
+  cooking_info list array *
+  int Future.UUIDMap.t
+
+(** When stored indirectly, opaque terms are indexed by their library
+    dirpath and an integer index. The following two functions activate
+    this indirect storage, by telling how to store and retrieve terms.
+    Default creator always returns [None], preventing the creation of
+    any indirect link, and default accessor always raises an error.
+*)
+
+val set_indirect_opaque_accessor :
+  (DirPath.t -> int -> Term.constr Future.computation) -> unit
+val set_indirect_univ_accessor :
+  (DirPath.t -> int -> Univ.universe_context_set Future.computation option) -> unit
+
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 6ef1039e..557ed3d7 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -15,36 +15,55 @@
 
 open Util
 open Names
-open Sign
+open Context
 open Univ
 open Term
 open Declarations
 
 (* The type of environments. *)
 
+(* The key attached to each constant is used by the VM to retrieve previous *)
+(* evaluations of the constant. It is essentially an index in the symbols table *)
+(* used by the VM. *)
+type key = int Ephemeron.key option ref 
 
-type key = int option ref
+(** Linking information for the native compiler. *)
 
-type constant_key = constant_body * key
+type link_info =
+  | Linked of string
+  | LinkedInteractive of string
+  | NotLinked
+
+type constant_key = constant_body * (link_info ref * key)
+
+type mind_key = mutual_inductive_body * link_info ref
 
 type globals = {
   env_constants : constant_key Cmap_env.t;
-  env_inductives : mutual_inductive_body Mindmap_env.t;
+  env_inductives : mind_key Mindmap_env.t;
   env_modules : module_body MPmap.t;
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
-  env_engagement : engagement option
+  env_engagement : engagement option;
+  env_type_in_type : bool
 }
 
 type val_kind =
-    | VKvalue of values * Idset.t
+    | VKvalue of (values * Id.Set.t) Ephemeron.key
     | VKnone
 
 type lazy_val = val_kind ref
 
-type named_vals = (identifier * lazy_val) list
+let force_lazy_val vk = match !vk with
+| VKnone -> None
+| VKvalue v -> try Some (Ephemeron.get v) with Ephemeron.InvalidKey -> None
+
+let dummy_lazy_val () = ref VKnone
+let build_lazy_val vk key = vk := VKvalue (Ephemeron.create key)
+
+type named_vals = (Id.t * lazy_val) list
 
 type env = {
   env_globals       : globals;
@@ -54,7 +73,10 @@ type env = {
   env_rel_val       : lazy_val list;
   env_nb_rel        : int;
   env_stratification : stratification;
-  retroknowledge : Retroknowledge.retroknowledge }
+  env_conv_oracle   : Conv_oracle.oracle;
+  retroknowledge : Retroknowledge.retroknowledge;
+  indirect_pterms : Opaqueproof.opaquetab;
+}
 
 type named_context_val = named_context * named_vals
 
@@ -73,8 +95,11 @@ let empty_env = {
   env_nb_rel = 0;
   env_stratification = {
     env_universes = initial_universes;
-    env_engagement = None };
-  retroknowledge = Retroknowledge.initial_retroknowledge }
+    env_engagement = None;
+    env_type_in_type = false};
+  env_conv_oracle = Conv_oracle.empty;
+  retroknowledge = Retroknowledge.initial_retroknowledge;
+  indirect_pterms = Opaqueproof.empty_opaquetab }
 
 
 (* Rel context *)
@@ -90,12 +115,12 @@ let push_rel d env =
 
 let lookup_rel_val n env =
   try List.nth env.env_rel_val (n - 1)
-  with e when Errors.noncritical e -> raise Not_found
+  with Failure _ -> raise Not_found
 
 let env_of_rel n env =
   { env with
-    env_rel_context = Util.list_skipn n env.env_rel_context;
-    env_rel_val = Util.list_skipn n env.env_rel_val;
+    env_rel_context = Util.List.skipn n env.env_rel_context;
+    env_rel_val = Util.List.skipn n env.env_rel_val;
     env_nb_rel = env.env_nb_rel - n
   }
 
@@ -104,21 +129,27 @@ let env_of_rel n env =
 let push_named_context_val d (ctxt,vals) =
   let id,_,_ = d in
   let rval = ref VKnone in
-    Sign.add_named_decl d ctxt, (id,rval)::vals
-
-exception ASSERT of rel_context
+    add_named_decl d ctxt, (id,rval)::vals
 
 let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
   let id,body,_ = d in
   let rval = ref VKnone in
-    { env with
-      env_named_context = Sign.add_named_decl d env.env_named_context;
-      env_named_vals =  (id,rval):: env.env_named_vals }
+  { env_globals = env.env_globals;
+    env_named_context = Context.add_named_decl d env.env_named_context;
+    env_named_vals = (id, rval) :: env.env_named_vals;
+    env_rel_context = env.env_rel_context;
+    env_rel_val = env.env_rel_val;
+    env_nb_rel = env.env_nb_rel;
+    env_stratification = env.env_stratification;
+    env_conv_oracle = env.env_conv_oracle;
+    retroknowledge = env.retroknowledge;
+    indirect_pterms = env.indirect_pterms;
+  }
 
 let lookup_named_val id env =
-  snd(List.find (fun (id',_) -> id = id') env.env_named_vals)
+  snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals)
 
 (* Warning all the names should be different *)
 let env_of_named id env = env
@@ -133,5 +164,7 @@ let lookup_constant kn env =
 
 (* Mutual Inductives *)
 let lookup_mind kn env =
-  Mindmap_env.find kn env.env_globals.env_inductives
+  fst (Mindmap_env.find kn env.env_globals.env_inductives)
 
+let lookup_mind_key kn env =
+  Mindmap_env.find kn env.env_globals.env_inductives
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 85188b7b..03ac41b4 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -1,43 +1,49 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
 open Names
-open Sign
-open Univ
 open Term
+open Context
 open Declarations
+open Univ
 
 (** The type of environments. *)
 
+type link_info =
+  | Linked of string
+  | LinkedInteractive of string
+  | NotLinked
+
+type key = int Ephemeron.key option ref 
 
-type key = int option ref
+type constant_key = constant_body * (link_info ref * key)
 
-type constant_key = constant_body * key
+type mind_key = mutual_inductive_body * link_info ref
 
 type globals = {
   env_constants : constant_key Cmap_env.t;
-  env_inductives : mutual_inductive_body Mindmap_env.t;
+  env_inductives : mind_key Mindmap_env.t;
   env_modules : module_body MPmap.t;
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
-  env_engagement : engagement option
+  env_engagement : engagement option;
+  env_type_in_type : bool
 }
 
-type val_kind =
-    | VKvalue of values * Idset.t
-    | VKnone
+type lazy_val
 
-type lazy_val = val_kind ref
+val force_lazy_val : lazy_val -> (values * Id.Set.t) option
+val dummy_lazy_val : unit -> lazy_val
+val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit
 
-type named_vals = (identifier * lazy_val) list
+type named_vals = (Id.t * lazy_val) list
 
 type env = {
     env_globals       : globals;
@@ -47,7 +53,10 @@ type env = {
     env_rel_val       : lazy_val list;
     env_nb_rel        : int;
     env_stratification : stratification;
-    retroknowledge : Retroknowledge.retroknowledge }
+    env_conv_oracle   : Conv_oracle.oracle;
+    retroknowledge : Retroknowledge.retroknowledge;
+    indirect_pterms : Opaqueproof.opaquetab;
+}
 
 type named_context_val = named_context * named_vals
 
@@ -67,8 +76,8 @@ val env_of_rel     : int -> env -> env
 val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 val push_named       : named_declaration -> env -> env
-val lookup_named_val : identifier -> env -> lazy_val
-val env_of_named     : identifier -> env -> env
+val lookup_named_val : Id.t -> env -> lazy_val
+val env_of_named     : Id.t -> env -> env
 
 (** Global constants *)
 
@@ -77,5 +86,5 @@ val lookup_constant_key : constant -> env -> constant_key
 val lookup_constant : constant -> env -> constant_body
 
 (** Mutual Inductives *)
+val lookup_mind_key : mutual_inductive -> env -> mind_key
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
-
diff --git a/kernel/primitives.ml b/kernel/primitives.ml
new file mode 100644
index 00000000..649eb125
--- /dev/null
+++ b/kernel/primitives.ml
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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
+
+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
+
+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"
diff --git a/kernel/primitives.mli b/kernel/primitives.mli
new file mode 100644
index 00000000..9f99264a
--- /dev/null
+++ b/kernel/primitives.mli
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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
+
+val hash : t -> int
+
+val to_string : t -> string
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 9982d4ba..4153b323 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -15,23 +15,29 @@
 (* Equal inductive types by Jacek Chrzaszcz as part of the module
    system, Aug 2002 *)
 
+open Errors
 open Util
 open Names
 open Term
+open Vars
+open Context
 open Univ
-open Declarations
 open Environ
 open Closure
 open Esubst
 
-let unfold_reference ((ids, csts), infos) k =
-  match k with
-    | VarKey id when not (Idpred.mem id ids) -> None
-    | ConstKey cst when not (Cpred.mem cst csts) -> None
-    | _ -> unfold_reference infos k
+let left2right = ref false
 
+let conv_key k =
+  match k with
+    VarKey id -> 
+    VarKey id
+  | ConstKey (cst,_) -> 
+     ConstKey cst
+  | RelKey n -> RelKey n
+		       
 let rec is_empty_stack = function
-    [] -> true
+  [] -> true
   | Zupdate _::s -> is_empty_stack s
   | Zshift _::s -> is_empty_stack s
   | _ -> false
@@ -51,20 +57,24 @@ let el_stack el stk =
 let compare_stack_shape stk1 stk2 =
   let rec compare_rec bal stk1 stk2 =
   match (stk1,stk2) with
-      ([],[]) -> bal=0
+      ([],[]) -> Int.equal bal 0
     | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2
     | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
     | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2
     | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
-    | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) ->
-        bal=0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
+    | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) ->
+        Int.equal bal 0 && compare_rec 0 s1 s2
+    | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1,
+       (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) ->
+        Int.equal bal 0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
     | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) ->
-        bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
+        Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
     | (_,_) -> false in
   compare_rec 0 stk1 stk2
 
 type lft_constr_stack_elt =
     Zlapp of (lift * fconstr) array
+  | Zlproj of constant * lift
   | Zlfix of (lift * fconstr) * lft_constr_stack
   | Zlcase of case_info * lift * fconstr * fconstr array
 and lft_constr_stack = lft_constr_stack_elt list
@@ -83,9 +93,13 @@ let pure_stack lfts stk =
             | (Zshift n,(l,pstk)) -> (el_shft n l, pstk)
             | (Zapp a, (l,pstk)) ->
                 (l,zlapp (Array.map (fun t -> (l,t)) a) pstk)
+	    | (Zproj (n,m,c), (l,pstk)) ->
+		(l, Zlproj (c,l)::pstk)
             | (Zfix(fx,a),(l,pstk)) ->
                 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)
             | (Zcase(ci,p,br),(l,pstk)) ->
                 (l,Zlcase(ci,l,p,br)::pstk)) in
   snd (pure_rec lfts stk)
@@ -94,17 +108,17 @@ let pure_stack lfts stk =
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
 
-let whd_betaiota t =
-  whd_val (create_clos_infos betaiota empty_env) (inject t)
+let whd_betaiota env t =
+  whd_val (create_clos_infos betaiota env) (inject t)
 
-let nf_betaiota t =
-  norm_val (create_clos_infos betaiota empty_env) (inject t)
+let nf_betaiota env t =
+  norm_val (create_clos_infos betaiota env) (inject t)
 
-let whd_betaiotazeta x =
+let whd_betaiotazeta env x =
   match kind_of_term x with
     | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> x
-    | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x)
+    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
 
 let whd_betadeltaiota env t =
   match kind_of_term t with
@@ -126,14 +140,14 @@ let beta_appvect c v =
         Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl
       | _ -> applist (substl env t, stack) in
   stacklam [] c (Array.to_list v)
-
+    
 let betazeta_appvect n c v =
   let rec stacklam n env t stack =
-    if n = 0 then applist (substl env t, stack) else
+    if Int.equal n 0 then applist (substl env t, stack) else
     match kind_of_term t, stack with
         Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl
       | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack
-      | _ -> anomaly "Not enough lambda/let's" in
+      | _ -> anomaly (Pp.str "Not enough lambda/let's") in
   stacklam n [] c (Array.to_list v)
 
 (********************************************************************)
@@ -141,19 +155,76 @@ let betazeta_appvect n c v =
 (********************************************************************)
 
 (* Conversion utility functions *)
-type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
-type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints
+type 'a conversion_function = env -> 'a -> 'a -> unit
+type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function
+type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit
+type 'a trans_universe_conversion_function = 
+  Names.transparent_state -> 'a universe_conversion_function
 
 exception NotConvertible
 exception NotConvertibleVect of int
 
+
+(* Convertibility of sorts *)
+
+(* The sort cumulativity is
+
+    Prop <= Set <= Type 1 <= ... <= Type i <= ...
+
+    and this holds whatever Set is predicative or impredicative
+*)
+
+type conv_pb =
+  | CONV
+  | CUMUL
+
+let is_cumul = function CUMUL -> true | CONV -> false
+
+type 'a universe_compare = 
+  { (* Might raise NotConvertible *)
+    compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a;
+    compare_instances: bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a;
+  } 
+
+type 'a universe_state = 'a * 'a universe_compare
+
+type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b
+
+type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints
+
+let sort_cmp_universes env pb s0 s1 (u, check) =
+  (check.compare env pb s0 s1 u, check)
+
+let convert_instances flex u u' (s, check) =
+  (check.compare_instances flex u u' s, check)
+
+let conv_table_key infos k1 k2 cuniv =
+  if k1 == k2 then cuniv else
+  match k1, k2 with
+  | ConstKey (cst, u), ConstKey (cst', u') when eq_constant_key cst cst' ->
+    if Univ.Instance.equal u u' then cuniv
+    else 
+      let flex = evaluable_constant cst (info_env infos) 
+	&& RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst)
+      in convert_instances flex u u' cuniv
+  | VarKey id, VarKey id' when Id.equal id id' -> 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
+            | (Zlapp a1,Zlapp a2) -> 
+	      if !left2right then
+		Array.fold_left2 (fun cu x y -> f x y cu) cu1 a1 a2
+	      else Array.fold_right2 f a1 a2 cu1
+	    | (Zlproj (c1,l1),Zlproj (c2,l2)) -> 
+	      if not (eq_constant 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
@@ -161,52 +232,21 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
                 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
+                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
 
-(* Convertibility of sorts *)
-
-(* The sort cumulativity is
-
-    Prop <= Set <= Type 1 <= ... <= Type i <= ...
-
-    and this holds whatever Set is predicative or impredicative
-*)
-
-type conv_pb =
-  | CONV
-  | CUMUL
-
-let sort_cmp pb s0 s1 cuniv =
-  match (s0,s1) with
-    | (Prop c1, Prop c2) when pb = CUMUL ->
-        if c1 = Null or c2 = Pos then cuniv   (* Prop <= Set *)
-        else raise NotConvertible
-    | (Prop c1, Prop c2) ->
-        if c1 = c2 then cuniv else raise NotConvertible
-    | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv
-    | (Type u1, Type u2) ->
-	assert (is_univ_variable u2);
-	(match pb with
-           | CONV -> enforce_eq u1 u2 cuniv
-	   | CUMUL -> enforce_geq u2 u1 cuniv)
-    | (_, _) -> raise NotConvertible
-
-
-let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint
-
-let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint
-
 let rec no_arg_available = function
   | [] -> true
   | Zupdate _ :: stk -> no_arg_available stk
   | Zshift _ :: stk -> no_arg_available stk
-  | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk
+  | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk
+  | Zproj _ :: _ -> true
   | Zcase _ :: _ -> true
+  | ZcaseT _ :: _ -> true
   | Zfix _ :: _ -> true
 
 let rec no_nth_arg_available n = function
@@ -217,7 +257,9 @@ let rec no_nth_arg_available n = function
       let k = Array.length v in
       if n >= k then no_nth_arg_available (n-k) stk
       else false
+  | Zproj _ :: _ -> true
   | Zcase _ :: _ -> true
+  | ZcaseT _ :: _ -> true
   | Zfix _ :: _ -> true
 
 let rec no_case_available = function
@@ -225,30 +267,45 @@ let rec no_case_available = function
   | Zupdate _ :: stk -> no_case_available stk
   | Zshift _ :: stk -> no_case_available stk
   | Zapp _ :: stk -> no_case_available stk
+  | Zproj (_,_,p) :: _ -> false
   | Zcase _ :: _ -> false
+  | ZcaseT _ :: _ -> false
   | Zfix _ :: _ -> true
 
 let in_whnf (t,stk) =
   match fterm_of t with
-    | (FLetIn _ | FCases _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false
+    | (FLetIn _ | FCase _ | FCaseT _ | FApp _ 
+	  | FCLOS _ | FLIFT _ | FCast _) -> false
     | FLambda _ -> no_arg_available stk
     | FConstruct _ -> no_case_available stk
     | FCoFix _ -> no_case_available stk
     | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk
-    | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true
+    | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true
     | FLOCKED -> assert false
 
+let unfold_projection infos p c =
+  let unf = Projection.unfolded p in
+    if unf || RedFlags.red_set infos.i_flags (RedFlags.fCONST (Projection.constant p)) then
+      (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with
+      | Some pb -> 
+	let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, 
+		       Projection.constant p) in
+	  Some (c, s)
+      | None -> None)
+  else None
+
 (* 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
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
 and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
-  Util.check_for_interrupt ();
+  Control.check_for_interrupt ();
   (* First head reduce both terms *)
+  let whd = whd_stack (infos_with_reds infos betaiotazeta) in
   let rec whd_both (t1,stk1) (t2,stk2) =
-    let st1' = whd_stack (snd infos) t1 stk1 in
-    let st2' = whd_stack (snd infos) t2 stk2 in
+    let st1' = whd t1 stk1 in
+    let st2' = whd t2 stk2 in
     (* Now, whd_stack on term2 might have modified st1 (due to sharing),
        and st1 might not be in whnf anymore. If so, we iterate ccnv. *)
     if in_whnf st1' then (st1',st2') else whd_both st1' st2' in
@@ -263,143 +320,228 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
 	(match kind_of_term a1, kind_of_term a2 with
 	   | (Sort s1, Sort s2) ->
 	       if not (is_empty_stack v1 && is_empty_stack v2) then
-		 anomaly "conversion was given ill-typed terms (Sort)";
-	       sort_cmp cv_pb s1 s2 cuniv
+		 anomaly (Pp.str "conversion was given ill-typed terms (Sort)");
+	       sort_cmp_universes (env_of_infos infos) cv_pb s1 s2 cuniv
 	   | (Meta n, Meta m) ->
-               if n=m
+               if Int.equal n m
 	       then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
                else raise NotConvertible
 	   | _ -> raise NotConvertible)
     | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) ->
-        if ev1=ev2 then
-          let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
+        if Evar.equal ev1 ev2 then
+          let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
           convert_vect l2r infos el1 el2
             (Array.map (mk_clos env1) args1)
-            (Array.map (mk_clos env2) args2) u1
+            (Array.map (mk_clos env2) args2) cuniv
         else raise NotConvertible
 
     (* 2 index known to be bound to no constant *)
     | (FRel n, FRel m) ->
-        if reloc_rel n el1 = reloc_rel m el2
+        if Int.equal (reloc_rel n el1) (reloc_rel m el2)
         then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
         else raise NotConvertible
 
     (* 2 constants, 2 local defined vars or 2 defined rels *)
     | (FFlex fl1, FFlex fl2) ->
-	(try (* try first intensional equality *)
-	  if eq_table_key fl1 fl2
-          then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
-          else raise NotConvertible
-        with NotConvertible ->
-          (* else the oracle tells which constant is to be expanded *)
-          let (app1,app2) =
-            if Conv_oracle.oracle_order l2r fl1 fl2 then
-              match unfold_reference infos fl1 with
-                | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
-                | None ->
-                    (match unfold_reference infos fl2 with
-                      | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2))
-		      | None -> raise NotConvertible)
-            else
-	      match unfold_reference infos fl2 with
-                | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2))
-                | None ->
-                    (match unfold_reference infos fl1 with
-                    | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
-		    | None -> raise NotConvertible) in
-          eqappr cv_pb l2r infos app1 app2 cuniv)
-
+      (try
+	 let cuniv = conv_table_key infos fl1 fl2 cuniv in
+	   convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+       with NotConvertible ->
+           (* else the oracle tells which constant is to be expanded *)
+	 let oracle = Closure.oracle_of_infos infos in
+         let (app1,app2) =
+           if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then
+	     match unfold_reference infos fl1 with
+             | Some def1 -> ((lft1, whd def1 v1), appr2)
+             | None ->
+               (match unfold_reference infos fl2 with
+               | Some def2 -> (appr1, (lft2, whd def2 v2))
+	       | None -> raise NotConvertible)
+           else
+	     match unfold_reference infos fl2 with
+             | Some def2 -> (appr1, (lft2, whd def2 v2))
+             | None ->
+               (match unfold_reference infos fl1 with
+               | Some def1 -> ((lft1, whd def1 v1), appr2)
+	       | None -> raise NotConvertible) 
+	 in
+           eqappr cv_pb l2r infos app1 app2 cuniv)
+
+    | (FProj (p1,c1), FProj (p2, c2)) ->
+      (* Projections: prefer unfolding to first-order unification,
+	 which will happen naturally if the terms c1, c2 are not in constructor
+	 form *)
+      (match unfold_projection infos p1 c1 with
+      | Some (def1,s1) -> 
+	eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv
+      | None ->
+	match unfold_projection infos p2 c2 with
+	| Some (def2,s2) ->
+	  eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv
+	| None -> 
+          if Constant.equal (Projection.constant p1) (Projection.constant p2)
+	     && compare_stack_shape v1 v2 then
+	    let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in
+	      convert_stacks l2r infos lft1 lft2 v1 v2 u1
+	  else (* Two projections in WHNF: unfold *)
+	    raise NotConvertible)
+
+    | (FProj (p1,c1), t2) ->
+      (match unfold_projection infos p1 c1 with
+      | Some (def1,s1) ->
+         eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv
+      | None -> 
+	 (match t2 with 
+	  | FFlex fl2 ->
+	     (match unfold_reference infos fl2 with
+              | Some def2 ->
+		 eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv
+              | None -> raise NotConvertible)
+	  | _ -> raise NotConvertible))
+      
+    | (t1, FProj (p2,c2)) ->
+      (match unfold_projection infos p2 c2 with
+      | Some (def2,s2) -> 
+         eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv
+      | None -> 
+	 (match t1 with 
+	  | FFlex fl1 ->
+	     (match unfold_reference infos fl1 with
+              | Some def1 ->
+		 eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv
+              | None -> raise NotConvertible)
+	  | _ -> raise NotConvertible))
+      
     (* other constructors *)
     | (FLambda _, FLambda _) ->
         (* Inconsistency: we tolerate that v1, v2 contain shift and update but
            we throw them away *)
         if not (is_empty_stack v1 && is_empty_stack v2) then
-	  anomaly "conversion was given ill-typed terms (FLambda)";
+	  anomaly (Pp.str "conversion was given ill-typed terms (FLambda)");
         let (_,ty1,bd1) = destFLambda mk_clos hd1 in
         let (_,ty2,bd2) = destFLambda mk_clos hd2 in
-        let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
-        ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1
+        let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
+        ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv
 
     | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
         if not (is_empty_stack v1 && is_empty_stack v2) then
-	  anomaly "conversion was given ill-typed terms (FProd)";
+	  anomaly (Pp.str "conversion was given ill-typed terms (FProd)");
 	(* Luo's system *)
-        let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
-        ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1
+        let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
+        ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv
 
     (* Eta-expansion on the fly *)
     | (FLambda _, _) ->
-        if v1 <> [] then
-	  anomaly "conversion was given unreduced term (FLambda)";
+        let () = match v1 with
+        | [] -> ()
+        | _ ->
+          anomaly (Pp.str "conversion was given unreduced term (FLambda)")
+        in
         let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
 	eqappr CONV l2r infos
 	  (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv
     | (_, FLambda _) ->
-        if v2 <> [] then
-	  anomaly "conversion was given unreduced term (FLambda)";
+        let () = match v2 with
+        | [] -> ()
+        | _ ->
+	  anomaly (Pp.str "conversion was given unreduced term (FLambda)")
+	in
         let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
 	eqappr CONV l2r infos
 	  (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv
-
+	
     (* only one constant, defined var or defined rel *)
-    | (FFlex fl1, _)      ->
-        (match unfold_reference infos fl1 with
-           | Some def1 ->
-	       eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
-           | None -> raise NotConvertible)
-    | (_, FFlex fl2)      ->
-        (match unfold_reference infos fl2 with
-           | Some def2 ->
-	       eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
-           | None -> raise NotConvertible)
-
+    | (FFlex fl1, c2)      ->
+       (match unfold_reference infos fl1 with
+	| Some def1 ->
+	   eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv
+	| None -> 
+	   match c2 with
+	   | FConstruct ((ind2,j2),u2) ->
+	      (try
+	      let v2, v1 =
+		eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1)
+	      in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	      with Not_found -> raise NotConvertible)
+	   | _ -> raise NotConvertible)
+       
+    | (c1, FFlex fl2)      ->
+       (match unfold_reference infos fl2 with
+        | Some def2 ->
+	   eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv
+        | None -> 
+	   match c1 with
+	   | FConstruct ((ind1,j1),u1) ->
+ 	      (try let v1, v2 =
+	     	     eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2)
+	     	   in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	       with Not_found -> raise NotConvertible)
+	   | _ -> raise NotConvertible)
+       
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
-    | (FInd ind1, FInd ind2) ->
+    | (FInd (ind1,u1), FInd (ind2,u2)) ->
         if eq_ind ind1 ind2
 	then
-          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	  (let cuniv = convert_instances false u1 u2 cuniv in
+             convert_stacks l2r infos lft1 lft2 v1 v2 cuniv)
         else raise NotConvertible
 
-    | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
-	if j1 = j2 && eq_ind ind1 ind2
+    | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) ->
+	if Int.equal j1 j2 && eq_ind ind1 ind2
 	then
-          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	  (let cuniv = convert_instances false u1 u2 cuniv in
+           convert_stacks l2r infos lft1 lft2 v1 v2 cuniv)
         else raise NotConvertible
-
-    | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
-	if op1 = op2
+	  
+    (* Eta expansion of records *)
+    | (FConstruct ((ind1,j1),u1), _) ->
+      (try
+    	 let v1, v2 =
+    	   eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2)
+    	 in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+       with Not_found -> raise NotConvertible)
+
+    | (_, FConstruct ((ind2,j2),u2)) ->
+      (try
+    	 let v2, v1 =
+    	   eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1)
+    	 in convert_stacks 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
 	then
 	  let n = Array.length cl1 in
           let fty1 = Array.map (mk_clos e1) tys1 in
           let fty2 = Array.map (mk_clos e2) tys2 in
           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
-	  let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
-          let u2 =
+	  let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+          let cuniv =
             convert_vect l2r infos
-	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
-          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+	      (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)) ->
-        if op1 = op2
+        if Int.equal op1 op2
         then
 	  let n = Array.length cl1 in
           let fty1 = Array.map (mk_clos e1) tys1 in
           let fty2 = Array.map (mk_clos e2) tys2 in
           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
-          let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
-          let u2 =
+          let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+          let cuniv =
 	    convert_vect l2r infos
-	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
-          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in
+          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 _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
-       | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
+     | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
+       | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _)
        | (FLOCKED,_) | (_,FLOCKED) ) -> assert false
 
      (* In all other cases, terms are not convertible *)
@@ -407,53 +549,193 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
 
 and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
-    (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c)
+    (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv)
     (eq_ind)
     lft1 stk1 lft2 stk2 cuniv
 
 and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
   let lv1 = Array.length v1 in
   let lv2 = Array.length v2 in
-  if lv1 = lv2
+  if Int.equal lv1 lv2
   then
-    let rec fold n univ =
-      if n >= lv1 then univ
+    let rec fold n cuniv =
+      if n >= lv1 then cuniv
       else
-        let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in
-        fold (n+1) u1 in
+        let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in
+        fold (n+1) cuniv in
     fold 0 cuniv
   else raise NotConvertible
 
-let clos_fconv trans cv_pb l2r evars env t1 t2 =
-  let infos = trans, create_clos_infos ~evars betaiotazeta env in
-  ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint
+let clos_fconv trans cv_pb l2r evars env univs t1 t2 =
+  let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in
+  let infos = create_clos_infos ~evars reds env in
+  ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs
+
+
+let check_eq univs u u' = 
+  if not (check_eq univs u u') then raise NotConvertible
+
+let check_leq univs u u' = 
+  if not (check_leq univs u u') then raise NotConvertible
+
+let check_sort_cmp_universes env pb s0 s1 univs =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) when is_cumul pb ->
+      begin match c1, c2 with
+      | Null, _ | _, Pos -> () (* Prop <= Set *)
+      | _ -> raise NotConvertible
+      end
+    | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible
+    | (Prop c1, Type u) ->
+	if not (type_in_type env) then
+	let u0 = univ_of_sort s0 in
+	(match pb with
+	| CUMUL -> check_leq univs u0 u
+	| CONV -> check_eq univs u0 u)
+    | (Type u, Prop c) -> raise NotConvertible
+    | (Type u1, Type u2) ->
+        if not (type_in_type env) then
+	(match pb with
+	| CUMUL -> check_leq univs u1 u2
+	| CONV -> check_eq univs u1 u2)
+
+let checked_sort_cmp_universes env pb s0 s1 univs =
+  check_sort_cmp_universes env pb s0 s1 univs; univs
+
+let check_convert_instances _flex u u' univs =
+  if Univ.Instance.check_eq univs u u' then univs
+  else raise NotConvertible
+
+let checked_universes =
+  { compare = checked_sort_cmp_universes;
+    compare_instances = check_convert_instances }
+
+let infer_eq (univs, cstrs as cuniv) u u' =
+  if Univ.check_eq univs u u' then cuniv
+  else
+    univs, (Univ.enforce_eq u u' cstrs)
 
-let trans_fconv reds cv_pb l2r evars env t1 t2 =
-  if eq_constr t1 t2 then empty_constraint
-  else clos_fconv reds cv_pb l2r evars env t1 t2
+let infer_leq (univs, cstrs as cuniv) u u' =
+  if Univ.check_leq univs u u' then cuniv
+  else
+    let cstrs' = Univ.enforce_leq u u' cstrs in
+      univs, cstrs'
+
+let infer_cmp_universes env pb s0 s1 univs =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) when is_cumul pb ->
+      begin match c1, c2 with
+      | Null, _ | _, Pos -> univs (* Prop <= Set *)
+      | _ -> raise NotConvertible
+      end
+    | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible
+    | (Prop c1, Type u) ->
+      let u0 = univ_of_sort s0 in
+	(match pb with
+	| CUMUL -> infer_leq univs u0 u
+	| CONV -> infer_eq univs u0 u)
+    | (Type u, Prop c) -> raise NotConvertible
+    | (Type u1, Type u2) ->
+        if not (type_in_type env) then
+	(match pb with
+	| CUMUL -> infer_leq univs u1 u2
+	| CONV -> infer_eq univs u1 u2)
+        else univs
+
+let infer_convert_instances flex u u' (univs,cstrs) =
+  (univs, Univ.enforce_eq_instances u u' cstrs)
+
+let infered_universes : (Univ.universes * Univ.Constraint.t) universe_compare = 
+  { compare = infer_cmp_universes;
+    compare_instances = infer_convert_instances }
+
+let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 =
+  let b = 
+    if cv_pb = CUMUL then leq_constr_univs univs t1 t2 
+    else eq_constr_univs univs t1 t2
+  in
+    if b then ()
+    else 
+      let _ = clos_fconv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in
+	()
+
+(* Profiling *)
+let trans_fconv_universes = 
+  if Flags.profile then
+    let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in
+      Profile.profile8 trans_fconv_universes_key trans_fconv_universes
+  else trans_fconv_universes
+
+let trans_fconv reds cv_pb l2r evars env = 
+  trans_fconv_universes reds cv_pb l2r evars env (universes env)
 
 let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None)
 let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars
 let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars
 
-let fconv = trans_fconv (Idpred.full, Cpred.full)
+let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = 
+  trans_fconv_universes reds CONV l2r evars
+let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = 
+  trans_fconv_universes reds CUMUL l2r evars
+
+let fconv = trans_fconv (Id.Pred.full, Cpred.full)
 
 let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None)
 let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars
 let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars
 
 let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 =
-  array_fold_left2_i
-    (fun i c t1 t2 ->
-      let c' =
-        try conv_leq ~l2r ~evars env t1 t2
-        with NotConvertible -> raise (NotConvertibleVect i) in
-      union_constraints c c')
-    empty_constraint
+  Array.fold_left2_i
+    (fun i _ t1 t2 ->
+      try conv_leq ~l2r ~evars env t1 t2
+      with NotConvertible -> raise (NotConvertibleVect i))
+    ()
     v1
     v2
 
+let generic_conv cv_pb l2r evars reds env univs t1 t2 =
+  let (s, _) = 
+    clos_fconv reds cv_pb l2r evars env univs t1 t2 
+  in s
+
+let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 =
+  let b, cstrs =
+    if cv_pb == CUMUL then Constr.leq_constr_univs_infer univs t1 t2
+    else Constr.eq_constr_univs_infer univs t1 t2
+  in
+    if b then cstrs
+    else
+      let univs = ((univs, Univ.Constraint.empty), infered_universes) in
+      let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in
+	cstrs
+
+(* Profiling *)
+let infer_conv_universes = 
+  if Flags.profile then 
+    let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" in
+      Profile.profile8 infer_conv_universes_key infer_conv_universes
+  else infer_conv_universes
+
+let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state)
+    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) 
+    env univs t1 t2 = 
+  infer_conv_universes CUMUL l2r evars ts env univs t1 t2
+
 (* option for conversion *)
+let nat_conv = ref (fun cv_pb sigma ->
+		    fconv cv_pb false (sigma.Nativelambda.evars_val))
+let set_nat_conv f = nat_conv := f
+
+let native_conv cv_pb sigma env t1 t2 =
+  if eq_constr t1 t2 then ()
+  else begin
+    let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in
+    let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in
+    !nat_conv cv_pb sigma env t1 t2 
+  end
 
 let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None))
 let set_vm_conv f = vm_conv := f
@@ -500,7 +782,7 @@ let conv env t1 t2 =
 let hnf_prod_app env t n =
   match kind_of_term (whd_betadeltaiota env t) with
     | Prod (_,_,b) -> subst1 n b
-    | _ -> anomaly "hnf_prod_app: Need a product"
+    | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
 
 let hnf_prod_applist env t nl =
   List.fold_left (hnf_prod_app env) t nl
@@ -518,7 +800,7 @@ let dest_prod env =
   in
   decrec env empty_rel_context
 
-(* The same but preserving lets *)
+(* The same but preserving lets in the context, not internal ones. *)
 let dest_prod_assum env =
   let rec prodec_rec env l ty =
     let rty = whd_betadeltaiota_nolet env ty in
@@ -530,10 +812,28 @@ let dest_prod_assum env =
         let d = (x,Some b,t) in
 	prodec_rec (push_rel d env) (add_rel_decl d l) c
     | Cast (c,_,_)    -> prodec_rec env l c
-    | _               -> l,rty
+    | _               ->
+      let rty' = whd_betadeltaiota env rty in
+	if Term.eq_constr rty' rty then l, rty
+	else prodec_rec env l rty'
   in
   prodec_rec env empty_rel_context
 
+let dest_lam_assum env =
+  let rec lamec_rec env l ty =
+    let rty = whd_betadeltaiota_nolet env ty in
+    match kind_of_term rty with
+    | Lambda (x,t,c)  ->
+        let d = (x,None,t) in
+	lamec_rec (push_rel d env) (add_rel_decl d l) c
+    | LetIn (x,b,t,c) ->
+        let d = (x,Some b,t) in
+	lamec_rec (push_rel d env) (add_rel_decl d l) c
+    | Cast (c,_,_)    -> lamec_rec env l c
+    | _               -> l,rty
+  in
+  lamec_rec env empty_rel_context
+
 exception NotArity
 
 let dest_arity env c =
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 7ce8ee8b..6ced5c49 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -1,40 +1,62 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Term
+open Context
 open Environ
-open Closure
+
+val left2right : bool ref
 
 (***********************************************************************
   s Reduction functions *)
 
-val whd_betaiotazeta        : constr -> constr
+val whd_betaiotazeta        : env -> constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
 val whd_betadeltaiota_nolet : env -> constr -> constr
 
-val whd_betaiota      : constr -> constr
-val nf_betaiota      : constr -> constr
+val whd_betaiota     : env -> constr -> constr
+val nf_betaiota      : env -> constr -> constr
 
 (***********************************************************************
   s conversion functions *)
 
 exception NotConvertible
 exception NotConvertibleVect of int
-type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
-type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints
+
+type 'a conversion_function = env -> 'a -> 'a -> unit
+type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function
+type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit
+type 'a trans_universe_conversion_function = 
+  Names.transparent_state -> 'a universe_conversion_function
 
 type conv_pb = CONV | CUMUL
 
-val sort_cmp :
-    conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints
+type 'a universe_compare = 
+  { (* Might raise NotConvertible *)
+    compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a;
+    compare_instances: bool (* Instance of a flexible constant? *) -> 
+		       Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a;
+  } 
+
+type 'a universe_state = 'a * 'a universe_compare
+
+type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b
+
+type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints
+
+val check_sort_cmp_universes :
+  env -> conv_pb -> sorts -> sorts -> Univ.universes -> unit
 
-val conv_sort      : sorts conversion_function
-val conv_sort_leq  : sorts conversion_function
+(* val sort_cmp : *)
+(*     conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *)
+
+(* val conv_sort      : sorts conversion_function *)
+(* val conv_sort_leq  : sorts conversion_function *)
 
 val trans_conv_cmp       : ?l2r:bool -> conv_pb -> constr trans_conversion_function
 val trans_conv           :
@@ -42,6 +64,11 @@ val trans_conv           :
 val trans_conv_leq       :
   ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function
 
+val trans_conv_universes     :
+  ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function
+val trans_conv_leq_universes :
+  ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function
+
 val conv_cmp       : ?l2r:bool -> conv_pb -> constr conversion_function
 val conv           :
   ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function
@@ -50,10 +77,22 @@ val conv_leq       :
 val conv_leq_vecti :
   ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function
 
+val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> 
+  ?ts:Names.transparent_state -> constr infer_conversion_function
+val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> 
+  ?ts:Names.transparent_state -> types infer_conversion_function
+
+val generic_conv : conv_pb -> bool -> (existential->constr option) -> 
+  Names.transparent_state -> (constr,'a) generic_conversion_function
+
 (** option for conversion *)
 val set_vm_conv : (conv_pb -> types conversion_function) -> unit
 val vm_conv : conv_pb -> types conversion_function
 
+val set_nat_conv :
+  (conv_pb -> Nativelambda.evars -> types conversion_function) -> unit
+val native_conv : conv_pb -> Nativelambda.evars -> types conversion_function
+
 val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit
 val default_conv     : conv_pb -> ?l2r:bool -> types conversion_function
 val default_conv_leq : ?l2r:bool -> types conversion_function
@@ -75,6 +114,7 @@ val hnf_prod_applist : env -> types -> constr list -> types
 
 val dest_prod       : env -> types -> rel_context * types
 val dest_prod_assum : env -> types -> rel_context * types
+val dest_lam_assum  : env -> types -> rel_context * types
 
 exception NotArity
 
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index bbb8491e..cc307f14 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,22 +13,17 @@
 (* This file defines the knowledge that the kernel is able to optimize
    for evaluation in the bytecode virtual machine *)
 
-open Term
 open Names
+open Term
 
-(* Type declarations, these types shouldn't be exported they are accessed
-   through specific functions. As being mutable and all it is wiser *)
-(* These types are put into two distinct categories: proactive and reactive.
-   Proactive information allows to find the name of a combinator, constructor
-   or inductive type handling a specific function.
-   Reactive information is, on the other hand, everything you need to know
-   about a specific name.*)
+(* The retroknowledge defines a bijective correspondance between some
+   [entry]-s (which are, in fact, merely terms) and [field]-s which
+   are roles assigned to these entries. *)
 
 (* aliased type for clarity purpose*)
-type entry =  (constr, types) kind_of_term
+type entry = Constr.t
 
-(* the following types correspond to the different "things"
-   the kernel can learn about. These are the fields of the proactive knowledge*)
+(* [field]-s are the roles the kernel can learn of. *)
 type nat_field =
   | NatType
   | NatPlus
@@ -47,6 +42,7 @@ type n_field =
 type int31_field =
   | Int31Bits
   | Int31Type
+  | Int31Constructor
   | Int31Twice
   | Int31TwicePlusOne
   | Int31Phi
@@ -61,15 +57,19 @@ type int31_field =
   | Int31TimesC
   | Int31Div21
   | Int31Div
+  | Int31Diveucl
   | Int31AddMulDiv
   | Int31Compare
   | Int31Head0
   | Int31Tail0
+  | Int31Lor
+  | Int31Land
+  | Int31Lxor
 
 type field =
- (* | KEq
-  | KNat of nat_field
-  | KN of n_field *)
+  (* | KEq
+     | KNat of nat_field
+     | KN of n_field *)
   | KInt31 of string*int31_field
 
 
@@ -80,28 +80,26 @@ type flags = {fastcomputation : bool}
 
 
 
-(*A definition of maps from strings to pro_int31, to be able
-  to have any amount of coq representation for the 31bits integers *)
+(* The [proactive] knowledge contains the mapping [field->entry]. *)
 
 module Proactive =
   Map.Make (struct type t = field let compare = compare end)
 
 type proactive = entry Proactive.t
 
-(* the reactive knowledge is represented as a functionaly map
-   from the type of terms (actually it is the terms whose outermost
-   layer is unfolded (typically by Term.kind_of_term)) to the
-   type reactive_end which is a record containing all the kind of reactive
-   information needed *)
-(* todo: because of the bug with output state, reactive_end should eventually
-   contain no function. A forseen possibility is to make it a map from
-   a finite type describing the fields to the field of proactive retroknowledge
-   (and then to make as many functions as needed in environ.ml) *)
+(* The [reactive] knowledge contains the mapping
+   [entry->field]. Fields are later to be interpreted as a
+   [reactive_info]. *)
+
+module EntryOrd =
+struct
+  type t = entry
+  let compare = Constr.compare
+end
 
-module Reactive =
-  Map.Make (struct type t = entry let compare = compare end)
+module Reactive = Map.Make (EntryOrd)
 
-type reactive_end = {(*information required by the compiler of the VM *)
+type reactive_info = {(*information required by the compiler of the VM *)
   vm_compiling :
       (*fastcomputation flag -> continuation -> result *)
       (bool->Cbytecodes.comp_env->constr array ->
@@ -119,11 +117,27 @@ type reactive_end = {(*information required by the compiler of the VM *)
   (* fastcomputation flag -> cont -> result *)
   vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option;
   (* tag (= compiled int for instance) -> result *)
-  vm_decompile_const : (int -> Term.constr) option}
+  vm_decompile_const : (int -> Term.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
 
-and reactive = reactive_end Reactive.t
+}
+
+
+
+and reactive = field Reactive.t
 
 and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive}
 
@@ -150,125 +164,96 @@ let initial_retroknowledge =
    proactive = initial_proactive;
    reactive = initial_reactive }
 
-let empty_reactive_end =
+let empty_reactive_info =
   { vm_compiling = None ;
     vm_constant_static = None;
     vm_constant_dynamic = None;
     vm_before_match = None;
-    vm_decompile_const = 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 add_field knowledge field value =
-  {knowledge with proactive = Proactive.add field value knowledge.proactive}
-
 let mem knowledge field =
   Proactive.mem field knowledge.proactive
 
-let remove knowledge field =
-  {knowledge with proactive = Proactive.remove 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 (Reactive.find key knowledge.reactive).vm_compiling
+  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 (Reactive.find key knowledge.reactive).vm_constant_static
+  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 (Reactive.find key knowledge.reactive).vm_constant_dynamic
+  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 (Reactive.find key knowledge.reactive).vm_before_match
+  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 (Reactive.find key knowledge.reactive).vm_decompile_const
+  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
 
-(* functions manipulating reactive knowledge *)
-let add_vm_compiling_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_compiling = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_compiling = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_constant_static_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_constant_static = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_constant_static = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_constant_dynamic_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_constant_dynamic = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_constant_dynamic = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_before_match_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_before_match = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_before_match = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_decompile_constant_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_decompile_const = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_decompile_const = Some nfo}
-       knowledge.reactive
-  }
+(* 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 clear_info knowledge value =
-  {knowledge with reactive = Reactive.remove value knowledge.reactive}
+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
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index 0b1d8c69..9a63deb7 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,7 +12,7 @@ open Term
 type retroknowledge
 
 (** aliased type for clarity purpose*)
-type entry =  (constr, types) kind_of_term
+type entry = Constr.t
 
 (** the following types correspond to the different "things"
    the kernel can learn about.*)
@@ -34,6 +34,7 @@ type n_field =
 type int31_field =
   | Int31Bits
   | Int31Type
+  | Int31Constructor
   | Int31Twice
   | Int31TwicePlusOne
   | Int31Phi
@@ -48,10 +49,14 @@ type int31_field =
   | Int31TimesC
   | Int31Div21
   | Int31Div
+  | Int31Diveucl
   | Int31AddMulDiv
   | Int31Compare
   | Int31Head0
   | Int31Tail0
+  | Int31Lor
+  | Int31Land
+  | Int31Lxor
 
 type field =
 
@@ -115,38 +120,69 @@ val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes
 val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr
 
 
-(** the following functions are solely used in Pre_env and Environ to implement
-   the functions  register and unregister (and mem) of Environ *)
-val add_field : retroknowledge -> field -> entry -> retroknowledge
-val mem : retroknowledge -> field -> bool
-val remove : retroknowledge -> field -> retroknowledge
-val find : retroknowledge -> field -> entry
+val get_native_compiling_info  : retroknowledge -> entry -> Nativeinstr.prefix ->
+				 Nativeinstr.lambda array -> Nativeinstr.lambda
 
-(** the following function manipulate the reactive information of values
-   they are only used by the functions of Pre_env, and Environ to implement
-   the functions register and unregister of Environ *)
-val add_vm_compiling_info : retroknowledge-> entry ->
-                            (bool -> Cbytecodes.comp_env -> constr array -> int ->
-                            Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
-                            retroknowledge
-val add_vm_constant_static_info : retroknowledge-> entry ->
-                                  (bool->constr array->
-                                      Cbytecodes.structured_constant) ->
-                                  retroknowledge
-val add_vm_constant_dynamic_info : retroknowledge-> entry ->
-                                   (bool -> Cbytecodes.comp_env ->
-                                   Cbytecodes.block array -> int ->
-                                   Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
-                                   retroknowledge
-val add_vm_before_match_info : retroknowledge -> entry ->
-                              (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) ->
-                              retroknowledge
+val get_native_constant_static_info : retroknowledge -> entry ->
+                                      constr array -> Nativeinstr.lambda
 
-val add_vm_decompile_constant_info : retroknowledge -> entry ->
-                                    (int -> constr) -> retroknowledge
+val get_native_constant_dynamic_info : retroknowledge -> entry ->
+                                       Nativeinstr.prefix -> constructor ->
+				       Nativeinstr.lambda array ->
+				       Nativeinstr.lambda
 
+val get_native_before_match_info : retroknowledge -> entry ->
+				   Nativeinstr.prefix -> constructor ->
+				   Nativeinstr.lambda -> Nativeinstr.lambda
 
-val clear_info : retroknowledge-> entry -> retroknowledge
 
+(** the following functions are solely used in Pre_env and Environ to implement
+   the functions  register and unregister (and mem) of Environ *)
+val add_field : retroknowledge -> field -> entry -> retroknowledge
+val mem : retroknowledge -> field -> bool
+(* val remove : retroknowledge -> field -> retroknowledge *)
+val find : retroknowledge -> field -> entry
 
 
+(** 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->Cbytecodes.comp_env->constr array ->
+       int->Cbytecodes.bytecodes->Cbytecodes.bytecodes)
+      option;
+  vm_constant_static :
+      (*fastcomputation flag -> constructor -> args -> result*)
+      (bool->constr array->Cbytecodes.structured_constant)
+      option;
+  vm_constant_dynamic :
+      (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *)
+      (bool->Cbytecodes.comp_env->Cbytecodes.block array->int->
+         Cbytecodes.bytecodes->Cbytecodes.bytecodes)
+      option;
+  (* fastcomputation flag -> cont -> result *)
+  vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option;
+  (* tag (= compiled int for instance) -> result *)
+  vm_decompile_const : (int -> Term.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
+
+}
+
+val empty_reactive_info : reactive_info
+
+(** Hook to be set after the compiler are installed to dispatch fields
+    into the above [get_*] functions. *)
+val dispatch_hook : (retroknowledge -> entry -> field -> reactive_info) Hook.t
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index f9f206dd..20cecc84 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -25,13 +25,13 @@
      [,] |-
 
    push_named_assum(a,T):
-   
+
      E[Delta,Gamma] |-_G
      ------------------------
      E[Delta,Gamma,a:T] |-_G'
 
    push_named_def(a,t,T):
-   
+
      E[Delta,Gamma] |-_G
      ---------------------------
      E[Delta,Gamma,a:=t:T] |-_G'
@@ -59,668 +59,803 @@
 
 open Util
 open Names
-open Univ
-open Term
-open Reduction
-open Sign
 open Declarations
-open Inductive
-open Environ
-open Entries
-open Typeops
-open Type_errors
-open Indtypes
-open Term_typing
-open Modops
-open Subtyping
-open Mod_typing
-open Mod_subst
-
-
-type modvariant =
-  | NONE
-  | SIG of (* funsig params *) (mod_bound_id * module_type_body) list
-  | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list
-  | LIBRARY of dir_path
 
-type module_info =
-    {modpath : module_path;
-     label : label;
-     variant : modvariant;
-     resolver : delta_resolver;
-     resolver_of_param : delta_resolver;}
+(** {6 Safe environments }
+
+  Fields of [safe_environment] :
+
+  - [env] : the underlying environment (cf Environ)
+  - [modpath] : the current module name
+  - [modvariant] :
+    * NONE before coqtop initialization (or when -notop is used)
+    * LIBRARY at toplevel of a compilation or a regular coqtop session
+    * STRUCT (params,oldsenv) : inside a local module, with
+      module parameters [params] and earlier environment [oldsenv]
+    * SIG (params,oldsenv) : same for a local module type
+  - [modresolver] : delta_resolver concerning the module content
+  - [paramresolver] : delta_resolver concerning the module parameters
+  - [revstruct] : current module content, most recent declarations first
+  - [modlabels] and [objlabels] : names defined in the current module,
+      either for modules/modtypes or for constants/inductives.
+      These fields could be deduced from [revstruct], but they allow faster
+      name freshness checks.
+ - [univ] and [future_cst] : current and future universe constraints
+ - [engagement] : are we Set-impredicative?
+ - [type_in_type] : does the universe hierarchy collapse?
+ - [required] : names and digests of Require'd libraries since big-bang.
+      This field will only grow
+ - [loads] : list of libraries Require'd inside the current module.
+      They will be propagated to the upper module level when
+      the current module ends.
+ - [local_retroknowledge]
 
-let set_engagement_opt oeng env =
-  match oeng with
-      Some eng -> set_engagement eng env
-    | _ -> env
+*)
 
-type library_info = dir_path * Digest.t
+type vodigest =
+  | Dvo_or_vi of Digest.t        (* The digest of the seg_lib part *)
+  | Dvivo of Digest.t * Digest.t (* The digest of the seg_lib + seg_univ part *)
 
-type safe_environment =
-    { old : safe_environment;
-      env : env;
-      modinfo : module_info;
-      modlabels : Labset.t;
-      objlabels : Labset.t;
-      revstruct : structure_body;
-      univ : Univ.constraints;
-      engagement : engagement option;
-      imports : library_info list;
-      loads : (module_path * module_body) list;
-      local_retroknowledge : Retroknowledge.action list}
-
-let exists_modlabel l senv = Labset.mem l senv.modlabels
-let exists_objlabel l senv = Labset.mem l senv.objlabels
+let digest_match ~actual ~required =
+  match actual, required with
+  | Dvo_or_vi d1, Dvo_or_vi d2
+  | Dvivo (d1,_), Dvo_or_vi d2 -> String.equal d1 d2
+  | Dvivo (d1,e1), Dvivo (d2,e2) -> String.equal d1 d2 && String.equal e1 e2
+  | Dvo_or_vi _, Dvivo _ -> false
 
-let check_modlabel l senv =
-  if exists_modlabel l senv then error_existing_label l
-let check_objlabel l senv =
-  if exists_objlabel l senv then error_existing_label l
+type library_info = DirPath.t * vodigest
 
-let check_objlabels ls senv =
-  Labset.iter (fun l -> check_objlabel l senv) ls
+(** Functor and funsig parameters, most recent first *)
+type module_parameters = (MBId.t * module_type_body) list
 
-let labels_of_mib mib =
-  let add,get =
-    let labels = ref Labset.empty in
-    (fun id -> labels := Labset.add (label_of_id id) !labels),
-    (fun () -> !labels)
-  in
-  let visit_mip mip =
-    add mip.mind_typename;
-    Array.iter add mip.mind_consnames
-  in
-  Array.iter visit_mip mib.mind_packets;
-  get ()
+module DPMap = Map.Make(DirPath)
 
-(* a small hack to avoid variants and an unused case in all functions *)
-let rec empty_environment =
-  { old = empty_environment;
-    env = empty_env;
-    modinfo = {
-      modpath = initial_path;
-      label = mk_label "_";
-      variant = NONE;
-      resolver = empty_delta_resolver;
-      resolver_of_param = empty_delta_resolver};
-    modlabels = Labset.empty;
-    objlabels = Labset.empty;
+type safe_environment =
+  { env : Environ.env;
+    modpath : module_path;
+    modvariant : modvariant;
+    modresolver : Mod_subst.delta_resolver;
+    paramresolver : Mod_subst.delta_resolver;
+    revstruct : structure_body;
+    modlabels : Label.Set.t;
+    objlabels : Label.Set.t;
+    univ : Univ.constraints;
+    future_cst : Univ.constraints Future.computation list;
+    engagement : engagement option;
+    type_in_type : bool;
+    required : vodigest DPMap.t;
+    loads : (module_path * module_body) list;
+    local_retroknowledge : Retroknowledge.action list }
+
+and modvariant =
+  | NONE
+  | LIBRARY
+  | SIG of module_parameters * safe_environment (** saved env *)
+  | STRUCT of module_parameters * safe_environment (** saved env *)
+
+let rec library_dp_of_senv senv =
+  match senv.modvariant with
+  | NONE | LIBRARY -> ModPath.dp senv.modpath
+  | SIG(_,senv) -> library_dp_of_senv senv
+  | STRUCT(_,senv) -> library_dp_of_senv senv
+
+let empty_environment =
+  { env = Environ.empty_env;
+    modpath = initial_path;
+    modvariant = NONE;
+    modresolver = Mod_subst.empty_delta_resolver;
+    paramresolver = Mod_subst.empty_delta_resolver;
     revstruct = [];
-    univ = Univ.empty_constraint;
+    modlabels = Label.Set.empty;
+    objlabels = Label.Set.empty;
+    future_cst = [];
+    univ = Univ.Constraint.empty;
     engagement = None;
-    imports = [];
+    type_in_type = false;
+    required = DPMap.empty;
     loads = [];
     local_retroknowledge = [] }
 
+let is_initial senv =
+  match senv.revstruct, senv.modvariant with
+  | [], NONE -> ModPath.equal senv.modpath initial_path
+  | _ -> false
+
+let delta_of_senv senv = senv.modresolver,senv.paramresolver
+
+(** The safe_environment state monad *)
+
+type safe_transformer0 = safe_environment -> safe_environment
+type 'a safe_transformer = safe_environment -> 'a * safe_environment
+
+
+(** {6 Engagement } *)
+
+let set_engagement_opt env = function
+  | Some c -> Environ.set_engagement c env
+  | None -> env
+
+let set_engagement c senv =
+  { senv with
+    env = Environ.set_engagement c senv.env;
+    engagement = Some c }
+
+(** Check that the engagement [c] expected by a library matches
+    the current (initial) one *)
+let check_engagement env c =
+  match Environ.engagement env, c with
+  | None, Some ImpredicativeSet ->
+    Errors.error "Needs option -impredicative-set."
+  | _ -> ()
+
+let set_type_in_type senv = 
+  { senv with
+    env = Environ.set_type_in_type senv.env;
+    type_in_type = true }
+
+(** {6 Stm machinery } *)
+
+let get_opaque_body env cbo =
+  match cbo.const_body with
+  | Undef _ -> assert false
+  | Def _ -> `Nothing
+  | OpaqueDef opaque ->
+      `Opaque
+        (Opaqueproof.force_proof (Environ.opaque_tables env) opaque,
+         Opaqueproof.force_constraints (Environ.opaque_tables env) opaque)
+
+let sideff_of_con env c =
+  let cbo = Environ.lookup_constant c env.env in
+  SEsubproof (c, cbo, get_opaque_body env.env cbo)
+let sideff_of_scheme kind env cl =
+  SEscheme(
+    List.map (fun (i,c) ->
+      let cbo = Environ.lookup_constant c env.env in
+      i, c, cbo, get_opaque_body env.env cbo) cl,
+    kind)
+
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
 
+type constraints_addition =
+  Now of Univ.constraints | Later of Univ.constraints Future.computation
+
 let add_constraints cst senv =
+  match cst with
+  | Later fc -> 
+    {senv with future_cst = fc :: senv.future_cst}
+  | Now cst ->
   { senv with
     env = Environ.add_constraints cst senv.env;
-    univ = Univ.union_constraints cst senv.univ }
+    univ = Univ.Constraint.union cst senv.univ }
 
-let constraints_of_sfb = function
-  | SFBconst cb -> cb.const_constraints
-  | SFBmind mib -> mib.mind_constraints
-  | SFBmodtype mtb -> mtb.typ_constraints
-  | SFBmodule mb -> mb.mod_constraints
+let add_constraints_list cst senv =
+  List.fold_right add_constraints cst senv
 
-(* A generic function for adding a new field in a same environment.
-   It also performs the corresponding [add_constraints]. *)
+let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx))
+let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx))
 
-type generic_name =
-  | C of constant
-  | I of mutual_inductive
-  | MT of module_path
-  | M
+let is_curmod_library senv =
+  match senv.modvariant with LIBRARY -> true | _ -> false
 
-let add_field ((l,sfb) as field) gn senv =
-  let mlabs,olabs = match sfb with
-    | SFBmind mib ->
-      let l = labels_of_mib mib in
-      check_objlabels l senv; (Labset.empty,l)
-    | SFBconst _ ->
-      check_objlabel l senv; (Labset.empty, Labset.singleton l)
-    | SFBmodule _ | SFBmodtype _ ->
-      check_modlabel l senv; (Labset.singleton l, Labset.empty)
-  in
-  let senv = add_constraints (constraints_of_sfb sfb) senv in
-  let env' = match sfb, gn with
-    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
-    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
-    | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env
-    | SFBmodule mb, M -> Modops.add_module mb senv.env
-    | _ -> assert false
-  in
-  { senv with
-    env = env';
-    modlabels = Labset.union mlabs senv.modlabels;
-    objlabels = Labset.union olabs senv.objlabels;
-    revstruct = field :: senv.revstruct }
+let join_safe_environment ?(except=Future.UUIDSet.empty) e =
+  Modops.join_structure except (Environ.opaque_tables e.env) e.revstruct;
+  List.fold_left
+    (fun e fc ->
+       if Future.UUIDSet.mem (Future.uuid fc) except then e
+       else add_constraints (Now (Future.join fc)) e)
+    {e with future_cst = []} e.future_cst
 
-(* Applying a certain function to the resolver of a safe environment *)
+(** {6 Various checks } *)
 
-let update_resolver f senv =
-  let mi = senv.modinfo in
-  { senv with modinfo = { mi with resolver = f mi.resolver }}
+let exists_modlabel l senv = Label.Set.mem l senv.modlabels
+let exists_objlabel l senv = Label.Set.mem l senv.objlabels
 
+let check_modlabel l senv =
+  if exists_modlabel l senv then Modops.error_existing_label l
 
-(* universal lifting, used for the "get" operations mostly *)
-let retroknowledge f senv =
-  Environ.retroknowledge f (env_of_senv senv)
+let check_objlabel l senv =
+  if exists_objlabel l senv then Modops.error_existing_label l
 
-let register senv field value by_clause =
-  (* todo : value closed, by_clause safe, by_clause of the proper type*)
-  (* spiwack : updates the safe_env with the information that the register
-     action has to be performed (again) when the environement is imported *)
-  {senv with
-    env = Environ.register senv.env field value;
-    local_retroknowledge =
-      Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
-  }
+let check_objlabels ls senv =
+  Label.Set.iter (fun l -> check_objlabel l senv) ls
+
+(** Are we closing the right module / modtype ?
+    No user error here, since the opening/ending coherence
+    is now verified in [vernac_end_segment] *)
+
+let check_current_label lab = function
+  | MPdot (_,l) -> assert (Label.equal lab l)
+  | _ -> assert false
 
-(* spiwack : currently unused *)
-let unregister senv field  =
-  (*spiwack: todo: do things properly or delete *)
-  {senv with env = Environ.unregister senv.env field}
-(* /spiwack *)
+let check_struct = function
+  | STRUCT (params,oldsenv) -> params, oldsenv
+  | NONE | LIBRARY | SIG _ -> assert false
 
+let check_sig = function
+  | SIG (params,oldsenv) -> params, oldsenv
+  | NONE | LIBRARY | STRUCT _ -> assert false
 
+let check_current_library dir senv = match senv.modvariant with
+  | LIBRARY -> assert (ModPath.equal senv.modpath (MPfile dir))
+  | NONE | STRUCT _ | SIG _ -> assert false (* cf Lib.end_compilation *)
 
+(** When operating on modules, we're normally outside sections *)
 
+let check_empty_context senv =
+  assert (Environ.empty_context senv.env)
 
+(** When adding a parameter to the current module/modtype,
+    it must have been freshly started *)
 
+let check_empty_struct senv =
+  assert (List.is_empty senv.revstruct
+          && List.is_empty senv.loads)
 
+(** When starting a library, the current environment should be initial
+    i.e. only composed of Require's *)
 
+let check_initial senv = assert (is_initial senv)
 
+(** When loading a library, its dependencies should be already there,
+    with the correct digests. *)
 
-(* Insertion of section variables. They are now typed before being
-   added to the environment. *)
+let check_required current_libs needed =
+  let check (id,required) =
+    try
+      let actual = DPMap.find id current_libs in
+      if not(digest_match ~actual ~required) then
+        Errors.error
+          ("Inconsistent assumptions over module "^(DirPath.to_string id)^".")
+    with Not_found ->
+      Errors.error ("Reference to unknown module "^(DirPath.to_string id)^".")
+  in
+  Array.iter check needed
+
+
+(** {6 Insertion of section variables} *)
+
+(** They are now typed before being added to the environment.
+    Same as push_named, but check that the variable is not already
+    there. Should *not* be done in Environ because tactics add temporary
+    hypothesis many many times, and the check performed here would
+    cost too much. *)
 
-(* Same as push_named, but check that the variable is not already
-   there. Should *not* be done in Environ because tactics add temporary
-   hypothesis many many times, and the check performed here would
-   cost too much. *)
 let safe_push_named (id,_,_ as d) env =
   let _ =
     try
-      let _ = lookup_named id env in
-      error ("Identifier "^string_of_id id^" already defined.")
+      let _ = Environ.lookup_named id env in
+      Errors.error ("Identifier "^Id.to_string id^" already defined.")
     with Not_found -> () in
   Environ.push_named d env
 
-let push_named_def (id,b,topt) senv =
-  let (c,typ,cst) = translate_local_def senv.env (b,topt) in
-  let senv' = add_constraints cst senv in
+
+let push_named_def (id,de) senv =
+  let c,typ,univs = Term_typing.translate_local_def senv.env id de in
+  let senv' = push_context univs senv in
+  let c, senv' = match c with
+    | Def c -> Mod_subst.force_constr c, senv'
+    | OpaqueDef o ->
+        Opaqueproof.force_proof (Environ.opaque_tables senv'.env) o,
+        push_context_set
+          (Opaqueproof.force_constraints (Environ.opaque_tables senv'.env) o)
+          senv'
+    | _ -> assert false in
   let env'' = safe_push_named (id,Some c,typ) senv'.env in
-  (cst, {senv' with env=env''})
+    {senv' with env=env''}
 
-let push_named_assum (id,t) senv =
-  let (t,cst) = translate_local_assum senv.env t in
-  let senv' = add_constraints cst senv in
+let push_named_assum ((id,t),ctx) senv =
+  let senv' = push_context_set ctx senv in
+  let t = Term_typing.translate_local_assum senv'.env t in
   let env'' = safe_push_named (id,None,t) senv'.env in
-  (cst, {senv' with env=env''})
+    {senv' with env=env''}
+
+
+(** {6 Insertion of new declarations to current environment } *)
+
+let labels_of_mib mib =
+  let add,get =
+    let labels = ref Label.Set.empty in
+    (fun id -> labels := Label.Set.add (Label.of_id id) !labels),
+    (fun () -> !labels)
+  in
+  let visit_mip mip =
+    add mip.mind_typename;
+    Array.iter add mip.mind_consnames
+  in
+  Array.iter visit_mip mib.mind_packets;
+  get ()
+
+let globalize_constant_universes env cb =
+  if cb.const_polymorphic then
+    [Now Univ.Constraint.empty]
+  else
+    let cstrs = Univ.UContext.constraints cb.const_universes in
+      Now cstrs ::  
+	(match cb.const_body with
+	| (Undef _ | Def _) -> []
+	| OpaqueDef lc ->
+	  match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with
+	  | None -> []
+	  | Some fc ->
+            match Future.peek_val fc with
+            | None -> [Later (Future.chain ~pure:true fc Univ.ContextSet.constraints)]
+            | Some c -> [Now (Univ.ContextSet.constraints c)])
+      
+let globalize_mind_universes mb =
+  if mb.mind_polymorphic then
+    [Now Univ.Constraint.empty]
+  else
+    [Now (Univ.UContext.constraints mb.mind_universes)]
+
+let constraints_of_sfb env sfb = 
+  match sfb with
+  | SFBconst cb -> globalize_constant_universes env cb
+  | SFBmind mib -> globalize_mind_universes mib
+  | SFBmodtype mtb -> [Now mtb.mod_constraints]
+  | SFBmodule mb -> [Now mb.mod_constraints]
+
+(** A generic function for adding a new field in a same environment.
+    It also performs the corresponding [add_constraints]. *)
+
+type generic_name =
+  | C of constant
+  | I of mutual_inductive
+  | 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 mlabs,olabs = match sfb with
+    | SFBmind mib ->
+      let l = labels_of_mib mib in
+      check_objlabels l senv; (Label.Set.empty,l)
+    | SFBconst _ ->
+      check_objlabel l senv; (Label.Set.empty, Label.Set.singleton l)
+    | 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 env' = match sfb, gn with
+    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
+    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
+    | SFBmodtype mtb, MT -> Environ.add_modtype mtb senv.env
+    | SFBmodule mb, M -> Modops.add_module mb senv.env
+    | _ -> assert false
+  in
+  { senv with
+    env = env';
+    revstruct = field :: senv.revstruct;
+    modlabels = Label.Set.union mlabs senv.modlabels;
+    objlabels = Label.Set.union olabs senv.objlabels }
 
+(** Applying a certain function to the resolver of a safe environment *)
 
-(* Insertion of constants and parameters in environment. *)
+let update_resolver f senv = { senv with modresolver = f senv.modresolver }
 
+(** Insertion of constants and parameters in environment *)
 type global_declaration =
-  | ConstantEntry of constant_entry
+  | ConstantEntry of Entries.constant_entry
   | GlobalRecipe of Cooking.recipe
 
 let add_constant dir l decl senv =
-  let kn = make_con senv.modinfo.modpath dir l in
+  let kn = make_con senv.modpath dir l in
   let cb = match decl with
-    | ConstantEntry ce -> translate_constant senv.env kn ce
+    | ConstantEntry ce -> Term_typing.translate_constant senv.env kn ce
     | GlobalRecipe r ->
-      let cb = translate_recipe senv.env kn r in
-      if dir = empty_dirpath then hcons_const_body cb else cb
+      let cb = Term_typing.translate_recipe senv.env kn r in
+      if DirPath.is_empty dir then Declareops.hcons_const_body cb else cb
+  in
+  let cb, otab = match cb.const_body with
+    | OpaqueDef lc when DirPath.is_empty dir ->
+      (* In coqc, opaque constants outside sections will be stored
+         indirectly in a specific table *)
+      let od, otab =
+        Opaqueproof.turn_indirect
+          (library_dp_of_senv senv) lc (Environ.opaque_tables senv.env) in
+      { cb with const_body = OpaqueDef od }, otab
+    | _ -> cb, (Environ.opaque_tables senv.env)
   in
+  let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in
   let senv' = add_field (l,SFBconst cb) (C kn) senv in
   let senv'' = match cb.const_body with
     | Undef (Some lev) ->
-      update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv'
+      update_resolver
+        (Mod_subst.add_inline_delta_resolver (user_con kn) (lev,None)) senv'
     | _ -> senv'
   in
   kn, senv''
 
-(* Insertion of inductive types. *)
+(** Insertion of inductive types *)
+
+let check_mind mie lab =
+  let open Entries in
+  match mie.mind_entry_inds with
+  | [] -> assert false (* empty inductive entry *)
+  | oie::_ ->
+    (* The label and the first inductive type name should match *)
+    assert (Id.equal (Label.to_id lab) oie.mind_entry_typename)
 
 let add_mind dir l mie senv =
-  if mie.mind_entry_inds = [] then
-    anomaly "empty inductive types declaration";
-            (* this test is repeated by translate_mind *)
-  let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in
-  if l <> label_of_id id then
-    anomaly ("the label of inductive packet and its first inductive"^
-	     " type do not match");
-  let kn = make_mind senv.modinfo.modpath dir l in
-  let mib = translate_mind senv.env kn mie in
-  let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in
-  let senv' = add_field (l,SFBmind mib) (I kn) senv in
-  kn, senv'
-
-(* Insertion of module types *)
-
-let add_modtype l mte inl senv =
-  let mp = MPdot(senv.modinfo.modpath, l) in
-  let mtb = translate_module_type senv.env mp inl mte  in
-  let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in
+  let () = check_mind mie l in
+  let kn = make_mind senv.modpath dir l in
+  let mib = Term_typing.translate_mind senv.env kn mie in
+  let mib =
+    match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib
+  in
+  kn, add_field (l,SFBmind mib) (I kn) senv
+
+(** Insertion of module types *)
+
+let add_modtype l params_mte inl senv =
+  let mp = MPdot(senv.modpath, l) in
+  let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte  in
+  let senv' = add_field (l,SFBmodtype mtb) MT senv in
   mp, senv'
 
-(* full_add_module adds module with universes and constraints *)
+(** full_add_module adds module with universes and constraints *)
+
 let full_add_module mb senv =
-  let senv = add_constraints mb.mod_constraints senv in
-  { senv with env = Modops.add_module mb senv.env }
+  let senv = add_constraints (Now mb.mod_constraints) senv in
+  let dp = ModPath.dp mb.mod_mp in
+  let linkinfo = Nativecode.link_info_of_dirpath dp in
+  { senv with env = Modops.add_linked_module mb linkinfo senv.env }
+
+let full_add_module_type mp mt senv =
+  let senv = add_constraints (Now mt.mod_constraints) senv in
+  { senv with env = Modops.add_module_type mp mt senv.env }
 
-(* Insertion of modules *)
+(** Insertion of modules *)
 
 let add_module l me inl senv =
-  let mp = MPdot(senv.modinfo.modpath, l) in
-  let mb = translate_module senv.env mp inl me in
+  let mp = MPdot(senv.modpath, l) in
+  let mb = Mod_typing.translate_module senv.env mp inl me in
   let senv' = add_field (l,SFBmodule mb) M senv in
-  let senv'' = match mb.mod_type with
-    | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv'
-    | _ -> senv'
+  let senv'' =
+    if Modops.is_functor mb.mod_type then senv'
+    else update_resolver (Mod_subst.add_delta_resolver mb.mod_delta) senv'
   in
-  mp,mb.mod_delta,senv''
+  (mp,mb.mod_delta),senv''
 
-(* Interactive modules *)
+
+(** {6 Starting / ending interactive modules and module types } *)
 
 let start_module l senv =
-  check_modlabel l senv;
- let mp = MPdot(senv.modinfo.modpath, l) in
- let modinfo = { modpath = mp;
-		 label = l;
-		 variant = STRUCT [];
-		 resolver = empty_delta_resolver;
-		 resolver_of_param = empty_delta_resolver}
- in
-   mp, { old = senv;
-	 env = senv.env;
-	 modinfo = modinfo;
-	 modlabels = Labset.empty;
-	 objlabels = Labset.empty;
-	 revstruct = [];
-         univ = Univ.empty_constraint;
-         engagement = None;
-	 imports = senv.imports;
-	 loads = [];
-	 (* spiwack : not sure, but I hope it's correct *)
-         local_retroknowledge = [] }
+  let () = check_modlabel l senv in
+  let () = check_empty_context senv in
+  let mp = MPdot(senv.modpath, l) in
+  mp,
+  { empty_environment with
+    env = senv.env;
+    modpath = mp;
+    modvariant = STRUCT ([],senv);
+    required = senv.required }
 
-let end_module l restype senv =
-  let oldsenv = senv.old in
-  let modinfo = senv.modinfo in
-  let mp = senv.modinfo.modpath in
-  let restype =
-    Option.map
-      (fun (res,inl) -> translate_module_type senv.env mp inl res) restype in
-  let params,is_functor =
-    match modinfo.variant with
-      | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
-      | STRUCT params -> params, (List.length params > 0)
-  in
-  if l <> modinfo.label then error_incompatible_labels l modinfo.label;
-  if not (empty_context senv.env) then error_non_empty_local_context None;
-  let functorize_struct tb =
-    List.fold_left
-      (fun mtb (arg_id,arg_b) ->
-	SEBfunctor(arg_id,arg_b,mtb))
-      tb
-      params
-  in
-   let auto_tb =
-     SEBstruct (List.rev senv.revstruct)
-  in
-   let mexpr,mod_typ,mod_typ_alg,resolver,cst = 
-    match restype with
-      | None ->  let mexpr = functorize_struct auto_tb in
-	 mexpr,mexpr,None,modinfo.resolver,empty_constraint
-      | Some mtb ->
-	  let auto_mtb = {
-	    typ_mp = senv.modinfo.modpath;
-	    typ_expr = auto_tb;
-	    typ_expr_alg = None;
-	    typ_constraints = empty_constraint;
-	    typ_delta = empty_delta_resolver} in
-	  let cst = check_subtypes senv.env auto_mtb
-	    mtb in
-	  let mod_typ = functorize_struct mtb.typ_expr in
-	  let mexpr = functorize_struct auto_tb in
-	  let typ_alg = 
-	    Option.map functorize_struct mtb.typ_expr_alg in
-	    mexpr,mod_typ,typ_alg,mtb.typ_delta,cst
-  in
-  let cst = union_constraints cst senv.univ in
-  let mb =
-    { mod_mp = mp;
-      mod_expr = Some mexpr;
-      mod_type = mod_typ;
-      mod_type_alg = mod_typ_alg;
-      mod_constraints = cst;
-      mod_delta = resolver;
-      mod_retroknowledge = senv.local_retroknowledge }
-  in
-  let newenv = oldsenv.env in
-  let newenv = set_engagement_opt senv.engagement newenv in
-  let senv'= {senv with env = newenv; univ = cst} in
-  let senv' =
-    List.fold_left
-      (fun env (_,mb) -> full_add_module mb env) 
-      senv'
-      (List.rev senv'.loads)
-  in
-  let newenv = Environ.add_constraints cst senv'.env in
-  let newenv =
-    Modops.add_module mb newenv in 
-  let modinfo = match mb.mod_type with
-      SEBstruct _ -> 
-	{ oldsenv.modinfo with
-	    resolver = 
-	    add_delta_resolver resolver oldsenv.modinfo.resolver}
-    | _ -> oldsenv.modinfo
-  in
-    mp,resolver,{ old = oldsenv.old;
-		  env = newenv;
-		  modinfo = modinfo;
-		  modlabels = Labset.add l oldsenv.modlabels;
-		  objlabels = oldsenv.objlabels;
-		  revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
-		  univ = Univ.union_constraints senv'.univ oldsenv.univ;
-		  (* engagement is propagated to the upper level *)
-		  engagement = senv'.engagement;
-		  imports = senv'.imports;
-		  loads = senv'.loads@oldsenv.loads;
-		  local_retroknowledge =
-	senv'.local_retroknowledge@oldsenv.local_retroknowledge }
-
-
-(* Include for module and module type*)
- let add_include me is_module inl senv =
-   let sign,cst,resolver =
-     if is_module then
-       let sign,_,resolver,cst =
-	 translate_struct_include_module_entry senv.env
-	   senv.modinfo.modpath inl me in
-	 sign,cst,resolver
-     else
-       let mtb = 
-	 translate_module_type senv.env 
-	   senv.modinfo.modpath inl me in
-       mtb.typ_expr,mtb.typ_constraints,mtb.typ_delta
-   in
-   let senv = add_constraints cst senv in
-   let mp_sup = senv.modinfo.modpath in
-     (* Include Self support  *)
-   let rec compute_sign sign mb resolver senv = 
-     match sign with
-     | SEBfunctor(mbid,mtb,str) ->
-	 let cst_sub = check_subtypes senv.env mb mtb in
-	 let senv = add_constraints cst_sub senv in
-	 let mpsup_delta =
-	   inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta
-	 in
-	 let subst = map_mbid mbid mp_sup mpsup_delta in
-	 let resolver = subst_codom_delta_resolver subst resolver in
-	   (compute_sign 
-	     (subst_struct_expr subst str) mb resolver senv)
-     | str -> resolver,str,senv
-   in
-   let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup;
-				      typ_expr = SEBstruct (List.rev senv.revstruct);
-				      typ_expr_alg = None;
-				      typ_constraints = empty_constraint;
-				      typ_delta = senv.modinfo.resolver} resolver senv
-   in
-   let str = match sign with
-     | SEBstruct(str_l) -> str_l
-     | _ -> error ("You cannot Include a higher-order structure.")
-   in
-   let senv = update_resolver (add_delta_resolver resolver) senv
-   in
-   let add senv ((l,elem) as field) =
-     let new_name = match elem with
-       | SFBconst _ ->
-	   let kn = make_kn mp_sup empty_dirpath l in
-	   C (constant_of_delta_kn resolver kn)
-       | SFBmind _ ->
-	   let kn = make_kn mp_sup empty_dirpath l in
-	   I (mind_of_delta_kn resolver kn)
-       | SFBmodule _ -> M
-       | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l))
-     in
-     add_field field new_name senv
-   in
-   resolver,(List.fold_left add senv str)
-
-(* Adding parameters to modules or module types *)
+let start_modtype l senv =
+  let () = check_modlabel l senv in
+  let () = check_empty_context senv in
+  let mp = MPdot(senv.modpath, l) in
+  mp,
+  { empty_environment with
+    env = senv.env;
+    modpath = mp;
+    modvariant = SIG ([], senv);
+    required = senv.required }
+
+(** Adding parameters to the current module or module type.
+    This module should have been freshly started. *)
 
 let add_module_parameter mbid mte inl senv =
-  if  senv.revstruct <> [] or senv.loads <> [] then
-    anomaly "Cannot add a module parameter to a non empty module";
-  let mtb = translate_module_type senv.env (MPbound mbid) inl mte in
-  let senv = 
-    full_add_module (module_body_of_type (MPbound mbid) mtb) senv
+  let () = check_empty_struct senv in
+  let mp = MPbound mbid in
+  let mtb = Mod_typing.translate_modtype senv.env mp inl ([],mte) in
+  let senv = full_add_module_type mp mtb senv in
+  let new_variant = match senv.modvariant with
+    | STRUCT (params,oldenv) -> STRUCT ((mbid,mtb) :: params, oldenv)
+    | SIG (params,oldenv) -> SIG ((mbid,mtb) :: params, oldenv)
+    | _ -> assert false
   in
-  let new_variant = match senv.modinfo.variant with
-    | STRUCT params -> STRUCT ((mbid,mtb) :: params)
-    | SIG params -> SIG ((mbid,mtb) :: params)
-    | _ ->
-	anomaly "Module parameters can only be added to modules or signatures"  
+  let new_paramresolver =
+    if Modops.is_functor mtb.mod_type then senv.paramresolver
+    else Mod_subst.add_delta_resolver mtb.mod_delta senv.paramresolver
   in
-    
-  let resolver_of_param = match mtb.typ_expr with
-      SEBstruct _ -> mtb.typ_delta
-    | _ -> empty_delta_resolver
+  mtb.mod_delta,
+  { senv with
+    modvariant = new_variant;
+    paramresolver = new_paramresolver }
+
+let functorize params init =
+  List.fold_left (fun e (mbid,mt) -> MoreFunctor(mbid,mt,e)) init params
+
+let propagate_loads senv =
+  List.fold_left
+    (fun env (_,mb) -> full_add_module mb env)
+    senv
+    (List.rev senv.loads)
+
+(** Build the module body of the current module, taking in account
+    a possible return type (_:T) *)
+
+let functorize_module params mb =
+  let f x = functorize params x in
+  { mb with
+    mod_expr = Modops.implem_smartmap f f mb.mod_expr;
+    mod_type = f mb.mod_type;
+    mod_type_alg = Option.map f mb.mod_type_alg }
+
+let build_module_body params restype senv =
+  let struc = NoFunctor (List.rev senv.revstruct) in
+  let restype' = Option.map (fun (ty,inl) -> (([],ty),inl)) restype in
+  let mb =
+    Mod_typing.finalize_module senv.env senv.modpath
+      (struc,None,senv.modresolver,senv.univ) restype'
   in
-    mtb.typ_delta, { old = senv.old;
-		     env = senv.env;
-		     modinfo = { senv.modinfo with 
-				   variant = new_variant;
-				   resolver_of_param = add_delta_resolver
-			      resolver_of_param senv.modinfo.resolver_of_param};
-		     modlabels = senv.modlabels;
-		     objlabels = senv.objlabels;
-		     revstruct = [];
-		     univ = senv.univ;
-		     engagement = senv.engagement;
-		     imports = senv.imports;
-		     loads = [];
-		     local_retroknowledge = senv.local_retroknowledge }
-      
-
-(* Interactive module types *)
+  let mb' = functorize_module params mb in
+  { mb' with mod_retroknowledge = senv.local_retroknowledge }
+
+(** Returning back to the old pre-interactive-module environment,
+    with one extra component and some updated fields
+    (constraints, required, etc) *)
+
+let propagate_senv newdef newenv newresolver senv oldsenv =
+  let now_cst, later_cst = List.partition Future.is_val senv.future_cst in
+  (* This asserts that after Paral-ITP, standard vo compilation is behaving
+   * exctly as before: the same universe constraints are added to modules *)
+  if !Flags.compilation_mode = Flags.BuildVo &&
+     !Flags.async_proofs_mode = Flags.APoff then assert(later_cst = []);
+  { oldsenv with
+    env = newenv;
+    modresolver = newresolver;
+    revstruct = newdef::oldsenv.revstruct;
+    modlabels = Label.Set.add (fst newdef) oldsenv.modlabels;
+    univ =
+      List.fold_left (fun acc cst ->
+        Univ.Constraint.union acc (Future.force cst))
+      (Univ.Constraint.union senv.univ oldsenv.univ)
+      now_cst;
+    future_cst = later_cst @ oldsenv.future_cst;
+    (* engagement is propagated to the upper level *)
+    engagement = senv.engagement;
+    required = senv.required;
+    loads = senv.loads@oldsenv.loads;
+    local_retroknowledge =
+            senv.local_retroknowledge@oldsenv.local_retroknowledge }
 
-let start_modtype l senv =
-  check_modlabel l senv;
- let mp = MPdot(senv.modinfo.modpath, l) in
- let modinfo = { modpath = mp;
-		 label = l;
-		 variant = SIG [];
-		 resolver = empty_delta_resolver;
-		 resolver_of_param = empty_delta_resolver}
- in
-  mp, { old = senv;
-	env = senv.env;
-	modinfo = modinfo;
-	modlabels = Labset.empty;
-	objlabels = Labset.empty;
-	revstruct = [];
-        univ = Univ.empty_constraint;
-        engagement = None;
-	imports = senv.imports;
-	loads = [] ;
-	(* spiwack: not 100% sure, but I think it should be like that *)
-        local_retroknowledge = []}
+let end_module l restype senv =
+  let mp = senv.modpath in
+  let params, oldsenv = check_struct senv.modvariant in
+  let () = check_current_label l mp in
+  let () = check_empty_context senv in
+  let mbids = List.rev_map fst params in
+  let mb = build_module_body params restype senv in
+  let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in
+  let newenv = set_engagement_opt newenv senv.engagement in
+  let senv'=
+    propagate_loads { senv with
+      env = newenv;
+      univ = Univ.Constraint.union senv.univ mb.mod_constraints} in
+  let newenv = Environ.add_constraints mb.mod_constraints senv'.env in
+  let newenv = Modops.add_module mb newenv in
+  let newresolver =
+    if Modops.is_functor mb.mod_type then oldsenv.modresolver
+    else Mod_subst.add_delta_resolver mb.mod_delta oldsenv.modresolver
+  in
+  (mp,mbids,mb.mod_delta),
+  propagate_senv (l,SFBmodule mb) newenv newresolver senv' oldsenv
+
+let build_mtb mp sign cst delta =
+  { mod_mp = mp;
+    mod_expr = Abstract;
+    mod_type = sign;
+    mod_type_alg = None;
+    mod_constraints = cst;
+    mod_delta = delta;
+    mod_retroknowledge = [] }
 
 let end_modtype l senv =
-  let oldsenv = senv.old in
-  let modinfo = senv.modinfo in
-  let params =
-    match modinfo.variant with
-      | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end ()
-      | SIG params -> params
+  let mp = senv.modpath in
+  let params, oldsenv = check_sig senv.modvariant in
+  let () = check_current_label l mp in
+  let () = check_empty_context senv in
+  let mbids = List.rev_map fst params in
+  let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in
+  let newenv = Environ.add_constraints senv.univ newenv in
+  let newenv = set_engagement_opt newenv senv.engagement in
+  let senv' = propagate_loads {senv with env=newenv} in
+  let auto_tb = functorize params (NoFunctor (List.rev senv.revstruct)) in
+  let mtb = build_mtb mp auto_tb senv'.univ senv.modresolver in
+  let newenv = Environ.add_modtype mtb senv'.env in
+  let newresolver = oldsenv.modresolver in
+  (mp,mbids),
+  propagate_senv (l,SFBmodtype mtb) newenv newresolver senv' oldsenv
+
+(** {6 Inclusion of module or module type } *)
+
+let add_include me is_module inl senv =
+  let open Mod_typing in
+  let mp_sup = senv.modpath in
+  let sign,cst,resolver =
+    if is_module then
+      let sign,_,reso,cst = translate_mse_incl senv.env mp_sup inl me in
+      sign,cst,reso
+    else
+      let mtb = translate_modtype senv.env mp_sup inl ([],me) in
+      mtb.mod_type,mtb.mod_constraints,mtb.mod_delta
   in
-  if l <> modinfo.label then error_incompatible_labels l modinfo.label;
-  if not (empty_context senv.env) then error_non_empty_local_context None;
-  let auto_tb =
-     SEBstruct (List.rev senv.revstruct)
+  let senv = add_constraints (Now cst) senv in
+  (* Include Self support  *)
+  let rec compute_sign sign mb resolver senv =
+    match sign with
+    | MoreFunctor(mbid,mtb,str) ->
+      let cst_sub = Subtyping.check_subtypes senv.env mb mtb in
+      let senv = add_constraints (Now cst_sub) senv in
+      let mpsup_delta =
+	Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta
+      in
+      let subst = Mod_subst.map_mbid mbid mp_sup mpsup_delta in
+      let resolver = Mod_subst.subst_codom_delta_resolver subst resolver in
+      compute_sign (Modops.subst_signature subst str) mb resolver senv
+    | str -> resolver,str,senv
   in
-  let mtb_expr =
-    List.fold_left
-      (fun mtb (arg_id,arg_b) ->
-	 SEBfunctor(arg_id,arg_b,mtb))
-      auto_tb
-      params
+  let resolver,sign,senv =
+    let struc = NoFunctor (List.rev senv.revstruct) in
+    let mtb = build_mtb mp_sup struc Univ.Constraint.empty senv.modresolver in
+    compute_sign sign mtb resolver senv
   in
-  let mp = MPdot (oldsenv.modinfo.modpath, l) in
-  let newenv = oldsenv.env in
-  let newenv = Environ.add_constraints senv.univ  newenv in
-  let newenv = set_engagement_opt senv.engagement newenv in
-  let senv = {senv with env=newenv} in
-  let senv =
-    List.fold_left
-      (fun env (mp,mb) -> full_add_module mb env)
-      senv
-      (List.rev senv.loads)
+  let str = match sign with
+    | NoFunctor struc -> struc
+    | MoreFunctor _ -> Modops.error_higher_order_include ()
   in
-  let mtb = {typ_mp = mp;
-    typ_expr = mtb_expr;
-    typ_expr_alg = None;
-    typ_constraints = senv.univ;
-    typ_delta = senv.modinfo.resolver} in
-  let newenv =
-    Environ.add_modtype mp mtb senv.env
+  let senv = update_resolver (Mod_subst.add_delta_resolver resolver) senv
   in
-    mp, { old = oldsenv.old;
-	  env = newenv;
-	  modinfo = oldsenv.modinfo;
-	  modlabels = Labset.add l oldsenv.modlabels;
-	  objlabels = oldsenv.objlabels;
-	  revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
-          univ = Univ.union_constraints senv.univ oldsenv.univ;
-          engagement = senv.engagement;
-	  imports = senv.imports;
-	  loads = senv.loads@oldsenv.loads;
-          (* spiwack : if there is a bug with retroknowledge in nested modules
-             it's likely to come from here *)
-          local_retroknowledge = 
-        senv.local_retroknowledge@oldsenv.local_retroknowledge}
-
-let current_modpath senv = senv.modinfo.modpath
-let delta_of_senv senv = senv.modinfo.resolver,senv.modinfo.resolver_of_param
-
-(* Check that the engagement expected by a library matches the initial one *)
-let check_engagement env c =
-  match Environ.engagement env, c with
-    | Some ImpredicativeSet, Some ImpredicativeSet -> ()
-    | _, None -> ()
-    | _, Some ImpredicativeSet ->
-        error "Needs option -impredicative-set."
-
-let set_engagement c senv =
-  {senv with
-    env = Environ.set_engagement c senv.env;
-    engagement = Some c }
+  let add senv ((l,elem) as field) =
+    let new_name = match elem with
+      | SFBconst _ ->
+        C (Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp_sup l))
+      | SFBmind _ ->
+	I (Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp_sup l))
+      | SFBmodule _ -> M
+      | SFBmodtype _ -> MT
+    in
+    add_field field new_name senv
+  in
+  resolver, List.fold_left add senv str
 
-(* Libraries = Compiled modules *)
+(** {6 Libraries, i.e. compiled modules } *)
 
-type compiled_library =
-    dir_path * module_body * library_info list * engagement option
+type compiled_library = {
+  comp_name : DirPath.t;
+  comp_mod : module_body;
+  comp_deps : library_info array;
+  comp_enga : engagement option;
+  comp_natsymbs : Nativecode.symbol array
+}
 
-(* We check that only initial state Require's were performed before
-   [start_library] was called *)
+type native_library = Nativecode.global list
 
-let is_empty senv =
-  senv.revstruct = [] &&
-  senv.modinfo.modpath = initial_path &&
-  senv.modinfo.variant = NONE
+(** FIXME: MS: remove?*)
+let current_modpath senv = senv.modpath
+let current_dirpath senv = Names.ModPath.dp (current_modpath senv)
 
 let start_library dir senv =
-  if not (is_empty senv) then
-    anomaly "Safe_typing.start_library: environment should be empty";
-  let dir_path,l =
-    match (repr_dirpath dir) with
-	[] -> anomaly "Empty dirpath in Safe_typing.start_library"
-      | hd::tl ->
-	  make_dirpath tl, label_of_id hd
-  in
+  check_initial senv;
+  assert (not (DirPath.is_empty dir));
   let mp = MPfile dir in
-  let modinfo = {modpath = mp;
-		 label = l;
-		 variant = LIBRARY dir;
-		 resolver = empty_delta_resolver;
-		 resolver_of_param = empty_delta_resolver}
+  mp,
+  { empty_environment with
+    env = senv.env;
+    modpath = mp;
+    modvariant = LIBRARY;
+    required = senv.required }
+
+let export ?except senv dir =
+  let senv =
+    try join_safe_environment ?except senv
+    with e ->
+      let e = Errors.push e in
+      Errors.errorlabstrm "export" (Errors.iprint e)
   in
-  mp, { old = senv;
-	env = senv.env;
-	modinfo = modinfo;
-	modlabels = Labset.empty;
-	objlabels = Labset.empty;
-	revstruct = [];
-        univ = Univ.empty_constraint;
-        engagement = None;
-	imports = senv.imports;
-	loads = [];
-        local_retroknowledge = [] }
-
-let pack_module senv =
-  {mod_mp=senv.modinfo.modpath;
-   mod_expr=None;
-   mod_type= SEBstruct (List.rev senv.revstruct);
-   mod_type_alg=None;
-   mod_constraints=empty_constraint;
-   mod_delta=senv.modinfo.resolver;
-   mod_retroknowledge=[];
-  }
-
-let export senv dir =
-  let modinfo = senv.modinfo in
-  begin
-    match modinfo.variant with
-      | LIBRARY dp ->
-	  if dir <> dp then
-	    anomaly "We are not exporting the right library!"
-      | _ ->
-	  anomaly "We are not exporting the library"
-  end;
-  (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then
-    (* error_export_simple *) (); *)
-    let str = SEBstruct (List.rev senv.revstruct) in
-    let mp = senv.modinfo.modpath in
-    let mb = 
+  assert(senv.future_cst = []);
+  let () = check_current_library dir senv in
+  let mp = senv.modpath in
+  let str = NoFunctor (List.rev senv.revstruct) in
+  let mb =
     { mod_mp = mp;
-      mod_expr = Some str;
+      mod_expr = FullStruct;
       mod_type = str;
       mod_type_alg = None;
       mod_constraints = senv.univ;
-      mod_delta = senv.modinfo.resolver;
-      mod_retroknowledge = senv.local_retroknowledge}
+      mod_delta = senv.modresolver;
+      mod_retroknowledge = senv.local_retroknowledge
+    }
+  in
+  let ast, values =
+    if !Flags.no_native_compiler then [], [||]
+    else
+      Nativelibrary.dump_library mp dir senv.env str
+  in
+  let lib = {
+    comp_name = dir;
+    comp_mod = mb;
+    comp_deps = Array.of_list (DPMap.bindings senv.required);
+    comp_enga = Environ.engagement senv.env;
+    comp_natsymbs = values }
   in
-   mp, (dir,mb,senv.imports,engagement senv.env)
+  mp, lib, ast
+
+(* cst are the constraints that were computed by the vi2vo step and hence are
+ * not part of the mb.mod_constraints field (but morally should be) *)
+let import lib cst vodigest senv =
+  check_required senv.required lib.comp_deps;
+  check_engagement senv.env lib.comp_enga;
+  let mp = MPfile lib.comp_name in
+  let mb = lib.comp_mod in
+  let env = Environ.add_constraints mb.mod_constraints senv.env in
+  let env = Environ.push_context_set cst env in
+  (mp, lib.comp_natsymbs),
+  { senv with
+    env =
+      (let linkinfo =
+	 Nativecode.link_info_of_dirpath lib.comp_name
+       in
+       Modops.add_linked_module mb linkinfo env);
+    modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver;
+    required = DPMap.add lib.comp_name vodigest senv.required;
+    loads = (mp,mb)::senv.loads }
 
+(** {6 Safe typing } *)
 
-let check_imports senv needed =
-  let imports = senv.imports in
-  let check (id,stamp) =
-    try
-      let actual_stamp = List.assoc id imports in
-      if stamp <> actual_stamp then
-	error
-	  ("Inconsistent assumptions over module "^(string_of_dirpath id)^".")
-    with Not_found ->
-      error ("Reference to unknown module "^(string_of_dirpath id)^".")
-  in
-  List.iter check needed
+type judgment = Environ.unsafe_judgment
+
+let j_val j = j.Environ.uj_val
+let j_type j = j.Environ.uj_type
 
+let typing senv = Typeops.infer (env_of_senv senv)
 
+(** {6 Retroknowledge / native compiler } *)
+
+(** universal lifting, used for the "get" operations mostly *)
+let retroknowledge f senv =
+  Environ.retroknowledge f (env_of_senv senv)
+
+let register field value by_clause senv =
+  (* todo : value closed, by_clause safe, by_clause of the proper type*)
+  (* spiwack : updates the safe_env with the information that the register
+     action has to be performed (again) when the environement is imported *)
+  { senv with
+    env = Environ.register senv.env field value;
+    local_retroknowledge =
+      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
+  let open Pre_env in
+  if not (evaluable_constant kn senv.env) then
+    Errors.error "Register inline: an evaluable constant is expected";
+  let env = pre_env senv.env in
+  let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in
+  let cb = {cb with const_inline_code = true} in
+  let new_constants = Cmap_env.add kn (cb,r) env.env_globals.env_constants in
+  let new_globals = { env.env_globals with env_constants = new_constants } in
+  let env = { env with env_globals = new_globals } in
+  { senv with env = env_of_pre_env env }
+
+let add_constraints c = add_constraints (Now c)
+
+
+(* NB: The next old comment probably refers to [propagate_loads] above.
+   When a Require is done inside a module, we'll redo this require
+   at the upper level after the module is ended, and so on.
+   This is probably not a big deal anyway, since these Require's
+   inside modules should be pretty rare. Maybe someday we could
+   brutally forbid this tricky "feature"... *)
 
 (* we have an inefficiency: Since loaded files are added to the
 environment every time a module is closed, their components are
-calculated many times. Thic could be avoided in several ways:
+calculated many times. This could be avoided in several ways:
 
 1 - for each file create a dummy environment containing only this
 file's components, merge this environment with the global
@@ -731,170 +866,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 import (dp,mb,depends,engmt) digest senv =
-  check_imports senv depends;
-  check_engagement senv.env engmt;
-  let mp = MPfile dp in
-  let env = senv.env in
-  let env = Environ.add_constraints mb.mod_constraints env in
-  let env = Modops.add_module mb env in
-  mp, { senv with
-	  env = env;
-	  modinfo = 
-      {senv.modinfo with 
-	 resolver = 
-	    add_delta_resolver mb.mod_delta senv.modinfo.resolver};
-	  imports = (dp,digest)::senv.imports;
-	  loads = (mp,mb)::senv.loads }
-
-
- (* Store the body of modules' opaque constants inside a table.  
-
-    This module is used during the serialization and deserialization
-    of vo files. 
-
-    By adding an indirection to the opaque constant definitions, we
-    gain the ability not to load them. As these constant definitions
-    are usually big terms, we save a deserialization time as well as
-    some memory space. *)
-module LightenLibrary : sig
-  type table 
-  type lightened_compiled_library 
-  val save : compiled_library -> lightened_compiled_library * table
-  val load : load_proof:Flags.load_proofs -> table Lazy.t
-    -> lightened_compiled_library -> compiled_library
-end = struct
-
-  (* The table is implemented as an array of [constr_substituted].
-     Keys are hence integers. To avoid changing the [compiled_library]
-     type, we brutally encode integers into [lazy_constr]. This isn't
-     pretty, but shouldn't be dangerous since the produced structure
-     [lightened_compiled_library] is abstract and only meant for writing
-     to .vo via Marshal (which doesn't care about types).
-  *)
-  type table = constr_substituted array
-  let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr)
-  let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
-
-  (* To avoid any future misuse of the lightened library that could 
-     interpret encoded keys as real [constr_substituted], we hide 
-     these kind of values behind an abstract datatype. *)
-  type lightened_compiled_library = compiled_library
-
-  (* Map a [compiled_library] to another one by just updating 
-     the opaque term [t] to [on_opaque_const_body t]. *)
-  let traverse_library on_opaque_const_body =
-    let rec traverse_module mb =
-      match mb.mod_expr with 
-	  None -> 
-	    { mb with
-		mod_expr = None;
-		mod_type = traverse_modexpr mb.mod_type;
-	    }
-	| Some impl when impl == mb.mod_type-> 
-	    let mtb =  traverse_modexpr mb.mod_type in 
-	      { mb with
-		  mod_expr = Some mtb;
-		  mod_type = mtb;
-	      }    
-	| Some impl -> 
-	    { mb with
-		mod_expr = Option.map traverse_modexpr mb.mod_expr;
-		mod_type = traverse_modexpr mb.mod_type;
-	    }    
-    and traverse_struct struc =
-      let traverse_body (l,body) = (l,match body with
-	| SFBconst cb when is_opaque cb ->
-	  SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
-	| (SFBconst _ | SFBmind _ ) as x ->
-	  x
-	| SFBmodule m -> 
-	  SFBmodule (traverse_module m)
-	| SFBmodtype m -> 
-	  SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
-      in
-      List.map traverse_body struc
-	
-    and traverse_modexpr = function
-      | SEBfunctor (mbid,mty,mexpr) ->
-	SEBfunctor (mbid,
-		    ({mty with
-		      typ_expr = traverse_modexpr mty.typ_expr}),
-		    traverse_modexpr mexpr)
-      | SEBident mp as x -> x
-      | SEBstruct (struc) ->
-	SEBstruct  (traverse_struct struc)
-      | SEBapply (mexpr,marg,u) ->
-	SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
-      | SEBwith (seb,wdcl) ->
-	SEBwith (traverse_modexpr seb,wdcl)
-    in
-    fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) 
-
-  (* To disburden a library from opaque definitions, we simply 
-     traverse it and add an indirection between the module body 
-     and its reference to a [const_body]. *)
-  let save library = 
-    let ((insert    : constant_def -> constant_def),
-	 (get_table : unit -> table)) = 
-      (* We use an integer as a key inside the table. *)
-      let counter = ref (-1) in
-
-      (* During the traversal, the table is implemented by a list 
-	 to get constant time insertion. *)
-      let opaque_definitions = ref [] in
-      
-      ((* Insert inside the table. *) 
-	(fun def ->
-	  let opaque_definition = match def with
-	    | OpaqueDef lc -> force_lazy_constr lc
-	    | _ -> assert false
-	  in
-	  incr counter;
-	  opaque_definitions := opaque_definition :: !opaque_definitions;
-	  OpaqueDef (key_as_lazy_constr !counter)),
-
-       (* Get the final table representation. *)
-       (fun () -> Array.of_list (List.rev !opaque_definitions)))
-    in
-    let lightened_library = traverse_library insert library in
-    (lightened_library, get_table ())
-
-  (* Loading is also a traversing that decodes the embedded keys that
-     are inside the [lightened_library]. If the [load_proof] flag is
-     set, we lookup inside the table to graft the
-     [constr_substituted]. Otherwise, we set the [const_body] field
-     to [None]. 
-  *)
-  let load ~load_proof (table : table Lazy.t) lightened_library =
-    let decode_key = function
-      | Undef _ | Def _ -> assert false
-      | OpaqueDef k ->
-	  let k = key_of_lazy_constr k in
-	  let access key =
-	    try (Lazy.force table).(key)
-	    with e when Errors.noncritical e ->
-              error "Error while retrieving an opaque body"
-	  in
-	  match load_proof with
-	    | Flags.Force ->
-	      let lc = Lazy.lazy_from_val (access k) in
-	      OpaqueDef (make_lazy_constr lc)
-	    | Flags.Lazy ->
-	      let lc = lazy (access k) in
-	      OpaqueDef (make_lazy_constr lc)
-	    | Flags.Dont ->
-	      Undef None
-    in
-    traverse_library decode_key lightened_library
-
-end
-
-type judgment = unsafe_judgment
-
-let j_val j = j.uj_val
-let j_type j = j.uj_type
-
-let safe_infer senv = infer (env_of_senv senv)
-
-let typing senv = Typeops.typing (env_of_senv senv)
+let set_strategy e k l = { e with env =
+   (Environ.set_oracle e.env
+      (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) }
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index dada3001..abd5cd7a 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -1,150 +1,179 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Term
-open Declarations
-open Entries
-open Mod_subst
+
+type vodigest =
+  | Dvo_or_vi of Digest.t        (* The digest of the seg_lib part *)
+  | Dvivo of Digest.t * Digest.t (* The digest of the seg_lib + seg_univ part *)
+
+val digest_match : actual:vodigest -> required:vodigest -> bool
 
 (** {6 Safe environments } *)
 
-(** Since we are now able to type terms, we can
-  define an abstract type of safe environments, where objects are
-  typed before being added.
+(** Since we are now able to type terms, we can define an abstract type
+    of safe environments, where objects are typed before being added.
 
-  We also add [open_structure] and [close_section], [close_module] to
-  provide functionnality for sections and interactive modules
+    We also provide functionality for modules : [start_module], [end_module],
+    etc.
 *)
 
 type safe_environment
 
+val empty_environment : safe_environment
+
+val is_initial : safe_environment -> bool
+
 val env_of_safe_env : safe_environment -> Environ.env
 
-val empty_environment : safe_environment
-val is_empty : safe_environment -> bool
+(** The safe_environment state monad *)
+
+type safe_transformer0 = safe_environment -> safe_environment
+type 'a safe_transformer = safe_environment -> 'a * safe_environment
+
+
+(** {6 Stm machinery } *)
+
+val sideff_of_con : safe_environment -> constant -> Declarations.side_effect
+val sideff_of_scheme :
+  string -> safe_environment -> (inductive * constant) list ->
+    Declarations.side_effect
+
+val is_curmod_library : safe_environment -> bool
+
+(* safe_environment has functional data affected by lazy computations,
+ * thus this function returns a new safe_environment *)
+val join_safe_environment :
+  ?except:Future.UUIDSet.t -> safe_environment -> safe_environment
+
+(** {6 Enriching a safe environment } *)
+
+(** Insertion of local declarations (Local or Variables) *)
 
-(** Adding and removing local declarations (Local or Variables) *)
 val push_named_assum :
-  identifier * types -> safe_environment ->
-    Univ.constraints * safe_environment
+  (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0
 val push_named_def :
-  identifier * constr * types option -> safe_environment ->
-    Univ.constraints * safe_environment
+  Id.t * Entries.definition_entry -> safe_transformer0
+
+(** Insertion of global axioms or definitions *)
 
-(** Adding global axioms or definitions *)
 type global_declaration =
-  | ConstantEntry of constant_entry
+  | ConstantEntry of Entries.constant_entry
   | GlobalRecipe of Cooking.recipe
 
 val add_constant :
-  dir_path -> label -> global_declaration -> safe_environment ->
-      constant * safe_environment
+  DirPath.t -> Label.t -> global_declaration -> constant safe_transformer
 
 (** Adding an inductive type *)
+
 val add_mind :
-  dir_path -> label -> mutual_inductive_entry -> safe_environment ->
-    mutual_inductive * safe_environment
+  DirPath.t -> Label.t -> Entries.mutual_inductive_entry ->
+    mutual_inductive safe_transformer
 
-(** Adding a module *)
-val add_module :
-  label -> module_entry -> inline -> safe_environment
-    -> module_path * delta_resolver * safe_environment
+(** Adding a module or a module type *)
 
-(** Adding a module type *)
+val add_module :
+  Label.t -> Entries.module_entry -> Declarations.inline ->
+    (module_path * Mod_subst.delta_resolver) safe_transformer
 val add_modtype :
-  label -> module_struct_entry -> inline -> safe_environment
-    -> module_path * safe_environment
+  Label.t -> Entries.module_type_entry -> Declarations.inline ->
+    module_path safe_transformer
 
 (** Adding universe constraints *)
+
+val push_context_set :
+  Univ.universe_context_set -> safe_transformer0
+
+val push_context :
+  Univ.universe_context -> safe_transformer0
+
 val add_constraints :
-  Univ.constraints -> safe_environment -> safe_environment
+  Univ.constraints -> safe_transformer0
+
+(* (\** Generator of universes *\) *)
+(* val next_universe : int safe_transformer *)
 
-(** Settin the strongly constructive or classical logical engagement *)
-val set_engagement : engagement -> safe_environment -> safe_environment
+(** Setting the strongly constructive or classical logical engagement *)
+val set_engagement : Declarations.engagement -> safe_transformer0
 
+(** Collapsing the type hierarchy *)
+val set_type_in_type : safe_transformer0
 
 (** {6 Interactive module functions } *)
 
-val start_module :
-  label -> safe_environment -> module_path * safe_environment
+val start_module : Label.t -> module_path safe_transformer
 
-val end_module :
-  label -> (module_struct_entry * inline) option
-      -> safe_environment -> module_path * delta_resolver * safe_environment 
+val start_modtype : Label.t -> module_path safe_transformer
 
 val add_module_parameter :
-  mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment
+  MBId.t -> Entries.module_struct_entry -> Declarations.inline ->
+    Mod_subst.delta_resolver safe_transformer
+
+(** The optional result type is given without its functorial part *)
 
-val start_modtype :
-  label -> safe_environment -> module_path * safe_environment
+val end_module :
+  Label.t -> (Entries.module_struct_entry * Declarations.inline) option ->
+    (module_path * MBId.t list * Mod_subst.delta_resolver) safe_transformer
 
-val end_modtype :
-  label -> safe_environment -> module_path * safe_environment
+val end_modtype : Label.t -> (module_path * MBId.t list) safe_transformer
 
 val add_include :
-  module_struct_entry -> bool -> inline -> safe_environment ->
-   delta_resolver * safe_environment
+  Entries.module_struct_entry -> bool -> Declarations.inline ->
+   Mod_subst.delta_resolver safe_transformer
 
-val pack_module : safe_environment -> module_body
 val current_modpath : safe_environment -> module_path
-val delta_of_senv : safe_environment -> delta_resolver*delta_resolver
-  
 
-(** Loading and saving compilation units *)
+val current_dirpath : safe_environment -> dir_path
 
-(** exporting and importing modules *)
-type compiled_library
+(** {6 Libraries : loading and saving compilation units } *)
 
-val start_library : dir_path -> safe_environment
-      -> module_path * safe_environment
+type compiled_library
 
-val export : safe_environment -> dir_path
-      -> module_path * compiled_library
+type native_library = Nativecode.global list
 
-val import : compiled_library -> Digest.t -> safe_environment
-      -> module_path * safe_environment
+val start_library : DirPath.t -> module_path safe_transformer
 
-(** Remove the body of opaque constants *)
+val export :
+  ?except:Future.UUIDSet.t ->
+  safe_environment -> DirPath.t ->
+    module_path * compiled_library * native_library
 
-module LightenLibrary :
-sig
-  type table
-  type lightened_compiled_library
-  val save : compiled_library -> lightened_compiled_library * table
-  val load : load_proof:Flags.load_proofs -> table Lazy.t ->
-    lightened_compiled_library -> compiled_library
-end
+(* Constraints are non empty iff the file is a vi2vo *)
+val import : compiled_library -> Univ.universe_context_set -> vodigest ->
+  (module_path * Nativecode.symbol array) safe_transformer
 
-(** {6 Typing judgments } *)
+(** {6 Safe typing judgments } *)
 
 type judgment
 
-val j_val : judgment -> constr
-val j_type : judgment -> constr
+val j_val : judgment -> Term.constr
+val j_type : judgment -> Term.constr
 
-(** Safe typing of a term returning a typing judgment and universe
-   constraints to be added to the environment for the judgment to
-   hold. It is guaranteed that the constraints are satisfiable
- *)
-val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
+(** The safe typing of a term returns a typing judgment. *)
+val typing : safe_environment -> Term.constr -> judgment
 
-val typing : safe_environment -> constr -> judgment
+(** {6 Queries } *)
 
-(** {7 Query } *)
+val exists_objlabel : Label.t -> safe_environment -> bool
 
-val exists_objlabel : label -> safe_environment -> bool
+val delta_of_senv :
+  safe_environment -> Mod_subst.delta_resolver * Mod_subst.delta_resolver
 
-(*spiwack: safe retroknowledge functionalities *)
+(** {6 Retroknowledge / Native compiler } *)
 
 open Retroknowledge
 
 val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a
 
-val register : safe_environment -> field -> Retroknowledge.entry -> constr
-                                         -> safe_environment
+val register :
+  field -> Retroknowledge.entry -> Term.constr -> safe_transformer0
+
+val register_inline : constant -> safe_transformer0
+
+val set_strategy :
+  safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment
diff --git a/kernel/sign.ml b/kernel/sign.ml
deleted file mode 100644
index 15c5e435..00000000
--- a/kernel/sign.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Created by Jean-Christophe Filliâtre out of names.ml as part of the
-   rebuilding of Coq around a purely functional abstract type-checker,
-   Aug 1999 *)
-(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
-   Herbelin and Bruno Barras *)
-
-(* This file defines types and combinators regarding indexes-based and
-   names-based contexts *)
-
-open Names
-open Util
-open Term
-
-(*s Signatures of named hypotheses. Used for section variables and
-    goal assumptions. *)
-
-type named_context = named_declaration list
-
-let empty_named_context = []
-
-let add_named_decl d sign = d::sign
-
-let rec lookup_named id = function
-  | (id',_,_ as decl) :: _ when id=id' -> decl
-  | _ :: sign -> lookup_named id sign
-  | [] -> raise Not_found
-
-let named_context_length = List.length
-let named_context_equal = list_equal eq_named_declaration
-
-let vars_of_named_context = List.map (fun (id,_,_) -> id)
-
-let instance_from_named_context sign =
-  let rec inst_rec = function
-    | (id,None,_) :: sign -> mkVar id :: inst_rec sign
-    | _ :: sign -> inst_rec sign
-    | [] -> [] in
-  Array.of_list (inst_rec sign)
-
-let fold_named_context f l ~init = List.fold_right f l init
-let fold_named_context_reverse f ~init l = List.fold_left f init l
-
-(*s Signatures of ordered section variables *)
-type section_context = named_context
-
-let fold_rel_context f l ~init:x = List.fold_right f l x
-let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
-
-let map_context f l =
-  let map_decl (n, body_o, typ as decl) =
-    let body_o' = Option.smartmap f body_o in
-    let typ' = f typ in
-      if body_o' == body_o && typ' == typ then decl else
-	(n, body_o', typ')
-  in
-    list_smartmap map_decl l
-
-let map_rel_context = map_context
-let map_named_context = map_context
-
-let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
-let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
-
-(* Push named declarations on top of a rel context *)
-(* Bizarre. Should be avoided. *)
-let push_named_to_rel_context hyps ctxt =
-  let rec push = function
-    | (id,b,t) :: l ->
-	let s, hyps = push l in
-	let d = (Name id, Option.map (subst_vars s) b, subst_vars s t) in
-	id::s, d::hyps
-    | [] -> [],[] in
-  let s, hyps = push hyps in
-  let rec subst = function
-    | d :: l ->
-	let n, ctxt = subst l in
-	(n+1), (map_rel_declaration (substn_vars n s) d)::ctxt
-    | [] -> 1, hyps in
-  snd (subst ctxt)
diff --git a/kernel/sign.mli b/kernel/sign.mli
deleted file mode 100644
index 6014b5e9..00000000
--- a/kernel/sign.mli
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Term
-
-(** {6 Signatures of ordered named declarations } *)
-
-type named_context = named_declaration list
-type section_context = named_context
-
-val empty_named_context : named_context
-val add_named_decl : named_declaration -> named_context -> named_context
-val vars_of_named_context : named_context -> identifier list
-
-val lookup_named : identifier -> named_context -> named_declaration
-
-(** number of declarations *)
-val named_context_length : named_context -> int
-
-(** named context equality *)
-val named_context_equal : named_context -> named_context -> bool
-
-(** {6 Recurrence on [named_context]: older declarations processed first } *)
-val fold_named_context :
-  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
-
-(** newer declarations first *)
-val fold_named_context_reverse :
-  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
-
-(** {6 Section-related auxiliary functions } *)
-val instance_from_named_context : named_context -> constr array
-
-(** {6 ... } *)
-(** Signatures of ordered optionally named variables, intended to be
-   accessed by de Bruijn indices *)
-
-val push_named_to_rel_context : named_context -> rel_context -> rel_context
-
-(** {6 Recurrence on [rel_context]: older declarations processed first } *)
-val fold_rel_context :
-  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
-
-(** newer declarations first *)
-val fold_rel_context_reverse :
-  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
-
-(** {6 Map function of [rel_context] } *)
-val map_rel_context : (constr -> constr) -> rel_context -> rel_context
-
-(** {6 Map function of [named_context] } *)
-val map_named_context : (constr -> constr) -> named_context -> named_context
-
-(** {6 Map function of [rel_context] } *)
-val iter_rel_context : (constr -> unit) -> rel_context -> unit
-
-(** {6 Map function of [named_context] } *)
-val iter_named_context : (constr -> unit) -> named_context -> unit
diff --git a/kernel/sorts.ml b/kernel/sorts.ml
new file mode 100644
index 00000000..ae86d686
--- /dev/null
+++ b/kernel/sorts.ml
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Univ
+
+type contents = Pos | Null
+
+type family = InProp | InSet | InType
+
+type t =
+  | Prop of contents                      (* proposition types *)
+  | Type of universe
+
+let prop = Prop Null
+let set = Prop Pos
+let type1 = Type type1_univ
+
+let univ_of_sort = function
+  | Type u -> u
+  | Prop Pos -> Universe.type0
+  | Prop Null -> Universe.type0m
+
+let sort_of_univ u =
+  if is_type0m_univ u then Prop Null
+  else if is_type0_univ u then Prop Pos
+  else Type u
+
+let compare s1 s2 =
+  if s1 == s2 then 0 else
+  match s1, s2 with
+  | Prop c1, Prop c2 ->
+    begin match c1, c2 with
+    | Pos, Pos | Null, Null -> 0
+    | Pos, Null -> -1
+    | Null, Pos -> 1
+    end
+  | Type u1, Type u2 -> Universe.compare u1 u2
+  | Prop _, Type _ -> -1
+  | Type _, Prop _ -> 1
+
+let equal s1 s2 = Int.equal (compare s1 s2) 0
+
+let is_prop = function
+  | Prop Null -> true
+  | Type u when Universe.equal Universe.type0m u -> true
+  | _ -> false
+
+let is_set = function
+  | Prop Pos -> true
+  | Type u when Universe.equal Universe.type0 u -> true
+  | _ -> false
+
+let is_small = function
+  | Prop _ -> true
+  | Type u -> is_small_univ u
+
+let family = function
+  | Prop Null -> InProp
+  | Prop Pos -> InSet
+  | Type _ -> InType
+
+let family_equal = (==)
+
+open Hashset.Combine
+
+let hash = function
+| Prop p ->
+  let h = match p with
+  | Pos -> 0
+  | Null -> 1
+  in
+  combinesmall 1 h
+| Type u ->
+  let h = Hashtbl.hash u in (** FIXME *)
+  combinesmall 2 h
+
+module List = struct
+  let mem = List.memq
+  let intersect l l' = CList.intersect family_equal l l'
+end
+
+module Hsorts =
+  Hashcons.Make(
+    struct
+      type _t = t
+      type t = _t
+      type u = universe -> universe
+
+      let hashcons huniv = function
+        | Type u as c -> 
+	  let u' = huniv u in 
+	    if u' == u then c else Type u'
+        | s -> s
+      let equal s1 s2 = match (s1,s2) with
+        | (Prop c1, Prop c2) -> c1 == c2
+        | (Type u1, Type u2) -> u1 == u2
+        |_ -> false
+
+      let hash = Hashtbl.hash (** FIXME *)
+    end)
+
+let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ
diff --git a/kernel/sorts.mli b/kernel/sorts.mli
new file mode 100644
index 00000000..cd65b231
--- /dev/null
+++ b/kernel/sorts.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** {6 The sorts of CCI. } *)
+
+type contents = Pos | Null
+
+type family = InProp | InSet | InType
+
+type t =
+| Prop of contents       (** Prop and Set *)
+| Type of Univ.universe  (** Type *)
+
+val set  : t
+val prop : t
+val type1  : t
+
+val equal : t -> t -> bool
+val compare : t -> t -> int
+val hash : t -> int
+
+val is_set : t -> bool
+val is_prop : t -> bool
+val is_small : t -> bool
+val family : t -> family
+
+val hcons : t -> t
+
+val family_equal : family -> family -> bool
+
+module List : sig
+  val mem : family -> family list -> bool
+  val intersect : family list -> family list -> family list
+end
+
+val univ_of_sort : t -> Univ.universe
+val sort_of_univ : Univ.universe -> t
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index d17d7bb0..db155e6c 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -17,12 +17,11 @@ open Names
 open Univ
 open Term
 open Declarations
-open Environ
+open Declareops
 open Reduction
 open Inductive
 open Modops
 open Mod_subst
-open Entries
 (*i*)
 
 (* This local type is used to subtype a constant with a constructor or
@@ -41,65 +40,81 @@ type namedmodule =
    constructors *)
 
 let add_mib_nameobjects mp l mib map =
-  let ind = make_mind mp empty_dirpath l in
+  let ind = MutInd.make2 mp l in
   let add_mip_nameobjects j oib map =
     let ip = (ind,j) in
     let map =
-      array_fold_right_i
+      Array.fold_right_i
       (fun i id map ->
-        Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map)
+        Label.Map.add (Label.of_id id) (IndConstr((ip,i+1), mib)) map)
       oib.mind_consnames
       map
     in
-      Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
+      Label.Map.add (Label.of_id oib.mind_typename) (IndType (ip, mib)) map
   in
-  array_fold_right_i add_mip_nameobjects mib.mind_packets map
+  Array.fold_right_i add_mip_nameobjects mib.mind_packets map
 
 
 (* creates (namedobject/namedmodule) map for the whole signature *)
 
-type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t }
+type labmap = { objs : namedobject Label.Map.t; mods : namedmodule Label.Map.t }
 
-let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty }
+let empty_labmap = { objs = Label.Map.empty; mods = Label.Map.empty }
 
 let get_obj mp map l =
-  try Labmap.find l map.objs
+  try Label.Map.find l map.objs
   with Not_found -> error_no_such_label_sub l (string_of_mp mp)
 
 let get_mod mp map l =
-  try Labmap.find l map.mods
+  try Label.Map.find l map.mods
   with Not_found -> error_no_such_label_sub l (string_of_mp mp)
 
 let make_labmap mp list =
   let add_one (l,e) map =
    match e with
-    | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs }
+    | SFBconst cb -> { map with objs = Label.Map.add l (Constant cb) map.objs }
     | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs }
-    | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods }
-    | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods }
+    | SFBmodule mb -> { map with mods = Label.Map.add l (Module mb) map.mods }
+    | SFBmodtype mtb -> { map with mods = Label.Map.add l (Modtype mtb) map.mods }
   in
   List.fold_right add_one list empty_labmap
 
 
-let check_conv_error error why cst f env a1 a2 =
-  try
-    union_constraints cst (f env a1 a2)
-  with
-      NotConvertible -> error why
+let check_conv_error error why cst poly u f env a1 a2 =
+  try 
+    let a1 = Vars.subst_instance_constr u a1 in
+    let a2 = Vars.subst_instance_constr u a2 in
+    let cst' = f env (Environ.universes env) a1 a2 in
+      if poly then 
+	if Constraint.is_empty cst' then cst
+	else error (IncompatiblePolymorphism (env, a1, a2))
+      else Constraint.union cst cst'
+  with NotConvertible -> error why
 
 (* for now we do not allow reorderings *)
 
 let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= 
-  let kn1 = make_mind mp1 empty_dirpath l in
-  let kn2 = make_mind mp2 empty_dirpath l in
+  let kn1 = KerName.make2 mp1 l in
+  let kn2 = KerName.make2 mp2 l in
   let error why = error_signature_mismatch l spec2 why in
-  let check_conv why cst f = check_conv_error error why cst f in
+  let check_conv why cst poly u f = check_conv_error error why cst poly u f in
   let mib1 =
     match info1 with
-      | IndType ((_,0), mib) -> subst_mind subst1 mib
+      | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib
       | _ -> error (InductiveFieldExpected mib2)
   in
-  let mib2 =  subst_mind subst2 mib2 in
+  let poly = 
+    if not (mib1.mind_polymorphic == mib2.mind_polymorphic) then
+      error (PolymorphicStatusExpected mib2.mind_polymorphic)
+    else mib2.mind_polymorphic
+  in
+  let u = 
+    if poly then 
+      Errors.error ("Checking of subtyping of polymorphic" ^
+		       " inductive types not implemented")
+    else Instance.empty
+  in
+  let mib2 =  Declareops.subst_mind_body subst2 mib2 in
   let check_inductive_type cst name env t1 t2 =
 
     (* Due to sort-polymorphism in inductive types, the conclusions of
@@ -133,40 +148,44 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
 	error (NotConvertibleInductiveField name)
       | _ -> (s1, s2) in
     check_conv (NotConvertibleInductiveField name)
-      cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+      cst poly u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
   in
 
   let check_packet cst p1 p2 =
-    let check f why = if f p1 <> f p2 then error why in
-      check (fun p -> p.mind_consnames) NotSameConstructorNamesField;
-      check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField;
+    let check f test why = if not (test (f p1) (f p2)) then error why in
+      check (fun p -> p.mind_consnames) (Array.equal Id.equal) NotSameConstructorNamesField;
+      check (fun p -> p.mind_typename) Id.equal NotSameInductiveNameInBlockField;
       (* nf_lc later *)
       (* nf_arity later *)
       (* user_lc ignored *)
       (* user_arity ignored *)
-      check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
+      check (fun p -> p.mind_nrealargs) Int.equal (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
       (* kelim ignored *)
       (* listrec ignored *)
       (* finite done *)
       (* nparams done *)
       (* params_ctxt done because part of the inductive types *)
       (* Don't check the sort of the type if polymorphic *)
-      let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
-      in
+      let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in
+      let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in
+      let cst = Constraint.union cst1 (Constraint.union cst2 cst) in
+      let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in
 	cst
   in
+  let mind = mind_of_kn kn1 in
   let check_cons_types i cst p1 p2 =
-    array_fold_left3
-      (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2)
+    Array.fold_left3
+      (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst
+	poly u infer_conv env t1 t2)
       cst
       p2.mind_consnames
-      (arities_of_specif kn1 (mib1,p1))
-      (arities_of_specif kn1 (mib2,p2))
+      (arities_of_specif (mind,u) (mib1,p1))
+      (arities_of_specif (mind,u) (mib2,p2))
   in
-  let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in
-  check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x);
-  check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x);
-  assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
+  let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in
+  check (fun mib -> mib.mind_finite<>Decl_kinds.CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x);
+  check (fun mib -> mib.mind_ntypes) Int.equal (fun x -> InductiveNumbersFieldExpected x);
+  assert (List.is_empty mib1.mind_hyps && List.is_empty mib2.mind_hyps);
   assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
 
@@ -175,49 +194,50 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
   (* at the time of checking the inductive arities in check_packet. *)
   (* Notice that we don't expect the local definitions to match: only *)
   (* the inductive types and constructors types have to be convertible *)
-  check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x);
+  check (fun mib -> mib.mind_nparams) Int.equal (fun x -> InductiveParamsNumberField x);
 
   begin
-  match mind_of_delta reso2 kn2  with
-      | kn2' when kn2=kn2' -> ()
-      | kn2' -> 
-	  if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then 
-	    error NotEqualInductiveAliases
+    let kn2' = kn_of_delta reso2 kn2 in
+    if KerName.equal kn2 kn2' ||
+       MutInd.equal (mind_of_delta_kn reso1 kn1)
+                    (subst_mind subst2 (MutInd.make kn2 kn2'))
+    then ()
+    else error NotEqualInductiveAliases
   end;
   (* we check that records and their field names are preserved. *)
-  check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x);
-  if mib1.mind_record then begin
+  check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x);
+  if mib1.mind_record <> None then begin
     let rec names_prod_letin t = match kind_of_term t with
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
       | Cast(t,_,_) -> names_prod_letin t
       | _ -> []
     in
-    assert (Array.length mib1.mind_packets = 1);
-    assert (Array.length mib2.mind_packets = 1);
-    assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
-    assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
+    assert (Int.equal (Array.length mib1.mind_packets) 1);
+    assert (Int.equal (Array.length mib2.mind_packets) 1);
+    assert (Int.equal (Array.length mib1.mind_packets.(0).mind_user_lc) 1);
+    assert (Int.equal (Array.length mib2.mind_packets.(0).mind_user_lc) 1);
     check (fun mib ->
       let nparamdecls = List.length mib.mind_params_ctxt in
       let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in
-      snd (list_chop nparamdecls names))
+      snd (List.chop nparamdecls names)) (List.equal Name.equal)
       (fun x -> RecordProjectionsExpected x);
   end;
   (* we first check simple things *)
   let cst =
-    array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
+    Array.fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
   in
   (* and constructor types in the end *)
   let cst =
-    array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
+    Array.fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
   in
     cst
 
     
 let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = 
   let error why = error_signature_mismatch l spec2 why in
-  let check_conv cst f = check_conv_error error cst f in
-  let check_type cst env t1 t2 =
+  let check_conv cst poly u f = check_conv_error error cst poly u f in
+  let check_type poly u cst env t1 t2 =
 
     let err = NotConvertibleTypeField (env, t1, t2) in
 
@@ -264,18 +284,47 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
 	  t1,t2
       else
         (t1,t2) in
-    check_conv err cst conv_leq env t1 t2
+      check_conv err cst poly u infer_conv_leq env t1 t2
   in
-
   match info1 with
     | Constant cb1 ->
-      assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
-      let cb1 = subst_const_body subst1 cb1 in
-      let cb2 = subst_const_body subst2 cb2 in
-      (* Start by checking types*)
-      let typ1 = Typeops.type_of_constant_type env cb1.const_type in
-      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
-      let cst = check_type cst env typ1 typ2 in
+      let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in
+      let cb1 = Declareops.subst_const_body subst1 cb1 in
+      let cb2 = Declareops.subst_const_body subst2 cb2 in
+      (* Start by checking universes *)
+      let poly = 
+	if not (cb1.const_polymorphic == cb2.const_polymorphic) then
+	  error (PolymorphicStatusExpected cb2.const_polymorphic)
+	else cb2.const_polymorphic
+      in
+      let cst', env', u = 
+	if poly then 
+	  let ctx1 = Univ.instantiate_univ_context cb1.const_universes in
+	  let ctx2 = Univ.instantiate_univ_context cb2.const_universes in
+	  let inst1, ctx1 = Univ.UContext.dest ctx1 in
+	  let inst2, ctx2 = Univ.UContext.dest ctx2 in
+	    if not (Univ.Instance.length inst1 == Univ.Instance.length inst2) then
+	      error IncompatibleInstances
+	    else 
+	      let cstrs = Univ.enforce_eq_instances inst1 inst2 cst in
+	      let cstrs = Univ.Constraint.union cstrs ctx2 in
+		try 
+		  (* The environment with the expected universes plus equality 
+		     of the body instances with the expected instance *)
+		  let env = Environ.add_constraints cstrs env in
+		    (* Check that the given definition does not add any constraint over
+		       the expected ones, so that it can be used in place of the original. *)
+		    if Univ.check_constraints ctx1 (Environ.universes env) then
+		      cstrs, env, inst2
+		    else error (IncompatibleConstraints ctx1)
+		with Univ.UniverseInconsistency incon -> 
+		  error (IncompatibleUniverses incon)
+	else cst, env, Univ.Instance.empty
+      in
+      (* Now check types *)
+      let typ1 = Typeops.type_of_constant_type env' cb1.const_type in
+      let typ2 = Typeops.type_of_constant_type env' cb2.const_type in
+      let cst = check_type poly u cst env' typ1 typ2 in
       (* Now we check the bodies:
 	 - A transparent constant can only be implemented by a compatible
 	   transparent constant.
@@ -290,39 +339,47 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
 	    | Def lc1 ->
 	      (* NB: cb1 might have been strengthened and appear as transparent.
 		 Anyway [check_conv] will handle that afterwards. *)
-	      let c1 = Declarations.force lc1 in
-	      let c2 = Declarations.force lc2 in
-	      check_conv NotConvertibleBodyField cst conv env c1 c2))
+	      let c1 = Mod_subst.force_constr lc1 in
+	      let c2 = Mod_subst.force_constr lc2 in
+	      check_conv NotConvertibleBodyField cst poly u infer_conv env' c1 c2))
    | IndType ((kn,i),mind1) ->
-       ignore (Util.error (
+       ignore (Errors.error (
        "The kernel does not recognize yet that a parameter can be " ^
        "instantiated by an inductive type. Hint: you can rename the " ^
        "inductive type and give a definition to map the old name to the new " ^
        "name."));
-      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
-      if constant_has_body cb2 then error DefinitionFieldExpected;
-      let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
+      let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in
+      if Declareops.constant_has_body cb2 then error DefinitionFieldExpected;
+      let u1 = inductive_instance mind1 in
+      let arity1,cst1 = constrained_type_of_inductive env 
+	((mind1,mind1.mind_packets.(i)),u1) in
+      let cst2 =
+        Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in 
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+      let cst = Constraint.union cst (Constraint.union cst1 cst2) in
       let error = NotConvertibleTypeField (env, arity1, typ2) in
-       check_conv error cst conv_leq env arity1 typ2
+       check_conv error cst false Univ.Instance.empty infer_conv_leq env arity1 typ2
    | IndConstr (((kn,i),j) as cstr,mind1) ->
-      ignore (Util.error (
+      ignore (Errors.error (
        "The kernel does not recognize yet that a parameter can be " ^
        "instantiated by a constructor. Hint: you can rename the " ^
        "constructor and give a definition to map the old name to the new " ^
        "name."));
-      assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
-      if constant_has_body cb2 then error DefinitionFieldExpected;
-      let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
+      let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in
+      if Declareops.constant_has_body cb2 then error DefinitionFieldExpected;
+      let u1 = inductive_instance mind1 in
+      let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in
+      let cst2 =
+        Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
+      let cst = Constraint.union cst (Constraint.union cst1 cst2) in
       let error = NotConvertibleTypeField (env, ty1, ty2) in
-       check_conv error cst conv env ty1 ty2
+       check_conv error cst false Univ.Instance.empty infer_conv env ty1 ty2
 
 let rec check_modules cst env msb1 msb2 subst1 subst2 =
-  let mty1 = module_type_of_module None msb1 in
-  let mty2 =  module_type_of_module None msb2 in
-  let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in
-    cst
+  let mty1 = module_type_of_module msb1 in
+  let mty2 =  module_type_of_module msb2 in
+  check_modtypes cst env mty1 mty2 subst1 subst2 false
 
 and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= 
   let map1 = make_labmap mp1 sig1 in
@@ -344,67 +401,62 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
 	      | Modtype mtb -> mtb
 	      | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
 	    in
-	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
-	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
-	      check_modtypes cst env mtb1 mtb2 subst1 subst2 true
+	    let env =
+              add_module_type mtb2.mod_mp mtb2
+	        (add_module_type mtb1.mod_mp mtb1 env)
+            in
+	    check_modtypes cst env mtb1 mtb2 subst1 subst2 true
   in
     List.fold_left check_one_body cst sig2
 
-and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = 
-  if mtb1==mtb2 then cst else 
-  let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in
-  let rec check_structure cst env str1 str2 equiv subst1 subst2 = 
-	match str1,str2 with
-	  | SEBstruct (list1), 
-	    SEBstruct (list2) -> 
-	      if equiv then
-		let subst2 = 
-		  add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in
-		Univ.union_constraints 
-		  (check_signatures cst env
-		     mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
-		  mtb1.typ_delta mtb2.typ_delta) 
-		  (check_signatures cst env 
-		     mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1
-		  mtb2.typ_delta  mtb1.typ_delta)
-	      else
-		check_signatures cst env
-		  mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
-		  mtb1.typ_delta  mtb2.typ_delta
-	  | SEBfunctor (arg_id1,arg_t1,body_t1),
-	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
-	      let subst1 = 
-		(join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in
-	      let cst = check_modtypes cst env 
-		arg_t2 arg_t1 subst2 subst1
-		equiv in 
-		(* contravariant *)
-	      let env = add_module 
-		(module_body_of_type (MPbound arg_id2) arg_t2) env 
-	      in
-	      let env = match body_t1 with
-		  SEBstruct str -> 
-		    add_module {mod_mp = mtb1.typ_mp;
-				mod_expr = None;
-				mod_type = subst_struct_expr subst1 body_t1;
-				mod_type_alg= None;
-				mod_constraints=mtb1.typ_constraints;
-				mod_retroknowledge = [];
-				mod_delta = mtb1.typ_delta} env
-		| _ -> env
-	      in
-		check_structure cst env body_t1 body_t2 equiv 
-		  subst1
-		  subst2
-	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
-      in
-     if mtb1'== mtb2' then cst
-     else check_structure cst env mtb1' mtb2' equiv subst1 subst2
+and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
+  if mtb1==mtb2 || mtb1.mod_type == mtb2.mod_type then cst
+  else
+    let rec check_structure cst env str1 str2 equiv subst1 subst2 =
+      match str1,str2 with
+      |NoFunctor list1,
+       NoFunctor list2 ->
+	if equiv then
+	  let subst2 = add_mp mtb2.mod_mp mtb1.mod_mp mtb1.mod_delta subst2 in
+          let cst1 = check_signatures cst env
+	    mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2
+	    mtb1.mod_delta mtb2.mod_delta
+          in
+          let cst2 = check_signatures cst env
+	    mtb2.mod_mp list2 mtb1.mod_mp list1 subst2 subst1
+	    mtb2.mod_delta  mtb1.mod_delta
+	  in
+	  Univ.Constraint.union cst1 cst2
+	else
+	  check_signatures cst env
+	    mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2
+	    mtb1.mod_delta  mtb2.mod_delta
+      |MoreFunctor (arg_id1,arg_t1,body_t1),
+       MoreFunctor (arg_id2,arg_t2,body_t2) ->
+        let mp2 = MPbound arg_id2 in
+	let subst1 = join (map_mbid arg_id1 mp2 arg_t2.mod_delta) subst1 in
+	let cst = check_modtypes cst env arg_t2 arg_t1 subst2 subst1 equiv in
+        (* contravariant *)
+	let env = add_module_type mp2 arg_t2 env in
+	let env =
+          if Modops.is_functor body_t1 then env
+          else add_module
+            {mod_mp = mtb1.mod_mp;
+	     mod_expr = Abstract;
+	     mod_type = subst_signature subst1 body_t1;
+	     mod_type_alg = None;
+	     mod_constraints = mtb1.mod_constraints;
+	     mod_retroknowledge = [];
+	     mod_delta = mtb1.mod_delta} env
+	in
+	check_structure cst env body_t1 body_t2 equiv subst1 subst2
+      | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+    in
+    check_structure cst env mtb1.mod_type mtb2.mod_type equiv subst1 subst2
 
 let check_subtypes env sup super =
-  let env = add_module 
-		(module_body_of_type sup.typ_mp sup) env in
-  check_modtypes empty_constraint env 
-    (strengthen sup sup.typ_mp) super empty_subst
-    (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false
+  let env = add_module_type sup.mod_mp sup env in
+  check_modtypes Univ.Constraint.empty env
+    (strengthen sup sup.mod_mp) super empty_subst
+    (map_mp super.mod_mp sup.mod_mp sup.mod_delta) false
 
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index 32d108fe..443f5037 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/kernel/term.ml b/kernel/term.ml
index 38302463..7bf4c818 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -1,284 +1,201 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
-(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
-(* Extension to mutual inductive constructions by Christine Paulin for
-   Coq V5.10.2 *)
-(* Extension to co-inductive constructions by Eduardo Gimenez *)
-(* Optimization of substitution functions by Chet Murthy *)
-(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
-(* Hash-consing by Bruno Barras in Feb 1998 *)
-(* Restructuration of Coq of the type-checking kernel by Jean-Christophe 
-   Filliâtre, 1999 *)
-(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
-(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
-
-(* This file defines the internal syntax of the Calculus of
-   Inductive Constructions (CIC) terms together with constructors,
-   destructors, iterators and basic functions *)
-
 open Util
 open Pp
+open Errors
 open Names
-open Univ
-open Esubst
+open Context
+open Vars
 
+(**********************************************************************)
+(**         Redeclaration of types from module Constr                 *)
+(**********************************************************************)
 
-type existential_key = int
-type metavariable = int
+type contents = Sorts.contents = Pos | Null
 
-(* This defines the strategy to use for verifiying a Cast *)
-(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
-(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
-type cast_kind = VMcast | DEFAULTcast | REVERTcast
+type sorts = Sorts.t =
+  | Prop of contents       (** Prop and Set *)
+  | Type of Univ.universe  (** Type *)
 
-(* This defines Cases annotations *)
-type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
-type case_printing =
-  { ind_nargs : int; (* length of the arity of the inductive type *)
-    style     : case_style }
-type case_info =
-  { ci_ind        : inductive;
-    ci_npar       : int;
-    ci_cstr_ndecls : int array; (* number of pattern vars of each constructor *)
-    ci_pp_info    : case_printing (* not interpreted by the kernel *)
-  }
+type sorts_family = Sorts.family = InProp | InSet | InType
 
-(* Sorts. *)
+type constr = Constr.t
+(** Alias types, for compatibility. *)
 
-type contents = Pos | Null
+type types = Constr.t
+(** Same as [constr], for documentation purposes. *)
 
-type sorts =
-  | Prop of contents                      (* proposition types *)
-  | Type of universe
+type existential_key = Constr.existential_key
+type existential = Constr.existential
 
-let prop_sort = Prop Null
-let set_sort = Prop Pos
-let type1_sort = Type type1_univ
+type metavariable = Constr.metavariable
 
-type sorts_family = InProp | InSet | InType
+type case_style = Constr.case_style =
+  LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 
-let family_of_sort = function
-  | Prop Null -> InProp
-  | Prop Pos -> InSet
-  | Type _ -> InType
+type case_printing = Constr.case_printing =
+  { ind_tags : bool list; cstr_tags : bool list array; style : case_style }
+
+type case_info = Constr.case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_cstr_ndecls : int array;
+    ci_cstr_nargs : int array;
+    ci_pp_info    : case_printing
+  }
+
+type cast_kind = Constr.cast_kind =
+  VMcast | NATIVEcast | DEFAULTcast | REVERTcast
 
 (********************************************************************)
 (*       Constructions as implemented                               *)
 (********************************************************************)
 
-(* [constr array] is an instance matching definitional [named_context] in
-   the same order (i.e. last argument first) *)
-type 'constr pexistential = existential_key * 'constr array
+type rec_declaration = Constr.rec_declaration
+type fixpoint = Constr.fixpoint
+type cofixpoint = Constr.cofixpoint
+type 'constr pexistential = 'constr Constr.pexistential
 type ('constr, 'types) prec_declaration =
-    name array * 'types array * 'constr array
-type ('constr, 'types) pfixpoint =
-    (int array * int) * ('constr, 'types) prec_declaration
-type ('constr, 'types) pcofixpoint =
-    int * ('constr, 'types) prec_declaration
-
-(* [Var] is used for named variables and [Rel] for variables as
-   de Bruijn indices. *)
-type ('constr, 'types) kind_of_term =
+  ('constr, 'types) Constr.prec_declaration
+type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint
+type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint
+type 'a puniverses = 'a Univ.puniverses
+
+(** Simply type aliases *)
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term =
   | Rel       of int
-  | Var       of identifier
+  | Var       of Id.t
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
   | Cast      of 'constr * cast_kind * 'types
-  | Prod      of name * 'types * 'types
-  | Lambda    of name * 'types * 'constr
-  | LetIn     of name * 'constr * 'types * 'constr
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
   | App       of 'constr * 'constr array
-  | Const     of constant
-  | Ind       of inductive
-  | Construct of constructor
+  | Const     of pconstant
+  | Ind       of pinductive
+  | Construct of pconstructor
   | Case      of case_info * 'constr * 'constr * 'constr array
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
 
-(* constr is the fixpoint of the previous type. Requires option
-   -rectypes of the Caml compiler to be set *)
-type constr = (constr,constr) kind_of_term
-
-type existential = existential_key * constr array
-type rec_declaration = name array * constr array * constr array
-type fixpoint = (int array * int) * rec_declaration
-type cofixpoint = int * rec_declaration
-
-
-(*********************)
-(* Term constructors *)
-(*********************)
-
-(* Constructs a DeBrujin index with number n *)
-let rels =
-  [|Rel  1;Rel  2;Rel  3;Rel  4;Rel  5;Rel  6;Rel  7; Rel  8;
-    Rel  9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|]
-
-let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n
-
-(* Construct a type *)
-let mkProp   = Sort prop_sort
-let mkSet    = Sort set_sort
-let mkType u = Sort (Type u)
-let mkSort   = function
-  | Prop Null -> mkProp (* Easy sharing *)
-  | Prop Pos -> mkSet
-  | s -> Sort s
-
-(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) *)
-let mkCast (t1,k2,t2) =
-  match t1 with
-  | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2)
-  | _ -> Cast (t1,k2,t2)
-
-(* Constructs the product (x:t1)t2 *)
-let mkProd (x,t1,t2) = Prod (x,t1,t2)
-
-(* Constructs the abstraction [x:t1]t2 *)
-let mkLambda (x,t1,t2) = Lambda (x,t1,t2)
-
-(* Constructs [x=c_1:t]c_2 *)
-let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
-
-(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
-(* We ensure applicative terms have at least one argument and the
-   function is not itself an applicative term *)
-let mkApp (f, a) =
-  if Array.length a = 0 then f else
-    match f with
-      | App (g, cl) -> App (g, Array.append cl a)
-      | _ -> App (f, a)
-
-(* Constructs a constant *)
-let mkConst c = Const c
-
-(* Constructs an existential variable *)
-let mkEvar e = Evar e
-
-(* Constructs the ith (co)inductive type of the block named kn *)
-let mkInd m = Ind m
-
-(* Constructs the jth constructor of the ith (co)inductive type of the
-   block named kn. The array of terms correspond to the variables
-   introduced in the section *)
-let mkConstruct c = Construct c
-
-(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
-let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
-
-(* If recindxs = [|i1,...in|]
-      funnames = [|f1,...fn|]
-      typarray = [|t1,...tn|]
-      bodies   = [|b1,...bn|]
-   then
+type values = Constr.values
 
-      mkFix ((recindxs,i),(funnames,typarray,bodies))
-
-   constructs the ith function of the block
-
-    Fixpoint f1 [ctx1] : t1 := b1
-    with     f2 [ctx2] : t2 := b2
-    ...
-    with     fn [ctxn] : tn := bn.
-
-   where the lenght of the jth context is ij.
-*)
-
-let mkFix fix = Fix fix
-
-(* If funnames = [|f1,...fn|]
-      typarray = [|t1,...tn|]
-      bodies   = [|b1,...bn|]
-   then
-
-      mkCoFix (i,(funnames,typsarray,bodies))
-
-   constructs the ith function of the block
-
-    CoFixpoint f1 : t1 := b1
-    with       f2 : t2 := b2
-    ...
-    with       fn : tn := bn.
-*)
-let mkCoFix cofix= CoFix cofix
-
-(* Constructs an existential variable named "?n" *)
-let mkMeta  n =  Meta n
-
-(* Constructs a Variable named id *)
-let mkVar id = Var id
-
-
-(************************************************************************)
-(*    kind_of_term = constructions as seen by the user                 *)
-(************************************************************************)
+(**********************************************************************)
+(**         Redeclaration of functions from module Constr             *)
+(**********************************************************************)
 
-(* User view of [constr]. For [App], it is ensured there is at
-   least one argument and the function is not itself an applicative
-   term *)
+let set_sort  = Sorts.set
+let prop_sort = Sorts.prop
+let type1_sort  = Sorts.type1
+let sorts_ord = Sorts.compare
+let is_prop_sort = Sorts.is_prop
+let family_of_sort = Sorts.family
+let univ_of_sort = Sorts.univ_of_sort
+let sort_of_univ = Sorts.sort_of_univ
+
+(** {6 Term constructors. } *)
+
+let mkRel = Constr.mkRel
+let mkVar = Constr.mkVar
+let mkMeta = Constr.mkMeta
+let mkEvar = Constr.mkEvar
+let mkSort = Constr.mkSort
+let mkProp = Constr.mkProp
+let mkSet  = Constr.mkSet 
+let mkType = Constr.mkType
+let mkCast = Constr.mkCast
+let mkProd = Constr.mkProd
+let mkLambda = Constr.mkLambda
+let mkLetIn = Constr.mkLetIn
+let mkApp = Constr.mkApp
+let mkConst = Constr.mkConst
+let mkProj = Constr.mkProj
+let mkInd = Constr.mkInd
+let mkConstruct = Constr.mkConstruct
+let mkConstU = Constr.mkConstU
+let mkIndU = Constr.mkIndU
+let mkConstructU = Constr.mkConstructU
+let mkConstructUi = Constr.mkConstructUi
+let mkCase = Constr.mkCase
+let mkFix = Constr.mkFix
+let mkCoFix = Constr.mkCoFix
 
-let kind_of_term c = c
+(**********************************************************************)
+(**         Aliases of functions from module Constr                   *)
+(**********************************************************************)
 
-(* Experimental, used in Presburger contrib *)
-type ('constr, 'types) kind_of_type =
-  | SortType   of sorts
-  | CastType   of 'types * 'types
-  | ProdType   of name * 'types * 'types
-  | LetInType  of name * 'constr * 'types * 'types
-  | AtomicType of 'constr * 'constr array
+let eq_constr = Constr.equal
+let eq_constr_univs = Constr.eq_constr_univs
+let leq_constr_univs = Constr.leq_constr_univs
+let eq_constr_nounivs = Constr.eq_constr_nounivs
+
+let kind_of_term = Constr.kind
+let constr_ord = Constr.compare
+let fold_constr = Constr.fold
+let map_puniverses = Constr.map_puniverses
+let map_constr = Constr.map
+let map_constr_with_binders = Constr.map_with_binders
+let iter_constr = Constr.iter
+let iter_constr_with_binders = Constr.iter_with_binders
+let compare_constr = Constr.compare_head
+let hash_constr = Constr.hash
+let hcons_sorts = Sorts.hcons
+let hcons_constr = Constr.hcons
+let hcons_types = Constr.hcons
 
-let kind_of_type = function
-  | Sort s -> SortType s
-  | Cast (c,_,t) -> CastType (c, t)
-  | Prod (na,t,c) -> ProdType (na, t, c)
-  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
-  | App (c,l) -> AtomicType (c, l)
-  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
-    -> AtomicType (c,[||])
-  | (Lambda _ | Construct _) -> failwith "Not a type"
+(**********************************************************************)
+(**         HERE BEGINS THE INTERESTING STUFF                         *)
+(**********************************************************************)
 
 (**********************************************************************)
 (*          Non primitive term destructors                            *)
 (**********************************************************************)
 
 (* Destructor operations : partial functions
-   Raise invalid_arg "dest*" if the const has not the expected form *)
+   Raise [DestKO] if the const has not the expected form *)
+
+exception DestKO
 
 (* Destructs a DeBrujin index *)
 let destRel c = match kind_of_term c with
   | Rel n -> n
-  | _ -> invalid_arg "destRel"
+  | _ -> raise DestKO
 
 (* Destructs an existential variable *)
 let destMeta c = match kind_of_term c with
   | Meta n -> n
-  | _ -> invalid_arg "destMeta"
+  | _ -> raise DestKO
 
 let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false
-let isMetaOf mv c = match kind_of_term c with Meta mv' -> mv = mv' | _ -> false
+let isMetaOf mv c =
+  match kind_of_term c with Meta mv' -> Int.equal mv mv' | _ -> false
 
 (* Destructs a variable *)
 let destVar c = match kind_of_term c with
   | Var id -> id
-  | _ -> invalid_arg "destVar"
+  | _ -> raise DestKO
 
 (* Destructs a type *)
 let isSort c = match kind_of_term c with
-  | Sort s -> true
+  | Sort _ -> true
   | _ -> false
 
 let destSort c = match kind_of_term c with
   | Sort s -> s
-  | _ -> invalid_arg "destSort"
+  | _ -> raise DestKO
 
 let rec isprop c = match kind_of_term c with
   | Sort (Prop _) -> true
@@ -300,11 +217,9 @@ let rec is_Type c = match kind_of_term c with
   | Cast (c,_,_) -> is_Type c
   | _ -> false
 
-let is_small = function
-  | Prop _ -> true
-  | _ -> false
+let is_small = Sorts.is_small
 
-let iskind c = isprop c or is_Type c
+let iskind c = isprop c || is_Type c
 
 (* Tests if an evar *)
 let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
@@ -316,18 +231,20 @@ let isEvar_or_Meta c = match kind_of_term c with
 (* Destructs a casted term *)
 let destCast c = match kind_of_term c with
   | Cast (t1,k,t2) -> (t1,k,t2)
-  | _ -> invalid_arg "destCast"
+  | _ -> raise DestKO
 
 let isCast c = match kind_of_term c with Cast _ -> true | _ -> false
 
 
 (* Tests if a de Bruijn index *)
 let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
-let isRelN n c = match kind_of_term c with Rel n' -> n = n' | _ -> false
+let isRelN n c =
+  match kind_of_term c with Rel n' -> Int.equal n n' | _ -> false
 
 (* Tests if a variable *)
 let isVar c = match kind_of_term c with Var _ -> true | _ -> false
-let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false
+let isVarId id c =
+  match kind_of_term c with Var id' -> Id.equal id id' | _ -> false
 
 (* Tests if an inductive *)
 let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
@@ -335,28 +252,28 @@ let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
 (* Destructs the product (x:t1)t2 *)
 let destProd c = match kind_of_term c with
   | Prod (x,t1,t2) -> (x,t1,t2)
-  | _ -> invalid_arg "destProd"
+  | _ -> raise DestKO
 
 let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false
 
 (* Destructs the abstraction [x:t1]t2 *)
 let destLambda c = match kind_of_term c with
   | Lambda (x,t1,t2) -> (x,t1,t2)
-  | _ -> invalid_arg "destLambda"
+  | _ -> raise DestKO
 
 let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
 
 (* Destructs the let [x:=b:t1]t2 *)
 let destLetIn c = match kind_of_term c with
   | LetIn (x,b,t1,t2) -> (x,b,t1,t2)
-  | _ -> invalid_arg "destLetIn"
+  | _ -> raise DestKO
 
 let isLetIn c =  match kind_of_term c with LetIn _ -> true | _ -> false
 
 (* Destructs an application *)
 let destApp c = match kind_of_term c with
   | App (f,a) -> (f, a)
-  | _ -> invalid_arg "destApplication"
+  | _ -> raise DestKO
 
 let destApplication = destApp
 
@@ -365,43 +282,49 @@ let isApp c = match kind_of_term c with App _ -> true | _ -> false
 (* Destructs a constant *)
 let destConst c = match kind_of_term c with
   | Const kn -> kn
-  | _ -> invalid_arg "destConst"
+  | _ -> raise DestKO
 
 let isConst c = match kind_of_term c with Const _ -> true | _ -> false
 
 (* Destructs an existential variable *)
 let destEvar c = match kind_of_term c with
   | Evar (kn, a as r) -> r
-  | _ -> invalid_arg "destEvar"
+  | _ -> raise DestKO
 
 (* Destructs a (co)inductive type named kn *)
 let destInd c = match kind_of_term c with
   | Ind (kn, a as r) -> r
-  | _ -> invalid_arg "destInd"
+  | _ -> raise DestKO
 
 (* Destructs a constructor *)
 let destConstruct c = match kind_of_term c with
   | Construct (kn, a as r) -> r
-  | _ -> invalid_arg "dest"
+  | _ -> raise DestKO
 
 let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false
 
 (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
 let destCase c = match kind_of_term c with
   | Case (ci,p,c,v) -> (ci,p,c,v)
-  | _ -> anomaly "destCase"
+  | _ -> raise DestKO
 
 let isCase c =  match kind_of_term c with Case _ -> true | _ -> false
 
+let isProj c =  match kind_of_term c with Proj _ -> true | _ -> false
+
+let destProj c = match kind_of_term c with
+  | Proj (p, c) -> (p, c)
+  | _ -> raise DestKO
+
 let destFix c = match kind_of_term c with
   | Fix fix -> fix
-  | _ -> invalid_arg "destFix"
+  | _ -> raise DestKO
 
 let isFix c =  match kind_of_term c with Fix _ -> true | _ -> false
 
 let destCoFix c = match kind_of_term c with
   | CoFix cofix -> cofix
-  | _ -> invalid_arg "destCoFix"
+  | _ -> raise DestKO
 
 let isCoFix c =  match kind_of_term c with CoFix _ -> true | _ -> false
 
@@ -413,7 +336,7 @@ let rec strip_outer_cast c = match kind_of_term c with
   | Cast (c,_,_) -> strip_outer_cast c
   | _ -> c
 
-(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
+(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
 
 let under_outer_cast f c =  match kind_of_term c with
   | Cast (b,k,t) -> mkCast (f b, k, f t)
@@ -428,12 +351,12 @@ let rec under_casts f c = match kind_of_term c with
 (******************************************************************)
 
 (* flattens application lists throwing casts in-between *)
-let rec collapse_appl c = match kind_of_term c with
+let collapse_appl c = match kind_of_term c with
   | App (f,cl) ->
       let rec collapse_rec f cl2 =
         match kind_of_term (strip_outer_cast f) with
-	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| _ -> mkApp (f,cl2)
+        | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
+        | _ -> mkApp (f,cl2)
       in
       collapse_rec f cl
   | _ -> c
@@ -443,431 +366,15 @@ let decompose_app c =
     | App (f,cl) -> (f, Array.to_list cl)
     | _ -> (c,[])
 
-(****************************************************************************)
-(*              Functions to recur through subterms                         *)
-(****************************************************************************)
-
-(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
-   starting from [acc] and proceeding from left to right according to
-   the usual representation of the constructions; it is not recursive *)
-
-let fold_constr f acc c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> acc
-  | Cast (c,_,t) -> f (f acc c) t
-  | Prod (_,t,c) -> f (f acc t) c
-  | Lambda (_,t,c) -> f (f acc t) c
-  | LetIn (_,b,t,c) -> f (f (f acc b) t) c
-  | App (c,l) -> Array.fold_left f (f acc c) l
-  | Evar (_,l) -> Array.fold_left f acc l
-  | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
-  | Fix (_,(lna,tl,bl)) ->
-      let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
-      Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
-  | CoFix (_,(lna,tl,bl)) ->
-      let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
-      Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
-
-(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
-
-let iter_constr f c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> ()
-  | Cast (c,_,t) -> f c; f t
-  | Prod (_,t,c) -> f t; f c
-  | Lambda (_,t,c) -> f t; f c
-  | LetIn (_,b,t,c) -> f b; f t; f c
-  | App (c,l) -> f c; Array.iter f l
-  | Evar (_,l) -> Array.iter f l
-  | Case (_,p,c,bl) -> f p; f c; Array.iter f bl
-  | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
-  | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
-
-(* [iter_constr_with_binders g f n c] iters [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
-
-let iter_constr_with_binders g f n c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> ()
-  | Cast (c,_,t) -> f n c; f n t
-  | Prod (_,t,c) -> f n t; f (g n) c
-  | Lambda (_,t,c) -> f n t; f (g n) c
-  | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
-  | App (c,l) -> f n c; Array.iter (f n) l
-  | Evar (_,l) -> Array.iter (f n) l
-  | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
-  | Fix (_,(_,tl,bl)) ->
-      Array.iter (f n) tl;
-      Array.iter (f (iterate g (Array.length tl) n)) bl
-  | CoFix (_,(_,tl,bl)) ->
-      Array.iter (f n) tl;
-      Array.iter (f (iterate g (Array.length tl) n)) bl
-
-(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
-
-let map_constr f c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> c
-  | Cast (c,k,t) -> mkCast (f c, k, f t)
-  | Prod (na,t,c) -> mkProd (na, f t, f c)
-  | Lambda (na,t,c) -> mkLambda (na, f t, f c)
-  | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c)
-  | App (c,l) -> mkApp (f c, Array.map f l)
-  | Evar (e,l) -> mkEvar (e, Array.map f l)
-  | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl)
-  | Fix (ln,(lna,tl,bl)) ->
-      mkFix (ln,(lna,Array.map f tl,Array.map f bl))
-  | CoFix(ln,(lna,tl,bl)) ->
-      mkCoFix (ln,(lna,Array.map f tl,Array.map f bl))
-
-(* [map_constr_with_binders g f n c] maps [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
-
-let map_constr_with_binders g f l c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> c
-  | Cast (c,k,t) -> mkCast (f l c, k, f l t)
-  | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c)
-  | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c)
-  | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c)
-  | App (c,al) -> mkApp (f l c, Array.map (f l) al)
-  | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
-  | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
-  | Fix (ln,(lna,tl,bl)) ->
-      let l' = iterate g (Array.length tl) l in
-      mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
-  | CoFix(ln,(lna,tl,bl)) ->
-      let l' = iterate g (Array.length tl) l in
-      mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
-
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
-   the immediate subterms of [c1] of [c2] if needed; Cast's,
-   application associativity, binders name and Cases annotations are
-   not taken into account *)
-
-
-let compare_constr f t1 t2 =
-  match kind_of_term t1, kind_of_term t2 with
-  | Rel n1, Rel n2 -> n1 = n2
-  | Meta m1, Meta m2 -> m1 = m2
-  | Var id1, Var id2 -> id1 = id2
-  | Sort s1, Sort s2 -> s1 = s2
-  | Cast (c1,_,_), _ -> f c1 t2
-  | _, Cast (c2,_,_) -> f t1 c2
-  | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
-  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
-  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
-  | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
-  | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
-  | App (c1,l1), App (c2,l2) ->
-    Array.length l1 = Array.length l2 &&
-      f c1 c2 && array_for_all2 f l1 l2
-  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
-  | Const c1, Const c2 -> eq_constant c1 c2
-  | Ind c1, Ind c2 -> eq_ind c1 c2
-  | Construct c1, Construct c2 -> eq_constructor c1 c2
-  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-      f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
-  | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
-  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
-  | _ -> false
-
-(*******************************)
-(*  alpha conversion functions *)
-(*******************************)
-
-(* alpha conversion : ignore print names and casts *)
-
-let rec eq_constr m n =
-  (m==n) or
-  compare_constr eq_constr m n
-
-let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
-
-let constr_ord_int f t1 t2 =
-  let (=?) f g i1 i2 j1 j2=
-    let c=f i1 i2 in
-    if c=0 then g j1 j2 else c in
-  let (==?) fg h i1 i2 j1 j2 k1 k2=
-    let c=fg i1 i2 j1 j2 in
-    if c=0 then h k1 k2 else c in
-  match kind_of_term t1, kind_of_term t2 with
-    | Rel n1, Rel n2 -> n1 - n2
-    | Meta m1, Meta m2 -> m1 - m2
-    | Var id1, Var id2 -> id_ord id1 id2
-    | Sort s1, Sort s2 -> Pervasives.compare s1 s2
-    | Cast (c1,_,_), _ -> f c1 t2
-    | _, Cast (c2,_,_) -> f t1 c2
-    | Prod (_,t1,c1), Prod (_,t2,c2)
-    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
-	(f =? f) t1 t2 c1 c2
-    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
-	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
-    | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
-    | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
-    | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2
-    | Evar (e1,l1), Evar (e2,l2) ->
-	((-) =? (array_compare f)) e1 e2 l1 l2
-    | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2)
-    | Ind (spx, ix), Ind (spy, iy) ->
-	let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c
-    | Construct ((spx, ix), jx), Construct ((spy, iy), jy) ->
-	let c = jx - jy in if c = 0 then
-	  (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c)
-	else c
-    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-	((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2
-    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | t1, t2 -> Pervasives.compare t1 t2
-
-let rec constr_ord m n=
-  constr_ord_int constr_ord m n
-
-(***************************************************************************)
-(*     Type of assumptions                                                 *)
-(***************************************************************************)
-
-type types = constr
-
-type strategy = types option
-
-type named_declaration = identifier * constr option * types
-type rel_declaration = name * constr option * types
-
-let map_named_declaration f (id, v, ty) = (id, Option.map f v, f ty)
-let map_rel_declaration = map_named_declaration
-
-let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
-let fold_rel_declaration = fold_named_declaration
-
-let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
-let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
-
-let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
-let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
-
-let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
-  id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
-
-let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
-  n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
-
-(***************************************************************************)
-(*     Type of local contexts (telescopes)                                 *)
-(***************************************************************************)
-
-(*s Signatures of ordered optionally named variables, intended to be
-   accessed by de Bruijn indices (to represent bound variables) *)
-
-type rel_context = rel_declaration list
-
-let empty_rel_context = []
-
-let add_rel_decl d ctxt = d::ctxt
-
-let rec lookup_rel n sign =
-  match n, sign with
-  | 1, decl :: _ -> decl
-  | n, _ :: sign -> lookup_rel (n-1) sign
-  | _, []        -> raise Not_found
-
-let rel_context_length = List.length
-
-let rel_context_nhyps hyps =
-  let rec nhyps acc = function
-    | [] -> acc
-    | (_,None,_)::hyps -> nhyps (1+acc) hyps
-    | (_,Some _,_)::hyps -> nhyps acc hyps in
-  nhyps 0 hyps
+let decompose_appvect c =
+  match kind_of_term c with
+    | App (f,cl) -> (f, cl)
+    | _ -> (c,[||])
 
 (****************************************************************************)
 (*              Functions for dealing with constr terms                     *)
 (****************************************************************************)
 
-(*********************)
-(*     Occurring     *)
-(*********************)
-
-exception LocalOccur
-
-(* (closedn n M) raises FreeVar if a variable of height greater than n
-   occurs in M, returns () otherwise *)
-
-let closedn n c =
-  let rec closed_rec n c = match kind_of_term c with
-    | Rel m -> if m>n then raise LocalOccur
-    | _ -> iter_constr_with_binders succ closed_rec n c
-  in
-  try closed_rec n c; true with LocalOccur -> false
-
-(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
-
-let closed0 = closedn 0
-
-(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
-
-let noccurn n term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel m -> if m = n then raise LocalOccur
-    | _ -> iter_constr_with_binders succ occur_rec n c
-  in
-  try occur_rec n term; true with LocalOccur -> false
-
-(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M
-  for n <= p < n+m *)
-
-let noccur_between n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel(p) -> if n<=p && p<n+m then raise LocalOccur
-    | _        -> iter_constr_with_binders succ occur_rec n c
-  in
-  try occur_rec n term; true with LocalOccur -> false
-
-(* Checking function for terms containing existential variables.
- The function [noccur_with_meta] considers the fact that
- each existential variable (as well as each isevar)
- in the term appears applied to its local context,
- which may contain the CoFix variables. These occurrences of CoFix variables
- are not considered *)
-
-let noccur_with_meta n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel p -> if n<=p & p<n+m then raise LocalOccur
-    | App(f,cl) ->
-	(match kind_of_term f with
-           | Cast (c,_,_) when isMeta c -> ()
-           | Meta _ -> ()
-	   | _ -> iter_constr_with_binders succ occur_rec n c)
-    | Evar (_, _) -> ()
-    | _ -> iter_constr_with_binders succ occur_rec n c
-  in
-  try (occur_rec n term; true) with LocalOccur -> false
-
-
-(*********************)
-(*      Lifting      *)
-(*********************)
-
-(* The generic lifting function *)
-let rec exliftn el c = match kind_of_term c with
-  | Rel i -> mkRel(reloc_rel i el)
-  | _ -> map_constr_with_binders el_lift exliftn el c
-
-(* Lifting the binding depth across k bindings *)
-
-let liftn n k =
-  match el_liftn (pred k) (el_shft n el_id) with
-    | ELID -> (fun c -> c)
-    | el -> exliftn el
-
-let lift n = liftn n 1
-
-(*********************)
-(*   Substituting    *)
-(*********************)
-
-(* (subst1 M c) substitutes M for Rel(1) in c
-   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
-   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
-
-(* 1st : general case *)
-
-type info = Closed | Open | Unknown
-type 'a substituend = { mutable sinfo: info; sit: 'a }
-
-let rec lift_substituend depth s =
-  match s.sinfo with
-    | Closed -> s.sit
-    | Open -> lift depth s.sit
-    | Unknown ->
-        s.sinfo <- if closed0 s.sit then Closed else Open;
-        lift_substituend depth s
-
-let make_substituend c = { sinfo=Unknown; sit=c }
-
-let substn_many lamv n c =
-  let lv = Array.length lamv in
-  if lv = 0 then c
-  else
-    let rec substrec depth c = match kind_of_term c with
-      | Rel k     ->
-          if k<=depth then c
-          else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1)
-          else mkRel (k-lv)
-      | _ -> map_constr_with_binders succ substrec depth c in
-    substrec n c
-
-(*
-let substkey = Profile.declare_profile "substn_many";;
-let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;;
-*)
-
-let substnl laml n =
-  substn_many (Array.map make_substituend (Array.of_list laml)) n
-let substl laml = substnl laml 0
-let subst1 lam = substl [lam]
-
-let substnl_decl laml k = map_rel_declaration (substnl laml k)
-let substl_decl laml = substnl_decl laml 0
-let subst1_decl lam = substl_decl [lam]
-let substnl_named laml k = map_named_declaration (substnl laml k)
-let substl_named_decl = substl_decl
-let subst1_named_decl = subst1_decl
-
-(* (thin_val sigma) removes identity substitutions from sigma *)
-
-let rec thin_val = function
-  | [] -> []
-  | (((id,{ sit = v }) as s)::tl) when isVar v ->
-      if id = destVar v then thin_val tl else s::(thin_val tl)
-  | h::tl -> h::(thin_val tl)
-
-(* (replace_vars sigma M) applies substitution sigma to term M *)
-let replace_vars var_alist =
-  let var_alist =
-    List.map (fun (str,c) -> (str,make_substituend c)) var_alist in
-  let var_alist = thin_val var_alist in
-  let rec substrec n c = match kind_of_term c with
-    | Var x ->
-        (try lift_substituend n (List.assoc x var_alist)
-         with Not_found -> c)
-    | _ -> map_constr_with_binders succ substrec n c
-  in
-  if var_alist = [] then (function x -> x) else substrec 0
-
-(*
-let repvarkey = Profile.declare_profile "replace_vars";;
-let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;;
-*)
-
-(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
-let subst_var str = replace_vars [(str, mkRel 1)]
-
-(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *)
-let substn_vars p vars =
-  let _,subst =
-    List.fold_left (fun (n,l) var -> ((n+1),(var,mkRel n)::l)) (p,[]) vars
-  in replace_vars (List.rev subst)
-
-let subst_vars = substn_vars 1
-
 (***************************)
 (* Other term constructors *)
 (***************************)
@@ -947,7 +454,7 @@ let appvectc f l = mkApp (f,l)
 (* to_lambda n (x1:T1)...(xn:Tn)T =
  * [x1:T1]...[xn:Tn]T *)
 let rec to_lambda n prod =
-  if n = 0 then
+  if Int.equal n 0 then
     prod
   else
     match kind_of_term prod with
@@ -956,7 +463,7 @@ let rec to_lambda n prod =
       | _   -> errorlabstrm "to_lambda" (mt ())
 
 let rec to_prod n lam =
-  if n=0 then
+  if Int.equal n 0 then
     lam
   else
     match kind_of_term lam with
@@ -972,8 +479,8 @@ let prod_app t n =
   match kind_of_term (strip_outer_cast t) with
     | Prod (_,_,b) -> subst1 n b
     | _ ->
-	errorlabstrm "prod_app"
-	  (str"Needed a product, but didn't find one" ++ fnl ())
+        errorlabstrm "prod_app"
+          (str"Needed a product, but didn't find one" ++ fnl ())
 
 
 (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
@@ -1014,7 +521,7 @@ let decompose_lam =
 let decompose_prod_n n =
   if n < 0 then error "decompose_prod_n: integer parameter must be positive";
   let rec prodec_rec l n c =
-    if n=0 then l,c
+    if Int.equal n 0 then l,c
     else match kind_of_term c with
       | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)   -> prodec_rec l n c
@@ -1027,7 +534,7 @@ let decompose_prod_n n =
 let decompose_lam_n n =
   if n < 0 then error "decompose_lam_n: integer parameter must be positive";
   let rec lamdec_rec l n c =
-    if n=0 then l,c
+    if Int.equal n 0 then l,c
     else match kind_of_term c with
       | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)     -> lamdec_rec l n c
@@ -1065,7 +572,7 @@ let decompose_prod_n_assum n =
   if n < 0 then
     error "decompose_prod_n_assum: integer parameter must be positive";
   let rec prodec_rec l n c =
-    if n=0 then l,c
+    if Int.equal n 0 then l,c
     else match kind_of_term c with
     | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
@@ -1082,7 +589,7 @@ let decompose_lam_n_assum n =
   if n < 0 then
     error "decompose_lam_n_assum: integer parameter must be positive";
   let rec lamdec_rec l n c =
-    if n=0 then l,c
+    if Int.equal n 0 then l,c
     else match kind_of_term c with
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c
@@ -1138,7 +645,7 @@ let destArity =
     | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c
     | Cast (c,_,_)      -> prodec_rec l c
     | Sort s          -> l,s
-    | _               -> anomaly "destArity: not an arity"
+    | _               -> anomaly ~label:"destArity" (Pp.str "not an arity")
   in
   prodec_rec []
 
@@ -1152,262 +659,23 @@ let rec isArity c =
   | Sort _          -> true
   | _               -> false
 
-(*******************)
-(*  hash-consing   *)
-(*******************)
-
-(* Hash-consing of [constr] does not use the module [Hashcons] because
-   [Hashcons] is not efficient on deep tree-like data
-   structures. Indeed, [Hashcons] is based the (very efficient)
-   generic hash function [Hashtbl.hash], which computes the hash key
-   through a depth bounded traversal of the data structure to be
-   hashed. As a consequence, for a deep [constr] like the natural
-   number 1000 (S (S (... (S O)))), the same hash is assigned to all
-   the sub [constr]s greater than the maximal depth handled by
-   [Hashtbl.hash]. This entails a huge number of collisions in the
-   hash table and leads to cubic hash-consing in this worst-case.
-
-   In order to compute a hash key that is independent of the data
-   structure depth while being constant-time, an incremental hashing
-   function must be devised. A standard implementation creates a cache
-   of the hashing function by decorating each node of the hash-consed
-   data structure with its hash key. In that case, the hash function
-   can deduce the hash key of a toplevel data structure by a local
-   computation based on the cache held on its substructures.
-   Unfortunately, this simple implementation introduces a space
-   overhead that is damageable for the hash-consing of small [constr]s
-   (the most common case). One can think of an heterogeneous
-   distribution of caches on smartly chosen nodes, but this is forbidden
-   by the use of generic equality in Coq source code. (Indeed, this forces
-   each [constr] to have a unique canonical representation.)
-
-   Given that hash-consing proceeds inductively, we can nonetheless
-   computes the hash key incrementally during hash-consing by changing
-   a little the signature of the hash-consing function: it now returns
-   both the hash-consed term and its hash key. This simple solution is
-   implemented in the following code: it does not introduce a space
-   overhead in [constr], that's why the efficiency is unchanged for
-   small [constr]s. Besides, it does handle deep [constr]s without
-   introducing an unreasonable number of collisions in the hash table.
-   Some benchmarks make us think that this implementation of
-   hash-consing is linear in the size of the hash-consed data
-   structure for our daily use of Coq.
-*)
-
-let array_eqeq t1 t2 =
-  t1 == t2 ||
-  (Array.length t1 = Array.length t2 &&
-   let rec aux i =
-     (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1))
-   in aux 0)
-
-let equals_constr t1 t2 =
-  match t1, t2 with
-    | Rel n1, Rel n2 -> n1 == n2
-    | Meta m1, Meta m2 -> m1 == m2
-    | Var id1, Var id2 -> id1 == id2
-    | Sort s1, Sort s2 -> s1 == s2
-    | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & t1 == t2
-    | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
-    | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
-    | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
-      n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
-    | App (c1,l1), App (c2,l2) -> c1 == c2 & array_eqeq l1 l2
-    | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq l1 l2
-    | Const c1, Const c2 -> c1 == c2
-    | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
-    | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
-      sp1 == sp2 & i1 = i2 & j1 = j2
-    | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
-      ci1 == ci2 & p1 == p2 & c1 == c2 & array_eqeq bl1 bl2
-    | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
-      ln1 = ln2
-      & array_eqeq lna1 lna2
-      & array_eqeq tl1 tl2
-      & array_eqeq bl1 bl2
-    | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
-      ln1 = ln2
-      & array_eqeq lna1 lna2
-      & array_eqeq tl1 tl2
-      & array_eqeq bl1 bl2
-    | _ -> false
-
-(** Note that the following Make has the side effect of creating
-    once and for all the table we'll use for hash-consing all constr *)
-
-module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end)
-
-open Hashtbl_alt.Combine
-
-(* [hcons_term hash_consing_functions constr] computes an hash-consed
-   representation for [constr] using [hash_consing_functions] on
-   leaves. *)
-let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
-
-  (* Note : we hash-cons constr arrays *in place* *)
-
-  let rec hash_term_array t =
-    let accu = ref 0 in
-    for i = 0 to Array.length t - 1 do
-      let x, h = sh_rec t.(i) in
-      accu := combine !accu h;
-      t.(i) <- x
-    done;
-    !accu
-
-  and hash_term t =
-    match t with
-      | Var i ->
-	(Var (sh_id i), combinesmall 1 (Hashtbl.hash i))
-      | Sort s ->
-	(Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s))
-      | Cast (c, k, t) ->
-	let c, hc = sh_rec c in
-	let t, ht = sh_rec t in
-	(Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht))
-      | Prod (na,t,c) ->
-	let t, ht = sh_rec t
-	and c, hc = sh_rec c in
-	(Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc))
-      | Lambda (na,t,c) ->
-	let t, ht = sh_rec t
-	and c, hc = sh_rec c in
-	(Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc))
-      | LetIn (na,b,t,c) ->
-	let b, hb = sh_rec b in
-	let t, ht = sh_rec t in
-	let c, hc = sh_rec c in
-	(LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc))
-      | App (c,l) ->
-	let c, hc = sh_rec c in
-	let hl = hash_term_array l in
-	(App (c, l), combinesmall 7 (combine hl hc))
-      | Evar (e,l) ->
-	let hl = hash_term_array l in
-	(* since the array have been hashed in place : *)
-	(t, combinesmall 8 (combine (Hashtbl.hash e) hl))
-      | Const c ->
-	(Const (sh_con c), combinesmall 9 (Hashtbl.hash c))
-      | Ind ((kn,i) as ind) ->
-	(Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i))
-      | Construct (((kn,i),j) as c)->
-	(Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j))
-      | Case (ci,p,c,bl) ->
-	let p, hp = sh_rec p
-	and c, hc = sh_rec c in
-	let hbl = hash_term_array bl in
-	let hbl = combine (combine hc hp) hbl in
-	(Case (sh_ci ci, p, c, bl), combinesmall 11 hbl)
-      | Fix (ln,(lna,tl,bl)) ->
-	let hbl = hash_term_array  bl in
-	let htl = hash_term_array  tl in
-	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
-	(* since the three arrays have been hashed in place : *)
-	(t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl)))
-      | CoFix(ln,(lna,tl,bl)) ->
-	let hbl = hash_term_array bl in
-	let htl = hash_term_array tl in
-	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
-	(* since the three arrays have been hashed in place : *)
-	(t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl)))
-      | Meta n ->
-	(t, combinesmall 15 n)
-      | Rel n ->
-	(t, combinesmall 16 n)
-
-  and sh_rec t =
-    let (y, h) = hash_term t in
-    (* [h] must be positive. *)
-    let h = h land 0x3FFFFFFF in
-    (H.may_add_and_get h y, h)
+(** Kind of type *)
 
-  in
-  (* Make sure our statically allocated Rels (1 to 16) are considered
-     as canonical, and hence hash-consed to themselves *)
-  ignore (hash_term_array rels);
-
-  fun t -> fst (sh_rec t)
-
-(* Exported hashing fonction on constr, used mainly in plugins.
-   Appears to have slight differences from [snd (hash_term t)] above ? *)
-
-let rec hash_constr t =
-  match kind_of_term t with
-    | Var i -> combinesmall 1 (Hashtbl.hash i)
-    | Sort s -> combinesmall 2 (Hashtbl.hash s)
-    | Cast (c, _, _) -> hash_constr c
-    | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c))
-    | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c))
-    | LetIn (_, b, t, c) ->
-      combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c))
-    | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l))
-    | App (c,l) ->
-      combinesmall 7 (combine (hash_term_array l) (hash_constr c))
-    | Evar (e,l) ->
-      combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l))
-    | Const c ->
-      combinesmall 9 (Hashtbl.hash c)	(* TODO: proper hash function for constants *)
-    | Ind (kn,i) ->
-      combinesmall 9 (combine (Hashtbl.hash kn) i)
-    | Construct ((kn,i),j) ->
-      combinesmall 10 (combine3 (Hashtbl.hash kn) i j)
-    | Case (_ , p, c, bl) ->
-      combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl))
-    | Fix (ln ,(_, tl, bl)) ->
-      combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
-    | CoFix(ln, (_, tl, bl)) ->
-       combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
-    | Meta n -> combinesmall 15 n
-    | Rel n -> combinesmall 16 n
-
-and hash_term_array t =
-  Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t
-
-module Hsorts =
-  Hashcons.Make(
-    struct
-      type t = sorts
-      type u = universe -> universe
-      let hash_sub huniv = function
-          Prop c -> Prop c
-        | Type u -> Type (huniv u)
-      let equal s1 s2 =
-        match (s1,s2) with
-            (Prop c1, Prop c2) -> c1=c2
-          | (Type u1, Type u2) -> u1 == u2
-          |_ -> false
-      let hash = Hashtbl.hash
-    end)
-
-module Hcaseinfo =
-  Hashcons.Make(
-    struct
-      type t = case_info
-      type u = inductive -> inductive
-      let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind }
-      let equal ci ci' =
-	ci.ci_ind == ci'.ci_ind &&
-	ci.ci_npar = ci'.ci_npar &&
-	ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *)
-	ci.ci_pp_info = ci'.ci_pp_info  (* we use (=) on purpose *)
-      let hash = Hashtbl.hash
-    end)
-
-let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ
-let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind
-
-let hcons_constr =
-  hcons_term
-    (hcons_sorts,
-     hcons_caseinfo,
-     hcons_construct,
-     hcons_ind,
-     hcons_con,
-     hcons_name,
-     hcons_ident)
-
-let hcons_types = hcons_constr
-
-(*******)
-(* Type of abstract machine values *)
-type values
+(* Experimental, used in Presburger contrib *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of Name.t * 'types * 'types
+  | LetInType  of Name.t * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+let kind_of_type t = match kind_of_term t with
+  | Sort s -> SortType s
+  | Cast (c,_,t) -> CastType (c, t)
+  | Prod (na,t,c) -> ProdType (na, t, c)
+  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
+  | App (c,l) -> AtomicType (c, l)
+  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ 
+  | Proj _ | Case _ | Fix _ | CoFix _ | Ind _)
+    -> AtomicType (t,[||])
+  | (Lambda _ | Construct _) -> failwith "Not a type"
diff --git a/kernel/term.mli b/kernel/term.mli
index 33d3daaf..501aaf74 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -1,237 +1,101 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
+open Context
 
+(** {5 Redeclaration of types from module Constr and Sorts}
 
-(** {6 The sorts of CCI. } *)
+    This reexports constructors of inductive types defined in module [Constr],
+    for compatibility purposes. Refer to this module for further info.
 
-type contents = Pos | Null
+*)
+
+type contents = Sorts.contents = Pos | Null
 
-type sorts =
+type sorts = Sorts.t =
   | Prop of contents       (** Prop and Set *)
   | Type of Univ.universe  (** Type *)
 
-val set_sort  : sorts
-val prop_sort : sorts
-val type1_sort  : sorts
+type sorts_family = Sorts.family = InProp | InSet | InType
 
-(** {6 The sorts family of CCI. } *)
+type 'a puniverses = 'a Univ.puniverses
 
-type sorts_family = InProp | InSet | InType
+(** Simply type aliases *)
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
 
-val family_of_sort : sorts -> sorts_family
+type constr = Constr.constr
+(** Alias types, for compatibility. *)
+
+type types = Constr.types
+(** Same as [constr], for documentation purposes. *)
 
-(** {6 Useful types } *)
+type existential_key = Constr.existential_key
 
-(** {6 Existential variables } *)
-type existential_key = int
+type existential = Constr.existential
 
-(** {6 Existential variables } *)
-type metavariable = int
+type metavariable = Constr.metavariable
 
-(** {6 Case annotation } *)
-type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle 
-  | RegularStyle (** infer printing form from number of constructor *)
-type case_printing =
-  { ind_nargs : int; (** length of the arity of the inductive type *)
-    style     : case_style }
+type case_style = Constr.case_style =
+  LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 
-(** the integer is the number of real args, needed for reduction *)
-type case_info =
+type case_printing = Constr.case_printing =
+  { ind_tags : bool list; cstr_tags : bool list array; style : case_style }
+
+type case_info = Constr.case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
-    ci_cstr_ndecls : int array; (** number of real args of each constructor *)
-    ci_pp_info    : case_printing (** not interpreted by the kernel *)
+    ci_cstr_ndecls : int array;
+    ci_cstr_nargs : int array;
+    ci_pp_info    : case_printing
   }
 
-(** {6 The type of constructions } *)
-
-type constr
-
-(** [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
-   and application grouping *)
-val eq_constr : constr -> constr -> bool
-
-(** [types] is the same as [constr] but is intended to be used for
-   documentation to indicate that such or such function specifically works
-   with {e types} (i.e. terms of type a sort).
-   (Rem:plurial form since [type] is a reserved ML keyword) *)
-
-type types = constr
-
-(** {5 Functions for dealing with constr terms. }
-  The following functions are intended to simplify and to uniform the
-  manipulation of terms. Some of these functions may be overlapped with
-  previous ones. *)
-
-(** {6 Term constructors. } *)
-
-(** Constructs a DeBrujin index (DB indices begin at 1) *)
-val mkRel : int -> constr
-
-(** Constructs a Variable *)
-val mkVar : identifier -> constr
-
-(** Constructs an patvar named "?n" *)
-val mkMeta : metavariable -> constr
-
-(** Constructs an existential variable *)
-type existential = existential_key * constr array
-val mkEvar : existential -> constr
-
-(** Construct a sort *)
-val mkSort : sorts -> types
-val mkProp : types
-val mkSet  : types
-val mkType : Univ.universe -> types
-
-
-(** This defines the strategy to use for verifiying a Cast *)
-type cast_kind = VMcast | DEFAULTcast | REVERTcast
-
-(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the
-   type t{_ 2} (that means t2 is declared as the type of t1). *)
-val mkCast : constr * cast_kind * constr -> constr
-
-(** Constructs the product [(x:t1)t2] *)
-val mkProd : name * types * types -> types
-val mkNamedProd : identifier -> types -> types -> types
+type cast_kind = Constr.cast_kind =
+  VMcast | NATIVEcast | DEFAULTcast | REVERTcast
 
-(** non-dependent product [t1 -> t2], an alias for
-   [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
-   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
-*)
-val mkArrow : types -> types -> constr
-
-(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *)
-val mkLambda : name * types * constr -> constr
-val mkNamedLambda : identifier -> types -> constr -> constr
-
-(** Constructs the product [let x = t1 : t2 in t3] *)
-val mkLetIn : name * constr * types * constr -> constr
-val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
-
-(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application
-   {% $(f~t_1~\dots~t_n)$ %}. *)
-val mkApp : constr * constr array -> constr
-
-(** Constructs a constant 
-   The array of terms correspond to the variables introduced in the section *)
-val mkConst : constant -> constr
-
-(** Inductive types *)
-
-(** Constructs the ith (co)inductive type of the block named kn 
-   The array of terms correspond to the variables introduced in the section *)
-val mkInd : inductive -> constr
-
-(** Constructs the jth constructor of the ith (co)inductive type of the
-   block named kn. The array of terms correspond to the variables
-   introduced in the section *)
-val mkConstruct : constructor -> constr
-
-(** Constructs a destructor of inductive type.
-    
-    [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] 
-    presented as describe in [ci].
-
-    [p] stucture is [fun args x -> "return clause"]
-
-    [ac]{^ ith} element is ith constructor case presented as 
-    {e lambda construct_args (without params). case_term } *)
-val mkCase : case_info * constr * constr * constr array -> constr
-
-(** If [recindxs = [|i1,...in|]]
-      [funnames = [|f1,.....fn|]]
-      [typarray = [|t1,...tn|]]
-      [bodies   = [|b1,.....bn|]]
-   then [mkFix ((recindxs,i), funnames, typarray, bodies) ]
-   constructs the {% $ %}i{% $ %}th function of the block (counting from 0)
-
-    [Fixpoint f1 [ctx1] = b1
-     with     f2 [ctx2] = b2
-     ...
-     with     fn [ctxn] = bn.]
-
-   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
-*)
-type rec_declaration = name array * types array * constr array
-type fixpoint = (int array * int) * rec_declaration
-val mkFix : fixpoint -> constr
-
-(** If [funnames = [|f1,.....fn|]]
-      [typarray = [|t1,...tn|]]
-      [bodies   = [b1,.....bn]] 
-   then [mkCoFix (i, (funnames, typarray, bodies))]
-   constructs the ith function of the block
-   
-    [CoFixpoint f1 = b1
-     with       f2 = b2
-     ...
-     with       fn = bn.]
- *)
-type cofixpoint = int * rec_declaration
-val mkCoFix : cofixpoint -> constr
-
-
-(** {6 Concrete type for making pattern-matching. } *)
-
-(** [constr array] is an instance matching definitional [named_context] in
-   the same order (i.e. last argument first) *)
-type 'constr pexistential = existential_key * 'constr array
+type rec_declaration = Constr.rec_declaration
+type fixpoint = Constr.fixpoint
+type cofixpoint = Constr.cofixpoint
+type 'constr pexistential = 'constr Constr.pexistential
 type ('constr, 'types) prec_declaration =
-    name array * 'types array * 'constr array
-type ('constr, 'types) pfixpoint =
-    (int array * int) * ('constr, 'types) prec_declaration
-type ('constr, 'types) pcofixpoint =
-    int * ('constr, 'types) prec_declaration
+  ('constr, 'types) Constr.prec_declaration
+type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint
+type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint
 
-type ('constr, 'types) kind_of_term =
+type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term =
   | Rel       of int
-  | Var       of identifier
+  | Var       of Id.t
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
   | Cast      of 'constr * cast_kind * 'types
-  | Prod      of name * 'types * 'types
-  | Lambda    of name * 'types * 'constr
-  | LetIn     of name * 'constr * 'types * 'constr
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
   | App       of 'constr * 'constr array
-  | Const     of constant
-  | Ind       of inductive
-  | Construct of constructor
+  | Const     of constant puniverses
+  | Ind       of inductive puniverses
+  | Construct of constructor puniverses
   | Case      of case_info * 'constr * 'constr * 'constr array
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
 
-(** User view of [constr]. For [App], it is ensured there is at
-   least one argument and the function is not itself an applicative
-   term *)
+type values = Constr.values
 
-val kind_of_term : constr -> (constr, types) kind_of_term
-
-(** Experimental, used in Presburger contrib *)
-type ('constr, 'types) kind_of_type =
-  | SortType   of sorts
-  | CastType   of 'types * 'types
-  | ProdType   of name * 'types * 'types
-  | LetInType  of name * 'constr * 'types * 'types
-  | AtomicType of 'constr * 'constr array
-
-val kind_of_type : types -> (constr, types) kind_of_type
-
-(** {6 Simple term case analysis. } *)
+(** {5 Simple term case analysis. } *)
 
 val isRel  : constr -> bool
 val isRelN : int -> constr -> bool
 val isVar  : constr -> bool
-val isVarId : identifier -> constr -> bool
+val isVarId : Id.t -> constr -> bool
 val isInd  : constr -> bool
 val isEvar : constr -> bool
 val isMeta : constr -> bool
@@ -248,6 +112,7 @@ val isConstruct : constr -> bool
 val isFix : constr -> bool
 val isCoFix : constr -> bool
 val isCase : constr -> bool
+val isProj : constr -> bool
 
 val is_Prop : constr -> bool
 val is_Set  : constr -> bool
@@ -257,9 +122,11 @@ val iskind : constr -> bool
 val is_small : sorts -> bool
 
 
-(** {6 Term destructors } *)
+(** {5 Term destructors } *)
 (** Destructor operations are partial functions and
-    @raise Invalid_argument "dest*" if the term has not the expected form. *)
+    @raise DestKO if the term has not the expected form. *)
+
+exception DestKO
 
 (** Destructs a DeBrujin index *)
 val destRel : constr -> int
@@ -268,7 +135,7 @@ val destRel : constr -> int
 val destMeta : constr -> metavariable
 
 (** Destructs a variable *)
-val destVar : constr -> identifier
+val destVar : constr -> Id.t
 
 (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether
    [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *)
@@ -278,13 +145,13 @@ val destSort : constr -> sorts
 val destCast : constr -> constr * cast_kind * constr
 
 (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *)
-val destProd : types -> name * types * types
+val destProd : types -> Name.t * types * types
 
 (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *)
-val destLambda : constr -> name * types * constr
+val destLambda : constr -> Name.t * types * constr
 
 (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *)
-val destLetIn : constr -> name * constr * types * constr
+val destLetIn : constr -> Name.t * constr * types * constr
 
 (** Destructs an application *)
 val destApp : constr -> constr * constr array
@@ -295,17 +162,20 @@ val destApplication : constr -> constr * constr array
 (** Decompose any term as an applicative term; the list of args can be empty *)
 val decompose_app : constr -> constr * constr list
 
+(** Same as [decompose_app], but returns an array. *)
+val decompose_appvect : constr -> constr * constr array
+
 (** Destructs a constant *)
-val destConst : constr -> constant
+val destConst : constr -> constant puniverses
 
 (** Destructs an existential variable *)
 val destEvar : constr -> existential
 
 (** Destructs a (co)inductive type *)
-val destInd : constr -> inductive
+val destInd : constr -> inductive puniverses
 
 (** Destructs a constructor *)
-val destConstruct : constr -> constructor
+val destConstruct : constr -> constructor puniverses
 
 (** Destructs a [match c as x in I args return P with ... |
 Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args
@@ -314,6 +184,9 @@ return P in t1], or [if c then t1 else t2])
 where [info] is pretty-printing information *)
 val destCase : constr -> case_info * constr * constr * constr array
 
+(** Destructs a projection *)
+val destProj : constr -> projection * constr
+
 (** Destructs the {% $ %}i{% $ %}th function of the block
    [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1}
     with    f{_ 2} ctx{_ 2} = b{_ 2}
@@ -326,54 +199,18 @@ val destFix : constr -> fixpoint
 val destCoFix : constr -> cofixpoint
 
 
-(** {6 Local } *)
-(** A {e declaration} has the form [(name,body,type)]. It is either an
-    {e assumption} if [body=None] or a {e definition} if
-    [body=Some actualbody]. It is referred by {e name} if [na] is an
-    identifier or by {e relative index} if [na] is not an identifier
-    (in the latter case, [na] is of type [name] but just for printing
-    purpose) *)
-
-type named_declaration = identifier * constr option * types
-type rel_declaration = name * constr option * types
-
-val map_named_declaration :
-  (constr -> constr) -> named_declaration -> named_declaration
-val map_rel_declaration :
-  (constr -> constr) -> rel_declaration -> rel_declaration
-
-val fold_named_declaration :
-  (constr -> 'a -> 'a) -> named_declaration -> 'a -> 'a
-val fold_rel_declaration :
-  (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
-
-val exists_named_declaration :
-  (constr -> bool) -> named_declaration -> bool
-val exists_rel_declaration :
-  (constr -> bool) -> rel_declaration -> bool
-
-val for_all_named_declaration :
-  (constr -> bool) -> named_declaration -> bool
-val for_all_rel_declaration :
-  (constr -> bool) -> rel_declaration -> bool
+(** {5 Derived constructors} *)
 
-val eq_named_declaration :
-  named_declaration -> named_declaration -> bool
-
-val eq_rel_declaration :
-    rel_declaration -> rel_declaration -> bool
-
-(** {6 Contexts of declarations referred to by de Bruijn indices } *)
-
-(** In [rel_context], more recent declaration is on top *)
-type rel_context = rel_declaration list
-
-val empty_rel_context : rel_context
-val add_rel_decl : rel_declaration -> rel_context -> rel_context
+(** non-dependent product [t1 -> t2], an alias for
+   [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
+   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
+*)
+val mkArrow : types -> types -> constr
 
-val lookup_rel : int -> rel_context -> rel_declaration
-val rel_context_length : rel_context -> int
-val rel_context_nhyps : rel_context -> int
+(** 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
 
 (** Constructs either [(x:t)c] or [[x=b:t]c] *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
@@ -385,7 +222,7 @@ val mkNamedProd_wo_LetIn : named_declaration -> types -> types
 val mkLambda_or_LetIn : rel_declaration -> constr -> constr
 val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
 
-(** {6 Other term constructors. } *)
+(** {5 Other term constructors. } *)
 
 (** [applist (f,args)] and its variants work as [mkApp] *)
 
@@ -396,24 +233,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 * constr) list -> constr -> constr
+val prodn : int -> (Name.t * 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 * constr) list -> constr -> constr
+val compose_prod : (Name.t * 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 * constr) list -> constr -> constr
+val lamn : int -> (Name.t * 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 * constr) list -> constr -> constr
+val compose_lam : (Name.t * constr) list -> constr -> constr
 
 (** [to_lambda n l]
    @return [fun (x_1:T_1)...(x_n:T_n) => T]
@@ -434,24 +271,24 @@ val prod_applist : constr -> constr list -> constr
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
 val it_mkProd_or_LetIn : types -> rel_context -> types
 
-(** {6 Other term destructors. } *)
+(** {5 Other term destructors. } *)
 
 (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair
    {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *)
-val decompose_prod : constr -> (name*constr) list * constr
+val decompose_prod : constr -> (Name.t*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*constr) list * constr
+val decompose_lam : constr -> (Name.t*constr) list * constr
 
 (** Given a positive integer n, transforms a product term
    {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %}
    into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *)
-val decompose_prod_n : int -> constr -> (name * constr) list * constr
+val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr
 
 (** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term
    {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *)
-val decompose_lam_n : int -> constr -> (name * constr) list * constr
+val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr
 
 (** Extract the premisses and the conclusion of a term of the form
    "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *)
@@ -505,7 +342,7 @@ val under_casts : (constr -> constr) -> constr -> constr
 (** Apply a function under components of Cast if any *)
 val under_outer_cast : (constr -> constr) -> constr -> constr
 
-(** {6 ... } *)
+(** {5 ... } *)
 (** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
     Such a term can canonically be seen as the pair of a context of types
     and of a sort *)
@@ -521,117 +358,125 @@ val destArity : types -> arity
 (** Tells if a term has the form of an arity *)
 val isArity : types -> bool
 
-(** {6 Occur checks } *)
+(** {5 Kind of type} *)
+
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of Name.t * 'types * 'types
+  | LetInType  of Name.t * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+val kind_of_type : types -> (constr, types) kind_of_type
 
-(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
-val closedn : int -> constr -> bool
+(** {5 Redeclaration of stuff from module [Sorts]} *)
 
-(** [closed0 M] is true iff [M] is a (deBruijn) closed term *)
-val closed0 : constr -> bool
+val set_sort  : sorts
+(** Alias for Sorts.set *)
 
-(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
-val noccurn : int -> constr -> bool
+val prop_sort : sorts
+(** Alias for Sorts.prop *)
 
-(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
-  for n <= p < n+m *)
-val noccur_between : int -> int -> constr -> bool
+val type1_sort  : sorts
+(** Alias for Sorts.type1 *)
 
-(** Checking function for terms containing existential- or
-   meta-variables.  The function [noccur_with_meta] does not consider
-   meta-variables applied to some terms (intended to be its local
-   context) (for existential variables, it is necessarily the case) *)
-val noccur_with_meta : int -> int -> constr -> bool
+val sorts_ord : sorts -> sorts -> int
+(** Alias for Sorts.compare *)
 
-(** {6 Relocation and substitution } *)
+val is_prop_sort : sorts -> bool
+(** Alias for Sorts.is_prop *)
 
-(** [exliftn el c] lifts [c] with lifting [el] *)
-val exliftn : Esubst.lift -> constr -> constr
+val family_of_sort : sorts -> sorts_family
+(** Alias for Sorts.family *)
 
-(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
-val liftn : int -> int -> constr -> constr
+(** {5 Redeclaration of stuff from module [Constr]}
 
-(** [lift n c] lifts by [n] the positive indexes in [c] *)
-val lift : int -> constr -> constr
+    See module [Constr] for further info. *)
 
-(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
-    for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
-    accordingly indexes in [a1],...,[an] *)
-val substnl : constr list -> int -> constr -> constr
-val substl : constr list -> constr -> constr
-val subst1 : constr -> constr -> constr
+(** {6 Term constructors. } *)
 
-val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration
-val substl_decl : constr list -> rel_declaration -> rel_declaration
-val subst1_decl : constr -> rel_declaration -> rel_declaration
+val mkRel : int -> constr
+val mkVar : Id.t -> constr
+val mkMeta : metavariable -> constr
+val mkEvar : existential -> constr
+val mkSort : sorts -> types
+val mkProp : types
+val mkSet  : types
+val mkType : Univ.universe -> types
+val mkCast : constr * cast_kind * constr -> constr
+val mkProd : Name.t * types * types -> types
+val mkLambda : Name.t * types * constr -> constr
+val mkLetIn : Name.t * constr * types * constr -> constr
+val mkApp : constr * constr array -> constr
+val mkConst : constant -> constr
+val mkProj : projection * constr -> constr
+val mkInd : inductive -> constr
+val mkConstruct : constructor -> constr
+val mkConstU : constant puniverses -> constr
+val mkIndU : inductive puniverses -> constr
+val mkConstructU : constructor puniverses -> constr
+val mkConstructUi : (pinductive * int) -> constr
+val mkCase : case_info * constr * constr * constr array -> constr
+val mkFix : fixpoint -> constr
+val mkCoFix : cofixpoint -> constr
 
-val subst1_named_decl : constr -> named_declaration -> named_declaration
-val substl_named_decl : constr list -> named_declaration -> named_declaration
+(** {6 Aliases} *)
 
-val replace_vars : (identifier * constr) list -> constr -> constr
-val subst_var : identifier -> constr -> constr
+val eq_constr : constr -> constr -> bool
+(** Alias for [Constr.equal] *)
 
-(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
-   if two names are identical, the one of least indice is kept *)
-val subst_vars : identifier list -> constr -> constr
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe constraints in [u]. *)
+val eq_constr_univs : constr Univ.check_function
 
-(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
-   if two names are identical, the one of least indice is kept *)
-val substn_vars : int -> identifier list -> constr -> constr
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe constraints in [u]. *)
+val leq_constr_univs : constr Univ.check_function
 
+(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping and ignoring universe instances. *)
+val eq_constr_nounivs : constr -> constr -> bool
 
-(** {6 Functionals working on the immediate subterm of a construction } *)
+val kind_of_term : constr -> (constr, types) kind_of_term
+(** Alias for [Constr.kind] *)
 
-(** [fold_constr f acc c] folds [f] on the immediate subterms of [c]
-   starting from [acc] and proceeding from left to right according to
-   the usual representation of the constructions; it is not recursive *)
+val constr_ord : constr -> constr -> int
+(** Alias for [Constr.compare] *)
 
 val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
-
-(** [map_constr f c] maps [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
+(** Alias for [Constr.fold] *)
 
 val map_constr : (constr -> constr) -> constr -> constr
-
-(** [map_constr_with_binders g f n c] maps [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
+(** Alias for [Constr.map] *)
 
 val map_constr_with_binders :
   ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
+(** Alias for [Constr.map_with_binders] *)
 
-(** [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
+val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses
+val univ_of_sort : sorts -> Univ.universe
+val sort_of_univ : Univ.universe -> sorts
 
 val iter_constr : (constr -> unit) -> constr -> unit
-
-(** [iter_constr_with_binders g f n c] iters [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
+(** Alias for [Constr.iter] *)
 
 val iter_constr_with_binders :
   ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
-
-(** [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
-   the immediate subterms of [c1] of [c2] if needed; Cast's, binders
-   name and Cases annotations are not taken into account *)
+(** Alias for [Constr.iter_with_binders] *)
 
 val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
+(** Alias for [Constr.compare_head] *)
 
-val constr_ord : constr -> constr -> int
 val hash_constr : constr -> int
+(** Alias for [Constr.hash] *)
 
 (*********************************************************************)
 
 val hcons_sorts : sorts -> sorts
-val hcons_constr : constr -> constr
-val hcons_types : types -> types
+(** Alias for [Constr.hashcons_sorts] *)
 
-(**************************************)
+val hcons_constr : constr -> constr
+(** Alias for [Constr.hashcons] *)
 
-type values
+val hcons_types : types -> types
+(** Alias for [Constr.hashcons] *)
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 8932ce5e..a3441aa3 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,147 +12,286 @@
 (* This module provides the main entry points for type-checking basic
    declarations *)
 
+open Errors
 open Util
 open Names
 open Univ
 open Term
-open Reduction
-open Sign
+open Context
 open Declarations
-open Inductive
 open Environ
 open Entries
-open Type_errors
-open Indtypes
 open Typeops
+open Fast_typeops
 
-let constrain_type env j cst1 = function
-  | None ->
-      make_polymorphic_if_constant_for_ind env j, cst1
-  | Some t ->
-      let (tj,cst2) = infer_type env t in
-      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
+let constrain_type env j poly subst = function
+  | `None -> 
+    if not poly then (* Old-style polymorphism *)
+      make_polymorphic_if_constant_for_ind env j
+    else RegularArity (Vars.subst_univs_level_constr subst j.uj_type)
+  | `Some t ->
+      let tj = infer_type env t in
+      let _ = judge_of_cast env j DEFAULTcast tj in
 	assert (eq_constr t tj.utj_val);
-	let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in
-	  NonPolymorphicType t, cstrs
-
-let local_constrain_type env j cst1 = function
-  | None ->
-      j.uj_type, cst1
-  | Some t ->
-      let (tj,cst2) = infer_type env t in
-      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
-      assert (eq_constr t tj.utj_val);
-      t, union_constraints (union_constraints cst1 cst2) cst3
-
-let translate_local_def env (b,topt) =
-  let (j,cst) = infer env b in
-  let (typ,cst) = local_constrain_type env j cst topt in
-    (j.uj_val,typ,cst)
+	RegularArity (Vars.subst_univs_level_constr subst t)
+  | `SomeWJ (t, tj) ->
+      let tj = infer_type env t in
+      let _ = judge_of_cast env j DEFAULTcast tj in
+	assert (eq_constr t tj.utj_val);
+	RegularArity (Vars.subst_univs_level_constr subst t)
 
-let translate_local_assum env t =
-  let (j,cst) = infer env t in
-  let t = Typeops.assumption_of_judgment env j in
-    (t,cst)
-
-(*
-
-(* Same as push_named, but check that the variable is not already
-   there. Should *not* be done in Environ because tactics add temporary
-   hypothesis many many times, and the check performed here would
-   cost too much. *)
-let safe_push_named (id,_,_ as d) env =
-  let _ =
-    try
-      let _ = lookup_named id env in
-      error ("Identifier "^string_of_id id^" already defined.")
-    with Not_found -> () in
-  push_named d env
-
-let push_named_def = push_rel_or_named_def safe_push_named
-let push_rel_def = push_rel_or_named_def push_rel
-
-let push_rel_or_named_assum push (id,t) env =
-  let (j,cst) = safe_infer env t in
-  let t = Typeops.assumption_of_judgment env j in
-  let env' = add_constraints cst env in
-  let env'' = push (id,None,t) env' in
-  (cst,env'')
+let map_option_typ = function None -> `None | Some x -> `Some x
+
+(* Insertion of constants and parameters in environment. *)
 
-let push_named_assum = push_rel_or_named_assum push_named
-let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env)
+let mk_pure_proof c = (c, Univ.ContextSet.empty), Declareops.no_seff
 
-let push_rels_with_univ vars env =
-  List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars
-*)
+let handle_side_effects env body side_eff =
+  let handle_sideff t se =
+    let cbl = match se with
+      | SEsubproof (c,cb,b) -> [c,cb,b]
+      | SEscheme (cl,_) -> List.map (fun (_,c,cb,b) -> c,cb,b) cl 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
+    let cname c = 
+      let name = string_of_con c in
+      for i = 0 to String.length name - 1 do
+        if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done;
+      Name (id_of_string name) in
+    let rec sub c i x = match kind_of_term x with
+      | Const (c', _) when eq_constant c c' -> mkRel i
+      | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub c i x) i x in
+    let rec sub_body c u b i x = match kind_of_term x with
+      | Const (c',u') when eq_constant c c' -> 
+	Vars.subst_instance_constr u' b
+      | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub_body c u b i x) i x in
+    let fix_body (c,cb,b) t =
+      match cb.const_body, b with
+      | Def b, _ ->
+          let b = Mod_subst.force_constr b in
+	  let poly = cb.const_polymorphic in
+	    if not poly then
+              let b_ty = Typeops.type_of_constant_type env cb.const_type in
+              let t = sub c 1 (Vars.lift 1 t) in
+		mkLetIn (cname c, b, b_ty, t)
+	    else 
+	      let univs = cb.const_universes in
+		sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t)
+      | OpaqueDef _, `Opaque (b,_) -> 
+	  let poly = cb.const_polymorphic in
+	    if not poly then
+              let b_ty = Typeops.type_of_constant_type env cb.const_type in
+              let t = sub c 1 (Vars.lift 1 t) in
+		mkApp (mkLambda (cname c, b_ty, t), [|b|]) 
+	    else
+	      let univs = cb.const_universes in
+		sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t)
+      | _ -> assert false
+    in
+      List.fold_right fix_body cbl t
+  in
+  (* CAVEAT: we assure a proper order *)
+  Declareops.fold_side_effects handle_sideff body
+    (Declareops.uniquize_side_effects side_eff)
 
+let hcons_j j =
+  { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} 
 
-(* Insertion of constants and parameters in environment. *)
+let feedback_completion_typecheck =
+  Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete)
+  
+let subst_instance_j s j =
+  { uj_val = Vars.subst_univs_level_constr s j.uj_val;
+    uj_type = Vars.subst_univs_level_constr s j.uj_type }
 
-let infer_declaration env dcl =
+let infer_declaration env kn dcl =
   match dcl with
+  | ParameterEntry (ctx,poly,(t,uctx),nl) ->
+      let env = push_context uctx env in
+      let j = infer env t in
+      let abstract = poly && not (Option.is_empty kn) in
+      let usubst, univs = Univ.abstract_universes abstract uctx in
+      let c = Typeops.assumption_of_judgment env j in
+      let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in
+	Undef nl, RegularArity t, None, poly, univs, false, ctx
+
+  | DefinitionEntry ({ const_entry_type = Some typ;
+                       const_entry_opaque = true;
+		       const_entry_polymorphic = false} as c) ->
+      let env = push_context c.const_entry_universes env in
+      let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
+      let tyj = infer_type env typ in
+      let proofterm =
+        Future.chain ~greedy:true ~pure:true body (fun ((body, ctx),side_eff) ->
+          let body = handle_side_effects env body side_eff in
+	  let env' = push_context_set ctx env in
+          let j = infer env' body in
+          let j = hcons_j j in
+	  let subst = Univ.LMap.empty in
+          let _typ = constrain_type env' j c.const_entry_polymorphic subst
+	    (`SomeWJ (typ,tyj)) in
+          feedback_completion_typecheck feedback_id;
+          j.uj_val, ctx) in
+      let def = OpaqueDef (Opaqueproof.create proofterm) in
+      def, RegularArity typ, None, c.const_entry_polymorphic, 
+	c.const_entry_universes,
+	c.const_entry_inline_code, c.const_entry_secctx
+
   | DefinitionEntry c ->
-      let (j,cst) = infer env c.const_entry_body in
-      let j =
-        {uj_val = hcons_constr j.uj_val;
-         uj_type = hcons_constr j.uj_type} in
-      let (typ,cst) = constrain_type env j cst c.const_entry_type in
-      let def =
-	if c.const_entry_opaque
-	then OpaqueDef (Declarations.opaque_from_val j.uj_val)
-	else Def (Declarations.from_val j.uj_val)
+      let env = push_context c.const_entry_universes env in
+      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
+      assert(Univ.ContextSet.is_empty ctx);
+      let body = handle_side_effects env body side_eff in
+      let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in
+      let usubst, univs = Univ.abstract_universes abstract c.const_entry_universes in
+      let j = infer env body in
+      let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in
+      let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in
+      let def = 
+	if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty)))
+	else Def (Mod_subst.from_val def) 
       in
-      def, typ, cst, c.const_entry_secctx
-  | ParameterEntry (ctx,t,nl) ->
-      let (j,cst) = infer env t in
-      let t = hcons_constr (Typeops.assumption_of_judgment env j) in
-      Undef nl, NonPolymorphicType t, cst, ctx
+	feedback_completion_typecheck feedback_id;
+	def, typ, None, c.const_entry_polymorphic,
+        univs, c.const_entry_inline_code, c.const_entry_secctx
+
+  | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} ->
+    let mib, _ = Inductive.lookup_mind_specif env (ind,0) in
+    let kn, pb = 
+      match mib.mind_record with
+      | Some (Some (id, kns, pbs)) -> 
+	if i < Array.length pbs then
+	  kns.(i), pbs.(i)
+	else assert false
+      | _ -> assert false
+    in
+    let term, typ = pb.proj_eta in
+      Def (Mod_subst.from_val (hcons_constr term)), RegularArity typ, Some pb,
+      mib.mind_polymorphic, mib.mind_universes, false, None
 
 let global_vars_set_constant_type env = function
-  | NonPolymorphicType t -> global_vars_set env t
-  | PolymorphicArity (ctx,_) ->
-      Sign.fold_rel_context
+  | RegularArity t -> global_vars_set env t
+  | TemplateArity (ctx,_) ->
+      Context.fold_rel_context
         (fold_rel_declaration
-	  (fun t c -> Idset.union (global_vars_set env t) c))
-      ctx ~init:Idset.empty
-
-let build_constant_declaration env kn (def,typ,cst,ctx) =
-  let hyps = 
-    let inferred =
-      let ids_typ = global_vars_set_constant_type env typ in
-      let ids_def = match def with
-      | Undef _ -> Idset.empty
-      | Def cs -> global_vars_set env (Declarations.force cs)
-      | OpaqueDef lc -> 
-          global_vars_set env (Declarations.force_opaque lc) in
-      keep_hyps env (Idset.union ids_typ ids_def) in
-    let declared = match ctx with
-      | None -> inferred 
-      | Some declared -> declared in
-    let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in
+	  (fun t c -> Id.Set.union (global_vars_set env t) c))
+      ctx ~init:Id.Set.empty
+
+let record_aux env s1 s2 =
+  let v =
+    String.concat " "
+      (List.map (fun (id, _,_) -> Id.to_string id)
+        (keep_hyps env (Id.Set.union s1 s2))) in
+  Aux_file.record_in_aux "context_used" v
+
+let suggest_proof_using = ref (fun _ _ _ _ _ -> ())
+let set_suggest_proof_using f = suggest_proof_using := f
+
+let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) =
+  let check declared inferred =
+    let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in
     let inferred_set, declared_set = mk_set inferred, mk_set declared in
-    if not (Idset.subset inferred_set declared_set) then
-      error ("The following section variable are used but not declared:\n"^
-        (String.concat ", " (List.map string_of_id
-          (Idset.elements (Idset.diff inferred_set declared_set)))));
-    declared in
-  let tps = Cemitcodes.from_val (compile_constant_body env def) in
+    if not (Id.Set.subset inferred_set declared_set) then
+      let l = Id.Set.elements (Idset.diff inferred_set declared_set) in
+      let n = List.length l in
+      errorlabstrm "" (Pp.(str "The following section " ++
+        str (String.plural n "variable") ++
+        str " " ++ str (String.conjugate_verb_to_be n) ++
+        str " used but not declared:" ++
+        fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in
+  (* We try to postpone the computation of used section variables *)
+  let hyps, def =
+    let context_ids = List.map pi1 (named_context env) in
+    match ctx with
+    | None when not (List.is_empty context_ids) -> 
+        (* No declared section vars, and non-empty section context:
+           we must look at the body NOW, if any *)
+        let ids_typ = global_vars_set_constant_type env typ in
+        let ids_def = match def with
+        | Undef _ -> Idset.empty
+        | Def cs -> global_vars_set env (Mod_subst.force_constr cs)
+        | OpaqueDef lc ->
+            let vars =
+              global_vars_set env
+                (Opaqueproof.force_proof (opaque_tables env) lc) in
+            (* we force so that cst are added to the env immediately after *)
+            ignore(Opaqueproof.force_constraints (opaque_tables env) lc);
+            !suggest_proof_using kn env vars ids_typ context_ids;
+            if !Flags.compilation_mode = Flags.BuildVo then
+              record_aux env ids_typ vars;
+            vars
+        in
+        keep_hyps env (Idset.union ids_typ ids_def), def
+    | None ->
+        if !Flags.compilation_mode = Flags.BuildVo then
+          record_aux env Id.Set.empty Id.Set.empty;
+        [], def (* Empty section context: no need to check *)
+    | Some declared ->
+        (* We use the declared set and chain a check of correctness *)
+        declared,
+        match def with
+        | Undef _ as x -> x (* nothing to check *)
+        | Def cs as x ->
+            let ids_typ = global_vars_set_constant_type env typ in
+            let ids_def = global_vars_set env (Mod_subst.force_constr cs) in
+            let inferred = keep_hyps env (Idset.union ids_typ ids_def) in
+            check declared inferred;
+            x
+        | OpaqueDef lc -> (* In this case we can postpone the check *)
+            OpaqueDef (Opaqueproof.iter_direct_opaque (fun c ->
+              let ids_typ = global_vars_set_constant_type env typ in
+              let ids_def = global_vars_set env c in
+              let inferred = keep_hyps env (Idset.union ids_typ ids_def) in
+              check declared inferred) lc) in
+  let tps = 
+    (* FIXME: incompleteness of the bytecode vm: we compile polymorphic 
+       constants like opaque definitions. *)
+    if poly then Cemitcodes.from_val Cemitcodes.BCconstant
+    else
+      match proj with
+      | None -> Cemitcodes.from_val (compile_constant_body env def)
+      | Some pb ->
+	Cemitcodes.from_val (compile_constant_body env (Def (Mod_subst.from_val pb.proj_body)))
+  in
   { const_hyps = hyps;
     const_body = def;
     const_type = typ;
+    const_proj = proj;
     const_body_code = tps;
-    const_constraints = cst }
+    const_polymorphic = poly;
+    const_universes = univs;
+    const_inline_code = inline_code }
+
 
 (*s Global and local constant declaration. *)
 
 let translate_constant env kn ce =
-  build_constant_declaration env kn (infer_declaration env ce)
+  build_constant_declaration kn env (infer_declaration env (Some kn) ce)
+
+let translate_local_assum env t =
+  let j = infer env t in
+  let t = Typeops.assumption_of_judgment env j in
+    t
 
 let translate_recipe env kn r =
-  build_constant_declaration env kn 
-    (let def,typ,cst,hyps = Cooking.cook_constant env r in
-     def,typ,cst,Some hyps)
+  build_constant_declaration kn env (Cooking.cook_constant env r)
+
+let translate_local_def env id centry =
+  let def,typ,proj,poly,univs,inline_code,ctx =
+    infer_declaration env None (DefinitionEntry centry) in
+  let typ = type_of_constant_type env typ in
+  def, typ, univs
 
 (* Insertion of inductive types. *)
 
-let translate_mind env kn mie = check_inductive env kn mie
+let translate_mind env kn mie = Indtypes.check_inductive env kn mie
+
+let handle_entry_side_effects env ce = { ce with
+  const_entry_body = Future.chain ~greedy:true ~pure:true
+    ce.const_entry_body (fun ((body, ctx), side_eff) ->
+      (handle_side_effects env body side_eff, ctx), Declareops.no_seff);
+}
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index bcc2ca0d..696fc3d2 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,29 +9,40 @@
 open Names
 open Term
 open Univ
-open Declarations
-open Inductive
 open Environ
+open Declarations
 open Entries
-open Typeops
 
-val translate_local_def : env -> constr * types option ->
-  constr * types * Univ.constraints
+val translate_local_def : env -> Id.t -> definition_entry ->
+  constant_def * types * constant_universes
 
-val translate_local_assum : env -> types ->
-  types * Univ.constraints
+val translate_local_assum : env -> types -> types
 
-val infer_declaration : env -> constant_entry ->
-  constant_def * constant_type * constraints * Sign.section_context option
+val mk_pure_proof : constr -> proof_output
 
-val build_constant_declaration : env -> 'a ->
-  constant_def * constant_type * constraints * Sign.section_context option -> 
-    constant_body
+val handle_side_effects : env -> constr -> Declareops.side_effects -> constr
+(** Returns the term where side effects have been turned into let-ins or beta
+    redexes. *)
+
+val handle_entry_side_effects : env -> definition_entry -> definition_entry
+(** Same as {!handle_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 translate_constant : env -> constant -> constant_entry -> constant_body
 
 val translate_mind :
   env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
 
-val translate_recipe :
-  env -> constant -> Cooking.recipe -> constant_body
+val translate_recipe : env -> constant -> Cooking.recipe -> constant_body
+
+(** Internal functions, mentioned here for debug purpose only *)
+
+val infer_declaration : env -> constant option -> 
+  constant_entry -> Cooking.result
+
+val build_constant_declaration :
+  constant -> env -> Cooking.result -> constant_body
+
+val set_suggest_proof_using :
+  (constant -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> unit) -> unit
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 0a920e40..33c4172e 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Sign
 open Environ
 open Reduction
 
@@ -31,6 +30,7 @@ type guard_error =
   | RecCallInCaseArg of constr
   | RecCallInCasePred of constr
   | NotGuardedForm of constr
+  | ReturnPredicateNotCoInductive of constr
 
 type arity_error =
   | NonInformativeToInformative
@@ -42,26 +42,27 @@ type type_error =
   | UnboundVar of variable
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
-  | ReferenceVariables of constr
-  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+  | ReferenceVariables of identifier * constr
+  | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment
       * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
-  | WrongCaseInfo of inductive * case_info
+  | WrongCaseInfo of pinductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * constructor * constr * constr
-  | Generalization of (name * types) * unsafe_judgment
+  | IllFormedBranch of constr * pconstructor * constr * constr
+  | Generalization of (Name.t * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
       (int * constr * constr) * unsafe_judgment * unsafe_judgment array
   | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
-  | IllFormedRecBody of guard_error * name array * int * env * unsafe_judgment array
+  | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array
   | IllTypedRecBody of
-      int * name array * unsafe_judgment array * types array
+      int * Name.t array * unsafe_judgment array * types array
+  | UnsatisfiedConstraints of Univ.constraints
 
 exception TypeError of env * type_error
 
-let nfj {uj_val=c;uj_type=ct} =
-  {uj_val=c;uj_type=nf_betaiota ct}
+let nfj env {uj_val=c;uj_type=ct} =
+  {uj_val=c;uj_type=nf_betaiota env ct}
 
 let error_unbound_rel env n =
   raise (TypeError (env, UnboundRel n))
@@ -75,8 +76,8 @@ let error_not_type env j =
 let error_assumption env j =
   raise (TypeError (env, BadAssumption j))
 
-let error_reference_variables env id =
-  raise (TypeError (env, ReferenceVariables id))
+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)))
@@ -85,11 +86,11 @@ let error_case_not_inductive env j =
   raise (TypeError (env, CaseNotInductive j))
 
 let error_number_branches env cj expn =
-  raise (TypeError (env, NumberBranches (nfj cj,expn)))
+  raise (TypeError (env, NumberBranches (nfj env cj,expn)))
 
 let error_ill_formed_branch env c i actty expty =
   raise (TypeError (env,
-    IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty)))
+    IllFormedBranch (c,i,nf_betaiota env actty, nf_betaiota env expty)))
 
 let error_generalization env nvar c =
   raise (TypeError (env, Generalization (nvar,c)))
@@ -115,3 +116,5 @@ let error_elim_explain kp ki =
   | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
   | _ -> WrongArity
 
+let error_unsatisfied_constraints env c =
+  raise (TypeError (env, UnsatisfiedConstraints c))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index c62cd446..7b3d2f1c 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -31,6 +31,7 @@ type guard_error =
   | RecCallInCaseArg of constr
   | RecCallInCasePred of constr
   | NotGuardedForm of constr
+  | ReturnPredicateNotCoInductive of constr
 
 type arity_error =
   | NonInformativeToInformative
@@ -42,21 +43,22 @@ type type_error =
   | UnboundVar of variable
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
-  | ReferenceVariables of constr
-  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+  | ReferenceVariables of identifier * constr
+  | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment
       * (sorts_family * sorts_family * arity_error) option
   | CaseNotInductive of unsafe_judgment
-  | WrongCaseInfo of inductive * case_info
+  | WrongCaseInfo of pinductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * constructor * constr * constr
-  | Generalization of (name * types) * unsafe_judgment
+  | IllFormedBranch of constr * pconstructor * constr * constr
+  | Generalization of (Name.t * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
       (int * constr * constr) * unsafe_judgment * unsafe_judgment array
   | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
-  | IllFormedRecBody of guard_error * name array * int * env * unsafe_judgment array
+  | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array
   | IllTypedRecBody of
-      int * name array * unsafe_judgment array * types array
+      int * Name.t array * unsafe_judgment array * types array
+  | UnsatisfiedConstraints of Univ.constraints
 
 exception TypeError of env * type_error
 
@@ -68,19 +70,19 @@ val error_not_type : env -> unsafe_judgment -> 'a
 
 val error_assumption : env -> unsafe_judgment -> 'a
 
-val error_reference_variables : env -> constr -> 'a
+val error_reference_variables : env -> identifier -> constr -> 'a
 
 val error_elim_arity :
-  env -> inductive -> sorts_family list -> constr -> unsafe_judgment ->
+  env -> pinductive -> sorts_family list -> constr -> unsafe_judgment ->
       (sorts_family * sorts_family * arity_error) option -> 'a
 
 val error_case_not_inductive : env -> unsafe_judgment -> 'a
 
 val error_number_branches : env -> unsafe_judgment -> int -> 'a
 
-val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a
+val error_ill_formed_branch : env -> constr -> pconstructor -> constr -> constr -> 'a
 
-val error_generalization : env -> name * types -> unsafe_judgment -> 'a
+val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a
 
 val error_actual_type : env -> unsafe_judgment -> types -> 'a
 
@@ -92,9 +94,11 @@ val error_cant_apply_bad_type :
       unsafe_judgment -> unsafe_judgment array -> 'a
 
 val error_ill_formed_rec_body :
-  env -> guard_error -> name array -> int -> env -> unsafe_judgment array -> 'a
+  env -> guard_error -> Name.t array -> int -> env -> unsafe_judgment array -> 'a
 
 val error_ill_typed_rec_body  :
-  env -> int -> name array -> unsafe_judgment array -> types array -> 'a
+  env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a
 
 val error_elim_explain : sorts_family -> sorts_family -> arity_error
+
+val error_unsatisfied_constraints : env -> Univ.constraints -> 'a
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 8b27cf91..2642b186 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -1,36 +1,40 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
 open Univ
 open Term
+open Vars
+open Context
 open Declarations
-open Sign
 open Environ
 open Entries
 open Reduction
 open Inductive
 open Type_errors
 
-let conv_leq l2r = default_conv CUMUL ~l2r
+let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y
 
 let conv_leq_vecti env v1 v2 =
-  array_fold_left2_i
-    (fun i c t1 t2 ->
-      let c' =
-        try default_conv CUMUL env t1 t2
-        with NotConvertible -> raise (NotConvertibleVect i) in
-      union_constraints c c')
-    empty_constraint
+  Array.fold_left2_i
+    (fun i _ t1 t2 ->
+      try conv_leq false env t1 t2
+      with NotConvertible -> raise (NotConvertibleVect i))
+    ()
     v1
     v2
 
+let check_constraints cst env = 
+  if Environ.check_constraints cst env then ()
+  else error_unsatisfied_constraints env cst
+
 (* This should be a type (a priori without intension to be an assumption) *)
 let type_judgment env j =
   match kind_of_term(whd_betadeltaiota env j.uj_type) with
@@ -67,9 +71,9 @@ let judge_of_prop_contents = function
 (* Type of Type(i). *)
 
 let judge_of_type u =
-  let uu = super u in
-  { uj_val = mkType u;
-    uj_type = mkType uu }
+  let uu = Universe.super u in
+    { uj_val = mkType u;
+      uj_type = mkType uu }
 
 (*s Type of a de Bruijn index. *)
 
@@ -91,82 +95,106 @@ let judge_of_variable env id =
 
 (* Management of context of variables. *)
 
-(* Checks if a context of variable can be instantiated by the
-   variables of the current env *)
-(* TODO: check order? *)
-let rec check_hyps_inclusion env sign =
-  Sign.fold_named_context
-    (fun (id,_,ty1) () ->
-      let ty2 = named_type id env in
-      if not (eq_constr ty2 ty1) then
-        error "types do not match")
+(* 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 c sign =
+  Context.fold_named_context
+    (fun (id,b1,ty1) () ->
+      try
+        let (_,b2,ty2) = lookup_named id env in
+        conv env ty2 ty1;
+        (match b2,b1 with
+        | None, None -> ()
+        | None, Some _ ->
+            (* This is wrong, because we don't know if the body is
+               needed or not for typechecking: *) ()
+        | Some _, None -> raise NotConvertible
+        | Some b2, Some b1 -> conv env b2 b1);
+      with Not_found | NotConvertible | Option.Heterogeneous ->
+        error_reference_variables env id c)
     sign
     ~init:()
 
-
-let check_args env c hyps =
-  try check_hyps_inclusion env hyps
-  with UserError _ | Not_found ->
-    error_reference_variables env c
-
-
-(* Checks if the given context of variables [hyps] is included in the
-   current context of [env]. *)
-(*
-let check_hyps id env hyps =
-  let hyps' = named_context env in
-  if not (hyps_inclusion env hyps hyps') then
-    error_reference_variables env id
-*)
 (* Instantiation of terms on real arguments. *)
 
 (* Make a type polymorphic if an arity *)
 
 let extract_level env p =
   let _,c = dest_prod_assum env p in
-  match kind_of_term c with Sort (Type u) -> Some u | _ -> None
+  match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None
 
-let extract_context_levels env =
-  List.fold_left
-    (fun l (_,b,p) -> if b=None then extract_level env p::l else l) []
+let extract_context_levels env l =
+  let fold l (_, b, p) = match b with
+  | None -> extract_level env p :: l
+  | _ -> l
+  in
+  List.fold_left fold [] l
 
 let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} =
   let params, ccl = dest_prod_assum env t in
   match kind_of_term ccl with
   | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) ->
       let param_ccls = extract_context_levels env params in
-      let s = { poly_param_levels = param_ccls; poly_level = u} in
-      PolymorphicArity (params,s)
+      let s = { template_param_levels = param_ccls; template_level = u} in
+      TemplateArity (params,s)
   | _ ->
-      NonPolymorphicType t
+      RegularArity t
 
 (* Type of constants *)
 
-let type_of_constant_knowing_parameters env t paramtyps =
+let type_of_constant_type_knowing_parameters env t paramtyps =
   match t with
-  | NonPolymorphicType t -> t
-  | PolymorphicArity (sign,ar) ->
+  | RegularArity t -> t
+  | TemplateArity (sign,ar) ->
       let ctx = List.rev sign in
       let ctx,s = instantiate_universes env ctx ar paramtyps in
       mkArity (List.rev ctx,s)
 
+let type_of_constant_knowing_parameters env cst paramtyps =
+  let cb = lookup_constant (fst cst) env in
+  let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+  let ty, cu = constant_type env cst in
+    type_of_constant_type_knowing_parameters env ty paramtyps, cu
+
+let type_of_constant_knowing_parameters_in env cst paramtyps =
+  let cb = lookup_constant (fst cst) env in
+  let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+  let ty = constant_type_in env cst in
+    type_of_constant_type_knowing_parameters env ty paramtyps
+
 let type_of_constant_type env t =
-  type_of_constant_knowing_parameters env t [||]
+  type_of_constant_type_knowing_parameters env t [||]
 
 let type_of_constant env cst =
-  type_of_constant_type env (constant_type env cst)
+  type_of_constant_knowing_parameters env cst [||]
 
-let judge_of_constant_knowing_parameters env cst jl =
-  let c = mkConst cst in
-  let cb = lookup_constant cst env in
-  let _ = check_args env c cb.const_hyps in
-  let paramstyp = Array.map (fun j -> j.uj_type) jl in
-  let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in
-  make_judge c t
+let type_of_constant_in env cst =
+  let cb = lookup_constant (fst cst) env in
+  let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+  let ar = constant_type_in env cst in
+    type_of_constant_type_knowing_parameters env ar [||]
+
+let judge_of_constant_knowing_parameters env (kn,u as cst) args =
+  let c = mkConstU cst in
+  let ty, cu = type_of_constant_knowing_parameters env cst args in
+  let _ = Environ.check_constraints cu env in
+    make_judge c ty
 
 let judge_of_constant env cst =
   judge_of_constant_knowing_parameters env cst [||]
 
+let type_of_projection env (p,u) =
+  let cst = Projection.constant p in
+  let cb = lookup_constant cst env in
+  match cb.const_proj with
+  | Some pb -> 
+    if cb.const_polymorphic then
+      Vars.subst_instance_constr u pb.proj_type
+    else pb.proj_type
+  | None -> raise (Invalid_argument "type_of_projection: not a projection")
+
+
 (* Type of a lambda-abstraction. *)
 
 (* [judge_of_abstraction env name var j] implements the rule
@@ -192,18 +220,16 @@ let judge_of_letin env name defj typj j =
 (* Type of an application. *)
 
 let judge_of_apply env funj argjv =
-  let rec apply_rec n typ cst = function
+  let rec apply_rec n typ = function
     | [] ->
 	{ uj_val  = mkApp (j_val funj, Array.map j_val argjv);
-          uj_type = typ },
-	cst
+          uj_type = typ }
     | hj::restjl ->
         (match kind_of_term (whd_betadeltaiota env typ) with
           | Prod (_,c1,c2) ->
 	      (try
-		let c = conv_leq false env hj.uj_type c1 in
-		let cst' = union_constraints cst c in
-		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
+		 let () = conv_leq false env hj.uj_type c1 in
+		   apply_rec (n+1) (subst1 hj.uj_val c2) restjl
 	      with NotConvertible ->
 		error_cant_apply_bad_type env
 		  (n,c1, hj.uj_type)
@@ -214,7 +240,6 @@ let judge_of_apply env funj argjv =
   in
   apply_rec 1
     funj.uj_type
-    empty_constraint
     (Array.to_list argjv)
 
 (* Type of product *)
@@ -227,18 +252,20 @@ let sort_of_product env domsort rangsort =
     | (Prop _,  Prop Pos) -> rangsort
     (* Product rule (Type,Set,?) *)
     | (Type u1, Prop Pos) ->
-        if engagement env = Some ImpredicativeSet then
+        begin match engagement env with
+        | Some ImpredicativeSet ->
           (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
           rangsort
-        else
+        | _ ->
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
-          Type (sup u1 type0_univ)
+          Type (Universe.sup Universe.type0 u1)
+        end
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
+    | (Prop Pos,  Type u2)  -> Type (Universe.sup Universe.type0 u2)
     (* Product rule (Prop,Type_i,Type_i) *)
     | (Prop Null, Type _)  -> rangsort
     (* Product rule (Type_i,Type_i,Type_i) *)
-    | (Type u1, Type u2) -> Type (sup u1 u2)
+    | (Type u1, Type u2) -> Type (Universe.sup u1 u2)
 
 (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
 
@@ -272,13 +299,17 @@ let judge_of_cast env cj k tj =
           vm_conv CUMUL env cj.uj_type expected_type
       | DEFAULTcast ->
           mkCast (cj.uj_val, k, expected_type),
-          conv_leq false env cj.uj_type expected_type
+          default_conv ~l2r:false CUMUL env cj.uj_type expected_type
       | REVERTcast ->
           cj.uj_val,
-          conv_leq true env cj.uj_type expected_type in
-    { uj_val = c;
-      uj_type = expected_type },
-    cst
+          default_conv ~l2r:true CUMUL env cj.uj_type expected_type
+      | NATIVEcast ->
+	 let sigma = Nativelambda.empty_evars in
+         mkCast (cj.uj_val, k, expected_type),
+         native_conv CUMUL sigma env cj.uj_type expected_type
+    in
+      { uj_val = c;
+	uj_type = expected_type }
   with NotConvertible ->
     error_actual_type env cj expected_type
 
@@ -296,50 +327,70 @@ let judge_of_cast env cj k tj =
    the App case of execute; from this constraints, the expected
    dynamic constraints of the form u<=v are enforced *)
 
-let judge_of_inductive_knowing_parameters env ind jl =
-  let c = mkInd ind in
-  let (mib,mip) = lookup_mind_specif env ind in
-  check_args env c mib.mind_hyps;
-  let paramstyp = Array.map (fun j -> j.uj_type) jl in
-  let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in
-  make_judge c t
+let judge_of_inductive_knowing_parameters env (ind,u as indu) args =
+  let c = mkIndU indu in
+  let (mib,mip) as spec = lookup_mind_specif env ind in
+  check_hyps_inclusion env c mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters 
+    env (spec,u) args
+  in
+    check_constraints cst env;
+    make_judge c t
 
-let judge_of_inductive env ind =
-  judge_of_inductive_knowing_parameters env ind [||]
+let judge_of_inductive env (ind,u as indu) =
+  let c = mkIndU indu in
+  let (mib,mip) as spec = lookup_mind_specif env ind in
+  check_hyps_inclusion env c mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive env (spec,u) in
+    check_constraints cst env;
+    (make_judge c t)
 
 (* Constructors. *)
 
-let judge_of_constructor env c =
-  let constr = mkConstruct c in
+let judge_of_constructor env (c,u as cu) =
+  let constr = mkConstructU cu in
   let _ =
     let ((kn,_),_) = c in
     let mib = lookup_mind kn env in
-    check_args env constr mib.mind_hyps in
+    check_hyps_inclusion env constr mib.mind_hyps in
   let specif = lookup_mind_specif env (inductive_of_constructor c) in
-  make_judge constr (type_of_constructor c specif)
+  let t,cst = constrained_type_of_constructor cu specif in
+  let () = check_constraints cst env in
+    (make_judge constr t)
 
 (* Case. *)
 
-let check_branch_types env ind cj (lfj,explft) =
+let check_branch_types env (ind,u) cj (lfj,explft) =
   try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
-        error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
+        error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i)
     | Invalid_argument _ ->
         error_number_branches env cj (Array.length explft)
 
 let judge_of_case env ci pj cj lfj =
-  let indspec =
+  let (pind, _ as indspec) =
     try find_rectype env cj.uj_type
     with Not_found -> error_case_not_inductive env cj in
-  let _ = check_case_info env (fst indspec) ci in
-  let (bty,rslty,univ) =
+  let _ = check_case_info env pind ci in
+  let (bty,rslty) =
     type_case_branches env indspec pj cj.uj_val in
-  let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in
+  let () = check_branch_types env pind cj (lfj,bty) in
   ({ uj_val  = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
                        Array.map j_val lfj);
-     uj_type = rslty },
-  union_constraints univ univ')
+     uj_type = rslty })
+
+let judge_of_projection env p cj =
+  let pb = lookup_projection p env in
+  let (ind,u), args =
+    try find_rectype env cj.uj_type
+    with Not_found -> error_case_not_inductive env cj
+  in
+    assert(eq_mind pb.proj_ind (fst ind));
+    let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
+    let ty = substl (cj.uj_val :: List.rev args) ty in
+      {uj_val = mkProj (p,cj.uj_val);
+       uj_type = ty}
 
 (* Fixpoints. *)
 
@@ -348,7 +399,7 @@ let judge_of_case env ci pj cj lfj =
 
 let type_fixpoint env lna lar vdefj =
   let lt = Array.length vdefj in
-  assert (Array.length lar = lt);
+  assert (Int.equal (Array.length lar) lt);
   try
     conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar)
   with NotConvertibleVect i ->
@@ -357,166 +408,155 @@ let type_fixpoint env lna lar vdefj =
 (************************************************************************)
 (************************************************************************)
 
-(* This combinator adds the universe constraints both in the local
-   graph and in the universes of the environment. This is to ensure
-   that the infered local graph is satisfiable. *)
-let univ_combinator (cst,univ) (j,c') =
-  (j,(union_constraints cst c', merge_constraints c' univ))
-
 (* The typing machine. *)
     (* ATTENTION : faudra faire le typage du contexte des Const,
     Ind et Constructsi un jour cela devient des constructions
     arbitraires et non plus des variables *)
-let rec execute env cstr cu =
+let rec execute env cstr =
   match kind_of_term cstr with
     (* Atomic terms *)
     | Sort (Prop c) ->
-	(judge_of_prop_contents c, cu)
-
+      judge_of_prop_contents c
+	
     | Sort (Type u) ->
-	(judge_of_type u, cu)
+      judge_of_type u
 
     | Rel n ->
-	(judge_of_relative env n, cu)
+      judge_of_relative env n
 
     | Var id ->
-	(judge_of_variable env id, cu)
+      judge_of_variable env id
 
     | Const c ->
-        (judge_of_constant env c, cu)
+      judge_of_constant env c
+	
+    | Proj (p, c) ->
+        let cj = execute env c in
+          judge_of_projection env p cj
 
     (* Lambda calculus operators *)
     | App (f,args) ->
-        let (jl,cu1) = execute_array env args cu in
-	let (j,cu2) =
+        let jl = execute_array env args in
+	let j =
 	  match kind_of_term f with
-	    | Ind ind ->
+	    | Ind ind when Environ.template_polymorphic_pind ind env ->
 		(* Sort-polymorphism of inductive types *)
-		judge_of_inductive_knowing_parameters env ind jl, cu1
-	    | Const cst ->
+	      let args = Array.map (fun j -> lazy j.uj_type) jl in
+		judge_of_inductive_knowing_parameters env ind args
+	    | Const cst when Environ.template_polymorphic_pconstant cst env ->
 		(* Sort-polymorphism of constant *)
-		judge_of_constant_knowing_parameters env cst jl, cu1
+	      let args = Array.map (fun j -> lazy j.uj_type) jl in
+		judge_of_constant_knowing_parameters env cst args
 	    | _ ->
 		(* No sort-polymorphism *)
-		execute env f cu1
+		execute env f
 	in
-	univ_combinator cu2 (judge_of_apply env j jl)
+	  judge_of_apply env j jl
 
     | Lambda (name,c1,c2) ->
-        let (varj,cu1) = execute_type env c1 cu in
-	let env1 = push_rel (name,None,varj.utj_val) env in
-        let (j',cu2) = execute env1 c2 cu1 in
-        (judge_of_abstraction env name varj j', cu2)
+      let varj = execute_type env c1 in
+      let env1 = push_rel (name,None,varj.utj_val) env in
+      let j' = execute env1 c2 in
+        judge_of_abstraction env name varj j'
 
     | Prod (name,c1,c2) ->
-        let (varj,cu1) = execute_type env c1 cu in
-	let env1 = push_rel (name,None,varj.utj_val) env in
-        let (varj',cu2) = execute_type env1 c2 cu1 in
-	(judge_of_product env name varj varj', cu2)
+      let varj = execute_type env c1 in
+      let env1 = push_rel (name,None,varj.utj_val) env in
+      let varj' = execute_type env1 c2 in
+	judge_of_product env name varj varj'
 
     | LetIn (name,c1,c2,c3) ->
-        let (j1,cu1) = execute env c1 cu in
-        let (j2,cu2) = execute_type env c2 cu1 in
-        let (_,cu3) =
-	  univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in
-        let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
-        let (j',cu4) = execute env1 c3 cu3 in
-        (judge_of_letin env name j1 j2 j', cu4)
+      let j1 = execute env c1 in
+      let j2 = execute_type env c2 in
+      let _ = judge_of_cast env j1 DEFAULTcast j2 in
+      let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+      let j' = execute env1 c3 in
+        judge_of_letin env name j1 j2 j'
 
     | Cast (c,k, t) ->
-        let (cj,cu1) = execute env c cu in
-        let (tj,cu2) = execute_type env t cu1 in
-	univ_combinator cu2
-          (judge_of_cast env cj k tj)
+      let cj = execute env c in
+      let tj = execute_type env t in
+        judge_of_cast env cj k tj
 
     (* Inductive types *)
     | Ind ind ->
-	(judge_of_inductive env ind, cu)
+      judge_of_inductive env ind
 
     | Construct c ->
-	(judge_of_constructor env c, cu)
+      judge_of_constructor env c
 
     | Case (ci,p,c,lf) ->
-        let (cj,cu1) = execute env c cu in
-        let (pj,cu2) = execute env p cu1 in
-        let (lfj,cu3) = execute_array env lf cu2 in
-        univ_combinator cu3
-          (judge_of_case env ci pj cj lfj)
+        let cj = execute env c in
+        let pj = execute env p in
+        let lfj = execute_array env lf in
+          judge_of_case env ci pj cj lfj
 
     | Fix ((vn,i as vni),recdef) ->
-        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
-        let fix = (vni,recdef') in
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let fix = (vni,recdef') in
         check_fix env fix;
-	(make_judge (mkFix fix) fix_ty, cu1)
-
+	make_judge (mkFix fix) fix_ty
+	  
     | CoFix (i,recdef) ->
-        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
-        let cofix = (i,recdef') in
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let cofix = (i,recdef') in
         check_cofix env cofix;
-	(make_judge (mkCoFix cofix) fix_ty, cu1)
-
+	(make_judge (mkCoFix cofix) fix_ty)
+	  
     (* Partial proofs: unsupported by the kernel *)
     | Meta _ ->
-	anomaly "the kernel does not support metavariables"
+	anomaly (Pp.str "the kernel does not support metavariables")
 
     | Evar _ ->
-	anomaly "the kernel does not support existential variables"
+	anomaly (Pp.str "the kernel does not support existential variables")
 
-and execute_type env constr cu =
-  let (j,cu1) = execute env constr cu in
-  (type_judgment env j, cu1)
+and execute_type env constr =
+  let j = execute env constr in
+    type_judgment env j
 
-and execute_recdef env (names,lar,vdef) i cu =
-  let (larj,cu1) = execute_array env lar cu in
+and execute_recdef env (names,lar,vdef) i =
+  let larj = execute_array env lar in
   let lara = Array.map (assumption_of_judgment env) larj in
   let env1 = push_rec_types (names,lara,vdef) env in
-  let (vdefj,cu2) = execute_array env1 vdef cu1 in
+  let vdefj = execute_array env1 vdef in
   let vdefv = Array.map j_val vdefj in
-  let cst = type_fixpoint env1 names lara vdefj in
-  univ_combinator cu2
-    ((lara.(i),(names,lara,vdefv)),cst)
+  let () = type_fixpoint env1 names lara vdefj in
+    (lara.(i),(names,lara,vdefv))
 
-and execute_array env = array_fold_map' (execute env)
+and execute_array env = Array.map (execute env)
 
 (* Derived functions *)
 let infer env constr =
-  let (j,(cst,_)) =
-    execute env constr (empty_constraint, universes env) in
-  assert (eq_constr j.uj_val constr);
-  (j, cst)
+  let j = execute env constr in
+    assert (eq_constr j.uj_val constr);
+    j
+
+(* let infer_key = Profile.declare_profile "infer" *)
+(* let infer = Profile.profile2 infer_key infer *)
 
 let infer_type env constr =
-  let (j,(cst,_)) =
-    execute_type env constr (empty_constraint, universes env) in
-  (j, cst)
+  let j = execute_type env constr in
+    j
 
 let infer_v env cv =
-  let (jv,(cst,_)) =
-    execute_array env cv (empty_constraint, universes env) in
-  (jv, cst)
+  let jv = execute_array env cv in
+    jv
 
 (* Typing of several terms. *)
 
 let infer_local_decl env id = function
   | LocalDef c ->
-      let (j,cst) = infer env c in
-      (Name id, Some j.uj_val, j.uj_type), cst
+      let j = infer env c in
+      (Name id, Some j.uj_val, j.uj_type)
   | LocalAssum c ->
-      let (j,cst) = infer env c in
-      (Name id, None, assumption_of_judgment env j), cst
+      let j = infer env c in
+      (Name id, None, assumption_of_judgment env j)
 
 let infer_local_decls env decls =
   let rec inferec env = function
   | (id, d) :: l ->
-      let env, l, cst1 = inferec env l in
-      let d, cst2 = infer_local_decl env id d in
-      push_rel d env, add_rel_decl d l, union_constraints cst1 cst2
-  | [] -> env, empty_rel_context, empty_constraint in
+      let (env, l) = inferec env l in
+      let d = infer_local_decl env id d in
+	(push_rel d env, add_rel_decl d l)
+  | [] -> (env, empty_rel_context) in
   inferec env decls
-
-(* Exported typing functions *)
-
-let typing env c =
-  let (j,cst) = infer env c in
-  let _ = add_constraints cst env in
-  j
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 5ce419b3..010b2b6f 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,19 +9,26 @@
 open Names
 open Univ
 open Term
+open Context
 open Environ
 open Entries
 open Declarations
 
-(** {6 Typing functions (not yet tagged as safe) } *)
+(** {6 Typing functions (not yet tagged as safe) }
 
-val infer      : env -> constr       -> unsafe_judgment * constraints
-val infer_v    : env -> constr array -> unsafe_judgment array * constraints
-val infer_type : env -> types        -> unsafe_type_judgment * constraints
+    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.
+ *)
+
+
+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 -> (identifier * local_entry) list
-    -> env * rel_context * constraints
+  env -> (Id.t * local_entry) list -> (env * rel_context)
 
 (** {6 Basic operations of the typing machine. } *)
 
@@ -32,8 +39,10 @@ val assumption_of_judgment :  env -> unsafe_judgment -> types
 val type_judgment          :  env -> unsafe_judgment -> unsafe_type_judgment
 
 (** {6 Type of sorts. } *)
-val judge_of_prop_contents : contents -> unsafe_judgment
-val judge_of_type          : universe -> unsafe_judgment
+val judge_of_prop : unsafe_judgment
+val judge_of_set  : unsafe_judgment
+val judge_of_prop_contents  : contents -> unsafe_judgment
+val judge_of_type           : universe -> unsafe_judgment
 
 (** {6 Type of a bound variable. } *)
 val judge_of_relative : env -> int -> unsafe_judgment
@@ -42,65 +51,81 @@ val judge_of_relative : env -> int -> unsafe_judgment
 val judge_of_variable : env -> variable -> unsafe_judgment
 
 (** {6 type of a constant } *)
-val judge_of_constant : env -> constant -> unsafe_judgment
+
+val judge_of_constant : env -> pconstant -> unsafe_judgment
 
 val judge_of_constant_knowing_parameters :
-  env -> constant -> unsafe_judgment array -> unsafe_judgment
+  env -> pconstant -> types Lazy.t array -> unsafe_judgment
+
+(** {6 type of an applied projection } *)
+
+val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment
 
 (** {6 Type of application. } *)
 val judge_of_apply :
   env -> unsafe_judgment -> unsafe_judgment array
-    -> unsafe_judgment * constraints
+    -> unsafe_judgment
 
 (** {6 Type of an abstraction. } *)
 val judge_of_abstraction :
-  env -> name -> unsafe_type_judgment -> unsafe_judgment
+  env -> Name.t -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
+val sort_of_product : env -> sorts -> sorts -> sorts
+
 (** {6 Type of a product. } *)
 val judge_of_product :
-  env -> name -> unsafe_type_judgment -> unsafe_type_judgment
+  env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment
     -> unsafe_judgment
 
 (** s Type of a let in. *)
 val judge_of_letin :
-  env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
+  env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
 (** {6 Type of a cast. } *)
 val judge_of_cast :
   env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
-    unsafe_judgment * constraints
+  unsafe_judgment
 
 (** {6 Inductive types. } *)
 
-val judge_of_inductive : env -> inductive -> unsafe_judgment
+val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment
 
-val judge_of_inductive_knowing_parameters :
-  env -> inductive -> unsafe_judgment array -> unsafe_judgment
+(* val judge_of_inductive_knowing_parameters : *)
+(*   env -> inductive -> unsafe_judgment array -> unsafe_judgment *)
 
-val judge_of_constructor : env -> constructor -> unsafe_judgment
+val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment
 
 (** {6 Type of Cases. } *)
 val judge_of_case : env -> case_info
   -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
-    -> unsafe_judgment * constraints
+    -> unsafe_judgment
 
 (** Typecheck general fixpoint (not checking guard conditions) *)
-val type_fixpoint : env -> name array -> types array
-    -> unsafe_judgment array -> constraints
-
-(** Kernel safe typing but applicable to partial proofs *)
-val typing : env -> constr -> unsafe_judgment
+val type_fixpoint : env -> Name.t array -> types array
+    -> unsafe_judgment array -> unit
 
-val type_of_constant : env -> constant -> types
+val type_of_constant : env -> pconstant -> types constrained
 
 val type_of_constant_type : env -> constant_type -> types
 
+val type_of_projection : env -> Names.projection puniverses -> types
+
+val type_of_constant_in : env -> pconstant -> types
+
+val type_of_constant_type_knowing_parameters :
+  env -> constant_type -> types Lazy.t array -> types
+
 val type_of_constant_knowing_parameters :
-  env -> constant_type -> constr array -> types
+  env -> pconstant -> types Lazy.t array -> types constrained
+
+val type_of_constant_knowing_parameters_in :
+  env -> pconstant -> types Lazy.t array -> types
 
 (** Make a type polymorphic if an arity *)
 val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
   constant_type
 
+(** Check that hyps are included in env and fails with error otherwise *)
+val check_hyps_inclusion : env -> constr -> section_context -> unit
diff --git a/kernel/uint31.ml b/kernel/uint31.ml
new file mode 100644
index 00000000..3a0da2f6
--- /dev/null
+++ b/kernel/uint31.ml
@@ -0,0 +1,153 @@
+  (* Invariant: For arch64 all extra bytes are set to 0 *)
+type t = int 
+    
+  (* to be used only on 32 bits achitectures *)
+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
+ 	
+    (* convertion 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/uint31.mli
new file mode 100644
index 00000000..e8b98080
--- /dev/null
+++ b/kernel/uint31.mli
@@ -0,0 +1,41 @@
+type t
+
+      (* conversion to int *)
+val to_int : t -> int
+val of_int : int -> t
+val of_uint : int -> t
+
+     (* convertion to a string *)
+val to_string : t -> string
+val of_string : string -> t
+
+      (* logical operations *)
+val l_sl    : t -> t -> t
+val l_sr    : t -> t -> t
+val l_and   : t -> t -> t
+val l_xor   : t -> t -> t
+val l_or    : t -> t -> t
+
+      (* 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 div21   : t -> t -> t -> t * t
+      
+      (* comparison *)
+val lt      : t -> t -> bool
+val equal   : t -> t -> bool
+val le      : t -> t -> bool
+val compare : t -> t -> int
+
+      (* head and tail *)
+val head0   : t -> t
+val tail0   : t -> t
+
+(** Used by retroknowledge *)
+val add_digit : t -> t -> t
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 822f6ca6..08e9fee0 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,10 +10,13 @@
 (* 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] *)
 
-(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, 
+   Pierre-Marie Pédrot *)
 
 open Pp
+open Errors
 open Util
 
 (* Universes are stratified by a partial ordering $\le$.
@@ -28,40 +31,337 @@ open Util
    union-find algorithm. The assertions $<$ and $\le$ are represented by
    adjacency lists *)
 
-module UniverseLevel = struct
+module type Hashconsed =
+sig
+  type t
+  val hash : t -> int
+  val equal : t -> t -> bool
+  val hcons : t -> t
+end
 
-  type t =
-    | Set
-    | Level of Names.dir_path * int
+module HashedList (M : Hashconsed) :
+sig
+  type t = private Nil | Cons of M.t * int * t
+  val nil : t
+  val cons : M.t -> t -> t
+end =
+struct
+  type t = Nil | Cons of M.t * int * t
+  module Self =
+  struct
+    type _t = t
+    type t = _t
+    type u = (M.t -> M.t)
+    let hash = function Nil -> 0 | Cons (_, h, _) -> h
+    let equal l1 l2 = match l1, l2 with
+    | Nil, Nil -> true
+    | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2
+    | _ -> false
+    let hashcons hc = function
+    | Nil -> Nil
+    | Cons (x, h, l) -> Cons (hc x, h, l)
+  end
+  module Hcons = Hashcons.Make(Self)
+  let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons
+  (** No recursive call: the interface guarantees that all HLists from this
+      program are already hashconsed. If we get some external HList, we can
+      still reconstruct it by traversing it entirely. *)
+  let nil = Nil
+  let cons x l =
+    let h = M.hash x in
+    let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in
+    let h = Hashset.Combine.combine h hl in
+    hcons (Cons (x, h, l))
+end
+
+module HList = struct
+
+  module type S = sig
+    type elt
+    type t = private Nil | Cons of elt * int * t
+    val hash : t -> int
+    val nil : t
+    val cons : elt -> t -> t
+    val tip : elt -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val map : (elt -> elt) -> t -> t
+    val smartmap : (elt -> elt) -> t -> t
+    val exists : (elt -> bool) -> t -> bool
+    val for_all : (elt -> bool) -> t -> bool
+    val for_all2 : (elt -> elt -> bool) -> t -> t -> bool
+    val mem : elt -> t -> bool
+    val remove : elt -> t -> t
+    val to_list : t -> elt list
+    val compare : (elt -> elt -> int) -> t -> t -> int
+  end
+
+  module Make (H : Hashconsed) : S with type elt = H.t =
+  struct
+  type elt = H.t
+  include HashedList(H)
+
+  let hash = function Nil -> 0 | Cons (_, h, _) -> h
+
+  let tip e = cons e nil
 
-  (* A specialized comparison function: we compare the [int] part
-     first (this property is used by the [check_sorted] function
-     below). This way, most of the time, the [dir_path] part is not
-     considered. *)
+  let rec fold f l accu = match l with
+  | Nil -> accu
+  | Cons (x, _, l) -> fold f l (f x accu)
+
+  let rec map f = function
+  | Nil -> nil
+  | Cons (x, _, l) -> cons (f x) (map f l)
+
+  let smartmap = map
+  (** Apriori hashconsing ensures that the map is equal to its argument *)
+
+  let rec exists f = function
+  | Nil -> false
+  | Cons (x, _, l) -> f x || exists f l
+
+  let rec for_all f = function
+  | Nil -> true
+  | Cons (x, _, l) -> f x && for_all f l
+
+  let rec for_all2 f l1 l2 = match l1, l2 with
+  | Nil, Nil -> true
+  | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2
+  | _ -> false
+
+  let rec to_list = function
+  | Nil -> []
+  | Cons (x, _, l) -> x :: to_list l
+
+  let rec remove x = function
+  | Nil -> nil
+  | Cons (y, _, l) ->
+    if H.equal x y then l
+    else cons y (remove x l)
+
+  let rec mem x = function
+  | Nil -> false
+  | Cons (y, _, l) -> H.equal x y || mem x l
+
+  let rec compare cmp l1 l2 = match l1, l2 with
+  | Nil, Nil -> 0
+  | Cons (x1, h1, l1), Cons (x2, h2, l2) ->
+    let c = Int.compare h1 h2 in
+    if c == 0 then
+      let c = cmp x1 x2 in
+      if c == 0 then
+        compare cmp l1 l2
+      else c
+    else c
+  | Cons _, Nil -> 1
+  | Nil, Cons _ -> -1
+
+  end
+end
 
-  let compare u v = match u,v with
+module RawLevel =
+struct
+  open Names
+  type t =
+    | Prop
+    | Set
+    | Level of int * DirPath.t
+    | Var of int
+
+  (* Hash-consing *)
+
+  let equal x y =
+    x == y ||
+      match x, y with
+      | Prop, Prop -> true
+      | Set, Set -> true
+      | Level (n,d), Level (n',d') ->
+        Int.equal n n' && DirPath.equal d d'
+      | Var n, Var n' -> Int.equal n n'
+      | _ -> false
+
+  let compare u v =
+    match u, v with
+    | Prop,Prop -> 0
+    | Prop, _ -> -1
+    | _, Prop -> 1
     | Set, Set -> 0
     | Set, _ -> -1
     | _, Set -> 1
-    | Level (dp1, i1), Level (dp2, i2) ->
+    | Level (i1, dp1), Level (i2, dp2) ->
       if i1 < i2 then -1
       else if i1 > i2 then 1
-      else compare dp1 dp2
+      else DirPath.compare dp1 dp2
+    | Level _, _ -> -1
+    | _, Level _ -> 1
+    | Var n, Var m -> Int.compare n m
+      
+  let hcons = function
+    | Prop as x -> x
+    | Set as x -> x
+    | Level (n,d) as x -> 
+      let d' = Names.DirPath.hcons d in
+        if d' == d then x else Level (n,d')
+    | Var n as x -> x
+
+  open Hashset.Combine
+
+  let hash = function
+    | Prop -> combinesmall 1 0
+    | Set -> combinesmall 1 1
+    | Var n -> combinesmall 2 n
+    | Level (n, d) -> combinesmall 3 (combine n (Names.DirPath.hash d))
+
+end
+
+module Level = struct
+
+  open Names
+
+  type raw_level = RawLevel.t =
+  | Prop
+  | Set
+  | Level of int * DirPath.t
+  | Var of int
+
+  (** Embed levels with their hash value *)
+  type t = { 
+    hash : int;
+    data : RawLevel.t }
+
+  let equal x y = 
+    x == y || Int.equal x.hash y.hash && RawLevel.equal x.data y.data
+
+  let hash x = x.hash
+
+  let hcons x = 
+    let data' = RawLevel.hcons x.data in
+      if data' == x.data then x
+      else { x with data = data' }
+
+  let data x = x.data
+
+  (** Hashcons on levels + their hash *)
+
+  let make =
+    let module Self = struct
+      type _t = t
+      type t = _t
+      let equal = equal
+      let hash = hash
+    end in
+    let module WH = Weak.Make(Self) in
+    let pool = WH.create 4910 in fun x ->
+    let x = { hash = RawLevel.hash x; data = x } in
+    try WH.find pool x
+    with Not_found -> WH.add pool x; x
+
+  let set = make Set
+  let prop = make Prop
+
+  let is_small x = 
+    match data x with
+    | Level _ -> false
+    | _ -> true
 
-  let to_string = function
+  let is_prop x =
+    match data x with
+    | Prop -> true
+    | _ -> false
+
+  let is_set x =
+    match data x with
+    | Set -> true
+    | _ -> false
+
+  let compare u v =
+    if u == v then 0
+    else
+      let c = Int.compare (hash u) (hash v) in
+	if c == 0 then RawLevel.compare (data u) (data v)
+	else c
+
+  let natural_compare u v =
+    if u == v then 0
+    else RawLevel.compare (data u) (data v)
+	    
+  let to_string x = 
+    match data x with
+    | Prop -> "Prop"
     | Set -> "Set"
-    | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
+    | Level (n,d) -> 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
+    | Prop, Set | Set, Prop -> true
+    | _ -> false
+
+  let vars = Array.init 20 (fun i -> make (Var i))
+
+  let var n = 
+    if n < 20 then vars.(n) else make (Var n)
+
+  let var_index u =
+    match data u with
+    | Var n -> Some n | _ -> None
+
+  let make m n = make (Level (n, Names.DirPath.hcons m))
+
+end
+
+(** Level maps *)
+module LMap = struct 
+  module M = HMap.Make (Level)
+  include M
+
+  let union l r = 
+    merge (fun k l r -> 
+      match l, r with
+      | Some _, _ -> l
+      | _, _ -> r) l r
+
+  let subst_union l r = 
+    merge (fun k l r -> 
+      match l, r with
+      | Some (Some _), _ -> l
+      | Some None, None -> l
+      | _, _ -> r) l r
+
+  let diff ext orig =
+    fold (fun u v acc -> 
+      if mem u orig then acc 
+      else add u v acc)
+      ext empty
+
+  let pr f m =
+    h 0 (prlist_with_sep fnl (fun (u, v) ->
+      Level.pr u ++ f v) (bindings m))
+end
+
+module LSet = struct
+  include LMap.Set
+
+  let pr prl s =
+    str"{" ++ prlist_with_sep spc prl (elements s) ++ str"}"
+
+  let of_array l =
+    Array.fold_left (fun acc x -> add x acc) empty l
+
 end
 
-module UniverseLMap = Map.Make (UniverseLevel)
-module UniverseLSet = Set.Make (UniverseLevel)
 
-type universe_level = UniverseLevel.t
+type 'a universe_map = 'a LMap.t
+
+type universe_level = Level.t
 
-let compare_levels = UniverseLevel.compare
+type universe_level_subst_fn = universe_level -> universe_level
+
+type universe_set = LSet.t
 
 (* An algebraic universe [universe] is either a universe variable
-   [UniverseLevel.t] or a formal universe known to be greater than some
+   [Level.t] or a formal universe known to be greater than some
    universe variables and strictly greater than some (other) universe
    variables
 
@@ -72,121 +372,354 @@ let compare_levels = UniverseLevel.compare
    maximum of two algebraic universes
 *)
 
-type universe =
-  | Atom of UniverseLevel.t
-  | Max of UniverseLevel.t list * UniverseLevel.t list
-
-let make_universe_level (m,n) = UniverseLevel.Level (m,n)
-let make_universe l = Atom l
-let make_univ c = Atom (make_universe_level c)
+module Universe =
+struct
+  (* Invariants: non empty, sorted and without duplicates *)
 
-let universe_level = function
-  | Atom l -> Some l
-  | Max _ -> None
-
-let pr_uni_level u = str (UniverseLevel.to_string u)
+  module Expr = 
+  struct
+    type t = Level.t * int
+    type _t = t
+	
+    (* Hashing of expressions *)
+    module ExprHash = 
+    struct
+      type t = _t
+      type u = Level.t -> Level.t
+      let hashcons hdir (b,n as x) = 
+	let b' = hdir b in 
+	  if b' == b then x else (b',n)
+      let equal l1 l2 =
+        l1 == l2 || 
+        match l1,l2 with
+	| (b,n), (b',n') -> b == b' && n == n'
+
+      let hash (x, n) = n + Level.hash x
+
+    end
+
+    module HExpr = 
+    struct 
+
+      module H = Hashcons.Make(ExprHash)
+
+      type t = ExprHash.t
+
+      let hcons =
+	Hashcons.simple_hcons H.generate H.hcons Level.hcons
+      let hash = ExprHash.hash
+      let equal x y = x == y ||
+	(let (u,n) = x and (v,n') = y in
+	   Int.equal n n' && Level.equal u v)
+
+    end
+
+    let hcons = HExpr.hcons
+
+    let make l = hcons (l, 0)
+
+    let compare u v =
+      if u == v then 0
+      else 
+	let (x, n) = u and (x', n') = v in
+	  if Int.equal n n' then Level.compare x x'
+	  else n - n'
+
+    let prop = make Level.prop
+    let set = make Level.set
+    let type1 = hcons (Level.set, 1)
+
+    let is_prop = function
+      | (l,0) -> Level.is_prop l
+      | _ -> false
+	
+    let is_small = function
+      | (l,0) -> Level.is_small l
+      | _ -> false
+
+    let equal x y = x == y ||
+      (let (u,n) = x and (v,n') = y in
+	 Int.equal n n' && Level.equal u v)
+
+    let leq (u,n) (v,n') =
+      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)
+	else false
+
+    let successor (u,n) =
+      if Level.is_prop u then type1
+      else hcons (u, n + 1)
+
+    let addn k (u,n as x) = 
+      if k = 0 then x 
+      else if Level.is_prop u then
+	hcons (Level.set,n+k)
+      else hcons (u,n+k)
+	
+    let super (u,n as x) (v,n' as y) =
+      let cmp = Level.compare u v in
+	if Int.equal cmp 0 then 
+	  if n < n' then Inl true
+	  else Inl false
+	else if is_prop x then Inl true
+	else if is_prop y then Inl false
+	else Inr cmp
+
+    let to_string (v, n) =
+      if Int.equal n 0 then Level.to_string v
+      else Level.to_string v ^ "+" ^ string_of_int n
+
+    let pr x = str(to_string x)
+
+    let pr_with f (v, n) = 
+      if Int.equal n 0 then f v
+      else f v ++ str"+" ++ int n
+
+    let is_level = function
+      | (v, 0) -> true
+      | _ -> false
+
+    let level = function
+      | (v,0) -> Some v
+      | _ -> None
+	
+    let get_level (v,n) = v
+
+    let map f (v, n as x) = 
+      let v' = f v in 
+	if v' == v then x
+	else if Level.is_prop v' && n != 0 then
+	  hcons (Level.set, n)
+	else hcons (v', n)
+
+  end
+    
+  let compare_expr = Expr.compare
+
+  module Huniv = HList.Make(Expr.HExpr)
+  type t = Huniv.t
+  open Huniv
+    
+  let equal x y = x == y || 
+    (Huniv.hash x == Huniv.hash y && 
+       Huniv.for_all2 Expr.equal x y)
+
+  let hash = Huniv.hash
+
+  let compare x y =
+    if x == y then 0
+    else 
+      let hx = Huniv.hash x and hy = Huniv.hash y in
+      let c = Int.compare hx hy in 
+	if c == 0 then
+	  Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y
+	else c
+
+  let rec hcons = function
+  | Nil -> Huniv.nil
+  | Cons (x, _, l) -> Huniv.cons x (hcons l)
+
+  let make l = Huniv.tip (Expr.make l)
+  let tip x = Huniv.tip x
+
+  let pr l = match l with
+    | Cons (u, _, Nil) -> Expr.pr u
+    | _ -> 
+      str "max(" ++ hov 0
+	(prlist_with_sep pr_comma Expr.pr (to_list l)) ++
+        str ")"
 
-let pr_uni = function
-  | Atom u ->
-      pr_uni_level u
-  | Max ([],[u]) ->
-      str "(" ++ pr_uni_level u ++ str ")+1"
-  | Max (gel,gtl) ->
+  let pr_with f l = match l with
+    | Cons (u, _, Nil) -> Expr.pr_with f u
+    | _ -> 
       str "max(" ++ hov 0
-       (prlist_with_sep pr_comma pr_uni_level gel ++
-	  (if gel <> [] & gtl <> [] then pr_comma () else mt ()) ++
-	prlist_with_sep pr_comma
-	  (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++
-      str ")"
-
-(* Returns the formal universe that lies juste above the universe variable u.
-   Used to type the sort u. *)
-let super = function
-  | Atom u ->
-      Max ([],[u])
-  | Max _ ->
-      anomaly ("Cannot take the successor of a non variable universe:\n"^
-               "(maybe a bugged tactic)")
-
-(* Returns the formal universe that is greater than the universes u and v.
-   Used to type the products. *)
-let sup u v =
-  match u,v with
-    | Atom u, Atom v ->
-	if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[])
-    | u, Max ([],[]) -> u
-    | Max ([],[]), v -> v
-    | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
-    | Max (gel,gtl), Atom v -> Max (list_add_set v gel,gtl)
-    | Max (gel,gtl), Max (gel',gtl') ->
-	let gel'' = list_union gel gel' in
-	let gtl'' = list_union gtl gtl' in
-	Max (list_subtract gel'' gtl'',gtl'')
+	(prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++
+        str ")"
 
-(* Comparison on this type is pointer equality *)
-type canonical_arc =
-    { univ: UniverseLevel.t;
-      lt: UniverseLevel.t list;
-      le: UniverseLevel.t list;
-      rank: int }
+  let is_level l = match l with
+    | Cons (l, _, Nil) -> Expr.is_level l
+    | _ -> false
 
-let terminal u = {univ=u; lt=[]; le=[]; rank=0}
+  let level l = match l with
+    | Cons (l, _, Nil) -> Expr.level l
+    | _ -> None
 
-(* A UniverseLevel.t is either an alias for another one, or a canonical one,
-   for which we know the universes that are above *)
+  let levels l = 
+    fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty
 
-type univ_entry =
-    Canonical of canonical_arc
-  | Equiv of UniverseLevel.t
+  let is_small u = 
+    match u with
+    | Cons (l, _, Nil) -> Expr.is_small l
+    | _ -> false
 
+  (* The lower predicative level of the hierarchy that contains (impredicative)
+     Prop and singleton inductive types *)
+  let type0m = tip Expr.prop
 
-type universes = univ_entry UniverseLMap.t
+  (* The level of sets *)
+  let type0 = tip Expr.set
 
-let enter_equiv_arc u v g =
-  UniverseLMap.add u (Equiv v) g
+  (* 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 enter_arc ca g =
-  UniverseLMap.add ca.univ (Canonical ca) g
+  let is_type0m x = equal type0m x
+  let is_type0 x = equal type0 x
+
+  (* Returns the formal universe that lies juste above the universe variable u.
+     Used to type the sort u. *)
+  let super l = 
+    if is_small l then type1
+    else
+      Huniv.map (fun x -> Expr.successor x) l
+
+  let addn n l =
+    Huniv.map (fun x -> Expr.addn n x) l
+
+  let rec merge_univs l1 l2 =
+    match l1, l2 with
+    | Nil, _ -> l2
+    | _, Nil -> l1
+    | Cons (h1, _, t1), Cons (h2, _, t2) ->
+      (match Expr.super h1 h2 with
+      | Inl true (* h1 < h2 *) -> merge_univs t1 l2
+      | Inl false -> merge_univs l1 t2
+      | Inr c -> 
+        if c <= 0 (* h1 < h2 is name order *)
+	then cons h1 (merge_univs t1 l2)
+	else cons h2 (merge_univs l1 t2))
+
+  let sort u =
+    let rec aux a l = 
+      match l with
+      | Cons (b, _, l') ->
+        (match Expr.super a b with
+	| Inl false -> aux a l'
+	| Inl true -> l
+	| Inr c ->
+	  if c <= 0 then cons a l
+	  else cons b (aux a l'))
+      | Nil -> cons a l
+    in 
+      fold (fun a acc -> aux a acc) u nil
+	
+  (* Returns the formal universe that is greater than the universes u and v.
+     Used to type the products. *)
+  let sup x y = merge_univs x y
+
+  let empty = nil
+
+  let exists = Huniv.exists
+
+  let for_all = Huniv.for_all
+
+  let smartmap = Huniv.smartmap
 
-(* The lower predicative level of the hierarchy that contains (impredicative)
-   Prop and singleton inductive types *)
-let type0m_univ = Max ([],[])
+end
 
-let is_type0m_univ = function
-  | Max ([],[]) -> true
-  | _ -> false
+type universe = Universe.t
 
 (* The level of predicative Set *)
-let type0_univ = Atom UniverseLevel.Set
+let type0m_univ = Universe.type0m
+let type0_univ = Universe.type0
+let type1_univ = Universe.type1
+let is_type0m_univ = Universe.is_type0m
+let is_type0_univ = Universe.is_type0
+let is_univ_variable l = Universe.level l != None
+let is_small_univ = Universe.is_small
+let pr_uni = Universe.pr
 
-let is_type0_univ = function
-  | Atom UniverseLevel.Set -> true
-  | Max ([UniverseLevel.Set], []) -> msg_warn "Non canonical Set"; true
-  | u -> false
+let sup = Universe.sup
+let super = Universe.super
 
-let is_univ_variable = function
-  | Atom a when a<>UniverseLevel.Set -> true
-  | _ -> false
+open Universe
 
-(* When typing [Prop] and [Set], there is no constraint on the level,
-   hence the definition of [type1_univ], the type of [Prop] *)
+let universe_level = Universe.level
 
-let type1_univ = Max ([], [UniverseLevel.Set])
+type status = Unset | SetLe | SetLt
 
-let initial_universes = UniverseLMap.empty
-let is_initial_universes = UniverseLMap.is_empty
+(* Comparison on this type is pointer equality *)
+type canonical_arc =
+    { univ: Level.t;
+      lt: Level.t list;
+      le: Level.t list;
+      rank : int;
+      predicative : bool;
+      mutable status : status;
+      (** Guaranteed to be unset out of the [compare_neq] functions. It is used
+          to do an imperative traversal of the graph, ensuring a O(1) check that
+          a node has already been visited. Quite performance critical indeed. *)
+    }
+
+let arc_is_le arc = match arc.status with
+| Unset -> false
+| SetLe | SetLt -> true
+
+let arc_is_lt arc = match arc.status with
+| Unset | SetLe -> false
+| SetLt -> true
+
+let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false; status = Unset}
+
+module UMap :
+sig
+  type key = Level.t
+  type +'a t
+  val empty : 'a t
+  val add : key -> 'a -> 'a t -> 'a t
+  val find : key -> 'a t -> 'a
+  val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val iter : (key -> 'a -> unit) -> 'a t -> unit
+  val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+end = HMap.Make(Level)
+
+(* A Level.t is either an alias for another one, or a canonical one,
+   for which we know the universes that are above *)
 
-(* Every UniverseLevel.t has a unique canonical arc representative *)
+type univ_entry =
+    Canonical of canonical_arc
+  | Equiv of Level.t
+
+type universes = univ_entry UMap.t
+
+(** 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 _ arc = match arc with
+  | Equiv _ -> ()
+  | Canonical arc -> arc.status <- Unset
+  in
+  UMap.iter iter g
+
+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
+
+let enter_equiv_arc u v g =
+  UMap.add u (Equiv v) g
+
+let enter_arc ca g =
+  UMap.add ca.univ (Canonical ca) g
 
-(* repr : universes -> UniverseLevel.t -> canonical_arc *)
+(* Every Level.t has a unique canonical arc representative *)
+
+(* repr : universes -> Level.t -> canonical_arc *)
 (* canonical representative : we follow the Equiv links *)
 
 let repr g u =
   let rec repr_rec u =
     let a =
-      try UniverseLMap.find u g
-      with Not_found -> anomalylabstrm "Univ.repr"
-	  (str"Universe " ++ pr_uni_level u ++ str" undefined")
+      try UMap.find u g
+      with Not_found -> anomaly ~label:"Univ.repr"
+	  (str"Universe " ++ Level.pr u ++ str" undefined")
     in
     match a with
       | Equiv v -> repr_rec v
@@ -194,14 +727,12 @@ let repr g u =
   in
   repr_rec u
 
-let can g = List.map (repr g)
-
 (* [safe_repr] also search for the canonical representative, but
    if the graph doesn't contain the searched universe, we add it. *)
 
 let safe_repr g u =
   let rec safe_repr_rec u =
-    match UniverseLMap.find u g with
+    match UMap.find u g with
       | Equiv v -> safe_repr_rec v
       | Canonical arc -> arc
   in
@@ -225,8 +756,8 @@ let reprleq g arcu =
   searchrec [] arcu.le
 
 
-(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *)
-(* between u v = {w|u<=w<=v, w canonical}          *)
+(* between : Level.t -> canonical_arc -> canonical_arc list *)
+(* between u v = { w | u<=w<=v, w canonical }          *)
 (* between is the most costly operation *)
 
 let between g arcu arcv =
@@ -258,10 +789,20 @@ let between g arcu arcv =
    Otherwise, between g u v = []
  *)
 
+type constraint_type = Lt | Le | Eq
+
+type explanation = (constraint_type * universe) list
 
-type order = EQ | LT | LE | NLE
+let constraint_type_ord c1 c2 = match c1, c2 with
+| Lt, Lt -> 0
+| Lt, _ -> -1
+| Le, Lt -> 1
+| Le, Le -> 0
+| Le, Eq -> -1
+| Eq, Eq -> 0
+| Eq, _ -> 1
 
-(** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ?
+(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ?
 
   In [strict] mode, we fully distinguish between LE and LT, while in
   non-strict mode, we simply answer LE for both situations.
@@ -279,46 +820,179 @@ type order = EQ | LT | LE | NLE
   We use depth-first search, but the presence of [arcv] in [new_lt]
   is checked as soon as possible : this seems to be slightly faster
   on a test.
+
+  We do the traversal imperatively, setting the [status] flag on visited nodes.
+  This ensures O(1) check, but it also requires unsetting the flag when leaving
+  the function. Some special care has to be taken in order to ensure we do not
+  recover a messed up graph at the end. This occurs in particular when the
+  traversal raises an exception. Even though the code below is exception-free,
+  OCaml may still raise random exceptions, essentially fatal exceptions or
+  signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note
+  also that the use of an imperative solution does make this function
+  thread-unsafe. For now we do not check universes in different threads, but if
+  ever this is to be done, we would need some lock somewhere.
+
 *)
 
-let compare_neq strict g arcu arcv =
-  let rec cmp c lt_done le_done = function
-  | [],[] -> c
+let get_explanation strict g arcu arcv =
+  (* [c] characterizes whether (and how) arcv has already been related
+     to arcu among the lt_done,le_done universe *)
+  let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
+  | [],[] -> (to_revert, c)
+  | (arc,p)::lt_todo, le_todo ->
+    if arc_is_lt arc then
+      cmp c to_revert lt_todo le_todo
+    else
+      let rec find lt_todo lt le = match le with
+      | [] ->
+        begin match lt with
+        | [] ->
+          let () = arc.status <- SetLt in
+          cmp c (arc :: to_revert) lt_todo le_todo
+        | u :: lt ->
+          let arc = repr g u in
+          let p = (Lt, make u) :: p in
+          if arc == arcv then
+            if strict then (to_revert, p) else (to_revert, p)
+          else find ((arc, p) :: lt_todo) lt le
+        end
+      | u :: le ->
+        let arc = repr g u in
+        let p = (Le, make u) :: p in
+        if arc == arcv then
+          if strict then (to_revert, p) else (to_revert, p)
+        else find ((arc, p) :: lt_todo) lt le
+      in
+      find lt_todo arc.lt arc.le
+  | [], (arc,p)::le_todo ->
+    if arc == arcv then
+      (* No need to continue inspecting universes above arc:
+	 if arcv is strictly above arc, then we would have a cycle.
+         But we cannot answer LE yet, a stronger constraint may
+	 come later from [le_todo]. *)
+      if strict then cmp p to_revert [] le_todo else (to_revert, p)
+    else
+      if arc_is_le arc then
+        cmp c to_revert [] le_todo
+      else
+        let rec find lt_todo lt = match lt with
+        | [] ->
+          let fold accu u =
+            let p = (Le, make u) :: p in
+            let node = (repr g u, p) in
+            node :: accu
+          in
+          let le_new = List.fold_left fold le_todo arc.le in
+          let () = arc.status <- SetLe in
+          cmp c (arc :: to_revert) lt_todo le_new
+        | u :: lt ->
+          let arc = repr g u in
+          let p = (Lt, make u) :: p in
+          if arc == arcv then
+            if strict then (to_revert, p) else (to_revert, p)
+          else find ((arc, p) :: lt_todo) lt
+        in
+        find [] arc.lt
+  in
+  try
+    let (to_revert, c) = cmp [] [] [] [(arcu, [])] in
+    (** Reset all the touched arcs. *)
+    let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
+    List.rev c
+  with e ->
+    (** Unlikely event: fatal error or signal *)
+    let () = cleanup_universes g in
+    raise e
+
+let get_explanation strict g arcu arcv =
+  if !Flags.univ_print then Some (get_explanation strict g arcu arcv)
+  else None
+
+type fast_order = FastEQ | FastLT | FastLE | FastNLE
+
+let fast_compare_neq strict g arcu arcv =
+  (* [c] characterizes whether arcv has already been related
+     to arcu among the lt_done,le_done universe *)
+  let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
+  | [],[] -> (to_revert, c)
   | arc::lt_todo, le_todo ->
-    if List.memq arc lt_done then
-      cmp c lt_done le_done (lt_todo,le_todo)
+    if arc_is_lt arc then
+      cmp c to_revert lt_todo le_todo
     else
-      let lt_new = can g (arc.lt@arc.le) in
-      if List.memq arcv lt_new then
-	if strict then LT else LE
-      else cmp c (arc::lt_done) le_done (lt_new@lt_todo,le_todo)
+      let rec find lt_todo lt le = match le with
+      | [] ->
+        begin match lt with
+        | [] ->
+          let () = arc.status <- SetLt in
+          cmp c (arc :: to_revert) lt_todo le_todo
+        | u :: lt ->
+          let arc = repr g u in
+          if arc == arcv then
+            if strict then (to_revert, FastLT) else (to_revert, FastLE)
+          else find (arc :: lt_todo) lt le
+        end
+      | u :: le ->
+        let arc = repr g u in
+        if arc == arcv then
+          if strict then (to_revert, FastLT) else (to_revert, FastLE)
+        else find (arc :: lt_todo) lt le
+      in
+      find lt_todo arc.lt arc.le
   | [], arc::le_todo ->
     if arc == arcv then
       (* No need to continue inspecting universes above arc:
 	 if arcv is strictly above arc, then we would have a cycle.
          But we cannot answer LE yet, a stronger constraint may
 	 come later from [le_todo]. *)
-      if strict then cmp LE lt_done le_done ([],le_todo) else LE
+      if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE)
     else
-      if (List.memq arc lt_done) || (List.memq arc le_done) then
-	cmp c lt_done le_done ([],le_todo)
+      if arc_is_le arc then
+        cmp c to_revert [] le_todo
       else
-	let lt_new = can g arc.lt in
-	if List.memq arcv lt_new then
-	  if strict then LT else LE
-	else
-	  let le_new = can g arc.le in
-	  cmp c lt_done (arc::le_done) (lt_new, le_new@le_todo)
+        let rec find lt_todo lt = match lt with
+        | [] ->
+          let fold accu u =
+            let node = repr g u in
+            node :: accu
+          in
+          let le_new = List.fold_left fold le_todo arc.le in
+          let () = arc.status <- SetLe in
+          cmp c (arc :: to_revert) lt_todo le_new
+        | u :: lt ->
+          let arc = repr g u in
+          if arc == arcv then
+            if strict then (to_revert, FastLT) else (to_revert, FastLE)
+          else find (arc :: lt_todo) lt
+        in
+        find [] arc.lt
   in
-  cmp NLE [] [] ([],[arcu])
+  try
+    let (to_revert, c) = cmp FastNLE [] [] [arcu] in
+    (** Reset all the touched arcs. *)
+    let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
+    c
+  with e ->
+    (** Unlikely event: fatal error or signal *)
+    let () = cleanup_universes g in
+    raise e
 
-let compare g arcu arcv =
-  if arcu == arcv then EQ else compare_neq true g arcu arcv
+let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv
 
-let is_leq g arcu arcv =
-  arcu == arcv || (compare_neq false g arcu arcv = LE)
+let fast_compare g arcu arcv =
+  if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv
 
-let is_lt g arcu arcv = (compare g arcu arcv = LT)
+let is_leq g arcu arcv =
+  arcu == arcv ||
+    (match fast_compare_neq false g arcu arcv with
+    | FastNLE -> false
+    | (FastEQ|FastLE|FastLT) -> true)
+    
+let is_lt g arcu arcv =
+  if arcu == arcv then false
+  else
+    match fast_compare_neq true g arcu arcv with
+    | FastLT -> true
+    | (FastEQ|FastLE|FastNLE) -> false
 
 (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
                 compare(u,v) = LT or LE => compare(v,u) = NLE
@@ -329,60 +1003,84 @@ let is_lt g arcu arcv = (compare g arcu arcv = LT)
    Adding u>v is consistent iff compare(v,u) = NLE
     and then it is redundant iff compare(u,v) = LT *)
 
-(** * Universe checks [check_eq] and [check_geq], used in coqchk *)
+(** * Universe checks [check_eq] and [check_leq], used in coqchk *)
+
+(** First, checks on universe levels *)
 
-let compare_eq g u v =
+let check_equal g u v =
   let g, arcu = safe_repr g u in
   let _, arcv = safe_repr g v in
   arcu == arcv
 
-type check_function = universes -> universe -> universe -> bool
+let check_eq_level g u v = u == v || check_equal g u v
 
-let incl_list cmp l1 l2 =
-  List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1
+let is_set_arc u = Level.is_set u.univ
+let is_prop_arc u = Level.is_prop u.univ
+let get_prop_arc g = snd (safe_repr g Level.prop)
 
-let compare_list cmp l1 l2 =
-  incl_list cmp l1 l2 && incl_list cmp l2 l1
-
-let rec check_eq g u v =
-  match (u,v) with
-    | Atom ul, Atom vl -> compare_eq g ul vl
-    | Max(ule,ult), Max(vle,vlt) ->
-        (* TODO: remove elements of lt in le! *)
-        compare_list (compare_eq g) ule vle &&
-        compare_list (compare_eq g) ult vlt
-    | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
-
-let compare_greater g strict u v =
+let check_smaller g strict u v =
   let g, arcu = safe_repr g u in
   let g, arcv = safe_repr g v in
   if strict then
-    is_lt g arcv arcu
+    is_lt g arcu arcv
   else
-    arcv == snd (safe_repr g UniverseLevel.Set) || is_leq g arcv arcu
-
-(*
-let compare_greater g strict u v =
-  let b = compare_greater g strict u v in
-  ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
-  b
-*)
-let check_geq g u v =
-  match u, v with
-    | Atom ul, Atom vl -> compare_greater g false ul vl
-    | Atom ul, Max(le,lt) ->
-        List.for_all (fun vl -> compare_greater g false ul vl) le &&
-        List.for_all (fun vl -> compare_greater g true ul vl) lt
-    | _ -> anomaly "check_greater"
+    is_prop_arc arcu 
+    || (is_set_arc arcu && arcv.predicative) 
+    || is_leq g arcu arcv
+
+(** Then, checks on universes *)
+
+type 'a check_function = universes -> 'a -> 'a -> bool
+
+let check_equal_expr g x y =
+  x == y || (let (u, n) = x and (v, m) = y in 
+	       Int.equal n m && check_equal g u v)
+
+let check_eq_univs g l1 l2 =
+  let f x1 x2 = check_equal_expr g x1 x2 in
+  let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in
+    Huniv.for_all (fun x1 -> exists x1 l2) l1
+    && Huniv.for_all (fun x2 -> exists x2 l1) l2
+
+let check_eq g u v =
+  Universe.equal u v || check_eq_univs g u v
+
+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
+    | _ -> false
+
+let exists_bigger g ul l =
+  Huniv.exists (fun ul' -> 
+    check_smaller_expr g ul ul') l
+
+let real_check_leq g u v =
+  Huniv.for_all (fun ul -> exists_bigger g ul v) u
+    
+let check_leq g u v =
+  Universe.equal u v ||
+    Universe.is_type0m u ||
+    check_eq_univs g u v || real_check_leq g u v
 
 (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
 
-(* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(** To speed up tests of Set </<= i *)
+let set_predicative g arcv = 
+  enter_arc {arcv with predicative = true} g
+
+(* setlt : Level.t -> Level.t -> reason -> unit *)
 (* forces u > v *)
 (* this is normally an update of u in g rather than a creation. *)
 let setlt g arcu arcv =
   let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
-  enter_arc arcu' g, arcu'
+  let g = 
+    if is_set_arc arcu then set_predicative g arcv
+    else g
+  in
+    enter_arc arcu' g, arcu'
 
 (* checks that non-redundant *)
 let setlt_if (g,arcu) v =
@@ -390,13 +1088,17 @@ let setlt_if (g,arcu) v =
   if is_lt g arcu arcv then g, arcu
   else setlt g arcu arcv
 
-(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(* setleq : Level.t -> Level.t -> unit *)
 (* forces u >= v *)
 (* this is normally an update of u in g rather than a creation. *)
 let setleq g arcu arcv =
   let arcu' = {arcu with le=arcv.univ::arcu.le} in
-  enter_arc arcu' g, arcu'
-
+  let g = 
+    if is_set_arc arcu' then
+      set_predicative g arcv
+    else g
+  in
+    enter_arc arcu' g, arcu'
 
 (* checks that non-redundant *)
 let setleq_if (g,arcu) v =
@@ -404,32 +1106,32 @@ let setleq_if (g,arcu) v =
   if is_leq g arcu arcv then g, arcu
   else setleq g arcu arcv
 
-(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(* merge : Level.t -> Level.t -> unit *)
 (* we assume  compare(u,v) = LE *)
 (* merge u v  forces u ~ v with repr u as canonical repr *)
 let merge g arcu arcv =
   (* we find the arc with the biggest rank, and we redirect all others to it *)
   let arcu, g, v =
     let best_ranked (max_rank, old_max_rank, best_arc, rest) arc =
-      if arc.rank >= max_rank
+      if Level.is_small arc.univ || arc.rank >= max_rank
       then (arc.rank, max_rank, arc, best_arc::rest)
       else (max_rank, old_max_rank, best_arc, arc::rest)
     in
-    match between g arcu arcv with
-      | [] -> anomaly "Univ.between"
+      match between g arcu arcv with
+      | [] -> anomaly (str "Univ.between")
       | arc::rest ->
         let (max_rank, old_max_rank, best_arc, rest) =
           List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in
-        if max_rank > old_max_rank then best_arc, g, rest
-        else begin
-          (* one redirected node also has max_rank *)
-          let arcu = {best_arc with rank = max_rank + 1} in
-          arcu, enter_arc arcu g, rest
-        end
+          if max_rank > old_max_rank then best_arc, g, rest
+          else begin
+              (* one redirected node also has max_rank *)
+            let arcu = {best_arc with rank = max_rank + 1} in
+	      arcu, enter_arc arcu g, rest
+          end 
   in
   let redirect (g,w,w') arcv =
     let g' = enter_equiv_arc arcv.univ arcu.univ g in
-    (g',list_unionq arcv.lt w,arcv.le@w')
+    (g',List.unionq arcv.lt w,arcv.le@w')
   in
   let (g',w,w') = List.fold_left redirect (g,[],[]) v in
   let g_arcu = (g',arcu) in
@@ -437,13 +1139,13 @@ let merge g arcu arcv =
   let g_arcu = List.fold_left setleq_if g_arcu w' in
   fst g_arcu
 
-(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(* merge_disc : Level.t -> Level.t -> unit *)
 (* we assume  compare(u,v) = compare(v,u) = NLE *)
 (* merge_disc u v  forces u ~ v with repr u as canonical repr *)
 let merge_disc g arc1 arc2 =
   let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in
   let arcu, g = 
-    if arc1.rank <> arc2.rank then arcu, g
+    if not (Int.equal arc1.rank arc2.rank) then arcu, g
     else
       let arcu = {arcu with rank = succ arcu.rank} in 
       arcu, enter_arc arcu g
@@ -457,107 +1159,241 @@ let merge_disc g arc1 arc2 =
 (* Universe inconsistency: error raised when trying to enforce a relation
    that would create a cycle in the graph of universes. *)
 
-type constraint_type = Lt | Le | Eq
+type univ_inconsistency = constraint_type * universe * universe * explanation option
 
-exception UniverseInconsistency of constraint_type * universe * universe
+exception UniverseInconsistency of univ_inconsistency
 
-let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v))
+let error_inconsistency o u v (p:explanation option) =
+  raise (UniverseInconsistency (o,make u,make v,p))
+
+(* enforc_univ_eq : Level.t -> Level.t -> unit *)
+(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
 
-(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *)
+let enforce_univ_eq u v g =
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+    match fast_compare g arcu arcv with
+    | FastEQ -> g
+    | FastLT ->
+      let p = get_explanation_strict g arcu arcv in
+      error_inconsistency Eq v u p
+    | FastLE -> merge g arcu arcv
+    | FastNLE ->
+      (match fast_compare g arcv arcu with
+      | FastLT ->
+        let p = get_explanation_strict g arcv arcu in
+        error_inconsistency Eq u v p
+      | FastLE -> merge g arcv arcu
+      | FastNLE -> merge_disc g arcu arcv
+      | FastEQ -> anomaly (Pp.str "Univ.compare"))
+
+(* enforce_univ_leq : Level.t -> Level.t -> unit *)
 (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
 let enforce_univ_leq u v g =
   let g,arcu = safe_repr g u in
   let g,arcv = safe_repr g v in
   if is_leq g arcu arcv then g
-  else match compare g arcv arcu with
-    | LT -> error_inconsistency Le u v
-    | LE -> merge g arcv arcu
-    | NLE -> fst (setleq g arcu arcv)
-    | EQ -> anomaly "Univ.compare"
-
-(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *)
-(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
-let enforce_univ_eq u v g =
-  let g,arcu = safe_repr g u in
-  let g,arcv = safe_repr g v in
-  match compare g arcu arcv with
-    | EQ -> g
-    | LT -> error_inconsistency Eq u v
-    | LE -> merge g arcu arcv
-    | NLE ->
-	(match compare g arcv arcu with
-           | LT -> error_inconsistency Eq u v
-           | LE -> merge g arcv arcu
-           | NLE -> merge_disc g arcu arcv
-           | EQ -> anomaly "Univ.compare")
+  else
+    match fast_compare g arcv arcu with
+    | FastLT ->
+      let p = get_explanation_strict g arcv arcu in
+      error_inconsistency Le u v p
+    | FastLE  -> merge g arcv arcu
+    | FastNLE -> fst (setleq g arcu arcv)
+    | FastEQ -> anomaly (Pp.str "Univ.compare")
 
 (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
 let enforce_univ_lt u v g =
   let g,arcu = safe_repr g u in
   let g,arcv = safe_repr g v in
-  match compare g arcu arcv with
-    | LT -> g
-    | LE -> fst (setlt g arcu arcv)
-    | EQ -> error_inconsistency Lt u v
-    | NLE ->
-      if is_leq g arcv arcu then error_inconsistency Lt u v
-      else fst (setlt g arcu arcv)
-
-(* Constraints and sets of consrtaints. *)
-
-type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t
+    match fast_compare g arcu arcv with
+    | FastLT -> g
+    | FastLE -> fst (setlt g arcu arcv)
+    | FastEQ -> error_inconsistency Lt u v (Some [(Eq,make v)])
+    | FastNLE ->
+      match fast_compare_neq false g arcv arcu with
+	FastNLE -> fst (setlt g arcu arcv)
+      | FastEQ -> anomaly (Pp.str "Univ.compare")
+      | (FastLE|FastLT) ->
+        let p = get_explanation false g arcv arcu  in
+        error_inconsistency Lt u v p
+
+let empty_universes = UMap.empty
+
+(* Prop = Set is forbidden here. *)
+let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty
+
+let is_initial_universes g = UMap.equal (==) g initial_universes
+
+let add_universe vlev g = 
+  let v = terminal vlev in
+  let proparc = get_prop_arc g in
+    enter_arc {proparc with le=vlev::proparc.le}
+      (enter_arc v g)
+      
+(* Constraints and sets of constraints. *)    
+
+type univ_constraint = Level.t * constraint_type * Level.t
 
 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 pr_constraint_type op = 
+  let op_str = match op with
+    | Lt -> " < "
+    | Le -> " <= "
+    | Eq -> " = "
+  in str op_str
+
+module UConstraintOrd =
+struct
+  type t = univ_constraint
+  let compare (u,c,v) (u',c',v') =
+    let i = constraint_type_ord c c' in
+    if not (Int.equal i 0) then i
+    else
+      let i' = Level.compare u u' in
+      if not (Int.equal i' 0) then i'
+      else Level.compare v v'
+end
 
-module Constraint = Set.Make(
-  struct
-    type t = univ_constraint
-    let compare (u,c,v) (u',c',v') =
-      let i = Pervasives.compare c c' in
-      if i <> 0 then i
-      else
-	let i' = UniverseLevel.compare u u' in
-	if i' <> 0 then i'
-	else UniverseLevel.compare v v'
-  end)
+module Constraint = 
+struct 
+  module S = Set.Make(UConstraintOrd)
+  include S
 
-type constraints = Constraint.t
+  let pr prl c =
+    fold (fun (u1,op,u2) pp_std ->
+      pp_std ++ prl u1 ++ pr_constraint_type op ++
+	prl u2 ++ fnl () )  c (str "")
+
+end
 
 let empty_constraint = Constraint.empty
-let is_empty_constraint = Constraint.is_empty
+let union_constraint = Constraint.union
+let eq_constraint = Constraint.equal
+let merge_constraints c g =
+  Constraint.fold enforce_constraint c g
 
-let union_constraints = Constraint.union
+type constraints = Constraint.t
 
-type constraint_function =
-    universe -> universe -> constraints -> constraints
+module Hconstraint =
+  Hashcons.Make(
+    struct
+      type t = univ_constraint
+      type u = universe_level -> universe_level
+      let hashcons hul (l1,k,l2) = (hul l1, k, hul l2)
+      let equal (l1,k,l2) (l1',k',l2') =
+	l1 == l1' && k == k' && l2 == l2'
+      let hash = Hashtbl.hash
+    end)
 
-let constraint_add_leq v u c =
-  if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c
+module Hconstraints =
+  Hashcons.Make(
+    struct
+      type t = constraints
+      type u = univ_constraint -> univ_constraint
+      let hashcons huc s =
+	Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
+      let equal s s' =
+	List.for_all2eq (==)
+	  (Constraint.elements s)
+	  (Constraint.elements s')
+      let hash = Hashtbl.hash
+    end)
+
+let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate Hconstraint.hcons Level.hcons
+let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate Hconstraints.hcons hcons_constraint
+
+
+(** A value with universe constraints. *)
+type 'a constrained = 'a * constraints
+
+let constraints_of (_, cst) = cst
 
-let enforce_geq u v c =
-  match u, v with
-  | Atom u, Atom v -> constraint_add_leq v u c
-  | Atom u, Max (gel,gtl) ->
-      let d = List.fold_right (fun v -> constraint_add_leq v u) gel c in
-      List.fold_right (fun v -> Constraint.add (v,Lt,u)) gtl d
-  | _ -> anomaly "A universe bound can only be a variable"
+(** Constraint functions. *)
+
+type 'a constraint_function = 'a -> 'a -> constraints -> constraints
+
+let enforce_eq_level u v c =
+  (* We discard trivial constraints like u=u *)
+  if Level.equal u v then c 
+  else if Level.apart u v then
+    error_inconsistency Eq u v None
+  else Constraint.add (u,Eq,v) c
 
 let enforce_eq u v c =
-  match (u,v) with
-    | Atom u, Atom v -> Constraint.add (u,Eq,v) c
-    | _ -> anomaly "A universe comparison can only happen between variables"
+  match Universe.level u, Universe.level v with
+    | Some u, Some v -> enforce_eq_level u v c
+    | _ -> anomaly (Pp.str "A universe comparison can only happen between variables")
 
-let merge_constraints c g =
-  Constraint.fold enforce_constraint c g
+let check_univ_eq u v = Universe.equal u v
+
+let enforce_eq u v c =
+  if check_univ_eq u v then c
+  else 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 
+    match v, u with
+    | (x,n), (y,m) -> 
+    let j = m - n in
+      if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then
+	Constraint.add (x,Lt,y) c
+      else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then
+	if Level.equal x y then (* u+(k+1) <= u *)
+	  raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, None))
+	else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints")
+      else if j = 0 then
+	Constraint.add (x,Le,y) c
+      else (* j >= 1 *) (* m = n + k, u <= v+k *)
+	if Level.equal x y then c (* u <= u+k, trivial *)
+	else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *)
+	else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints")
+	  
+let check_univ_leq_one u v = Universe.exists (Expr.leq u) v
+
+let check_univ_leq u v = 
+  Universe.for_all (fun u -> check_univ_leq_one u v) u
+
+let enforce_leq u v c =
+  let open Universe.Huniv in
+  match v with
+  | Cons (v, _, Nil) ->
+    fold (fun u -> constraint_add_leq u v) u c
+  | _ -> anomaly (Pp.str"A universe bound can only be a variable")
+
+let enforce_leq u v c =
+  if check_univ_leq u v then c
+  else enforce_leq u v c
+
+let enforce_leq_level u v c =
+  if Level.equal u v then c else Constraint.add (u,Le,v) c
+
+let check_constraint g (l,d,r) =
+  match d with
+  | Eq -> check_equal g l r
+  | Le -> check_smaller g false l r
+  | Lt -> check_smaller g true l r
+
+let check_constraints c g =
+  Constraint.for_all (check_constraint g) c
+
+let enforce_univ_constraint (u,d,v) =
+  match d with
+  | Eq -> enforce_eq u v
+  | Le -> enforce_leq u v
+  | Lt -> enforce_leq (super u) v
 
 (* Normalization *)
 
 let lookup_level u g =
-  try Some (UniverseLMap.find u g) with Not_found -> None
+  try Some (UMap.find u g) with Not_found -> None
 
 (** [normalize_universes g] returns a graph where all edges point
     directly to the canonical representent of their target. The output
@@ -571,20 +1407,20 @@ let normalize_universes g =
     | Some x -> x, cache
     | None -> match Lazy.force arc with
     | None ->
-      u, UniverseLMap.add u u cache
+      u, UMap.add u u cache
     | Some (Canonical {univ=v; lt=_; le=_}) ->
-      v, UniverseLMap.add u v cache
+      v, UMap.add u v cache
     | Some (Equiv v) ->
       let v, cache = visit v (lazy (lookup_level v g)) cache in
-      v, UniverseLMap.add u v cache
+      v, UMap.add u v cache
   in
-  let cache = UniverseLMap.fold
+  let cache = UMap.fold
     (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
-    g UniverseLMap.empty
+    g UMap.empty
   in
-  let repr x = UniverseLMap.find x cache in
+  let repr x = UMap.find x cache in
   let lrepr us = List.fold_left
-    (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us
+    (fun e x -> LSet.add (repr x) e) LSet.empty us
   in
   let canonicalize u = function
     | Equiv _ -> Equiv (repr u)
@@ -592,355 +1428,674 @@ let normalize_universes g =
       assert (u == v);
       (* avoid duplicates and self-loops *)
       let lt = lrepr lt and le = lrepr le in
-      let le = UniverseLSet.filter
-        (fun x -> x != u && not (UniverseLSet.mem x lt)) le
+      let le = LSet.filter
+        (fun x -> x != u && not (LSet.mem x lt)) le
       in
-      UniverseLSet.iter (fun x -> assert (x != u)) lt;
+      LSet.iter (fun x -> assert (x != u)) lt;
       Canonical {
         univ = v;
-        lt = UniverseLSet.elements lt;
-        le = UniverseLSet.elements le;
-	rank = rank
+        lt = LSet.elements lt;
+        le = LSet.elements le;
+	rank = rank;
+	predicative = false;
+	status = Unset;
       }
   in
-  UniverseLMap.mapi canonicalize g
-
-(** [check_sorted g sorted]: [g] being a universe graph, [sorted]
-    being a map to levels, checks that all constraints in [g] are
-    satisfied in [sorted]. *)
-let check_sorted g sorted =
-  let get u = try UniverseLMap.find u sorted with
-    | Not_found -> assert false
-  in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with
-    | Equiv v -> assert (lu = get v)
-    | Canonical {univ=u'; lt=lt; le=le} ->
-      assert (u == u');
-      List.iter (fun v -> assert (lu <= get v)) le;
-      List.iter (fun v -> assert (lu < get v)) lt) g
-
-(**
-  Bellman-Ford algorithm with a few customizations:
-    - [weight(eq|le) = 0], [weight(lt) = -1]
-    - a [le] edge is initially added from [bottom] to all other
-      vertices, and [bottom] is used as the source vertex
-*)
-let bellman_ford bottom g =
-  assert (lookup_level bottom g = None);
-  let ( << ) a b = match a, b with
-    | _, None -> true
-    | None, _ -> false
-    | Some x, Some y -> x < y
-  and ( ++ ) a y = match a with
-    | None -> None
-    | Some x -> Some (x-y)
-  and push u x m = match x with
-    | None -> m
-    | Some y -> UniverseLMap.add u y m
+  UMap.mapi canonicalize g
+
+let constraints_of_universes g =
+  let constraints_of u v acc =
+    match v with
+    | Canonical {univ=u; lt=lt; le=le} ->
+      let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in
+      let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in
+	acc
+    | Equiv v -> Constraint.add (u,Eq,v) acc
   in
-  let relax u v uv distances =
-    let x = lookup_level u distances ++ uv in
-    if x << lookup_level v distances then push v x distances
-    else distances
+  UMap.fold constraints_of g Constraint.empty
+
+let constraints_of_universes g =
+  constraints_of_universes (normalize_universes g)
+
+(** Longest path algorithm. This is used to compute the minimal number of
+    universes required if the only strict edge would be the Lt one. This
+    algorithm assumes that the given universes constraints are a almost DAG, in
+    the sense that there may be {Eq, Le}-cycles. This is OK for consistent
+    universes, which is the only case where we use this algorithm. *)
+
+(** Adjacency graph *)
+type graph = constraint_type LMap.t LMap.t
+
+exception Connected
+
+(** Check connectedness *)
+let connected x y (g : graph) =
+  let rec connected x target seen g =
+    if Level.equal x target then raise Connected
+    else if not (LSet.mem x seen) then
+      let seen = LSet.add x seen in
+      let fold z _ seen = connected z target seen g in
+      let neighbours = try LMap.find x g with Not_found -> LMap.empty in
+      LMap.fold fold neighbours seen
+    else seen
   in
-  let init = UniverseLMap.add bottom 0 UniverseLMap.empty in
-  let vertices = UniverseLMap.fold (fun u arc res ->
-    let res = UniverseLSet.add u res in
-    match arc with
-      | Equiv e -> UniverseLSet.add e res
-      | Canonical {univ=univ; lt=lt; le=le} ->
-        assert (u == univ);
-        let add res v = UniverseLSet.add v res in
-        let res = List.fold_left add res le in
-        let res = List.fold_left add res lt in
-        res) g UniverseLSet.empty
+  try ignore(connected x y LSet.empty g); false with Connected -> true
+
+let add_edge x y v (g : graph) =
+  try
+    let neighbours = LMap.find x g in
+    let neighbours = LMap.add y v neighbours in
+    LMap.add x neighbours g
+  with Not_found ->
+    LMap.add x (LMap.singleton y v) g
+
+(** We want to keep the graph DAG. If adding an edge would cause a cycle, that
+    would necessarily be an {Eq, Le}-cycle, otherwise there would have been a
+    universe inconsistency. Therefore we may omit adding such a cycling edge
+    without changing the compacted graph. *)
+let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g
+
+(** Construct the DAG and its inverse at the same time. *)
+let make_graph g : (graph * graph) =
+  let fold u arc accu = match arc with
+  | Equiv v ->
+    let (dir, rev) = accu in
+    (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev)
+  | Canonical { univ; lt; le; } ->
+    let () = assert (u == univ) in
+    let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in
+    let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in
+    (** Order is important : lt after le, because of the possible redundancy
+        between [le] and [lt] in a canonical arc. This way, the [lt] constraint
+        is the last one set, which is correct because it implies [le]. *)
+    let accu = List.fold_left fold_le accu le in
+    let accu = List.fold_left fold_lt accu lt in
+    accu
   in
-  let g =
-    let node = Canonical {
-      univ = bottom;
-      lt = [];
-      le = UniverseLSet.elements vertices;
-      rank = 0
-    } in UniverseLMap.add bottom node g
+  UMap.fold fold g (LMap.empty, LMap.empty)
+
+(** Construct a topological order out of a DAG. *)
+let rec topological_fold u g rem seen accu =
+  let is_seen =
+    try
+      let status = LMap.find u seen in
+      assert status; (** If false, not a DAG! *)
+      true
+    with Not_found -> false
   in
-  let rec iter count accu =
-    if count <= 0 then
-      accu
-    else
-      let accu = UniverseLMap.fold (fun u arc res -> match arc with
-        | Equiv e -> relax e u 0 (relax u e 0 res)
-        | Canonical {univ=univ; lt=lt; le=le} ->
-          assert (u == univ);
-          let res = List.fold_left (fun res v -> relax u v 0 res) res le in
-          let res = List.fold_left (fun res v -> relax u v 1 res) res lt in
-          res) g accu
-      in iter (count-1) accu
+  if not is_seen then
+    let rem = LMap.remove u rem in
+    let seen = LMap.add u false seen in
+    let neighbours = try LMap.find u g with Not_found -> LMap.empty in
+    let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in
+    let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in
+    (rem, LMap.add u true seen, u :: accu)
+  else (rem, seen, accu)
+
+let rec topological g rem seen accu =
+  let node = try Some (LMap.choose rem) with Not_found -> None in
+  match node with
+  | None -> accu
+  | Some (u, _) ->
+    let rem, seen, accu = topological_fold u g rem seen accu in
+    topological g rem seen accu
+
+(** Compute the longest path from any vertex. *)
+let constraint_cost = function
+| Eq | Le -> 0
+| Lt -> 1
+
+(** This algorithm browses the graph in topological order, computing for each
+    encountered node the length of the longest path leading to it. Should be
+    O(|V|) or so (modulo map representation). *)
+let rec flatten_graph rem (rev : graph) map mx = match rem with
+| [] -> map, mx
+| u :: rem ->
+  let prev = try LMap.find u rev with Not_found -> LMap.empty in
+  let fold v cstr accu =
+    let v_cost = LMap.find v map in
+    max (v_cost + constraint_cost cstr) accu
   in
-  let distances = iter (UniverseLSet.cardinal vertices) init in
-  let () = UniverseLMap.iter (fun u arc ->
-    let lu = lookup_level u distances in match arc with
-      | Equiv v ->
-        let lv = lookup_level v distances in
-        assert (not (lu << lv) && not (lv << lu))
-      | Canonical {univ=univ; lt=lt; le=le} ->
-        assert (u == univ);
-        List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le;
-        List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g
-  in distances
+  let u_cost = LMap.fold fold prev 0 in
+  let map = LMap.add u u_cost map in
+  flatten_graph rem rev map (max mx u_cost)
 
 (** [sort_universes g] builds a map from universes in [g] to natural
     numbers. It outputs a graph containing equivalence edges from each
     level appearing in [g] to [Type.n], and [lt] edges between the
     [Type.n]s. The output graph should imply the input graph (and the
+    [Type.n]s. The output graph should imply the input graph (and the
     implication will be strict most of the time), but is not
     necessarily minimal. Note: the result is unspecified if the input
     graph already contains [Type.n] nodes (calling a module Type is
     probably a bad idea anyway). *)
 let sort_universes orig =
-  let mp = Names.make_dirpath [Names.id_of_string "Type"] in
-  let rec make_level accu g i =
-    let type0 = UniverseLevel.Level (mp, i) in
-    let distances = bellman_ford type0 g in
-    let accu, continue = UniverseLMap.fold (fun u x (accu, continue) ->
-      let continue = continue || x < 0 in
-      let accu =
-        if x = 0 && u != type0 then UniverseLMap.add u i accu
-        else accu
-      in accu, continue) distances (accu, false)
-    in
-    let filter x = not (UniverseLMap.mem x accu) in
-    let push g u =
-      if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g
-    in
-    let g = UniverseLMap.fold (fun u arc res -> match arc with
-      | Equiv v as x ->
-        begin match filter u, filter v with
-          | true, true -> UniverseLMap.add u x res
-          | true, false -> push res u
-          | false, true -> push res v
-          | false, false -> res
-        end
-      | Canonical {univ=v; lt=lt; le=le; rank=r} ->
-        assert (u == v);
-        if filter u then
-          let lt = List.filter filter lt in
-          let le = List.filter filter le in
-          UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res
-        else
-          let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in
-          let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in
-          res) g UniverseLMap.empty
-    in
-    if continue then make_level accu g (i+1) else i, accu
+  let (dir, rev) = make_graph orig in
+  let order = topological dir dir LMap.empty [] in
+  let compact, max = flatten_graph order rev LMap.empty 0 in
+  let mp = Names.DirPath.make [Names.Id.of_string "Type"] in
+  let types = Array.init (max + 1) (fun n -> Level.make mp n) in
+  (** Old universes are made equal to [Type.n] *)
+  let fold u level accu = UMap.add u (Equiv types.(level)) accu in
+  let sorted = LMap.fold fold compact UMap.empty in
+  (** Add all [Type.n] nodes *)
+  let fold i accu u =
+    if 0 < i then
+      let pred = types.(i - 1) in
+      let arc = {univ = u; lt = [pred]; le = []; rank = 0; predicative = false; status = Unset; } in
+      UMap.add u (Canonical arc) accu
+    else accu
   in
-  let max, levels = make_level UniverseLMap.empty orig 0 in
-  (* defensively check that the result makes sense *)
-  check_sorted orig levels;
-  let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in
-  let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in
-  let g =
-    let rec aux i g =
-      if i < max then
-        let u = types.(i) in
-        let g = UniverseLMap.add u (Canonical {
-          univ = u;
-          le = [];
-          lt = [types.(i+1)];
-	  rank = 1
-        }) g in aux (i+1) g
-      else g
-    in aux 0 g
-  in g
+  Array.fold_left_i fold sorted types
+
+(* Miscellaneous functions to remove or test local univ assumed to
+   occur in a universe *)
+
+let univ_level_mem u v = Huniv.mem (Expr.make u) v
+
+let univ_level_rem u v min = 
+  match Universe.level v with
+  | Some u' -> if Level.equal u u' then min else v
+  | None -> Huniv.remove (Universe.Expr.make u) v
 
+(* Is u mentionned in v (or equals to v) ? *)
+
+
+(**********************************************************************)
+(** Universe polymorphism                                             *)
 (**********************************************************************)
-(* Tools for sort-polymorphic inductive types                         *)
 
-(* Temporary inductive type levels *)
+(** A universe level substitution, note that no algebraic universes are
+    involved *)
 
-let fresh_level =
-  let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n)
+type universe_level_subst = universe_level universe_map
 
-let fresh_local_univ () = Atom (fresh_level ())
+(** A full substitution might involve algebraic universes *)
+type universe_subst = universe universe_map
 
-(* Miscellaneous functions to remove or test local univ assumed to
-   occur only in the le constraints *)
+let level_subst_of f = 
+  fun l -> 
+    try let u = f l in 
+	  match Universe.level u with
+	  | None -> l
+	  | Some l -> l
+    with Not_found -> l
+     
+module Instance : sig 
+    type t = Level.t array
+
+    val empty : t
+    val is_empty : t -> bool
+      
+    val of_array : Level.t array -> t
+    val to_array : t -> Level.t array
 
-let make_max = function
-  | ([u],[]) -> Atom u
-  | (le,lt) -> Max (le,lt)
+    val append : t -> t -> t
+    val equal : t -> t -> bool
+    val length : t -> int
 
-let remove_large_constraint u = function
-  | Atom u' as x -> if u = u' then Max ([],[]) else x
-  | Max (le,lt) -> make_max (list_remove u le,lt)
+    val hcons : t -> t
+    val hash : t -> int
 
-let is_direct_constraint u = function
-  | Atom u' -> u = u'
-  | Max (le,lt) -> List.mem u le
+    val share : t -> t * int
 
-(*
-   Solve a system of universe constraint of the form
+    val subst_fn : universe_level_subst_fn -> t -> t
+    
+    val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+    val levels : t -> LSet.t
+    val check_eq : t check_function 
+end = 
+struct
+  type t = Level.t array
 
-   u_s11, ..., u_s1p1, w1 <= u1
-   ...
-   u_sn1, ..., u_snpn, wn <= un
+  let empty : t = [||]
 
-where
+  module HInstancestruct =
+  struct
+    type _t = t
+    type t = _t
+    type u = Level.t -> Level.t
+
+    let hashcons huniv a = 
+      let len = Array.length a in
+	if Int.equal len 0 then empty
+	else begin
+	  for i = 0 to len - 1 do
+	    let x = Array.unsafe_get a i in
+	    let x' = huniv x in
+	      if x == x' then ()
+	      else Array.unsafe_set a i x'
+	  done;
+	  a
+	end
+
+    let equal t1 t2 =
+      t1 == t2 ||
+	(Int.equal (Array.length t1) (Array.length t2) &&
+	   let rec aux i =
+	     (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1))
+	   in aux 0)
+	
+    let hash a = 
+      let accu = ref 0 in
+	for i = 0 to Array.length a - 1 do
+	  let l = Array.unsafe_get a i in
+	  let h = Level.hash l in
+	    accu := Hashset.Combine.combine !accu h;
+	done;
+	(* [h] must be positive. *)
+	let h = !accu land 0x3FFFFFFF in
+	  h
+  end
+
+  module HInstance = Hashcons.Make(HInstancestruct)
+
+  let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons
+    
+  let hash = HInstancestruct.hash
+    
+  let share a = (hcons a, hash a)
+	      
+  let empty = hcons [||]
+
+  let is_empty x = Int.equal (Array.length x) 0
+
+  let append x y =
+    if Array.length x = 0 then y
+    else if Array.length y = 0 then x 
+    else Array.append x y
+
+  let of_array a = a
+
+  let to_array a = a
+
+  let length a = Array.length a
+
+  let subst_fn fn t = 
+    let t' = CArray.smartmap fn t in
+      if t' == t then t else t'
+
+  let levels x = LSet.of_array x
+
+  let pr =
+    prvect_with_sep spc
+
+  let equal t u = 
+    t == u ||
+      (Array.is_empty t && Array.is_empty u) ||
+      (CArray.for_all2 Level.equal t u 
+	 (* Necessary as universe instances might come from different modules and 
+	    unmarshalling doesn't preserve sharing *))
+
+  let check_eq g t1 t2 =
+    t1 == t2 ||
+      (Int.equal (Array.length t1) (Array.length t2) &&
+	 let rec aux i =
+	   (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1))
+	 in aux 0)
 
-  - the ui (1 <= i <= n) are universe variables,
-  - the sjk select subsets of the ui for each equations,
-  - the wi are arbitrary complex universes that do not mention the ui.
+end
+
+let enforce_eq_instances x y = 
+  let ax = Instance.to_array x and ay = Instance.to_array y in
+    if Array.length ax != Array.length ay then
+      anomaly (Pp.(++) (Pp.str "Invalid argument: enforce_eq_instances called with")
+		 (Pp.str " instances of different lengths"));
+    CArray.fold_right2 enforce_eq_level ax ay
+
+type universe_instance = Instance.t
+
+type 'a puniverses = 'a * Instance.t
+let out_punivs (x, y) = x
+let in_punivs x = (x, Instance.empty)
+let eq_puniverses f (x, u) (y, u') =
+  f x y && Instance.equal u u'
+
+(** A context of universe levels with universe constraints,
+    representiong local universe variables and constraints *)
+
+module UContext =
+struct
+  type t = Instance.t constrained
+
+  let make x = x
+
+  (** Universe contexts (variables as a list) *)
+  let empty = (Instance.empty, Constraint.empty)
+  let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst
+
+  let pr prl (univs, cst as ctx) =
+    if is_empty ctx then mt() else
+      Instance.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst)
+
+  let hcons (univs, cst) =
+    (Instance.hcons univs, hcons_constraints cst)
+
+  let instance (univs, cst) = univs
+  let constraints (univs, cst) = cst
+
+  let union (univs, cst) (univs', cst') =
+    Instance.append univs univs', Constraint.union cst cst'
+      
+  let dest x = x
+end
+
+type universe_context = UContext.t
+let hcons_universe_context = UContext.hcons
+
+(** A set of universes with universe constraints.
+    We linearize the set to a list after typechecking. 
+    Beware, representation could change.
 *)
 
-let is_direct_sort_constraint s v = match s with
-  | Some u -> is_direct_constraint u v
-  | None -> false
-
-let solve_constraints_system levels level_bounds =
-  let levels =
-    Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom"))
-      levels in
-  let v = Array.copy level_bounds in
-  let nind = Array.length v in
-  for i=0 to nind-1 do
-    for j=0 to nind-1 do
-      if i<>j & is_direct_sort_constraint levels.(j) v.(i) then
-	v.(i) <- sup v.(i) level_bounds.(j)
-    done;
-    for j=0 to nind-1 do
-      match levels.(j) with
-      | Some u -> v.(i) <- remove_large_constraint u v.(i)
-      | None -> ()
-    done
-  done;
-  v
-
-let subst_large_constraint u u' v =
-  match u with
-  | Atom u ->
-      if is_direct_constraint u v then sup u' (remove_large_constraint u v)
-      else v
-  | _ ->
-      anomaly "expect a universe level"
-
-let subst_large_constraints =
-  List.fold_right (fun (u,u') -> subst_large_constraint u u')
-
-let no_upper_constraints u cst =
-  match u with
-  | Atom u -> Constraint.for_all (fun (u1,_,_) -> u1 <> u) cst
-  | Max _ -> anomaly "no_upper_constraints"
+module ContextSet =
+struct
+  type t = universe_set constrained
 
-(* Is u mentionned in v (or equals to v) ? *)
+  let empty = (LSet.empty, Constraint.empty)
+  let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst
+
+  let of_set s = (s, Constraint.empty)
+  let singleton l = of_set (LSet.singleton l)
+  let of_instance i = of_set (Instance.levels i)
 
-let univ_depends u v =
-  match u, v with
-    | Atom u, Atom v -> u = v
-    | Atom u, Max (gel,gtl) -> List.mem u gel || List.mem u gtl
-    | _ -> anomaly "univ_depends given a non-atomic 1st arg"
+  let union (univs, cst as x) (univs', cst' as y) =
+    if x == y then x
+    else LSet.union univs univs', Constraint.union cst cst'
 
-(* Pretty-printing *)
+  let append (univs, cst) (univs', cst') =
+    let univs = LSet.fold LSet.add univs univs' in
+    let cst = Constraint.fold Constraint.add cst cst' in
+    (univs, cst)
 
-let pr_arc = function
+  let diff (univs, cst) (univs', cst') =
+    LSet.diff univs univs', Constraint.diff cst cst'
+
+  let add_universe u (univs, cst) =
+    LSet.add u univs, cst
+
+  let add_constraints cst' (univs, cst) =
+    univs, Constraint.union cst cst'
+
+  let add_instance inst (univs, cst) =
+    let v = Instance.to_array inst in
+    let fold accu u = LSet.add u accu in
+    let univs = Array.fold_left fold univs v in
+    (univs, cst)
+
+  let sort_levels a = 
+    Array.sort Level.natural_compare a; a
+
+  let to_context (ctx, cst) =
+    (Instance.of_array (sort_levels (Array.of_list (LSet.elements ctx))), cst)
+
+  let of_context (ctx, cst) =
+    (Instance.levels ctx, cst)
+
+  let pr prl (univs, cst as ctx) =
+    if is_empty ctx then mt() else
+      LSet.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst)
+
+  let constraints (univs, cst) = cst
+  let levels (univs, cst) = univs
+
+end
+
+type universe_context_set = ContextSet.t
+
+(** A value in a universe context (resp. context set). *)
+type 'a in_universe_context = 'a * universe_context
+type 'a in_universe_context_set = 'a * universe_context_set
+
+(** Substitutions. *)
+
+let empty_subst = LMap.empty
+let is_empty_subst = LMap.is_empty
+
+let empty_level_subst = LMap.empty
+let is_empty_level_subst = LMap.is_empty
+
+(** Substitution functions *)
+
+(** With level to level substitutions. *)
+let subst_univs_level_level subst l =
+  try LMap.find l subst
+  with Not_found -> l
+
+let subst_univs_level_universe subst u =
+  let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in
+  let u' = Universe.smartmap f u in
+    if u == u' then u
+    else Universe.sort u'
+
+let subst_univs_level_instance subst i =
+  let i' = Instance.subst_fn (subst_univs_level_level subst) i in
+    if i == i' then i
+    else i'
+	
+let subst_univs_level_constraint subst (u,d,v) =
+  let u' = subst_univs_level_level subst u 
+  and v' = subst_univs_level_level subst v in
+    if d != Lt && Level.equal u' v' then None
+    else Some (u',d,v')
+
+let subst_univs_level_constraints subst csts =
+  Constraint.fold 
+    (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c))
+    csts Constraint.empty 
+
+(** With level to universe substitutions. *)
+type universe_subst_fn = universe_level -> universe
+
+let make_subst subst = fun l -> LMap.find l subst
+
+let subst_univs_expr_opt fn (l,n) =
+  Universe.addn n (fn l)
+
+let subst_univs_universe fn ul =
+  let subst, nosubst = 
+    Universe.Huniv.fold (fun u (subst,nosubst) -> 
+      try let a' = subst_univs_expr_opt fn u in
+	    (a' :: subst, nosubst)
+      with Not_found -> (subst, u :: nosubst))
+      ul ([], [])
+  in 
+    if CList.is_empty subst then ul
+    else 
+      let substs = 
+	List.fold_left Universe.merge_univs Universe.empty subst
+      in
+	List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u))
+	  substs nosubst
+
+let subst_univs_level fn l = 
+  try Some (fn l)
+  with Not_found -> None
+
+let subst_univs_constraint fn (u,d,v as c) cstrs =
+  let u' = subst_univs_level fn u in
+  let v' = subst_univs_level fn v in
+  match u', v' with
+  | None, None -> Constraint.add c cstrs
+  | Some u, None -> enforce_univ_constraint (u,d,make v) cstrs
+  | None, Some v -> enforce_univ_constraint (make u,d,v) cstrs
+  | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs
+
+let subst_univs_constraints subst csts =
+  Constraint.fold 
+    (fun c cstrs -> subst_univs_constraint subst c cstrs)
+    csts Constraint.empty 
+
+let subst_instance_level s l =
+  match l.Level.data with
+  | Level.Var n -> s.(n) 
+  | _ -> l
+
+let subst_instance_instance s i = 
+  Array.smartmap (fun l -> subst_instance_level s l) i
+
+let subst_instance_universe s u =
+  let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in
+  let u' = Universe.smartmap f u in
+    if u == u' then u
+    else Universe.sort u'
+
+let subst_instance_constraint s (u,d,v as c) =
+  let u' = subst_instance_level s u in
+  let v' = subst_instance_level s v in
+    if u' == u && v' == v then c
+    else (u',d,v')
+
+let subst_instance_constraints s csts =
+  Constraint.fold 
+    (fun c csts -> Constraint.add (subst_instance_constraint s c) csts)
+    csts Constraint.empty 
+
+(** Substitute instance inst for ctx in csts *)
+let instantiate_univ_context (ctx, csts) = 
+  (ctx, subst_instance_constraints ctx csts)
+
+let instantiate_univ_constraints u (_, csts) = 
+  subst_instance_constraints u csts
+
+let make_instance_subst i = 
+  let arr = Instance.to_array i in
+    Array.fold_left_i (fun i acc l ->
+      LMap.add l (Level.var i) acc)
+      LMap.empty arr
+
+let make_inverse_instance_subst i = 
+  let arr = Instance.to_array i in
+    Array.fold_left_i (fun i acc l ->
+      LMap.add (Level.var i) l acc)
+      LMap.empty arr
+
+let abstract_universes poly ctx =
+  let instance = UContext.instance ctx in
+    if poly then
+      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
+	subst, ctx
+    else empty_level_subst, ctx
+
+(** Pretty-printing *)
+
+let pr_arc prl = function
   | _, Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
   | _, Canonical {univ=u; lt=lt; le=le} ->
-      pr_uni_level u ++ str " " ++
+      let opt_sep = match lt, le with
+      | [], _ | _, [] -> mt ()
+      | _ -> spc ()
+      in
+      prl u ++ str " " ++
       v 0
-        (prlist_with_sep pr_spc (fun v -> str "< " ++ pr_uni_level v) lt ++
-	 (if lt <> [] & le <> [] then spc () else mt()) ++
-         prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++
+        (pr_sequence (fun v -> str "< " ++ prl v) lt ++
+	 opt_sep ++
+         pr_sequence (fun v -> str "<= " ++ prl v) le) ++
       fnl ()
   | u, Equiv v ->
-      pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
+      prl u  ++ str " = " ++ prl v ++ fnl ()
 
-let pr_universes g =
-  let graph = UniverseLMap.fold (fun u a l -> (u,a)::l) g [] in
-  prlist pr_arc graph
+let pr_universes prl g =
+  let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in
+  prlist (pr_arc prl) graph
 
-let pr_constraints c =
-  Constraint.fold (fun (u1,op,u2) pp_std ->
-		     let op_str = match op with
-		       | Lt -> " < "
-		       | Le -> " <= "
-		       | Eq -> " = "
-		     in pp_std ++  pr_uni_level u1 ++ str op_str ++
-			  pr_uni_level u2 ++ fnl () )  c (str "")
+let pr_constraints prl = Constraint.pr prl
+
+let pr_universe_context = UContext.pr
+
+let pr_universe_context_set = ContextSet.pr
+
+let pr_universe_subst = 
+  LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ())
+
+let pr_universe_level_subst = 
+  LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ())
 
 (* Dumping constraints to a file *)
 
 let dump_universes output g =
   let dump_arc u = function
     | Canonical {univ=u; lt=lt; le=le} ->
-	let u_str = UniverseLevel.to_string u in
-	List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt;
-	List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le
+	let u_str = Level.to_string u in
+	List.iter (fun v -> output Lt (Level.to_string v) u_str) lt;
+	List.iter (fun v -> output Le (Level.to_string v) u_str) le
     | Equiv v ->
-      output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v)
+      output Eq (Level.to_string u) (Level.to_string v)
   in
-    UniverseLMap.iter dump_arc g
-
-(* Hash-consing *)
-
-module Hunivlevel =
-  Hashcons.Make(
-    struct
-      type t = universe_level
-      type u = Names.dir_path -> Names.dir_path
-      let hash_sub hdir = function
-	| UniverseLevel.Set -> UniverseLevel.Set
-	| UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n)
-      let equal l1 l2 = match l1,l2 with
-	| UniverseLevel.Set, UniverseLevel.Set -> true
-	| UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') ->
-	  n == n' && d == d'
-	| _ -> false
-      let hash = Hashtbl.hash
-    end)
+  UMap.iter dump_arc g
 
-module Huniv =
+module Huniverse_set = 
   Hashcons.Make(
     struct
-      type t = universe
+      type t = universe_set
       type u = universe_level -> universe_level
-      let hash_sub hdir = function
-	| Atom u -> Atom (hdir u)
-	| Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl)
-      let equal u v =
-	match u, v with
-	  | Atom u, Atom v -> u == v
-	  | Max (gel,gtl), Max (gel',gtl') ->
-	      (list_for_all2eq (==) gel gel') &&
-              (list_for_all2eq (==) gtl gtl')
-	  | _ -> false
+      let hashcons huc s =
+	LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty
+      let equal s s' =
+	LSet.equal s s'
       let hash = Hashtbl.hash
     end)
 
-let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath
-let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel
+let hcons_universe_set = 
+  Hashcons.simple_hcons Huniverse_set.generate Huniverse_set.hcons Level.hcons
 
-module Hconstraint =
-  Hashcons.Make(
-    struct
-      type t = univ_constraint
-      type u = universe_level -> universe_level
-      let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2)
-      let equal (l1,k,l2) (l1',k',l2') =
-	l1 == l1' && k = k' && l2 == l2'
-      let hash = Hashtbl.hash
-    end)
+let hcons_universe_context_set (v, c) = 
+  (hcons_universe_set v, hcons_constraints c)
 
-module Hconstraints =
-  Hashcons.Make(
-    struct
-      type t = constraints
-      type u = univ_constraint -> univ_constraint
-      let hash_sub huc s =
-	Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
-      let equal s s' =
-	list_for_all2eq (==)
-	  (Constraint.elements s)
-	  (Constraint.elements s')
-      let hash = Hashtbl.hash
-    end)
+let hcons_univ x = Universe.hcons x
 
-let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel
-let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint
+let explain_universe_inconsistency prl (o,u,v,p) =
+  let pr_uni = Universe.pr_with prl in
+  let pr_rel = function
+    | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" 
+  in
+  let reason = match p with
+    | None | Some [] -> mt()
+    | Some p ->
+      str " because" ++ spc() ++ pr_uni v ++
+	prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v)
+	p ++
+	(if Universe.equal (snd (List.last p)) u then mt() else
+	    (spc() ++ str "= " ++ pr_uni u)) 
+  in
+    str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++
+      pr_rel o ++ spc() ++ pr_uni v ++ reason ++ str")"
+
+let compare_levels = Level.compare
+let eq_levels = Level.equal
+let equal_universes = Universe.equal
+
+
+let subst_instance_constraints = 
+  if Flags.profile then 
+    let key = Profile.declare_profile "subst_instance_constraints" in
+      Profile.profile2 key subst_instance_constraints
+  else subst_instance_constraints
+
+let merge_constraints = 
+  if Flags.profile then 
+    let key = Profile.declare_profile "merge_constraints" in
+      Profile.profile2 key merge_constraints
+  else merge_constraints
+let check_constraints =
+  if Flags.profile then
+    let key = Profile.declare_profile "check_constraints" in
+      Profile.profile2 key check_constraints
+  else check_constraints
+
+let check_eq = 
+  if Flags.profile then
+    let check_eq_key = Profile.declare_profile "check_eq" in
+      Profile.profile3 check_eq_key check_eq
+  else check_eq
+
+let check_leq = 
+  if Flags.profile then 
+    let check_leq_key = Profile.declare_profile "check_leq" in
+      Profile.profile3 check_leq_key check_leq
+  else check_leq
diff --git a/kernel/univ.mli b/kernel/univ.mli
index d6a9b56f..7aaf2ffe 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,60 +8,189 @@
 
 (** Universes. *)
 
-type universe_level
-type universe
+module Level :
+sig
+  type t
+  (** Type of universe levels. A universe level is essentially a unique name
+      that will be associated to constraints later on. *)
 
-module UniverseLSet : Set.S with type elt = universe_level
+  val set : t
+  val prop : t
+  (** The set and prop universe levels. *)
 
-(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... 
-   Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
+  val is_small : t -> bool
+  (** Is the universe set or prop? *)
+
+  val compare : t -> t -> int
+  (** Comparison function *)
+
+  val equal : t -> t -> bool
+  (** Equality function *)
+
+  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 pr : t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+
+  val var : int -> t
+
+  val var_index : t -> int option
+end
+
+type universe_level = Level.t
+(** Alias name. *)
+
+(** Sets of universe levels *)
+module LSet : 
+sig 
+  include CSig.SetS with type elt = universe_level
+	      
+  val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+end
+
+type universe_set = LSet.t
+
+module Universe :
+sig
+  type t
+  (** Type of universes. A universe is defined as a set of level expressions.
+      A level expression is built from levels and successors of level expressions, i.e.:
+      le ::= l + n, n \in N.
+
+      A universe is said atomic if it consists of a single level expression with
+      no increment, and algebraic otherwise (think the least upper bound of a set of
+      level expressions).
+  *)
 
-val type0m_univ : universe  (** image of Prop in the universes hierarchy *)
-val type0_univ : universe  (** image of Set in the universes hierarchy *)
-val type1_univ : universe  (** the universe of the type of Prop/Set *)
+  val compare : t -> t -> int
+  (** Comparison function *)
 
-val make_universe_level : Names.dir_path * int -> universe_level
-val make_universe : universe_level -> universe
-val make_univ : Names.dir_path * int -> universe
+  val equal : t -> t -> bool
+  (** Equality function on formal universes *)
+
+  val hash : t -> int
+  (** Hash function *)
+
+  val make : Level.t -> t
+  (** Create a universe representing the given level. *)
+
+  val pr : t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+
+  val pr_with : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+
+  val is_level : t -> bool
+  (** Test if the universe is a level or an algebraic universe. *)
+
+  val level : t -> Level.t option
+  (** Try to get a level out of a universe, returns [None] if it
+      is an algebraic universe. *)
+
+  val levels : t -> LSet.t
+  (** Get the levels inside the universe, forgetting about increments *)
+
+  val super : t -> t
+  (** The universe strictly above *)
+    
+  val sup   : t -> t -> t
+  (** The l.u.b. of 2 universes *)
+
+  val type0m : t  
+  (** image of Prop in the universes hierarchy *)
+  
+  val type0 : t  
+  (** image of Set in the universes hierarchy *)
+  
+  val type1 : t 
+  (** the universe of the type of Prop/Set *)
+end
+
+type universe = Universe.t
+
+(** Alias name. *)
+
+val pr_uni : universe -> Pp.std_ppcmds
+	      
+(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... 
+   Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
+val type0m_univ : universe
+val type0_univ : universe
+val type1_univ : universe
 
 val is_type0_univ : universe -> bool
 val is_type0m_univ : universe -> bool
 val is_univ_variable : universe -> bool
+val is_small_univ : universe -> bool
+
+val sup : universe -> universe -> universe
+val super : universe -> universe
 
 val universe_level : universe -> universe_level option
-val compare_levels : universe_level -> universe_level -> int
 
-(** The type of a universe *)
-val super : universe -> universe
+(** [univ_level_mem l u] Is l is mentionned in u ? *)
+
+val univ_level_mem : universe_level -> universe -> bool
 
-(** The max of 2 universes *)
-val sup   : universe -> universe -> universe
+(** [univ_level_rem u v min] removes [u] from [v], resulting in [min]
+    if [v] was exactly [u]. *)
+
+val univ_level_rem : universe_level -> universe -> universe -> universe
 
 (** {6 Graphs of universes. } *)
 
 type universes
 
-type check_function = universes -> universe -> universe -> bool
-val check_geq : check_function
-val check_eq : check_function
+type 'a check_function = universes -> 'a -> 'a -> bool
+val check_leq : universe check_function
+val check_eq : universe check_function
 
 (** The empty graph of universes *)
+val empty_universes : universes
+
+(** The initial graph of universes: Prop < Set *)
 val initial_universes : universes
+
 val is_initial_universes : universes -> bool
 
+val sort_universes : universes -> universes
+
+(** Adds a universe to the graph, ensuring it is >= Prop. *)
+val add_universe : universe_level -> universes -> universes
+
 (** {6 Constraints. } *)
 
-type constraints
+type constraint_type = Lt | Le | Eq
+type univ_constraint = universe_level * constraint_type * universe_level
+
+module Constraint : sig
+ include Set.S with type elt = univ_constraint
+end
+
+type constraints = Constraint.t
 
 val empty_constraint : constraints
-val union_constraints : constraints -> constraints -> constraints
+val union_constraint : constraints -> constraints -> constraints
+val eq_constraint : constraints -> constraints -> bool
+
+(** A value with universe constraints. *)
+type 'a constrained = 'a * constraints
 
-val is_empty_constraint : constraints -> bool
+(** Constrained *)
+val constraints_of : 'a constrained -> constraints
 
-type constraint_function = universe -> universe -> constraints -> constraints
+(** Enforcing constraints. *)
 
-val enforce_geq : constraint_function
-val enforce_eq : constraint_function
+type 'a constraint_function = 'a -> 'a -> constraints -> constraints
+
+val enforce_eq : universe constraint_function
+val enforce_leq : universe constraint_function
+val enforce_eq_level : universe_level constraint_function
+val enforce_leq_level : universe_level constraint_function
 
 (** {6 ... } *)
 (** Merge of constraints in a universes graph.
@@ -69,38 +198,231 @@ val enforce_eq : constraint_function
   universes graph. It raises the exception [UniverseInconsistency] if the
   constraints are not satisfiable. *)
 
-type constraint_type = Lt | Le | Eq
+(** Type explanation is used to decorate error messages to provide
+  useful explanation why a given constraint is rejected. It is composed
+  of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means
+   .. <(r1) u1 <(r2) ... <(rn) un (where <(ri) is the relation symbol
+  denoted by ri, currently only < and <=). The lowest end of the chain
+  is supposed known (see UniverseInconsistency exn). The upper end may
+  differ from the second univ of UniverseInconsistency because all
+  universes in the path are canonical. Note that each step does not
+  necessarily correspond to an actual constraint, but reflect how the
+  system stores the graph and may result from combination of several
+  constraints...
+*)
+type explanation = (constraint_type * universe) list
+type univ_inconsistency = constraint_type * universe * universe * explanation option
+
+exception UniverseInconsistency of univ_inconsistency
+
+val enforce_constraint : univ_constraint -> universes -> universes
+val merge_constraints : constraints -> universes -> universes
 
-exception UniverseInconsistency of constraint_type * universe * universe
+val constraints_of_universes : universes -> constraints
 
-val merge_constraints : constraints -> universes -> universes
-val normalize_universes : universes -> universes
-val sort_universes : universes -> universes
+val check_constraint  : universes -> univ_constraint -> bool
+val check_constraints : constraints -> universes -> bool
+
+(** {6 Support for universe polymorphism } *)
+
+(** Polymorphic maps from universe levels to 'a *)
+module LMap : 
+sig
+  include CMap.ExtS with type key = universe_level and module Set := LSet
+
+  val union : 'a t -> 'a t -> 'a t
+  (** [union x y] favors the bindings in the first map. *)
+
+  val diff : 'a t -> 'a t -> 'a t
+  (** [diff x y] removes bindings from x that appear in y (whatever the value). *)
 
-(** {6 Support for sort-polymorphic inductive types } *)
+  val subst_union : 'a option t -> 'a option t -> 'a option t
+  (** [subst_union x y] favors the bindings of the first map that are [Some],
+      otherwise takes y's bindings. *)
 
-val fresh_local_univ : unit -> universe
+  val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+end
 
-val solve_constraints_system : universe option array -> universe array ->
-  universe array
+type 'a universe_map = 'a LMap.t
 
-val subst_large_constraint : universe -> universe -> universe -> universe
+(** {6 Substitution} *)
 
-val subst_large_constraints :
-  (universe * universe) list -> universe -> universe
+type universe_subst_fn = universe_level -> universe
+type universe_level_subst_fn = universe_level -> universe_level
 
-val no_upper_constraints : universe -> constraints -> bool
+(** A full substitution, might involve algebraic universes *)
+type universe_subst = universe universe_map
+type universe_level_subst = universe_level universe_map
 
-(** Is u mentionned in v (or equals to v) ? *)
+val level_subst_of : universe_subst_fn -> universe_level_subst_fn
 
-val univ_depends : universe -> universe -> bool
+(** {6 Universe instances} *)
+
+module Instance : 
+sig
+  type t
+  (** A universe instance represents a vector of argument universes
+      to a polymorphic definition (constant, inductive or constructor). *)
+
+  val empty : t
+  val is_empty : t -> bool
+
+  val of_array : Level.t array -> t
+  val to_array : t -> Level.t array
+
+  val append : t -> t -> t
+  (** To concatenate two instances, used for discharge *)
+
+  val equal : t -> t -> bool
+  (** Equality *)
+
+  val length : t -> int
+  (** Instance length *)
+
+  val hcons : t -> t
+  (** Hash-consing. *)
+
+  val hash : t -> int
+  (** Hash value *)
+
+  val share : t -> t * int
+  (** Simultaneous hash-consing and hash-value computation *)
+
+  val subst_fn : universe_level_subst_fn -> t -> t
+  (** Substitution by a level-to-level function. *)
+
+  val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+  (** Pretty-printing, no comments *)
+
+  val levels : t -> LSet.t
+  (** The set of levels in the instance *)
+
+  val check_eq : t check_function 
+  (** Check equality of instances w.r.t. a universe graph *)
+end
+
+type universe_instance = Instance.t
+
+val enforce_eq_instances : universe_instance constraint_function
+
+type 'a puniverses = 'a * universe_instance
+val out_punivs : 'a puniverses -> 'a
+val in_punivs : 'a -> 'a puniverses
+
+val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool
+
+(** A vector of universe levels with universe constraints,
+    representiong local universe variables and associated constraints *)
+
+module UContext :
+sig 
+  type t
+
+  val make : Instance.t constrained -> t
+
+  val empty : t
+  val is_empty : t -> bool
+    
+  val instance : t -> Instance.t
+  val constraints : t -> constraints
+
+  val dest : t -> Instance.t * constraints
+
+  (** Keeps the order of the instances *)
+  val union : t -> t -> t
+
+end
+
+type universe_context = UContext.t
+
+(** Universe contexts (as sets) *)
+
+module ContextSet :
+sig 
+  type t = universe_set constrained
+
+  val empty : t
+  val is_empty : t -> bool
+
+  val singleton : universe_level -> t
+  val of_instance : Instance.t -> t
+  val of_set : universe_set -> t
+
+  val union : t -> t -> t
+
+  val append : t -> t -> t
+  (** Variant of {!union} which is more efficient when the left argument is
+      much smaller than the right one. *)
+
+  val diff : t -> t -> t
+  val add_universe : universe_level -> t -> t
+  val add_constraints : constraints -> t -> t
+  val add_instance : Instance.t -> t -> t
+
+  (** Arbitrary choice of linear order of the variables *)
+  val to_context : t -> universe_context
+  val of_context : universe_context -> t
+
+  val constraints : t -> constraints
+  val levels : t -> universe_set
+end
+
+(** A set of universes with universe constraints.
+    We linearize the set to a list after typechecking. 
+    Beware, representation could change.
+*)
+type universe_context_set = ContextSet.t
+
+(** A value in a universe context (resp. context set). *)
+type 'a in_universe_context = 'a * universe_context
+type 'a in_universe_context_set = 'a * universe_context_set
+
+val empty_level_subst : universe_level_subst
+val is_empty_level_subst : universe_level_subst -> bool
+
+(** Substitution of universes. *)
+val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level
+val subst_univs_level_universe : universe_level_subst -> universe -> universe
+val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints
+val subst_univs_level_instance : universe_level_subst -> universe_instance -> universe_instance
+
+(** Level to universe substitutions. *)
+
+val empty_subst : universe_subst
+val is_empty_subst : universe_subst -> bool
+val make_subst : universe_subst -> universe_subst_fn
+
+val subst_univs_universe : universe_subst_fn -> universe -> universe
+val subst_univs_constraints : universe_subst_fn -> constraints -> constraints
+
+(** Substitution of instances *)
+val subst_instance_instance : universe_instance -> universe_instance -> universe_instance
+val subst_instance_universe : universe_instance -> universe -> universe
+val subst_instance_constraints : universe_instance -> constraints -> constraints
+
+val make_instance_subst : universe_instance -> universe_level_subst
+val make_inverse_instance_subst : universe_instance -> universe_level_subst
+
+val abstract_universes : bool -> universe_context -> universe_level_subst * universe_context
+
+(** Get the instantiated graph. *)
+val instantiate_univ_context : universe_context -> universe_context
+
+val instantiate_univ_constraints : universe_instance -> universe_context -> constraints
 
 (** {6 Pretty-printing of universes. } *)
 
-val pr_uni_level : universe_level -> Pp.std_ppcmds
-val pr_uni : universe -> Pp.std_ppcmds
-val pr_universes : universes -> Pp.std_ppcmds
-val pr_constraints : constraints -> Pp.std_ppcmds
+val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds
+val pr_constraint_type : constraint_type -> Pp.std_ppcmds
+val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds
+val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds
+val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> universe_context_set -> Pp.std_ppcmds
+val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> 
+  univ_inconsistency -> Pp.std_ppcmds
+
+val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds
+val pr_universe_subst : universe_subst -> Pp.std_ppcmds
 
 (** {6 Dumping to a file } *)
 
@@ -110,6 +432,17 @@ val dump_universes :
 
 (** {6 Hash-consing } *)
 
-val hcons_univlevel : universe_level -> universe_level
 val hcons_univ : universe -> universe
 val hcons_constraints : constraints -> constraints
+val hcons_universe_set : universe_set -> universe_set
+val hcons_universe_context : universe_context -> universe_context
+val hcons_universe_context_set : universe_context_set -> universe_context_set 
+
+(******)
+
+(* deprecated: use qualified names instead *)
+val compare_levels : universe_level -> universe_level -> int
+val eq_levels : universe_level -> universe_level -> bool
+
+(** deprecated: Equality of formal universe expressions. *)
+val equal_universes : universe -> universe -> bool
diff --git a/kernel/vars.ml b/kernel/vars.ml
new file mode 100644
index 00000000..88c1e103
--- /dev/null
+++ b/kernel/vars.ml
@@ -0,0 +1,341 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Esubst
+open Context
+
+(*********************)
+(*     Occurring     *)
+(*********************)
+
+exception LocalOccur
+
+(* (closedn n M) raises FreeVar if a variable of height greater than n
+   occurs in M, returns () otherwise *)
+
+let closedn n c =
+  let rec closed_rec n c = match Constr.kind c with
+    | Constr.Rel m -> if m>n then raise LocalOccur
+    | _ -> Constr.iter_with_binders succ closed_rec n c
+  in
+  try closed_rec n c; true with LocalOccur -> false
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+
+let closed0 c = closedn 0 c
+
+(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
+
+let noccurn n term =
+  let rec occur_rec n c = match Constr.kind c with
+    | Constr.Rel m -> if Int.equal m n then raise LocalOccur
+    | _ -> Constr.iter_with_binders succ occur_rec n c
+  in
+  try occur_rec n term; true with LocalOccur -> false
+
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M
+  for n <= p < n+m *)
+
+let noccur_between n m term =
+  let rec occur_rec n c = match Constr.kind c with
+    | Constr.Rel p -> if n<=p && p<n+m then raise LocalOccur
+    | _        -> Constr.iter_with_binders succ occur_rec n c
+  in
+  try occur_rec n term; true with LocalOccur -> false
+
+(* Checking function for terms containing existential variables.
+ The function [noccur_with_meta] considers the fact that
+ each existential variable (as well as each isevar)
+ in the term appears applied to its local context,
+ which may contain the CoFix variables. These occurrences of CoFix variables
+ are not considered *)
+
+let isMeta c = match Constr.kind c with
+| Constr.Meta _ -> true
+| _ -> false
+
+let noccur_with_meta n m term =
+  let rec occur_rec n c = match Constr.kind c with
+    | Constr.Rel p -> if n<=p && p<n+m then raise LocalOccur
+    | Constr.App(f,cl) ->
+        (match Constr.kind f with
+           | Constr.Cast (c,_,_) when isMeta c -> ()
+           | Constr.Meta _ -> ()
+           | _ -> Constr.iter_with_binders succ occur_rec n c)
+    | Constr.Evar (_, _) -> ()
+    | _ -> Constr.iter_with_binders succ occur_rec n c
+  in
+  try (occur_rec n term; true) with LocalOccur -> false
+
+(*********************)
+(*      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
+
+(*********************)
+(*   Substituting    *)
+(*********************)
+
+(* (subst1 M c) substitutes M for Rel(1) in c
+   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
+   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
+
+(* 1st : general case *)
+
+type info = Closed | Open | Unknown
+type 'a substituend = { mutable sinfo: info; sit: 'a }
+
+let lift_substituend depth s =
+  match s.sinfo with
+    | Closed -> s.sit
+    | Open -> lift depth s.sit
+    | Unknown ->
+      let sit = s.sit in
+      if closed0 sit then
+        let () = s.sinfo <- Closed in
+        sit
+      else
+        let () = s.sinfo <- Open in
+        lift depth sit
+
+let make_substituend c = { sinfo=Unknown; sit=c }
+
+let substn_many lamv n c =
+  let lv = Array.length lamv in
+  if Int.equal lv 0 then c
+  else
+    let rec substrec depth c = match Constr.kind c with
+      | Constr.Rel k     ->
+          if k<=depth then c
+          else if k-depth <= lv then lift_substituend depth (Array.unsafe_get lamv (k-depth-1))
+          else Constr.mkRel (k-lv)
+      | _ -> Constr.map_with_binders succ substrec depth c in
+    substrec n c
+
+(*
+let substkey = Profile.declare_profile "substn_many";;
+let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;;
+*)
+
+let make_subst = function
+| [] -> [||]
+| hd :: tl ->
+  let len = List.length tl in
+  let subst = Array.make (1 + len) (make_substituend hd) in
+  let s = ref tl in
+  for i = 1 to len do
+    match !s with
+    | [] -> assert false
+    | x :: tl ->
+      Array.unsafe_set subst i (make_substituend x);
+      s := tl
+  done;
+  subst
+
+let substnl laml n c = substn_many (make_subst laml) n c
+let substl laml c = substn_many (make_subst laml) 0 c
+let subst1 lam c = substn_many [|make_substituend lam|] 0 c
+
+let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r
+let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r
+let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r
+
+let substnl_named_decl laml k d =
+  map_named_declaration (fun c -> substnl laml k c) d
+let substl_named_decl laml d =
+  map_named_declaration (fun c -> substnl laml 0 c) d
+let subst1_named_decl lam d =
+  map_named_declaration (fun c -> subst1 lam c) d
+
+(* (thin_val sigma) removes identity substitutions from sigma *)
+
+let rec thin_val = function
+  | [] -> []
+  | (id, c) :: tl ->
+    match Constr.kind c with
+    | Constr.Var v ->
+      if Id.equal id v then thin_val tl
+      else (id, make_substituend c) :: (thin_val tl)
+    | _ -> (id, make_substituend c) :: (thin_val tl)
+
+let rec find_var id = function
+| [] -> raise Not_found
+| (idc, c) :: subst ->
+  if Id.equal id idc then c
+  else find_var id subst
+
+(* (replace_vars sigma M) applies substitution sigma to term M *)
+let replace_vars var_alist x =
+  let var_alist = thin_val var_alist in
+  match var_alist with
+  | [] -> x
+  | _ ->
+    let rec substrec n c = match Constr.kind c with
+    | Constr.Var x ->
+      (try lift_substituend n (find_var x var_alist)
+      with Not_found -> c)
+    | _ -> Constr.map_with_binders succ substrec n c
+    in
+    substrec 0 x
+
+(*
+let repvarkey = Profile.declare_profile "replace_vars";;
+let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;;
+*)
+
+(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
+let subst_var str t = replace_vars [(str, Constr.mkRel 1)] t
+
+(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *)
+let substn_vars p vars c =
+  let _,subst =
+    List.fold_left (fun (n,l) var -> ((n+1),(var,Constr.mkRel n)::l)) (p,[]) vars
+  in replace_vars (List.rev subst) c
+
+let subst_vars subst c = substn_vars 1 subst c
+
+(** Universe substitutions *)
+open Constr
+
+let subst_univs_fn_puniverses fn =
+  let f = Univ.Instance.subst_fn fn in
+    fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u')
+
+let subst_univs_fn_constr f c =
+  let changed = ref false in
+  let fu = Univ.subst_univs_universe f in
+  let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in
+  let rec aux t = 
+    match kind t with
+    | Sort (Sorts.Type u) -> 
+      let u' = fu u in
+	if u' == u then t else 
+	  (changed := true; mkSort (Sorts.sort_of_univ u'))
+    | Const (c, u) -> 
+      let u' = fi u in 
+	if u' == u then t
+	else (changed := true; mkConstU (c, u'))
+    | Ind (i, u) ->
+      let u' = fi u in 
+	if u' == u then t
+	else (changed := true; mkIndU (i, u'))
+    | Construct (c, u) ->
+      let u' = fi u in 
+	if u' == u then t
+	else (changed := true; mkConstructU (c, u'))
+    | _ -> map aux t
+  in 
+  let c' = aux c in
+    if !changed then c' else c
+
+let subst_univs_constr subst c =
+  if Univ.is_empty_subst subst then c
+  else 
+    let f = Univ.make_subst subst in
+      subst_univs_fn_constr f c
+
+let subst_univs_constr = 
+  if Flags.profile then
+    let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" in
+      Profile.profile2 subst_univs_constr_key subst_univs_constr
+  else subst_univs_constr
+
+let subst_univs_level_constr subst c =
+  if Univ.is_empty_level_subst subst then c
+  else 
+    let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in
+    let changed = ref false in
+    let rec aux t = 
+      match kind t with
+      | Const (c, u) -> 
+	if Univ.Instance.is_empty u then t
+	else 
+          let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; mkConstU (c, u'))
+      | Ind (i, u) ->
+	if Univ.Instance.is_empty u then t
+	else 
+	  let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; mkIndU (i, u'))
+      | Construct (c, u) ->
+	if Univ.Instance.is_empty u then t
+	else 
+          let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; mkConstructU (c, u'))
+      | Sort (Sorts.Type u) -> 
+         let u' = Univ.subst_univs_level_universe subst u in
+	   if u' == u then t else 
+	     (changed := true; mkSort (Sorts.sort_of_univ u'))
+      | _ -> Constr.map aux t
+    in
+    let c' = aux c in
+      if !changed then c' else c
+
+let subst_univs_level_context s = 
+  map_rel_context (subst_univs_level_constr s)
+      
+let subst_instance_constr subst c =
+  if Univ.Instance.is_empty subst then c
+  else
+    let f u = Univ.subst_instance_instance subst u in
+    let changed = ref false in
+    let rec aux t = 
+      match kind t with
+      | Const (c, u) -> 
+	if Univ.Instance.is_empty u then t
+	else 
+          let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; mkConstU (c, u'))
+      | Ind (i, u) ->
+	if Univ.Instance.is_empty u then t
+	else 
+	  let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; mkIndU (i, u'))
+      | Construct (c, u) ->
+	if Univ.Instance.is_empty u then t
+	else 
+          let u' = f u in 
+	    if u' == u then t
+	    else (changed := true; mkConstructU (c, u'))
+      | Sort (Sorts.Type u) -> 
+         let u' = Univ.subst_instance_universe subst u in
+	   if u' == u then t else 
+	     (changed := true; mkSort (Sorts.sort_of_univ u'))
+      | _ -> Constr.map aux t
+    in
+    let c' = aux c in
+      if !changed then c' else c
+
+(* let substkey = Profile.declare_profile "subst_instance_constr";; *)
+(* let subst_instance_constr inst c = Profile.profile2 substkey subst_instance_constr inst c;; *)
+
+let subst_instance_context s ctx = 
+  if Univ.Instance.is_empty s then ctx
+  else map_rel_context (fun x -> subst_instance_constr s x) ctx
+
+type id_key = pconstant tableKey
+let eq_id_key x y = Names.eq_table_key (Univ.eq_puniverses Constant.equal) x y
diff --git a/kernel/vars.mli b/kernel/vars.mli
new file mode 100644
index 00000000..fdd4603b
--- /dev/null
+++ b/kernel/vars.mli
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Constr
+open Context
+
+(** {6 Occur checks } *)
+
+(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
+val closedn : int -> constr -> bool
+
+(** [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+val closed0 : constr -> bool
+
+(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
+val noccurn : int -> constr -> bool
+
+(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
+  for n <= p < n+m *)
+val noccur_between : int -> int -> constr -> bool
+
+(** Checking function for terms containing existential- or
+   meta-variables.  The function [noccur_with_meta] does not consider
+   meta-variables applied to some terms (intended to be its local
+   context) (for existential variables, it is necessarily the case) *)
+val noccur_with_meta : int -> int -> constr -> bool
+
+(** {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
+
+(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
+    for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
+    accordingly indexes in [a1],...,[an] and [c] *)
+val substnl : constr list -> int -> constr -> constr
+val substl : constr list -> constr -> constr
+val subst1 : constr -> constr -> constr
+
+val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration
+val substl_decl : constr list -> rel_declaration -> rel_declaration
+val subst1_decl : constr -> rel_declaration -> rel_declaration
+
+val substnl_named_decl : constr list -> int -> named_declaration -> named_declaration
+val subst1_named_decl : constr -> named_declaration -> named_declaration
+val substl_named_decl : constr list -> named_declaration -> named_declaration
+
+val replace_vars : (Id.t * constr) list -> constr -> constr
+(** (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
+val subst_var : Id.t -> constr -> constr
+
+(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
+   if two names are identical, the one of least indice is kept *)
+val subst_vars : Id.t list -> constr -> constr
+
+(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+   if two names are identical, the one of least indice is kept *)
+val substn_vars : int -> Id.t list -> constr -> constr
+
+(** {3 Substitution of universes} *)
+
+open Univ
+
+val subst_univs_fn_constr : universe_subst_fn -> constr -> constr
+val subst_univs_fn_puniverses : universe_level_subst_fn -> 
+  'a puniverses -> 'a puniverses
+
+val subst_univs_constr : universe_subst -> constr -> constr
+
+(** Level substitutions for polymorphism. *)
+
+val subst_univs_level_constr : universe_level_subst -> constr -> constr
+val subst_univs_level_context : Univ.universe_level_subst -> rel_context -> rel_context
+
+(** Instance substitution for polymorphism. *)
+val subst_instance_constr : universe_instance -> constr -> constr
+val subst_instance_context : universe_instance -> rel_context -> rel_context
+
+type id_key = pconstant tableKey
+val eq_id_key : id_key -> id_key -> bool
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index 4d0edc68..80b15f8b 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -1,5 +1,5 @@
+open Util
 open Names
-open Declarations
 open Term
 open Environ
 open Conv_oracle
@@ -16,8 +16,8 @@ let val_of_constr env c =
 
 let compare_zipper z1 z2 =
   match z1, z2 with
-  | Zapp args1, Zapp args2 -> nargs args1 = nargs args2
-  | Zfix(f1,args1), Zfix(f2,args2) ->  nargs args1 = nargs args2
+  | Zapp args1, Zapp args2 -> Int.equal (nargs args1) (nargs args2)
+  | Zfix(f1,args1), Zfix(f2,args2) ->  Int.equal (nargs args1) (nargs args2)
   | Zswitch _, Zswitch _ -> true
   | _ , _ -> false
 
@@ -32,7 +32,7 @@ let rec compare_stack stk1 stk2 =
 (* Conversion *)
 let conv_vect fconv vect1 vect2 cu =
   let n = Array.length vect1 in
-  if n = Array.length vect2 then
+  if Int.equal n (Array.length vect2) then
     let rcu = ref cu in
     for i = 0 to n - 1 do
       rcu := fconv vect1.(i) vect2.(i) !rcu
@@ -42,193 +42,206 @@ let conv_vect fconv vect1 vect2 cu =
 
 let infos = ref (create_clos_infos betaiotazeta Environ.empty_env)
 
-let rec conv_val pb k v1 v2 cu =
+let eq_table_key = Names.eq_table_key eq_constant
+
+let rec conv_val env pb k v1 v2 cu =
   if v1 == v2 then cu
-  else conv_whd pb k (whd_val v1) (whd_val v2) cu
+  else conv_whd env pb k (whd_val v1) (whd_val v2) cu
 
-and conv_whd pb k whd1 whd2 cu =
+and conv_whd env pb k whd1 whd2 cu =
   match whd1, whd2 with
-  | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu
+  | Vsort s1, Vsort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu
   | Vprod p1, Vprod p2 ->
-      let cu = conv_val CONV k (dom p1) (dom p2) cu in
-      conv_fun pb k (codom p1) (codom p2) cu
-  | Vfun f1, Vfun f2 -> conv_fun CONV k f1 f2 cu
-  | Vfix (f1,None), Vfix (f2,None) -> conv_fix k f1 f2 cu
+      let cu = conv_val env CONV k (dom p1) (dom p2) cu in
+      conv_fun env pb k (codom p1) (codom p2) cu
+  | Vfun f1, Vfun f2 -> conv_fun env CONV k f1 f2 cu
+  | Vfix (f1,None), Vfix (f2,None) -> conv_fix env k f1 f2 cu
   | Vfix (f1,Some args1), Vfix(f2,Some args2) ->
       if nargs args1 <> nargs args2 then raise NotConvertible
-      else conv_arguments k args1 args2 (conv_fix k f1 f2 cu)
-  | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu
+      else conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)
+  | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix env k cf1 cf2 cu
   | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) ->
       if nargs args1 <> nargs args2 then raise NotConvertible
-      else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu)
+      else conv_arguments env k args1 args2 (conv_cofix env k cf1 cf2 cu)
   | Vconstr_const i1, Vconstr_const i2 ->
-      if i1 = i2 then cu else raise NotConvertible
+      if Int.equal i1 i2 then cu else raise NotConvertible
   | Vconstr_block b1, Vconstr_block b2 ->
       let sz = bsize b1 in
-      if btag b1 = btag b2 && sz = bsize b2 then
+      if Int.equal (btag b1) (btag b2) && Int.equal sz (bsize b2) then
 	let rcu = ref cu in
 	for i = 0 to sz - 1 do
-	  rcu := conv_val CONV k (bfield b1 i) (bfield b2 i) !rcu
+	  rcu := conv_val env CONV k (bfield b1 i) (bfield b2 i) !rcu
 	done;
 	!rcu
       else raise NotConvertible
   | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
-      conv_atom pb k a1 stk1 a2 stk2 cu
+      conv_atom env pb k a1 stk1 a2 stk2 cu
   | Vfun _, _ | _, Vfun _ ->
-      conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
+      conv_val env CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
   | _, Vatom_stk(Aiddef(_,v),stk) ->
-      conv_whd pb k whd1 (force_whd v stk) cu
+      conv_whd env pb k whd1 (force_whd v stk) cu
   | Vatom_stk(Aiddef(_,v),stk), _ ->
-      conv_whd pb k (force_whd v stk) whd2 cu
+      conv_whd env pb k (force_whd v stk) whd2 cu
   | _, _ -> raise NotConvertible
 
-and conv_atom pb k a1 stk1 a2 stk2 cu =
+and conv_atom env pb k a1 stk1 a2 stk2 cu =
   match a1, a2 with
-  | Aind (kn1,i1), Aind(kn2,i2) ->
-      if eq_ind (kn1,i1) (kn2,i2) && compare_stack stk1 stk2
+  | Aind ind1, Aind ind2 ->
+      if eq_puniverses eq_ind ind1 ind2 && compare_stack stk1 stk2
       then
-	conv_stack k stk1 stk2 cu
+	conv_stack env k stk1 stk2 cu
       else raise NotConvertible
   | Aid ik1, Aid ik2 ->
-      if ik1 = ik2 && compare_stack stk1 stk2 then
-	conv_stack k stk1 stk2 cu
+      if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then
+	conv_stack env k stk1 stk2 cu
       else raise NotConvertible
   | Aiddef(ik1,v1), Aiddef(ik2,v2) ->
       begin
 	try
-	  if eq_table_key ik1 ik2 && compare_stack stk1 stk2 then
-	    conv_stack k stk1 stk2 cu
+	  if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then
+	    conv_stack env k stk1 stk2 cu
 	  else raise NotConvertible
 	with NotConvertible ->
-	  if oracle_order false ik1 ik2 then
-            conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
-          else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
+	  if oracle_order Univ.out_punivs (oracle_of_infos !infos) 
+	    false ik1 ik2 then
+            conv_whd env pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
+          else conv_whd env pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
       end
   | Aiddef(ik1,v1), _ ->
-      conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
+      conv_whd env pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
   | _, Aiddef(ik2,v2) ->
-      conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
+      conv_whd env pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
   | _, _ -> raise NotConvertible
 
-and conv_stack k stk1 stk2 cu =
+and conv_stack env k stk1 stk2 cu =
   match stk1, stk2 with
   | [], [] -> cu
   | Zapp args1 :: stk1, Zapp args2 :: stk2 ->
-      conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu)
+      conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 cu)
   | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 ->
-      conv_stack k stk1 stk2
-	(conv_arguments k args1 args2 (conv_fix k f1 f2 cu))
+      conv_stack env k stk1 stk2
+	(conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu))
   | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 ->
       if check_switch sw1 sw2 then
 	let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in
-	let rcu = ref (conv_val CONV k vt1 vt2 cu) in
+	let rcu = ref (conv_val env CONV k vt1 vt2 cu) in
 	let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in
 	for i = 0 to Array.length b1 - 1 do
 	  rcu :=
-	    conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu
+	    conv_val env CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu
 	done;
-	conv_stack k stk1 stk2 !rcu
+	conv_stack env k stk1 stk2 !rcu
       else raise NotConvertible
   | _, _ -> raise NotConvertible
 
-and conv_fun pb k f1 f2 cu =
+and conv_fun env pb k f1 f2 cu =
   if f1 == f2 then cu
   else
     let arity,b1,b2 = decompose_vfun2 k f1 f2 in
-    conv_val pb (k+arity) b1 b2 cu
+    conv_val env pb (k+arity) b1 b2 cu
 
-and conv_fix k f1 f2 cu =
+and conv_fix env k f1 f2 cu =
   if f1 == f2 then cu
   else
     if check_fix f1 f2 then
       let bf1, tf1 = reduce_fix k f1 in
       let bf2, tf2 = reduce_fix k f2 in
-      let cu = conv_vect (conv_val CONV k) tf1 tf2 cu in
-      conv_vect (conv_fun CONV (k + Array.length tf1)) bf1 bf2 cu
+      let cu = conv_vect (conv_val env CONV k) tf1 tf2 cu in
+      conv_vect (conv_fun env CONV (k + Array.length tf1)) bf1 bf2 cu
     else raise NotConvertible
 
-and conv_cofix k cf1 cf2 cu =
+and conv_cofix env k cf1 cf2 cu =
   if cf1 == cf2 then cu
   else
     if check_cofix cf1 cf2 then
       let bcf1, tcf1 = reduce_cofix k cf1 in
       let bcf2, tcf2 = reduce_cofix k cf2 in
-      let cu = conv_vect (conv_val CONV k) tcf1 tcf2 cu in
-      conv_vect (conv_val CONV (k + Array.length tcf1)) bcf1 bcf2 cu
+      let cu = conv_vect (conv_val env CONV k) tcf1 tcf2 cu in
+      conv_vect (conv_val env CONV (k + Array.length tcf1)) bcf1 bcf2 cu
     else raise NotConvertible
 
-and conv_arguments k args1 args2 cu =
+and conv_arguments env k args1 args2 cu =
   if args1 == args2 then cu
   else
     let n = nargs args1 in
-    if n = nargs args2 then
+    if Int.equal n (nargs args2) then
       let rcu = ref cu in
       for i = 0 to n - 1 do
-	rcu := conv_val CONV k (arg args1 i) (arg args2 i) !rcu
+	rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu
       done;
       !rcu
     else raise NotConvertible
 
-let rec conv_eq pb t1 t2 cu =
+let rec eq_puniverses f (x,l1) (y,l2) cu =
+  if f x y then conv_universes l1 l2 cu
+  else raise NotConvertible
+
+and conv_universes l1 l2 cu =
+  if Univ.Instance.equal l1 l2 then cu else raise NotConvertible
+
+let rec conv_eq env pb t1 t2 cu =
   if t1 == t2 then cu
   else
     match kind_of_term t1, kind_of_term t2 with
     | Rel n1, Rel n2 ->
-	if n1 = n2 then cu else raise NotConvertible
+	if Int.equal n1 n2 then cu else raise NotConvertible
     | Meta m1, Meta m2 ->
-	if m1 = m2 then cu else raise NotConvertible
+	if Int.equal m1 m2 then cu else raise NotConvertible
     | Var id1, Var id2 ->
-	if id1 = id2 then cu else raise NotConvertible
-    | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu
-    | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu
-    | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu
+	if Id.equal id1 id2 then cu else raise NotConvertible
+    | Sort s1, Sort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu
+    | Cast (c1,_,_), _ -> conv_eq env pb c1 t2 cu
+    | _, Cast (c2,_,_) -> conv_eq env pb t1 c2 cu
     | Prod (_,t1,c1), Prod (_,t2,c2) ->
-	conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu)
-    | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu
+	conv_eq env pb c1 c2 (conv_eq env CONV t1 t2 cu)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq env CONV c1 c2 cu
     | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
-	conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu)
+	conv_eq env pb c1 c2 (conv_eq env CONV b1 b2 cu)
     | App (c1,l1), App (c2,l2) ->
-	conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu)
+	conv_eq_vect env l1 l2 (conv_eq env CONV c1 c2 cu)
     | Evar (e1,l1), Evar (e2,l2) ->
-	if e1 = e2 then conv_eq_vect l1 l2 cu
+	if Evar.equal e1 e2 then conv_eq_vect env l1 l2 cu
+	else raise NotConvertible
+    | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu
+    | Proj (p1,c1), Proj (p2,c2) ->
+	if eq_constant (Projection.constant p1) (Projection.constant p2) then
+	  conv_eq env pb c1 c2 cu 
 	else raise NotConvertible
-    | Const c1, Const c2 ->
-	if eq_constant c1 c2 then cu else raise NotConvertible
     | Ind c1, Ind c2 ->
-	if eq_ind c1 c2 then cu else raise NotConvertible
+       eq_puniverses eq_ind c1 c2 cu
     | Construct c1, Construct c2 ->
-	if eq_constructor c1 c2 then cu else raise NotConvertible
+       eq_puniverses eq_constructor c1 c2 cu
     | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-	let pcu = conv_eq CONV p1 p2 cu in
-	let ccu = conv_eq CONV c1 c2 pcu in
-	conv_eq_vect bl1 bl2 ccu
-    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	let pcu = conv_eq env CONV p1 p2 cu in
+	let ccu = conv_eq env CONV c1 c2 pcu in
+	conv_eq_vect env bl1 bl2 ccu
+    | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
+	if Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu)
 	else raise NotConvertible
     | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	if Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu)
 	else raise NotConvertible
     | _ -> raise NotConvertible
 
-and conv_eq_vect vt1 vt2 cu =
+and conv_eq_vect env vt1 vt2 cu =
   let len = Array.length vt1 in
-  if len = Array.length vt2 then
+  if Int.equal len (Array.length vt2) then
     let rcu = ref cu in
     for i = 0 to len-1 do
-      rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu
+      rcu := conv_eq env CONV vt1.(i) vt2.(i) !rcu
     done; !rcu
   else raise NotConvertible
 
 let vconv pb env t1 t2 =
-  let cu =
-    try conv_eq pb t1 t2 empty_constraint
+  infos := create_clos_infos betaiotazeta env;
+  let _cu =
+    try conv_eq env pb t1 t2 (universes env)
     with NotConvertible ->
-      infos := create_clos_infos betaiotazeta env;
       let v1 = val_of_constr env t1 in
       let v2 = val_of_constr env t2 in
-      let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in
+      let cu = conv_val env pb (nb_rel env) v1 v2 (universes env) in
       cu
-  in cu
+  in ()
 
 let _ = Reduction.set_vm_conv vconv
 
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index fde0912a..096d31ac 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Names
 open Term
 open Environ
 open Reduction
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 9ff369e5..2cc1efe4 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,7 +8,6 @@
 
 open Names
 open Term
-open Conv_oracle
 open Cbytecodes
 
 external set_drawinstr : unit -> unit = "coq_set_drawinstr"
@@ -43,7 +42,6 @@ let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0)
 
 external mkAccuCode : int -> tcode = "coq_makeaccu"
 external mkPopStopCode : int -> tcode = "coq_pushpop"
-external mkAccuCond : int -> tcode = "coq_accucond"
 
 external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode"
 external int_tcode : tcode -> int -> int = "coq_int_tcode"
@@ -139,10 +137,11 @@ type vswitch = {
 (* Generally the first field is a code pointer.                           *)
 
 (* Do not edit this type without editing C code, especially "coq_values.h" *)
+
 type atom =
-  | Aid of id_key
-  | Aiddef of id_key * values
-  | Aind of inductive
+  | Aid of Vars.id_key
+  | Aiddef of Vars.id_key * values
+  | Aind of pinductive
 
 (* Zippers *)
 
@@ -171,7 +170,7 @@ type whd =
 
 let rec whd_accu a stk =
   let stk =
-    if Obj.size a = 2 then stk
+    if Int.equal (Obj.size a) 2 then stk
     else Zapp (Obj.obj a) :: stk in
   let at = Obj.field a 1 in
   match Obj.tag at with
@@ -213,7 +212,7 @@ let whd_val : values -> whd =
       let tag = Obj.tag o in
       if tag = accu_tag then
 	(
-	if Obj.size o = 1 then Obj.obj o (* sort *)
+	if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *)
 	else
 	  if is_accumulate (fun_code o) then whd_accu o []
 	  else (Vprod(Obj.obj o)))
@@ -224,7 +223,7 @@ let whd_val : values -> whd =
 	   | 1 -> Vfix(Obj.obj o, None)
 	   | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o))
 	   | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), [])
-	   | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work")
+	   | _ -> Errors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work"))
 	else Vconstr_block(Obj.obj o)
 
 
@@ -251,13 +250,13 @@ let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2
 let arg args i =
   if  0 <= i && i < (nargs args) then
     val_of_obj (Obj.field (Obj.repr args) (i+2))
-  else raise (Invalid_argument
+  else invalid_arg
 		("Vm.arg size = "^(string_of_int (nargs args))^
-		 " acces "^(string_of_int i)))
+		 " acces "^(string_of_int i))
 
 let apply_arguments vf vargs =
   let n = nargs vargs in
-  if n = 0 then vf
+  if Int.equal n 0 then vf
   else
    begin
      push_ra stop;
@@ -267,7 +266,7 @@ let apply_arguments vf vargs =
 
 let apply_vstack vf vstk =
   let n = Array.length vstk in
-  if n = 0 then vf
+  if Int.equal n 0 then vf
   else
     begin
       push_ra stop;
@@ -306,27 +305,33 @@ let val_of_str_const str = val_of_obj (obj_of_str_const str)
 
 let val_of_atom a = val_of_obj (obj_of_atom a)
 
-let idkey_tbl = Hashtbl.create 31
+module IdKeyHash =
+struct
+  type t = pconstant tableKey
+  let equal = Names.eq_table_key (Univ.eq_puniverses Constant.equal)
+  open Hashset.Combine
+  let hash = function
+  | ConstKey (c,u) -> combinesmall 1 (Constant.hash c)
+  | VarKey id -> combinesmall 2 (Id.hash id)
+  | RelKey i -> combinesmall 3 (Int.hash i)
+end
+
+module KeyTable = Hashtbl.Make(IdKeyHash)
+
+let idkey_tbl = KeyTable.create 31
 
 let val_of_idkey key =
-  try Hashtbl.find idkey_tbl key
+  try KeyTable.find idkey_tbl key
   with Not_found ->
     let v = val_of_atom (Aid key) in
-    Hashtbl.add idkey_tbl key v;
+    KeyTable.add idkey_tbl key v;
     v
 
 let val_of_rel k = val_of_idkey (RelKey k)
-let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v))
 
 let val_of_named id = val_of_idkey (VarKey id)
-let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v))
 
 let val_of_constant c = val_of_idkey (ConstKey c)
-let val_of_constant_def n c v =
-  let res = Obj.new_block accu_tag 2 in
-  Obj.set_field res 0 (Obj.repr (mkAccuCond n));
-  Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v)));
-  val_of_obj res
 
 external val_of_annot_switch : annot_switch -> values = "%identity"
 
@@ -497,7 +502,7 @@ let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b)
 let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b)
 let bfield b i =
   if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i)
-  else raise (Invalid_argument "Vm.bfield")
+  else invalid_arg "Vm.bfield"
 
 
 (* Functions over vswitch *)
@@ -511,7 +516,7 @@ let type_of_switch sw =
   interprete sw.sw_type_code crazy_val sw.sw_env 0
 
 let branch_arg k (tag,arity) =
-  if arity = 0 then  ((Obj.magic tag):values)
+  if Int.equal arity 0 then  ((Obj.magic tag):values)
   else
     let b = Obj.new_block tag arity in
     for i = 0 to arity - 1 do
diff --git a/kernel/vm.mli b/kernel/vm.mli
index 58228eb8..295ea83c 100644
--- a/kernel/vm.mli
+++ b/kernel/vm.mli
@@ -1,7 +1,6 @@
 open Names
 open Term
 open Cbytecodes
-open Cemitcodes
 
 (** Efficient Virtual Machine *)
 
@@ -25,9 +24,9 @@ type vswitch
 type arguments
 
 type atom =
-  | Aid of id_key
-  | Aiddef of id_key * values
-  | Aind of inductive
+  | Aid of Vars.id_key
+  | Aiddef of Vars.id_key * values
+  | Aind of pinductive
 
 (** Zippers *)
 
@@ -53,15 +52,9 @@ type whd =
 (** Constructors *)
 
 val val_of_str_const : structured_constant -> values
-
 val val_of_rel : int -> values
-val val_of_rel_def : int -> values -> values
-
-val val_of_named : identifier -> values
-val val_of_named_def : identifier -> values -> values
-
-val val_of_constant : constant -> values
-val val_of_constant_def : int -> constant -> values -> values
+val val_of_named : Id.t -> values
+val val_of_constant : pconstant -> values
 
 external val_of_annot_switch : annot_switch -> values = "%identity"