Imported Upstream version 8.9.0upstream/8.9.0upstream

87 files changed, 2407 insertions, 3271 deletions

diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
index d5feafbf..be2b05da 100644
--- a/kernel/byterun/coq_fix_code.c
+++ b/kernel/byterun/coq_fix_code.c
@@ -18,6 +18,7 @@
 #include <caml/misc.h>
 #include <caml/mlvalues.h>
 #include <caml/fail.h>
+#include <caml/alloc.h>
 #include <caml/memory.h>
 #include "coq_instruct.h"
 #include "coq_fix_code.h"
@@ -78,38 +79,41 @@ void * coq_stat_alloc (asize_t sz)
 }
 
 value coq_makeaccu (value i) {
-  code_t q;
-  code_t res = coq_stat_alloc(2 * sizeof(opcode_t));
-  q = res;
+  CAMLparam1(i);
+  CAMLlocal1(res);
+  code_t q = coq_stat_alloc(2 * sizeof(opcode_t));
+  res = caml_alloc_small(1, Abstract_tag);
+  Code_val(res) = q;
   *q++ = VALINSTR(MAKEACCU);
   *q = (opcode_t)Int_val(i);
-  return (value)res;
+  CAMLreturn(res);
 }
 
 value coq_pushpop (value i) {
-  code_t res;
-  int n;
-  n = Int_val(i);
+  CAMLparam1(i);
+  CAMLlocal1(res);
+  code_t q;
+  res = caml_alloc_small(1, Abstract_tag);
+  int n = Int_val(i);
   if (n == 0) {
-    res = coq_stat_alloc(sizeof(opcode_t));
-    *res = VALINSTR(STOP);
-    return (value)res;
+    q = coq_stat_alloc(sizeof(opcode_t));
+    Code_val(res) = q;
+    *q = VALINSTR(STOP);
+    CAMLreturn(res);
   }
   else {
-    code_t q;
-    res = coq_stat_alloc(3 * sizeof(opcode_t));
-    q = res;
+    q = coq_stat_alloc(3 * sizeof(opcode_t));
+    Code_val(res) = q;
     *q++ = VALINSTR(POP);
     *q++ = (opcode_t)n;
     *q = VALINSTR(STOP);
-    return (value)res;
+    CAMLreturn(res);
   }
 }
 
 value coq_is_accumulate_code(value code){
-  code_t q;
+  code_t q = Code_val(code);
   int res;
-  q = (code_t)code;
   res = Is_instruction(q,ACCUMULATE);
   return Val_bool(res);
 }
@@ -132,11 +136,14 @@ value coq_is_accumulate_code(value code){
 #define COPY32(dst,src) (*dst=*src)
 #endif /* ARCH_BIG_ENDIAN */
 
-value coq_tcode_of_code (value code, value size) {
-  code_t p, q, res; 
-  asize_t len = (asize_t) Long_val(size);
-  res = coq_stat_alloc(len);
-  q = res;
+value coq_tcode_of_code (value code) {
+  CAMLparam1 (code);
+  CAMLlocal1 (res);
+  code_t p, q;
+  asize_t len = (asize_t) caml_string_length(code);
+  res = caml_alloc_small(1, Abstract_tag);
+  q = coq_stat_alloc(len);
+  Code_val(res) = q;
   len /= sizeof(opcode_t);
   for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) {  
     opcode_t instr;
@@ -166,5 +173,5 @@ value coq_tcode_of_code (value code, value size) {
       for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; };
     }
   }
-  return (value)res;
+  CAMLreturn(res);
 }
diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h
index 5c85389d..638d6b5a 100644
--- a/kernel/byterun/coq_fix_code.h
+++ b/kernel/byterun/coq_fix_code.h
@@ -26,7 +26,7 @@ void init_arity();
 
 #define Is_instruction(pc,instr) (*pc == VALINSTR(instr))
 
-value coq_tcode_of_code(value code, value len);
+value coq_tcode_of_code(value code);
 value coq_makeaccu (value i);
 value coq_pushpop (value i);
 value coq_is_accumulate_code(value code);
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index af89712d..a944dbb0 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -16,6 +16,7 @@
 #include <stdio.h>
 #include <signal.h>
 #include <stdint.h>
+#include <caml/memory.h>
 #include "coq_gc.h"
 #include "coq_instruct.h"
 #include "coq_fix_code.h"
@@ -163,8 +164,11 @@ extern void caml_process_pending_signals(void);
 /* The interpreter itself */
 
 value coq_interprete
-(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args)
+(code_t coq_pc, value coq_accu, value coq_atom_tbl, value coq_global_data, value coq_env, long coq_extra_args)
 {
+  /* coq_accu is not allocated on the OCaml heap */
+  CAMLparam2(coq_atom_tbl, coq_global_data);
+
   /*Declaration des variables */
 #ifdef PC_REG
   register code_t pc PC_REG;
@@ -196,7 +200,7 @@ value coq_interprete
     coq_instr_table = (char **) coq_jumptable;
     coq_instr_base = coq_Jumptbl_base;
 #endif
-    return Val_unit;
+    CAMLreturn(Val_unit);
   }
 #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32)
   coq_jumptbl_base = coq_Jumptbl_base;
@@ -626,7 +630,7 @@ value coq_interprete
 	print_instr("CLOSUREREC");
 	if (nvars > 0) *--sp = accu;
 	/* construction du vecteur de type */
-	Alloc_small(accu, nfuncs, 0);
+        Alloc_small(accu, nfuncs, Abstract_tag);
 	for(i = 0; i < nfuncs; i++) {
 	  Field(accu,i) = (value)(pc+pc[i]);
 	}
@@ -662,7 +666,7 @@ value coq_interprete
 	print_instr("CLOSURECOFIX");
 	if (nvars > 0) *--sp = accu;
 	/* construction du vecteur de type */
-	Alloc_small(accu, nfunc, 0);
+        Alloc_small(accu, nfunc, Abstract_tag);
 	for(i = 0; i < nfunc; i++) {
 	  Field(accu,i) = (value)(pc+pc[i]);
 	}
@@ -1028,7 +1032,7 @@ value coq_interprete
             CHECK_STACK(nargs+1);
 	    sp -= nargs;
 	    for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); 
-	    *--sp = accu; // Last argument is the pointer to the suspension
+            *--sp = accu; // Leftmost argument is the pointer to the suspension
 	    print_lint(nargs);
 	    coq_extra_args = nargs;
 	    pc = Code_val(coq_env); // Trigger evaluation
@@ -1068,12 +1072,22 @@ value coq_interprete
 	      }
 	    }
 	    *--sp = accu;
-	    /* We create the switch zipper */
-	    Alloc_small(accu, 5, Default_tag);
-	    Field(accu, 0) =  (value)typlbl; Field(accu, 1) = (value)swlbl; 
-	    Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; 
-	    Field(accu, 4) = coq_env;
-	    sp++;sp[0] = accu;
+            /* Create bytecode wrappers */
+            Alloc_small(accu, 1, Abstract_tag);
+            Code_val(accu) = typlbl;
+            *--sp = accu;
+            Alloc_small(accu, 1, Abstract_tag);
+            Code_val(accu) = swlbl;
+            *--sp = accu;
+            /* We create the switch zipper */
+            Alloc_small(accu, 5, Default_tag);
+            Field(accu, 0) = sp[1];
+            Field(accu, 1) = sp[0];
+            Field(accu, 2) = sp[3];
+            Field(accu, 3) = sp[2];
+            Field(accu, 4) = coq_env;
+            sp += 3;
+            sp[0] = accu;
 	    /* We create the atom */
 	    Alloc_small(accu, 2, ATOM_SWITCH_TAG);
 	    Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0];
@@ -1460,7 +1474,7 @@ value coq_interprete
       Instruct(STOP){
 	print_instr("STOP");
 	coq_sp = sp;
-	return accu;
+        CAMLreturn(accu);
       }
       
   
@@ -1473,7 +1487,8 @@ value coq_interprete
 #endif
 }
 
-value coq_push_ra(value tcode) { 
+value coq_push_ra(value code) {
+  code_t tcode = Code_val(code);
   print_instr("push_ra");
   coq_sp -= 3;
   coq_sp[0] = (value) tcode;
@@ -1512,12 +1527,18 @@ value coq_push_vstack(value stk, value max_stack_size) {
   return Val_unit;
 }
 
-value  coq_interprete_ml(value tcode, value a, value e, value ea) {
+value  coq_interprete_ml(value tcode, value a, value t, value g, value e, value ea) {
+  // Registering the other arguments w.r.t. the OCaml GC is done by coq_interprete
+  CAMLparam1(tcode);
   print_instr("coq_interprete");
-  return coq_interprete((code_t)tcode, a, e, Long_val(ea));
+  CAMLreturn (coq_interprete(Code_val(tcode), a, t, g, e, Long_val(ea)));
   print_instr("end coq_interprete");
 }
 
-value coq_eval_tcode (value tcode, value e) {
-  return coq_interprete_ml(tcode, Val_unit, e, 0);
+value coq_interprete_byte(value* argv, int argn){
+  return coq_interprete_ml(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+}
+
+value coq_eval_tcode (value tcode, value t, value g, value e) {
+  return coq_interprete_ml(tcode, Val_unit, t, g, e, 0);
 }
diff --git a/kernel/byterun/coq_interp.h b/kernel/byterun/coq_interp.h
index 60865c32..c04e9e00 100644
--- a/kernel/byterun/coq_interp.h
+++ b/kernel/byterun/coq_interp.h
@@ -17,11 +17,10 @@ value coq_push_arguments(value args);
 
 value coq_push_vstack(value stk);
 
-value  coq_interprete_ml(value tcode, value a, value e, value ea);
+value coq_interprete_ml(value tcode, value a, value t, value g, value e, value ea);
+value coq_interprete_byte(value* argv, int argn);
 
 value coq_interprete
-    (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args);
-
-value coq_eval_tcode (value tcode, value e);
-
+    (code_t coq_pc, value coq_accu, value coq_atom_tbl, value coq_global_data, value coq_env, long coq_extra_args);
 
+value coq_eval_tcode (value tcode, value t, value g, value e);
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index 45cfae50..542a05fd 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -10,6 +10,8 @@
 
 #include <stdio.h>
 #include <string.h> 
+#include <caml/alloc.h>
+#include <caml/address_class.h>
 #include "coq_gc.h"
 #include "coq_instruct.h"
 #include "coq_fix_code.h"
@@ -24,10 +26,6 @@ value * coq_stack_threshold;
 asize_t coq_max_stack_size = Coq_max_stack_size;
 /* global_data */
 
-
-value coq_global_data;
-value coq_atom_tbl;
-
 int drawinstr;
 /* interp state */
 
@@ -50,7 +48,11 @@ value coq_static_alloc(value size) /* ML */
 
 value accumulate_code(value unit) /* ML */
 {
-  return (value) accumulate;
+  CAMLparam1(unit);
+  CAMLlocal1(res);
+  res = caml_alloc_small(1, Abstract_tag);
+  Code_val(res) = accumulate;
+  CAMLreturn(res);
 }
 
 static void (*coq_prev_scan_roots_hook) (scanning_action);
@@ -58,11 +60,12 @@ static void (*coq_prev_scan_roots_hook) (scanning_action);
 static void coq_scan_roots(scanning_action action)
 {
   register value * i;
-  /* Scan the global variables */
-  (*action)(coq_global_data, &coq_global_data);
-  (*action)(coq_atom_tbl, &coq_atom_tbl);
   /* Scan the stack */
   for (i = coq_sp; i < coq_stack_high; i++) {
+#ifdef NO_NAKED_POINTERS
+    /* The VM stack may contain C-allocated bytecode */
+    if (Is_block(*i) && !Is_in_heap_or_young(*i)) continue;
+#endif
     (*action) (*i, i);
   };
   /* Hook */
@@ -79,24 +82,10 @@ void init_coq_stack()
   coq_max_stack_size = Coq_max_stack_size;
 }  
 
-void init_coq_global_data(long requested_size)
-{
-  int i;
-  coq_global_data = alloc_shr(requested_size, 0);
-  for (i = 0; i < requested_size; i++) 
-    Field (coq_global_data, i) = Val_unit;
-}
-
-void init_coq_atom_tbl(long requested_size){
-  int i;
-  coq_atom_tbl = alloc_shr(requested_size, 0);
-  for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit;
-}
-
 void init_coq_interpreter()
 {
   coq_sp = coq_stack_high;
-  coq_interprete(NULL, Val_unit, Val_unit, 0);
+  coq_interprete(NULL, Val_unit, Atom(0), Atom(0), Val_unit, 0);
 }
 
 static int coq_vm_initialized = 0;
@@ -112,13 +101,15 @@ value init_coq_vm(value unit) /* ML */
 #endif /* THREADED_CODE */
     /* Allocate the table of global and the stack */
     init_coq_stack();
-    init_coq_global_data(Coq_global_data_Size);
-    init_coq_atom_tbl(40);
     /* Initialing the interpreter */
     init_coq_interpreter();
     
-    /* Some predefined pointer code */
-    accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t));
+    /* Some predefined pointer code.
+     * It is typically contained in accumlator blocks whose tag is 0 and thus
+     * scanned by the GC, so make it look like an OCaml block. */
+    value accu_block = (value) coq_stat_alloc(2 * sizeof(value));
+    Hd_hp (accu_block) = Make_header (1, Abstract_tag, Caml_black);        \
+    accumulate = (code_t) Val_hp(accu_block);
     *accumulate = VALINSTR(ACCUMULATE);
 
   /* Initialize GC */
@@ -157,53 +148,6 @@ void realloc_coq_stack(asize_t required_space)
 #undef shift
 }
 
-value get_coq_global_data(value unit)                /* ML */
-{
-  return coq_global_data;
-}
-
-value get_coq_atom_tbl(value unit)                  /* ML */
-{
-  return coq_atom_tbl;
-}
-
-value realloc_coq_global_data(value size)           /* ML */
-{
-  mlsize_t requested_size, actual_size, i;
-  value new_global_data;
-  requested_size = Long_val(size);
-  actual_size = Wosize_val(coq_global_data);
-  if (requested_size >= actual_size) {
-    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
-    new_global_data = alloc_shr(requested_size, 0);
-    for (i = 0; i < actual_size; i++)
-      initialize(&Field(new_global_data, i), Field(coq_global_data, i));
-    for (i = actual_size; i < requested_size; i++){
-      Field (new_global_data, i) = Val_long (0);
-    }
-    coq_global_data = new_global_data;
-  }
-  return Val_unit;
-}
-
-value realloc_coq_atom_tbl(value size)            /* ML */
-{
-  mlsize_t requested_size, actual_size, i;
-  value new_atom_tbl;
-  requested_size = Long_val(size);
-  actual_size = Wosize_val(coq_atom_tbl);
-  if (requested_size >= actual_size) {
-    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
-    new_atom_tbl = alloc_shr(requested_size, 0);
-    for (i = 0; i < actual_size; i++)
-      initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i));
-    for (i = actual_size; i < requested_size; i++)
-      Field (new_atom_tbl, i) = Val_long (0);
-    coq_atom_tbl = new_atom_tbl;
-  }
-  return Val_unit;
-}
-
 value coq_set_drawinstr(value unit)
 {
   drawinstr = 1;
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
index cec34f56..9375b15d 100644
--- a/kernel/byterun/coq_memory.h
+++ b/kernel/byterun/coq_memory.h
@@ -20,7 +20,6 @@
 
 #define Coq_stack_size (4096 * sizeof(value))
 #define Coq_stack_threshold (256 * sizeof(value))
-#define Coq_global_data_Size (4096 * sizeof(value))
 #define Coq_max_stack_size (256 * 1024)
 
 #define TRANSP 0
@@ -34,9 +33,7 @@ extern value * coq_stack_threshold;
 
 /* global_data */
 
-extern value coq_global_data;
 extern int coq_all_transp;
-extern value coq_atom_tbl;
 
 extern int drawinstr;
 /* interp state */
@@ -53,10 +50,6 @@ value init_coq_vm(value unit); /* ML */
 value re_init_coq_vm(value unit); /* ML */
 
 void  realloc_coq_stack(asize_t required_space); 
-value get_coq_global_data(value unit); /* ML */
-value realloc_coq_global_data(value size); /* ML */
-value get_coq_atom_tbl(value unit); /* ML */
-value realloc_coq_atom_tbl(value size); /* ML */
 value coq_set_transp_value(value transp); /* ML */
 value get_coq_transp_value(value unit); /* ML */
 #endif /* _COQ_MEMORY_ */
diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c
index 528babeb..e05f3fb8 100644
--- a/kernel/byterun/coq_values.c
+++ b/kernel/byterun/coq_values.c
@@ -9,6 +9,7 @@
 /***********************************************************************/
 
 #include <stdio.h>
+#include <caml/memory.h>
 #include "coq_fix_code.h"
 #include "coq_instruct.h"
 #include "coq_memory.h"
@@ -58,10 +59,36 @@ value coq_offset_closure(value v, value offset){
   return (value)&Field(v, Int_val(offset));
 }
 
+value coq_set_bytecode_field(value v, value i, value code) {
+  // No write barrier because the bytecode does not live on the OCaml heap
+  Field(v, Long_val(i)) = (value) Code_val(code);
+  return Val_unit;
+}
+
 value coq_offset_tcode(value code,value offset){
-  return((value)((code_t)code + Int_val(offset)));
+  CAMLparam1(code);
+  CAMLlocal1(res);
+  res = caml_alloc_small(1, Abstract_tag);
+  Code_val(res) = Code_val(code) + Int_val(offset);
+  CAMLreturn(res);
 }
 
-value coq_int_tcode(value code, value offset) {
+value coq_int_tcode(value pc, value offset) {
+  code_t code = Code_val(pc);
   return Val_int(*((code_t) code + Int_val(offset)));
 }
+
+value coq_tcode_array(value tcodes) {
+  CAMLparam1(tcodes);
+  CAMLlocal2(res, tmp);
+  int i;
+  /* Assumes that the vector of types is small. This was implicit in the
+    previous code which was building the type array using Alloc_small. */
+  res = caml_alloc_small(Wosize_val(tcodes), Default_tag);
+  for (i = 0; i < Wosize_val(tcodes); i++) {
+    tmp = caml_alloc_small(1, Abstract_tag);
+    Code_val(tmp) = (code_t) Field(tcodes, i);
+    Store_field(res, i, tmp);
+  }
+  CAMLreturn(res);
+}
diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml
index 08114abc..fd939402 100644
--- a/kernel/cClosure.ml
+++ b/kernel/cClosure.ml
@@ -31,7 +31,6 @@ open Environ
 open Esubst
 
 let stats = ref false
-let share = ref true
 
 (* Profiling *)
 let beta = ref 0
@@ -265,7 +264,8 @@ type 'a infos_cache = {
   i_repr : 'a infos -> 'a infos_tab -> constr -> 'a;
   i_env : env;
   i_sigma : existential -> constr option;
-  i_rels : (Context.Rel.Declaration.t * Pre_env.lazy_val) Range.t;
+  i_rels : (Constr.rel_declaration * lazy_val) Range.t;
+  i_share : bool;
 }
 
 and 'a infos = {
@@ -313,13 +313,13 @@ let ref_value_cache ({i_cache = cache} as infos) tab ref =
 let evar_value cache ev =
   cache.i_sigma ev
 
-let create mk_cl flgs env evars =
-  let open Pre_env in
+let create ~repr ~share flgs env evars =
   let cache =
-    { i_repr = mk_cl;
+    { i_repr = repr;
       i_env = env;
       i_sigma = evars;
-      i_rels = (Environ.pre_env env).env_rel_context.env_rel_map;
+      i_rels = env.env_rel_context.env_rel_map;
+      i_share = share;
     }
   in { i_flags = flgs; i_cache = cache }
 
@@ -385,8 +385,8 @@ let mk_red f = {norm=Red;term=f}
 
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
-let update v1 no t =
-  if !share then
+let update ~share v1 no t =
+  if share then
     (v1.norm <- no;
      v1.term <- t;
      v1)
@@ -398,7 +398,7 @@ let update v1 no t =
 type stack_member =
   | Zapp of fconstr array
   | ZcaseT of case_info * constr * constr array * fconstr subs
-  | Zproj of int * int * Constant.t
+  | Zproj of Projection.Repr.t
   | Zfix of fconstr * stack
   | Zshift of int
   | Zupdate of fconstr
@@ -482,7 +482,7 @@ let rec lft_fconstr n ft =
 let lift_fconstr k f =
   if Int.equal k 0 then f else lft_fconstr k f
 let lift_fconstr_vect k v =
-  if Int.equal k 0 then v else CArray.Fun1.map lft_fconstr k v
+  if Int.equal k 0 then v else Array.Fun1.map lft_fconstr k v
 
 let clos_rel e i =
   match expand_rel i e with
@@ -499,14 +499,16 @@ 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
+        (** The stack contains [Zupdate] marks only if in sharing mode *)
+        let _ = update ~share:true 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 && begin match m.norm with Red -> true | _ -> false end
+let zupdate info m s =
+  let share = info.i_cache.i_share in
+  if share && begin match m.norm with Red -> true | _ -> false end
   then
     let s' = compact_stack m s in
     let _ = m.term <- FLOCKED in
@@ -547,7 +549,7 @@ let mk_clos_vect env v = match v with
 | [|v0; v1; v2|] -> [|mk_clos env v0; mk_clos env v1; mk_clos env v2|]
 | [|v0; v1; v2; v3|] ->
   [|mk_clos env v0; mk_clos env v1; mk_clos env v2; mk_clos env v3|]
-| v -> CArray.Fun1.map mk_clos env v
+| v -> Array.Fun1.map mk_clos env v
 
 (* Translate the head constructor of t from constr to fconstr. This
    function is parameterized by the function to apply on the direct
@@ -562,7 +564,7 @@ let mk_clos_deep clos_fun env t =
           term = FCast (clos_fun env a, k, clos_fun env b)}
     | App (f,v) ->
         { norm = Red;
-	  term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) }
+          term = FApp (clos_fun env f, Array.Fun1.map clos_fun env v) }
     | Proj (p,c) ->
 	{ norm = Red;
 	  term = FProj (p, clos_fun env c) }
@@ -588,78 +590,95 @@ let mk_clos_deep clos_fun env t =
 let mk_clos2 = mk_clos_deep mk_clos
 
 (* The inverse of mk_clos_deep: move back to constr *)
-let rec to_constr constr_fun lfts v =
+let rec to_constr lfts v =
   match v.term with
     | FRel i -> mkRel (reloc_rel i lfts)
     | FFlex (RelKey p) -> mkRel (reloc_rel p lfts)
     | FFlex (VarKey x) -> mkVar x
     | FAtom c -> exliftn lfts c
     | FCast (a,k,b) ->
-        mkCast (constr_fun lfts a, k, constr_fun lfts b)
+      mkCast (to_constr lfts a, k, to_constr lfts b)
     | FFlex (ConstKey op) -> mkConstU op
     | FInd op -> mkIndU op
     | FConstruct op -> mkConstructU op
     | FCaseT (ci,p,c,ve,env) ->
-	mkCase (ci, constr_fun lfts (mk_clos env p),
-                constr_fun lfts c,
-		Array.map (fun b -> constr_fun lfts (mk_clos env b)) ve)
-    | FFix ((op,(lna,tys,bds)),e) ->
+      if is_subs_id env && is_lift_id lfts then
+        mkCase (ci, p, to_constr lfts c, ve)
+      else
+        let subs = comp_subs lfts env in
+        mkCase (ci, subst_constr subs p,
+            to_constr lfts c,
+            Array.map (fun b -> subst_constr subs b) ve)
+    | FFix ((op,(lna,tys,bds)) as fx, e) ->
+      if is_subs_id e && is_lift_id lfts then
+        mkFix fx
+      else
         let n = Array.length bds in
-        let ftys = CArray.Fun1.map mk_clos e tys in
-        let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in
-	let lfts' = el_liftn n lfts in
-	mkFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys,
-		         CArray.Fun1.map constr_fun lfts' fbds))
-    | FCoFix ((op,(lna,tys,bds)),e) ->
+        let subs_ty = comp_subs lfts e in
+        let subs_bd = comp_subs (el_liftn n lfts) (subs_liftn n e) in
+        let tys = Array.Fun1.map subst_constr subs_ty tys in
+        let bds = Array.Fun1.map subst_constr subs_bd bds in
+        mkFix (op, (lna, tys, bds))
+    | FCoFix ((op,(lna,tys,bds)) as cfx, e) ->
+      if is_subs_id e && is_lift_id lfts then
+        mkCoFix cfx
+      else
         let n = Array.length bds in
-        let ftys = CArray.Fun1.map mk_clos e tys in
-        let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in
-	let lfts' = el_liftn (Array.length bds) lfts in
-	mkCoFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys,
-		           CArray.Fun1.map constr_fun lfts' fbds))
+        let subs_ty = comp_subs lfts e in
+        let subs_bd = comp_subs (el_liftn n lfts) (subs_liftn n e) in
+        let tys = Array.Fun1.map subst_constr subs_ty tys in
+        let bds = Array.Fun1.map subst_constr subs_bd bds in
+        mkCoFix (op, (lna, tys, bds))
     | FApp (f,ve) ->
-	mkApp (constr_fun lfts f,
-	       CArray.Fun1.map constr_fun lfts ve)
+        mkApp (to_constr lfts f,
+               Array.Fun1.map to_constr lfts ve)
     | FProj (p,c) ->
-        mkProj (p,constr_fun lfts c)
+        mkProj (p,to_constr lfts c)
 
-    | FLambda _ ->
-        let (na,ty,bd) = destFLambda mk_clos2 v in
-	mkLambda (na, constr_fun lfts ty,
-	              constr_fun (el_lift lfts) bd)
+    | FLambda (len, tys, f, e) ->
+      if is_subs_id e && is_lift_id lfts then
+        Term.compose_lam (List.rev tys) f
+      else
+        let subs = comp_subs lfts e in
+        let tys = List.mapi (fun i (na, c) -> na, subst_constr (subs_liftn i subs) c) tys in
+        let f = subst_constr (subs_liftn len subs) f in
+        Term.compose_lam (List.rev tys) f
     | FProd (n,t,c)   ->
-	mkProd (n, constr_fun lfts t,
-	           constr_fun (el_lift lfts) c)
+        mkProd (n, to_constr lfts t,
+                   to_constr (el_lift lfts) c)
     | FLetIn (n,b,t,f,e) ->
-        let fc = mk_clos2 (subs_lift e) f in
-	mkLetIn (n, constr_fun lfts b,
-	            constr_fun lfts t,
-	            constr_fun (el_lift lfts) fc)
+      let subs = comp_subs (el_lift lfts) (subs_lift e) in
+        mkLetIn (n, to_constr lfts b,
+                    to_constr lfts t,
+                    subst_constr subs f)
     | FEvar ((ev,args),env) ->
-        mkEvar(ev,Array.map (fun a -> constr_fun lfts (mk_clos2 env a)) args)
-    | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a
+      let subs = comp_subs lfts env in
+        mkEvar(ev,Array.map (fun a -> subst_constr subs a) args)
+    | FLIFT (k,a) -> to_constr (el_shft k lfts) a
     | FCLOS (t,env) ->
-        let fr = mk_clos2 env t in
-        let unfv = update v fr.norm fr.term in
-        to_constr constr_fun lfts unfv
+      if is_subs_id env && is_lift_id lfts then t
+      else
+        let subs = comp_subs lfts env in
+        subst_constr subs t
     | FLOCKED -> assert false (*mkVar(Id.of_string"_LOCK_")*)
 
+and subst_constr subst c = match Constr.kind c with
+| Rel i ->
+  begin match expand_rel i subst with
+  | Inl (k, lazy v) -> Vars.lift k v
+  | Inr (m, _) -> mkRel m
+  end
+| _ ->
+  Constr.map_with_binders Esubst.subs_lift subst_constr subst c
+
+and comp_subs el s =
+  Esubst.lift_subst (fun el c -> lazy (to_constr el c)) el s
+
 (* This function defines the correspondance between constr and
    fconstr. When we find a closure whose substitution is the identity,
    then we directly return the constr to avoid possibly huge
    reallocation. *)
-let term_of_fconstr =
-  let rec term_of_fconstr_lift lfts v =
-    match v.term with
-      | FCLOS(t,env) when is_subs_id env && is_lift_id lfts -> t
-      | FLambda(_,tys,f,e) when is_subs_id e && is_lift_id lfts ->
-          Term.compose_lam (List.rev tys) f
-      | FFix(fx,e) when is_subs_id e && is_lift_id lfts -> mkFix fx
-      | FCoFix(cfx,e) when is_subs_id e && is_lift_id lfts -> mkCoFix cfx
-      | _ -> to_constr term_of_fconstr_lift lfts v in
-  term_of_fconstr_lift el_id
-
-
+let term_of_fconstr c = to_constr el_id c
 
 (* fstrong applies unfreeze_fun recursively on the (freeze) term and
  * yields a term.  Assumes that the unfreeze_fun never returns a
@@ -675,14 +694,15 @@ let rec zip m stk =
     | ZcaseT(ci,p,br,e)::s ->
         let t = FCaseT(ci, p, m, br, e) in
         zip {norm=neutr m.norm; term=t} s
-    | Zproj (i,j,cst) :: s ->
-        zip {norm=neutr m.norm; term=FProj(Projection.make cst true,m)} s
+    | Zproj p :: s ->
+        zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s
     | Zfix(fx,par)::s ->
         zip fx (par @ append_stack [|m|] s)
     | Zshift(n)::s ->
         zip (lift_fconstr n m) s
     | Zupdate(rf)::s ->
-        zip (update rf m.norm m.term) s
+      (** The stack contains [Zupdate] marks only if in sharing mode *)
+        zip (update ~share:true rf m.norm m.term) s
 
 let fapp_stack (m,stk) = zip m stk
 
@@ -702,7 +722,8 @@ let strip_update_shift_app_red 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
+      (** The stack contains [Zupdate] marks only if in sharing mode *)
+        strip_rec rstk (update ~share:true m h.norm h.term) depth s
     | stk -> (depth,List.rev rstk, stk) in
   strip_rec [] head 0 stk
 
@@ -727,7 +748,8 @@ let get_nth_arg head n stk =
             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
+        (** The stack contains [Zupdate] mark only if in sharing mode *)
+        strip_rec rstk (update ~share:true m h.norm h.term) n s
     | s -> (None, List.rev rstk @ s) in
   strip_rec [] head n stk
 
@@ -736,7 +758,8 @@ 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
+        (** The stack contains [Zupdate] mark only if in sharing mode *)
+        let _hd = update ~share:true 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
@@ -804,21 +827,26 @@ let drop_parameters depth n argstk =
     constructor is partially applied.
  *)
 let eta_expand_ind_stack env ind m s (f, s') =
+  let open Declarations in
   let mib = lookup_mind (fst ind) env in
-    match mib.Declarations.mind_record with
-    | Some (Some (_,projs,pbs)) when
-        mib.Declarations.mind_finite == Declarations.BiFinite ->
-	(* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') ->
+  (* disallow eta-exp for non-primitive records *)
+  if not (mib.mind_finite == BiFinite) then raise Not_found;
+  match Declareops.inductive_make_projections ind mib with
+  | Some projs ->
+    (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') ->
 	   arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *)
-      let pars = mib.Declarations.mind_nparams in
-      let right = fapp_stack (f, s') in
-      let (depth, args, s) = strip_update_shift_app m s in
-      (** Try to drop the params, might fail on partially applied constructors. *)
-      let argss = try_drop_parameters depth pars args in
-      let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *)
-					 term = FProj (Projection.make p true, right) }) projs in
-	argss, [Zapp hstack]
-    | _ -> raise Not_found (* disallow eta-exp for non-primitive records *)
+    let pars = mib.Declarations.mind_nparams in
+    let right = fapp_stack (f, s') in
+    let (depth, args, s) = strip_update_shift_app m s in
+    (** Try to drop the params, might fail on partially applied constructors. *)
+    let argss = try_drop_parameters depth pars args in
+    let hstack = Array.map (fun p ->
+        { norm = Red; (* right can't be a constructor though *)
+          term = FProj (Projection.make p true, right) })
+        projs
+    in
+    argss, [Zapp hstack]
+  | None -> raise Not_found (* disallow eta-exp for non-primitive records *)
 
 let rec project_nth_arg n argstk =
   match argstk with
@@ -857,9 +885,7 @@ let contract_fix_vect fix =
 let unfold_projection info p =
   if red_projection info.i_flags p
   then
-    let open Declarations in
-    let pb = lookup_projection p (info_env info) in
-    Some (Zproj (pb.proj_npars, pb.proj_arg, Projection.constant p))
+    Some (Zproj (Projection.repr p))
   else None
 
 (*********************************************************************)
@@ -870,10 +896,10 @@ let unfold_projection info p =
 let rec knh info m stk =
   match m.term with
     | FLIFT(k,a) -> knh info a (zshift k stk)
-    | FCLOS(t,e) -> knht info e t (zupdate m stk)
+    | FCLOS(t,e) -> knht info e t (zupdate info m stk)
     | FLOCKED -> assert false
-    | FApp(a,b) -> knh info a (append_stack b (zupdate m stk))
-    | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate m stk)
+    | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk))
+    | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk)
     | FFix(((ri,n),(_,_,_)),_) ->
         (match get_nth_arg m ri.(n) stk with
              (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk')
@@ -882,7 +908,7 @@ let rec knh info m stk =
     | FProj (p,c) ->
       (match unfold_projection info p with
        | None -> (m, stk)
-       | Some s -> knh info c (s :: zupdate m stk))
+       | Some s -> knh info c (s :: zupdate info m stk))
 
 (* cases where knh stops *)
     | (FFlex _|FLetIn _|FConstruct _|FEvar _|
@@ -940,9 +966,9 @@ let rec knr info tab m stk =
             let stk' = par @ append_stack [|rarg|] s in
             let (fxe,fxbd) = contract_fix_vect fx.term in
             knit info tab fxe fxbd stk'
-	| (depth, args, Zproj (n, m, cst)::s) when use_match ->
-	    let rargs = drop_parameters depth n args in
-	    let rarg = project_nth_arg m rargs in
+        | (depth, args, Zproj p::s) when use_match ->
+            let rargs = drop_parameters depth (Projection.Repr.npars p) args in
+            let rarg = project_nth_arg (Projection.Repr.arg p) rargs in
             kni info tab rarg s
         | (_,args,s) -> (m,args@s))
      else (m,stk)
@@ -984,7 +1010,7 @@ let rec zip_term zfun m stk =
         let t = mkCase(ci, zfun (mk_clos e p), m,
 		       Array.map (fun b -> zfun (mk_clos e b)) br) in
         zip_term zfun t s
-    | Zproj(_,_,p)::s ->
+    | Zproj p::s ->
         let t = mkProj (Projection.make p true, m) in
 	zip_term zfun t s
     | Zfix(fx,par)::s ->
@@ -1000,10 +1026,11 @@ let rec zip_term zfun m stk =
    2- tries to rebuild the term. If a closure still has to be computed,
       calls itself recursively. *)
 let rec kl info tab m =
+  let share = info.i_cache.i_share in
   if is_val m then (incr prune; term_of_fconstr m)
   else
     let (nm,s) = kni info tab m [] in
-    let () = if !share then ignore (fapp_stack (nm, s)) in (* to unlock Zupdates! *)
+    let () = if share then ignore (fapp_stack (nm, s)) in (* to unlock Zupdates! *)
     zip_term (kl info tab) (norm_head info tab nm) s
 
 (* no redex: go up for atoms and already normalized terms, go down
@@ -1024,14 +1051,14 @@ and norm_head info tab m =
       | FProd(na,dom,rng) ->
           mkProd(na, kl info tab dom, kl info tab rng)
       | FCoFix((n,(na,tys,bds)),e) ->
-          let ftys = CArray.Fun1.map mk_clos e tys in
+          let ftys = Array.Fun1.map mk_clos e tys in
           let fbds =
-            CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
+            Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
           mkCoFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds))
       | FFix((n,(na,tys,bds)),e) ->
-          let ftys = CArray.Fun1.map mk_clos e tys in
+          let ftys = Array.Fun1.map mk_clos e tys in
           let fbds =
-            CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
+            Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
           mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds))
       | FEvar((i,args),env) ->
           mkEvar(i, Array.map (fun a -> kl info tab (mk_clos env a)) args)
@@ -1052,16 +1079,22 @@ let norm_val info tab v =
 
 let inject c = mk_clos (subs_id 0) c
 
-let whd_stack infos tab m stk =
+let whd_stack infos tab m stk = match m.norm with
+| Whnf | Norm ->
+  (** No need to perform [kni] nor to unlock updates because
+      every head subterm of [m] is [Whnf] or [Norm] *)
+  knh infos m stk
+| Red | Cstr ->
   let k = kni infos tab m stk in
-  let () = if !share then ignore (fapp_stack k) in (* to unlock Zupdates! *)
+  let () = if infos.i_cache.i_share then ignore (fapp_stack k) in (* to unlock Zupdates! *)
   k
 
 (* cache of constants: the body is computed only when needed. *)
 type clos_infos = fconstr infos
 
 let create_clos_infos ?(evars=fun _ -> None) flgs env =
-  create (fun _ _ c -> inject c) flgs env evars
+  let share = (Environ.typing_flags env).Declarations.share_reduction in
+  create ~share ~repr:(fun _ _ c -> inject c) flgs env evars
 
 let create_tab () = KeyTable.create 17
 
diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli
index e2f5a3b8..6121b3a1 100644
--- a/kernel/cClosure.mli
+++ b/kernel/cClosure.mli
@@ -15,7 +15,6 @@ open Esubst
 
 (** Flags for profiling reductions. *)
 val stats : bool ref
-val share : bool ref
 
 val with_stats: 'a Lazy.t -> 'a
 
@@ -106,8 +105,13 @@ type 'a infos = {
   i_cache : 'a infos_cache }
 
 val ref_value_cache: 'a infos -> 'a infos_tab -> table_key -> 'a option
-val create: ('a infos -> 'a infos_tab -> constr -> 'a) -> reds -> env ->
-  (existential -> constr option) -> 'a infos
+val create:
+  repr:('a infos -> 'a infos_tab -> constr -> 'a) ->
+  share:bool ->
+  reds ->
+  env ->
+  (existential -> constr option) ->
+  'a infos
 val create_tab : unit -> 'a infos_tab
 val evar_value : 'a infos_cache -> existential -> constr option
 
@@ -152,7 +156,7 @@ type fterm =
 type stack_member =
   | Zapp of fconstr array
   | ZcaseT of case_info * constr * constr array * fconstr subs
-  | Zproj of int * int * Constant.t
+  | Zproj of Projection.Repr.t
   | Zfix of fconstr * stack
   | Zshift of int
   | Zupdate of fconstr
@@ -239,14 +243,11 @@ val lift_fconstr_vect : int -> fconstr array -> fconstr array
 
 val mk_clos      : fconstr subs -> constr -> fconstr
 val mk_clos_vect : fconstr subs -> constr array -> fconstr array
-val mk_clos_deep :
-  (fconstr subs -> constr -> fconstr) ->
-   fconstr subs -> constr -> fconstr
 
 val kni: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack
 val knr: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack
 val kl : clos_infos -> fconstr infos_tab -> fconstr -> constr
 
-val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
+val to_constr : lift -> fconstr -> constr
 
 (** End of cbn debug section i*)
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index 0f3a43d5..ed3bd866 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -15,82 +15,7 @@
 (* This file defines the type of bytecode instructions *)
 
 open Names
-open Constr
-
-type tag = int
-
-let accu_tag = 0
-
-let type_atom_tag = 2
-let max_atom_tag = 2
-let proj_tag = 3
-let fix_app_tag = 4
-let switch_tag = 5
-let cofix_tag = 6
-let cofix_evaluated_tag = 7
-
-(* It would be great if OCaml exported this value,
-   So fixme if this happens in a new version of OCaml *)
-let last_variant_tag = 245 
-
-type structured_constant =
-  | Const_sort of Sorts.t
-  | Const_ind of inductive
-  | Const_proj of Constant.t
-  | Const_b0 of tag
-  | Const_bn of tag * structured_constant array
-  | Const_univ_level of Univ.Level.t
-
-type reloc_table = (tag * int) array
-
-type annot_switch =
-   {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int}
-
-let rec eq_structured_constant c1 c2 = match c1, c2 with
-| Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2
-| Const_sort _, _ -> false
-| Const_ind i1, Const_ind i2 -> eq_ind i1 i2
-| Const_ind _, _ -> false
-| Const_proj p1, Const_proj p2 -> Constant.equal p1 p2
-| Const_proj _, _ -> false
-| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2
-| Const_b0 _, _ -> false
-| Const_bn (t1, a1), Const_bn (t2, a2) ->
-  Int.equal t1 t2 && CArray.equal eq_structured_constant a1 a2
-| Const_bn _, _ -> false
-| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2
-| Const_univ_level _ , _ -> false
-
-let rec hash_structured_constant c =
-  let open Hashset.Combine in
-  match c with
-  | Const_sort s -> combinesmall 1 (Sorts.hash s)
-  | Const_ind i -> combinesmall 2 (ind_hash i)
-  | Const_proj p -> combinesmall 3 (Constant.hash p)
-  | Const_b0 t -> combinesmall 4 (Int.hash t)
-  | Const_bn (t, a) ->
-    let fold h c = combine h (hash_structured_constant c) in
-    let h = Array.fold_left fold 0 a in
-    combinesmall 5 (combine (Int.hash t) h)
-  | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l)
-
-let eq_annot_switch asw1 asw2 =
-  let eq_ci ci1 ci2 =
-    eq_ind ci1.ci_ind ci2.ci_ind &&
-    Int.equal ci1.ci_npar ci2.ci_npar &&
-    CArray.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls
-  in
-  let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in
-  eq_ci asw1.ci asw2.ci &&
-  CArray.equal eq_rlc asw1.rtbl asw2.rtbl &&
-  (asw1.tailcall : bool) == asw2.tailcall
-
-let hash_annot_switch asw =
-  let open Hashset.Combine in
-  let h1 = Constr.case_info_hash asw.ci in
-  let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in
-  let h3 = if asw.tailcall then 1 else 0 in
-  combine3 h1 h2 h3
+open Vmvalues
 
 module Label =
   struct
@@ -132,8 +57,7 @@ type instruction =
   | Ksetfield of int
   | Kstop
   | Ksequence of bytecodes * bytecodes
-  | Kproj of int * Constant.t  (* index of the projected argument,
-                                           name of projection *)
+  | Kproj of Projection.Repr.t
   | Kensurestackcapacity of int
 (* spiwack: instructions concerning integers *)
   | Kbranch of Label.t                  (* jump to label *)
@@ -237,22 +161,6 @@ type comp_env = {
 open Pp
 open Util
 
-let pp_sort s =
-  let open Sorts in
-  match s with
-  | Prop Null -> str "Prop"
-  | Prop Pos -> str "Set"
-  | Type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}"
-
-let rec pp_struct_const = function
-  | Const_sort s -> pp_sort s
-  | Const_ind (mind, i) -> MutInd.print mind ++ str"#" ++ int i
-  | Const_proj p -> Constant.print p
-  | Const_b0 i -> int i
-  | Const_bn (i,t) ->
-     int i ++ surround (prvect_with_sep pr_comma pp_struct_const t)
-  | Const_univ_level l -> Univ.Level.pr l
-
 let pp_lbl lbl = str "L" ++ int lbl
 
 let pp_fv_elem = function
@@ -310,13 +218,13 @@ let rec pp_instr i =
 	     prlist_with_sep spc pp_lbl (Array.to_list lblb))
   | Kpushfields n -> str "pushfields " ++ int n
   | Kfield n -> str "field " ++ int n
-  | Ksetfield n -> str "set field" ++ int n
+  | Ksetfield n -> str "setfield " ++ int n
 
   | Kstop -> str "stop"
 
   | Kbranch lbl -> str "branch " ++ pp_lbl lbl
 
-  | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p
+  | Kproj p -> str "proj " ++ Projection.Repr.print p
 
   | Kensurestackcapacity size -> str "growstack " ++ int size
 
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index f87090c7..9c04c166 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -11,42 +11,7 @@
 (* $Id$ *)
 
 open Names
-open Constr
-
-type tag = int
-
-val accu_tag : tag
-
-val type_atom_tag : tag
-val max_atom_tag : tag
-val proj_tag : tag
-val fix_app_tag : tag
-val switch_tag : tag
-val cofix_tag : tag
-val cofix_evaluated_tag : tag
-
-val last_variant_tag : tag
-
-type structured_constant =
-  | Const_sort of Sorts.t
-  | Const_ind of inductive
-  | Const_proj of Constant.t
-  | Const_b0 of tag
-  | Const_bn of tag * structured_constant array
-  | Const_univ_level of Univ.Level.t
-
-val pp_struct_const : structured_constant -> Pp.t
-
-type reloc_table = (tag * int) array
-
-type annot_switch =
-   {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int}
-
-val eq_structured_constant : structured_constant -> structured_constant -> bool
-val hash_structured_constant : structured_constant -> int
-
-val eq_annot_switch : annot_switch -> annot_switch -> bool
-val hash_annot_switch : annot_switch -> int
+open Vmvalues
 
 module Label :
   sig
@@ -89,8 +54,7 @@ type instruction =
   | Ksetfield of int                    (** accu[n] = sp[0] ; sp = pop sp *)
   | Kstop
   | Ksequence of bytecodes * bytecodes
-  | Kproj of int * Constant.t  (** index of the projected argument,
-                                            name of projection *)
+  | Kproj of Projection.Repr.t
   | Kensurestackcapacity of int
 
 (** spiwack: instructions concerning integers *)
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index e2c535e9..5362f9a8 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -14,13 +14,14 @@
 
 open Util
 open Names
+open Vmvalues
 open Cbytecodes
 open Cemitcodes
 open Cinstr
 open Clambda
 open Constr
 open Declarations
-open Pre_env
+open Environ
 
 
 (* Compilation of variables + computing free variables                    *)
@@ -77,6 +78,7 @@ open Pre_env
 (*    ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ]   *)
 (* If such a block is matched against, we have to force evaluation,       *)
 (* function [fcofixi] is then applied to [ai'] [arg1] ... [argp]          *)
+(* (note that [ai'] is a pointer to the closure, passed as argument)      *)
 (* Once evaluation is completed [ai'] is updated with the result:         *)
 (*  ai' <--                                                               *)
 (*   [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ]   *)
@@ -394,72 +396,72 @@ let init_fun_code () = fun_code := []
 (*
 If [tag] hits the OCaml limitation for non constant constructors, we switch to
 another representation for the remaining constructors:
-[last_variant_tag|tag - last_variant_tag|args]
+[last_variant_tag|tag - Obj.last_non_constant_constructor_tag|args]
 
-We subtract last_variant_tag for efficiency of match interpretation.
+We subtract Obj.last_non_constant_constructor_tag for efficiency of match interpretation.
  *)
 
 let nest_block tag arity cont =
-  Kconst (Const_b0 (tag - last_variant_tag)) ::
-    Kmakeblock(arity+1, last_variant_tag) :: cont
+  Kconst (Const_b0 (tag - Obj.last_non_constant_constructor_tag)) ::
+    Kmakeblock(arity+1, Obj.last_non_constant_constructor_tag) :: cont
 
 let code_makeblock ~stack_size ~arity ~tag cont = 
-  if tag < last_variant_tag then
+  if tag < Obj.last_non_constant_constructor_tag then
     Kmakeblock(arity, tag) :: cont
   else begin
     set_max_stack_size (stack_size + 1);
     Kpush :: nest_block tag arity cont
   end
 
-let compile_structured_constant reloc sc sz cont =
+let compile_structured_constant cenv sc sz cont =
   set_max_stack_size sz;
   Kconst sc :: cont
 
 (* compiling application *)
-let comp_args comp_expr reloc args sz cont =
+let comp_args comp_expr cenv args sz cont =
   let nargs_m_1 = Array.length args - 1 in
-  let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in
+  let c = ref (comp_expr cenv args.(0) (sz + nargs_m_1) cont) in
   for i = 1 to nargs_m_1 do
-    c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c)
+    c := comp_expr cenv args.(i) (sz + nargs_m_1 - i) (Kpush :: !c)
   done;
   !c
 
-let comp_app comp_fun comp_arg reloc f args sz cont =
+let comp_app comp_fun comp_arg cenv f args sz cont =
   let nargs = Array.length args in
-  if Int.equal nargs 0 then comp_fun reloc f sz cont
+  if Int.equal nargs 0 then comp_fun cenv f sz cont
   else
   match is_tailcall cont with
   | Some k ->
-      comp_args comp_arg reloc args sz
+      comp_args comp_arg cenv args sz
 	(Kpush ::
-	 comp_fun reloc f (sz + nargs)
+         comp_fun cenv f (sz + nargs)
 	   (Kappterm(nargs, k + nargs) :: (discard_dead_code cont)))
   | None ->
       if nargs < 4 then
-	comp_args comp_arg reloc args sz
-	  (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont)))
+        comp_args comp_arg cenv args sz
+          (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont)))
       else
 	let lbl,cont1 = label_code cont in
 	Kpush_retaddr lbl ::
-	(comp_args comp_arg reloc args (sz + 3)
-	   (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1))))
+        (comp_args comp_arg cenv args (sz + 3)
+           (Kpush :: (comp_fun cenv f (sz+3+nargs) (Kapply nargs :: cont1))))
 
 (* Compiling free variables *)
 
-let compile_fv_elem reloc fv sz cont =
+let compile_fv_elem cenv fv sz cont =
   match fv with
-  | FVrel i -> pos_rel i reloc sz :: cont
-  | FVnamed id -> pos_named id reloc :: cont
-  | FVuniv_var i -> pos_universe_var i reloc sz :: cont
-  | FVevar evk -> pos_evar evk reloc :: cont
+  | FVrel i -> pos_rel i cenv sz :: cont
+  | FVnamed id -> pos_named id cenv :: cont
+  | FVuniv_var i -> pos_universe_var i cenv sz :: cont
+  | FVevar evk -> pos_evar evk cenv :: cont
 
-let rec compile_fv reloc l sz cont =
+let rec compile_fv cenv l sz cont =
   match l with
   | [] -> cont
-  | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont
+  | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem cenv fvn sz cont
   | fvn :: tl ->
-      compile_fv_elem reloc fvn sz
-	(Kpush :: compile_fv reloc tl (sz + 1) cont)
+      compile_fv_elem cenv fvn sz
+        (Kpush :: compile_fv cenv tl (sz + 1) cont)
 
 
 (* Compiling constants *)
@@ -484,61 +486,63 @@ let make_areconst n else_lbl cont =
     Kareconst (n, else_lbl)::cont
 
 (* sz is the size of the local stack *)
-let rec compile_lam env reloc lam sz cont =
+let rec compile_lam env cenv lam sz cont =
   set_max_stack_size sz;
   match lam with
-  | Lrel(_, i) -> pos_rel i reloc sz :: cont
+  | Lrel(_, i) -> pos_rel i cenv sz :: cont
 
-  | Lval v -> compile_structured_constant reloc v sz cont
+  | Lint i -> compile_structured_constant cenv (Const_b0 i) sz cont
 
-  | Lproj (n,kn,arg) ->
-     compile_lam env reloc arg sz (Kproj (n,kn) :: cont)
+  | Lval v -> compile_structured_constant cenv (Const_val v) sz cont
 
-  | Lvar id -> pos_named id reloc :: cont
+  | Lproj (p,arg) ->
+     compile_lam env cenv arg sz (Kproj p :: cont)
+
+  | Lvar id -> pos_named id cenv :: cont
 
   | Levar (evk, args) ->
       if Array.is_empty args then
-        compile_fv_elem reloc (FVevar evk) sz cont
+        compile_fv_elem cenv (FVevar evk) sz cont
       else
         (** Arguments are reversed in evar instances *)
         let args = Array.copy args in
         let () = Array.rev args in
-        comp_app compile_fv_elem (compile_lam env) reloc (FVevar evk) args sz cont
+        comp_app compile_fv_elem (compile_lam env) cenv (FVevar evk) args sz cont
 
-  | Lconst (kn,u) -> compile_constant env reloc kn u [||] sz cont
+  | Lconst (kn,u) -> compile_constant env cenv kn u [||] sz cont
 
   | Lind (ind,u) ->
     if Univ.Instance.is_empty u then
-      compile_structured_constant reloc (Const_ind ind) sz cont
-    else comp_app compile_structured_constant compile_universe reloc
+      compile_structured_constant cenv (Const_ind ind) sz cont
+    else comp_app compile_structured_constant compile_universe cenv
         (Const_ind ind) (Univ.Instance.to_array u) sz cont
 
-  | Lsort (Sorts.Prop _ as s) ->
-    compile_structured_constant reloc (Const_sort s) sz cont
+  | Lsort (Sorts.Prop | Sorts.Set as s) ->
+    compile_structured_constant cenv (Const_sort s) sz cont
   | Lsort (Sorts.Type u) ->
     (* We represent universes as a global constant with local universes
        "compacted", i.e. as [u arg0 ... argn] where we will substitute (after
        evaluation) [Var 0,...,Var n] with values of [arg0,...,argn] *)
     let u,s = Univ.compact_univ u in
-    let compile_get_univ reloc idx sz cont =
+    let compile_get_univ cenv idx sz cont =
       set_max_stack_size sz;
-      compile_fv_elem reloc (FVuniv_var idx) sz cont
+      compile_fv_elem cenv (FVuniv_var idx) sz cont
     in
     if List.is_empty s then
-      compile_structured_constant reloc (Const_sort (Sorts.Type u)) sz cont
+      compile_structured_constant cenv (Const_sort (Sorts.Type u)) sz cont
     else
-      comp_app compile_structured_constant compile_get_univ reloc
+      comp_app compile_structured_constant compile_get_univ cenv
         (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont
 
   | Llet (id,def,body) ->
-      compile_lam env reloc def sz
+      compile_lam env cenv def sz
         (Kpush ::
-         compile_lam env (push_local sz reloc) body (sz+1) (add_pop 1 cont))
+         compile_lam env (push_local sz cenv) body (sz+1) (add_pop 1 cont))
 
   | Lprod (dom,codom) ->
      let cont1 =
-       Kpush :: compile_lam env reloc dom (sz+1) (Kmakeprod :: cont) in
-     compile_lam env reloc codom sz cont1
+       Kpush :: compile_lam env cenv dom (sz+1) (Kmakeprod :: cont) in
+     compile_lam env cenv codom sz cont1
 
   | Llam (ids,body) ->
      let arity = Array.length ids in
@@ -549,12 +553,12 @@ let rec compile_lam env reloc lam sz cont =
      in
      fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)];
      let fv = fv r_fun in
-     compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont)
+     compile_fv cenv fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont)
 
   | Lapp (f, args) ->
     begin match f with
-    | Lconst (kn,u) -> compile_constant env reloc kn u args sz cont
-    | _ -> comp_app (compile_lam env) (compile_lam env) reloc f args sz cont
+    | Lconst (kn,u) -> compile_constant env cenv kn u args sz cont
+    | _ -> comp_app (compile_lam env) (compile_lam env) cenv f args sz cont
     end
 
   | Lfix ((rec_args, init), (decl, types, bodies)) ->
@@ -586,7 +590,7 @@ let rec compile_lam env reloc lam sz cont =
 	fun_code := [Ksequence(fcode,!fun_code)]
       done;
       let fv = !rfv in
-      compile_fv reloc fv.fv_rev sz
+      compile_fv cenv fv.fv_rev sz
 	(Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont)
 
 
@@ -622,7 +626,7 @@ let rec compile_lam env reloc lam sz cont =
       done;
       let fv = !rfv in
       set_max_stack_size (sz + fv.size + ndef + 2);
-      compile_fv reloc fv.fv_rev sz
+      compile_fv cenv fv.fv_rev sz
 	(Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont)
 
 
@@ -633,14 +637,14 @@ let rec compile_lam env reloc lam sz cont =
       let lbl_consts = Array.make oib.mind_nb_constant Label.no in
       let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *)
       let nconst = Array.length branches.constant_branches in
-      let nblock = min nallblock (last_variant_tag + 1) in
+      let nblock = min nallblock (Obj.last_non_constant_constructor_tag + 1) in
       let lbl_blocks = Array.make nblock Label.no in
-      let neblock = max 0 (nallblock - last_variant_tag) in
+      let neblock = max 0 (nallblock - Obj.last_non_constant_constructor_tag) in
       let lbl_eblocks = Array.make neblock Label.no in 
       let branch1, cont = make_branch cont in
       (* Compilation of the return type *)
       let fcode =
-        ensure_stack_capacity (compile_lam env reloc t sz) [Kpop sz; Kstop]
+        ensure_stack_capacity (compile_lam env cenv t sz) [Kpop sz; Kstop]
       in
       let lbl_typ,fcode = label_code fcode in
       fun_code := [Ksequence(fcode,!fun_code)];
@@ -661,14 +665,14 @@ let rec compile_lam env reloc lam sz cont =
         let lbl_b, code_b = 
           label_code (
             Kpush :: Kfield 0 :: Kswitch(lbl_eblocks, [||]) :: !c) in
-        lbl_blocks.(last_variant_tag) <- lbl_b;
+        lbl_blocks.(Obj.last_non_constant_constructor_tag) <- lbl_b;
         c := code_b
       end;
 
       (* Compilation of constant branches *)
       for i = nconst - 1 downto 0 do
         let aux =
-          compile_lam env reloc branches.constant_branches.(i) sz_b (branch::!c)
+          compile_lam env cenv branches.constant_branches.(i) sz_b (branch::!c)
         in
         let lbl_b,code_b = label_code aux in
         lbl_consts.(i) <- lbl_b;
@@ -680,10 +684,10 @@ let rec compile_lam env reloc lam sz cont =
         let (ids, body) = branches.nonconstant_branches.(i) in
         let arity = Array.length ids in
         let code_b =
-          compile_lam env (push_param arity sz_b reloc)
+          compile_lam env (push_param arity sz_b cenv)
             body (sz_b+arity) (add_pop arity (branch::!c)) in
         let code_b =
-            if tag < last_variant_tag then begin
+            if tag < Obj.last_non_constant_constructor_tag then begin
                 set_max_stack_size (sz_b + arity);
                 Kpushfields arity :: code_b
               end
@@ -693,8 +697,8 @@ let rec compile_lam env reloc lam sz cont =
               end
         in
         let lbl_b, code_b = label_code code_b in
-        if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b
-          else lbl_eblocks.(tag - last_variant_tag) <- lbl_b;
+        if tag < Obj.last_non_constant_constructor_tag then lbl_blocks.(tag) <- lbl_b
+          else lbl_eblocks.(tag - Obj.last_non_constant_constructor_tag) <- lbl_b;
         c := code_b
       done;
 
@@ -718,25 +722,25 @@ let rec compile_lam env reloc lam sz cont =
         | Kbranch lbl -> Kpush_retaddr lbl ::  !c
 	| _ -> !c
       in
-      compile_lam env reloc a sz code_sw
+      compile_lam env cenv a sz code_sw
 
   | Lmakeblock (tag,args) ->
     let arity = Array.length args in
     let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in
-    comp_args (compile_lam env) reloc args sz cont
+    comp_args (compile_lam env) cenv args sz cont
 
   | Lprim (kn, ar, op, args) ->
-    op_compilation env ar op kn reloc args sz cont
+    op_compilation env ar op kn cenv args sz cont
 
   | Luint v ->
      (match v with
-     | UintVal i -> compile_structured_constant reloc (Const_b0 (Uint31.to_int i)) sz cont
+     | UintVal i -> compile_structured_constant cenv (Const_b0 (Uint31.to_int i)) sz cont
      | UintDigits ds ->
        let nargs = Array.length ds in
        if Int.equal nargs 31 then
          let (escape,labeled_cont) = make_branch cont in
          let else_lbl = Label.create() in
-         comp_args (compile_lam env) reloc ds sz
+         comp_args (compile_lam env) cenv ds sz
            ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont)
        else
          let code_construct cont = (* spiwack: variant of the global code_construct
@@ -752,40 +756,40 @@ let rec compile_lam env reloc lam sz cont =
            Kclosure(lbl,0) :: cont
          in
          comp_app (fun _ _ _ cont -> code_construct cont)
-           (compile_lam env) reloc () ds sz cont
+           (compile_lam env) cenv () ds sz cont
      | UintDecomp t ->
        let escape_lbl, labeled_cont = label_code cont in
-       compile_lam env  reloc t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont))
+       compile_lam env  cenv t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont))
 
 
 (* spiwack : compilation of constants with their arguments.
    Makes a special treatment with 31-bit integer addition *)
-and compile_get_global reloc (kn,u) sz cont =
+and compile_get_global cenv (kn,u) sz cont =
   set_max_stack_size sz;
   if Univ.Instance.is_empty u then
     Kgetglobal kn :: cont
   else
     comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont)
-      compile_universe reloc () (Univ.Instance.to_array u) sz cont
+      compile_universe cenv () (Univ.Instance.to_array u) sz cont
 
-and compile_universe reloc uni sz cont =
+and compile_universe cenv uni sz cont =
   set_max_stack_size sz;
   match Univ.Level.var_index uni with
-  | None -> compile_structured_constant reloc (Const_univ_level uni) sz cont
-  | Some idx -> pos_universe_var idx reloc sz :: cont
+  | None -> compile_structured_constant cenv (Const_univ_level uni) sz cont
+  | Some idx -> pos_universe_var idx cenv sz :: cont
 
-and compile_constant env reloc kn u args sz cont =
+and compile_constant env cenv kn u args sz cont =
   set_max_stack_size sz;
   if Univ.Instance.is_empty u then
     (* normal compilation *)
     comp_app (fun _ _ sz cont ->
-        compile_get_global reloc (kn,u) sz cont)
-      (compile_lam env) reloc () args sz cont
+        compile_get_global cenv (kn,u) sz cont)
+      (compile_lam env) cenv () args sz cont
   else
-    let compile_arg reloc constr_or_uni sz cont =
+    let compile_arg cenv constr_or_uni sz cont =
       match constr_or_uni with
-      | ArgLambda t -> compile_lam env reloc t sz cont
-      | ArgUniv uni -> compile_universe reloc uni sz cont
+      | ArgLambda t -> compile_lam env cenv t sz cont
+      | ArgUniv uni -> compile_universe cenv uni sz cont
     in
     let u = Univ.Instance.to_array u in
     let lu = Array.length u in
@@ -794,7 +798,7 @@ and compile_constant env reloc kn u args sz cont =
         (fun i -> if i < lu then ArgUniv u.(i) else ArgLambda args.(i-lu))
     in
     comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont)
-      compile_arg reloc () all sz cont
+      compile_arg cenv () all sz cont
 
 (*template for n-ary operation, invariant: n>=1,
   the operations does the following :
@@ -803,34 +807,34 @@ and compile_constant env reloc kn u args sz cont =
   3/ if at least one is not, branches to the normal behavior:
       Kgetglobal (get_alias !global_env kn) *)
 and op_compilation env n op =
-  let code_construct reloc kn sz cont =
+  let code_construct cenv kn sz cont =
      let f_cont =
          let else_lbl = Label.create () in
          Kareconst(n, else_lbl):: Kacc 0:: Kpop 1::
           op:: Kreturn 0:: Klabel else_lbl::
          (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*)
-          compile_get_global reloc kn sz (
+          compile_get_global cenv kn sz (
             Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *)
      in
      let lbl = Label.create () in
      fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)];
      Kclosure(lbl, 0)::cont
   in
-  fun kn reloc args sz cont ->
+  fun kn cenv args sz cont ->
   let nargs = Array.length args in
   if Int.equal nargs n then (*if it is a fully applied addition*)
     let (escape, labeled_cont) = make_branch cont in
     let else_lbl = Label.create () in
     assert (n < 4);
-    comp_args (compile_lam env) reloc args sz
+    comp_args (compile_lam env) cenv args sz
       (Kisconst else_lbl::(make_areconst (n-1) else_lbl
          (*Kaddint31::escape::Klabel else_lbl::Kpush::*)
          (op::escape::Klabel else_lbl::Kpush::
          (* works as comp_app with nargs < 4 and non-tailcall cont*)
-         compile_get_global reloc kn (sz+n) (Kapply n::labeled_cont))))
+         compile_get_global cenv kn (sz+n) (Kapply n::labeled_cont))))
   else
-    comp_app (fun reloc _ sz cont -> code_construct reloc kn sz cont)
-      (compile_lam env) reloc () args sz cont
+    comp_app (fun cenv _ sz cont -> code_construct cenv kn sz cont)
+      (compile_lam env) cenv () args sz cont
 
 
 let is_univ_copy max u =
@@ -845,6 +849,8 @@ let is_univ_copy max u =
   else
     false
 
+let dump_bytecode = ref false
+
 let dump_bytecodes init code fvs =
   let open Pp in
     (str "code =" ++ fnl () ++
@@ -859,11 +865,11 @@ let compile ~fail_on_error ?universes:(universes=0) env c =
   Label.reset_label_counter ();
   let cont = [Kstop] in
   try
-    let reloc, init_code =
+    let cenv, init_code =
       if Int.equal universes 0 then
         let lam = lambda_of_constr ~optimize:true env c in
-        let reloc = empty_comp_env () in
-        reloc, ensure_stack_capacity (compile_lam env reloc lam 0) cont
+        let cenv = empty_comp_env () in
+        cenv, ensure_stack_capacity (compile_lam env cenv lam 0) cont
       else
         (* We are going to generate a lambda, but merge the universe closure
          * with the function closure if it exists.
@@ -871,7 +877,7 @@ let compile ~fail_on_error ?universes:(universes=0) env c =
         let lam = lambda_of_constr ~optimize:true env c in
         let params, body = decompose_Llam lam in
         let arity = Array.length params in
-        let reloc = empty_comp_env () in
+        let cenv = empty_comp_env () in
         let full_arity = arity + universes in
         let r_fun = comp_env_fun ~univs:universes arity in
         let lbl_fun = Label.create () in
@@ -882,13 +888,13 @@ let compile ~fail_on_error ?universes:(universes=0) env c =
         fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)];
         let fv = fv r_fun in
         let init_code =
-          ensure_stack_capacity (compile_fv reloc fv.fv_rev 0)
+          ensure_stack_capacity (compile_fv cenv fv.fv_rev 0)
                          (Kclosure(lbl_fun,fv.size) :: cont)
         in
-        reloc, init_code
+        cenv, init_code
     in
-    let fv = List.rev (!(reloc.in_env).fv_rev) in
-    (if !Flags.dump_bytecode then
+    let fv = List.rev (!(cenv.in_env).fv_rev) in
+    (if !dump_bytecode then
       Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ;
     Some (init_code,!fun_code, Array.of_list fv)
   with TooLargeInductive msg ->
@@ -935,13 +941,13 @@ let op2_compilation op =
      fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)];
      Kclosure(lbl, 0)::cont
   in
-  fun normal fc _ reloc args sz cont ->
+  fun normal fc _ cenv args sz cont ->
   if not fc then raise Not_found else
   let nargs = Array.length args in
   if nargs=2 then (*if it is a fully applied addition*)
     let (escape, labeled_cont) = make_branch cont in
     let else_lbl = Label.create () in
-      comp_args compile_constr reloc args sz
+      comp_args compile_constr cenv args sz
 	(Kisconst else_lbl::(make_areconst 1  else_lbl
            (*Kaddint31::escape::Klabel else_lbl::Kpush::*)
            (op::escape::Klabel else_lbl::Kpush::
@@ -953,5 +959,5 @@ let op2_compilation op =
     code_construct normal cont
   else
     comp_app (fun _ _ _ cont -> code_construct normal cont)
-      compile_constr reloc () args sz cont *)
+      compile_constr cenv () args sz cont *)
 
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index abab58b6..57d3e6fc 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -12,7 +12,7 @@ open Cbytecodes
 open Cemitcodes
 open Constr
 open Declarations
-open Pre_env
+open Environ
 
 (** Should only be used for monomorphic terms *)
 val compile : fail_on_error:bool ->
@@ -25,3 +25,6 @@ val compile_constant_body : fail_on_error:bool ->
 (** Shortcut of the previous function used during module strengthening *)
 
 val compile_alias : Names.Constant.t -> body_code
+
+(** Dump the bytecode after compilation (for debugging purposes) *)
+val dump_bytecode : bool ref
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 14f4f27c..50f5607e 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -13,20 +13,22 @@
 (* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
 
 open Names
-open Term
+open Constr
+open Vmvalues
 open Cbytecodes
 open Copcodes
 open Mod_subst
 
 type emitcodes = String.t
 
-external tcode_of_code : Bytes.t -> int -> Vmvalues.tcode = "coq_tcode_of_code"
+external tcode_of_code : Bytes.t -> Vmvalues.tcode = "coq_tcode_of_code"
 
 (* Relocation information *)
 type reloc_info =
   | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
   | Reloc_getglobal of Names.Constant.t
+  | Reloc_proj_name of Projection.Repr.t
 
 let eq_reloc_info r1 r2 = match r1, r2 with
 | Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2
@@ -35,6 +37,8 @@ let eq_reloc_info r1 r2 = match r1, r2 with
 | Reloc_const _, _ -> false
 | Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2
 | Reloc_getglobal _, _ -> false
+| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2
+| Reloc_proj_name _, _ -> false
 
 let hash_reloc_info r =
   let open Hashset.Combine in
@@ -42,6 +46,7 @@ let hash_reloc_info r =
   | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw)
   | Reloc_const c -> combinesmall 2 (hash_structured_constant c)
   | Reloc_getglobal c -> combinesmall 3 (Constant.hash c)
+  | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p)
 
 module RelocTable = Hashtbl.Make(struct
   type t = reloc_info
@@ -82,7 +87,7 @@ let patch buff pl f =
   (** Order seems important here? *)
   let reloc = CArray.map (fun (r, pos) -> (f r, pos)) pl.reloc_infos in
   let buff = patch_int buff reloc in
-  tcode_of_code buff (Bytes.length buff)
+  tcode_of_code buff
 
 (* Buffering of bytecode *)
 
@@ -187,6 +192,9 @@ let slot_for_getglobal env p =
   enter env (Reloc_getglobal p);
   out_int env 0
 
+let slot_for_proj_name env p =
+  enter env (Reloc_proj_name p);
+  out_int env 0
 
 (* Emission of one instruction *)
 
@@ -277,7 +285,7 @@ let emit_instr env = function
       if n <= 1 then out env (opSETFIELD0+n)
       else (out env opSETFIELD;out_int env n)
   | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr"
-  | Kproj (n,p) -> out env opPROJ; out_int env n; slot_for_const env (Const_proj p)
+  | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p
   | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size
   (* spiwack *)
   | Kbranch lbl -> out env opBRANCH; out_label env lbl
@@ -350,11 +358,9 @@ let rec emit env insns remaining = match insns with
 type to_patch = emitcodes * patches * fv
 
 (* Substitution *)
-let rec subst_strcst s sc =
+let subst_strcst s sc =
   match sc with
-  | Const_sort _ | Const_b0 _ | Const_univ_level _ -> sc
-  | Const_proj p -> Const_proj (subst_constant s p)
-  | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args)
+  | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ -> sc
   | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i)
 
 let subst_reloc s ri =
@@ -365,6 +371,7 @@ let subst_reloc s ri =
       Reloc_annot {a with ci = ci}
   | Reloc_const sc -> Reloc_const (subst_strcst s sc)
   | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn)
+  | Reloc_proj_name p -> Reloc_proj_name (subst_proj_repr s p)
 
 let subst_patches subst p =
   let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 03920dc1..39ddf4a0 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -1,10 +1,12 @@
 open Names
+open Vmvalues
 open Cbytecodes
 
 type reloc_info =
   | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
   | Reloc_getglobal of Constant.t
+  | Reloc_proj_name of Projection.Repr.t
 
 type patches
 type emitcodes
diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli
index f42c4617..dca1757b 100644
--- a/kernel/cinstr.mli
+++ b/kernel/cinstr.mli
@@ -9,6 +9,7 @@
 (************************************************************************)
 open Names
 open Constr
+open Vmvalues
 open Cbytecodes
 
 (** This file defines the lambda code for the bytecode compiler. It has been
@@ -33,10 +34,11 @@ and lambda =
   | Lfix          of (int array * int) * fix_decl
   | Lcofix        of int * fix_decl (* must be in eta-expanded form *)
   | Lmakeblock    of int * lambda array
-  | Lval          of structured_constant
+  | Lval          of structured_values
   | Lsort         of Sorts.t
   | Lind          of pinductive
-  | Lproj         of int * Constant.t * lambda
+  | Lproj         of Projection.Repr.t * lambda
+  | Lint          of int
   | Luint         of uint
 
 (* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation
diff --git a/kernel/clambda.ml b/kernel/clambda.ml
index c39f4259..7c930b3f 100644
--- a/kernel/clambda.ml
+++ b/kernel/clambda.ml
@@ -4,9 +4,10 @@ open Esubst
 open Term
 open Constr
 open Declarations
+open Vmvalues
 open Cbytecodes
 open Cinstr
-open Pre_env
+open Environ
 open Pp
 
 let pr_con sp = str(Names.Label.to_string (Constant.label sp))
@@ -111,10 +112,12 @@ let rec pp_lam lam =
       (str "(PRIM " ++ pr_con kn ++  spc() ++
        prlist_with_sep spc pp_lam  (Array.to_list args) ++
        str")")
-  | Lproj(i,kn,arg) ->
+  | Lproj(p,arg) ->
     hov 1
-      (str "(proj#" ++ int i ++ spc() ++ pr_con kn ++ str "(" ++ pp_lam arg
+      (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg
        ++ str ")")
+  | Lint i ->
+    Pp.(str "(int:" ++ int i ++ str ")")
   | Luint _ ->
     str "(uint)"
 
@@ -150,9 +153,9 @@ let shift subst = subs_shft (1, subst)
 
 let rec map_lam_with_binders g f n lam =
   match lam with
-  | Lrel _ | Lvar _  | Lconst _ | Lval _ | Lsort _ | Lind _ -> lam
+  | Lrel _ | Lvar _  | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ -> lam
   | Levar (evk, args) ->
-    let args' = Array.smartmap (f n) args in
+    let args' = Array.Smart.map (f n) args in
     if args == args' then lam else Levar (evk, args')
   | Lprod(dom,codom) ->
     let dom' = f n dom in
@@ -167,19 +170,19 @@ let rec map_lam_with_binders g f n lam =
     if body == body' && def == def' then lam else Llet(id,def',body')
   | Lapp(fct,args) ->
     let fct' = f n fct in
-    let args' = Array.smartmap (f n) args in
+    let args' = Array.Smart.map (f n) args in
     if fct == fct' && args == args' then lam else mkLapp fct' args'
   | Lcase(ci,rtbl,t,a,branches) ->
     let const = branches.constant_branches in
     let nonconst = branches.nonconstant_branches in
     let t' = f n t in
     let a' = f n a in
-    let const' = Array.smartmap (f n) const in
+    let const' = Array.Smart.map (f n) const in
     let on_b b =
       let (ids,body) = b in
       let body' = f (g (Array.length ids) n) body in
       if body == body' then b else (ids,body') in
-    let nonconst' = Array.smartmap on_b nonconst in
+    let nonconst' = Array.Smart.map on_b nonconst in
     let branches' =
       if const == const' && nonconst == nonconst' then
         branches
@@ -190,24 +193,24 @@ let rec map_lam_with_binders g f n lam =
     if t == t' && a == a' && branches == branches' then lam else
       Lcase(ci,rtbl,t',a',branches')
   | Lfix(init,(ids,ltypes,lbodies)) ->
-    let ltypes' = Array.smartmap (f n) ltypes in
-    let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+    let ltypes' = Array.Smart.map (f n) ltypes in
+    let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in
     if ltypes == ltypes' && lbodies == lbodies' then lam
     else Lfix(init,(ids,ltypes',lbodies'))
   | Lcofix(init,(ids,ltypes,lbodies)) ->
-    let ltypes' = Array.smartmap (f n) ltypes in
-    let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+    let ltypes' = Array.Smart.map (f n) ltypes in
+    let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in
     if ltypes == ltypes' && lbodies == lbodies' then lam
     else Lcofix(init,(ids,ltypes',lbodies'))
   | Lmakeblock(tag,args) ->
-    let args' = Array.smartmap (f n) args in
+    let args' = Array.Smart.map (f n) args in
     if args == args' then lam else Lmakeblock(tag,args')
   | Lprim(kn,ar,op,args) ->
-    let args' = Array.smartmap (f n) args in
+    let args' = Array.Smart.map (f n) args in
     if args == args' then lam else Lprim(kn,ar,op,args')
-  | Lproj(i,kn,arg) ->
+  | Lproj(p,arg) ->
     let arg' = f n arg in
-    if arg == arg' then lam else Lproj(i,kn,arg')
+    if arg == arg' then lam else Lproj(p,arg')
   | Luint u ->
     let u' = map_uint g f n u in
     if u == u' then lam else Luint u'
@@ -216,7 +219,7 @@ and map_uint g f n u =
   match u with
   | UintVal _ -> u
   | UintDigits(args) ->
-    let args' = Array.smartmap (f n) args in
+    let args' = Array.Smart.map (f n) args in
     if args == args' then u else UintDigits(args')
   | UintDecomp(a) ->
     let a' = f n a in
@@ -250,7 +253,7 @@ let rec lam_exsubst subst lam =
 
 let lam_subst_args subst args =
   if is_subs_id subst then args
-  else Array.smartmap (lam_exsubst subst) args
+  else Array.Smart.map (lam_exsubst subst) args
 
 (** Simplification of lambda expression *)
 
@@ -316,7 +319,7 @@ and simplify_app substf f substa args =
     simplify_app substf f subst_id args
   | _ -> mkLapp (simplify substf f) (simplify_args substa args)
 
-and simplify_args subst args = Array.smartmap (simplify subst) args
+and simplify_args subst args = Array.Smart.map (simplify subst) args
 
 and reduce_lapp substf lids body substa largs =
   match lids, largs with
@@ -349,7 +352,7 @@ let rec occurrence k kind lam =
     if n = k then
       if kind then false else raise Not_found
     else kind
-  | Lvar _  | Lconst _  | Lval _ | Lsort _ | Lind _ -> kind
+  | Lvar _  | Lconst _  | Lval _ | Lsort _ | Lind _ | Lint _ -> kind
   | Levar (_, args) ->
     occurrence_args k kind args
   | Lprod(dom, codom) ->
@@ -376,7 +379,7 @@ let rec occurrence k kind lam =
     let kind = occurrence_args k kind ltypes in
     let _ = occurrence_args (k+Array.length ids) false lbodies in
     kind
-  | Lproj(_,_,arg) ->
+  | Lproj(_,arg) ->
     occurrence k kind arg
   | Luint u -> occurrence_uint k kind u
 
@@ -419,7 +422,7 @@ let rec remove_let subst lam =
 exception TooLargeInductive of Pp.t
 
 let max_nb_const = 0x1000000
-let max_nb_block = 0x1000000 + last_variant_tag - 1
+let max_nb_block = 0x1000000 + Obj.last_non_constant_constructor_tag - 1
 
 let str_max_constructors =
   Format.sprintf
@@ -436,23 +439,22 @@ let check_compilable ib =
 
 let is_value lc =
   match lc with
-  | Lval _ -> true
+  | Lval _ | Lint _ -> true
   | _ -> false
 
 let get_value lc =
   match lc with
   | Lval v -> v
+  | Lint i -> val_of_int i
   | _ -> raise Not_found
 
-let mkConst_b0 n = Lval (Cbytecodes.Const_b0 n)
-
 let make_args start _end =
   Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i))
 
 (* Translation of constructors *)
 let expand_constructor tag nparams arity =
   let ids = Array.make (nparams + arity) Anonymous in
-  if arity = 0 then mkLlam ids (mkConst_b0 tag)
+  if arity = 0 then mkLlam ids (Lint tag)
   else
     let args = make_args arity 1 in
     Llam(ids, Lmakeblock (tag, args))
@@ -463,15 +465,15 @@ let makeblock tag nparams arity args =
     mkLapp (expand_constructor tag nparams arity) args
   else
     (* The constructor is fully applied *)
-  if arity = 0 then mkConst_b0 tag
+  if arity = 0 then Lint tag
   else
   if Array.for_all is_value args then
-    if tag < last_variant_tag then
-      Lval(Cbytecodes.Const_bn(tag, Array.map get_value args))
+    if tag < Obj.last_non_constant_constructor_tag then
+      Lval(val_of_block tag (Array.map get_value args))
     else
       let args = Array.map get_value args in
-      let args = Array.append [|Cbytecodes.Const_b0 (tag - last_variant_tag) |] args in
-      Lval(Cbytecodes.Const_bn(last_variant_tag, args))
+      let args = Array.append [| val_of_int (tag - Obj.last_non_constant_constructor_tag) |] args in
+      Lval(val_of_block Obj.last_non_constant_constructor_tag args)
   else Lmakeblock(tag, args)
 
 
@@ -605,8 +607,6 @@ end
 
 open Renv
 
-let (eta_expand,eta_expand_hook) = Hook.make ()
-
 let rec lambda_of_constr env c =
   match Constr.kind c with
   | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta")
@@ -702,7 +702,7 @@ let rec lambda_of_constr env c =
     Lfix(rec_init, (names, ltypes, lbodies))
 
   | CoFix(init,(names,type_bodies,rec_bodies)) ->
-    let rec_bodies = Array.map2 (Hook.get eta_expand env.global_env) rec_bodies type_bodies in
+    let rec_bodies = Array.map2 (Reduction.eta_expand env.global_env) rec_bodies type_bodies in
     let ltypes = lambda_of_args env 0 type_bodies in
     Renv.push_rels env names;
     let lbodies = lambda_of_args env 0 rec_bodies in
@@ -710,12 +710,8 @@ let rec lambda_of_constr env c =
     Lcofix(init, (names, ltypes, lbodies))
 
   | Proj (p,c) ->
-    let kn = Projection.constant p in
-    let cb = lookup_constant kn env.global_env in
-    let pb = Option.get cb.const_proj in
-    let n = pb.proj_arg in
     let lc = lambda_of_constr env c in
-    Lproj (n,kn,lc)
+    Lproj (Projection.repr p,lc)
 
 and lambda_of_app env f args =
   match Constr.kind f with
@@ -767,7 +763,7 @@ and lambda_of_app env f args =
                               and such, which can't be done at this time.
                               for instance, for int31: if one of the digit is
                                   not closed, it's not impossible that the number
-                                  gets fully instanciated at run-time, thus to ensure
+                                  gets fully instantiated at run-time, thus to ensure
                                   uniqueness of the representation in the vm
                                   it is necessary to try and build a caml integer
                                   during the execution *)
@@ -810,7 +806,7 @@ and lambda_of_args env start args =
 
 
 (*********************************)
-
+let dump_lambda = ref false
 
 let optimize_lambda lam =
   let lam = simplify subst_id lam in
@@ -818,11 +814,11 @@ let optimize_lambda lam =
 
 let lambda_of_constr ~optimize genv c =
   let env = Renv.make genv in
-  let ids = List.rev_map Context.Rel.Declaration.get_name genv.env_rel_context.env_rel_ctx in
+  let ids = List.rev_map Context.Rel.Declaration.get_name (rel_context genv) in
   Renv.push_rels env (Array.of_list ids);
   let lam = lambda_of_constr env c in
   let lam = if optimize then optimize_lambda lam else lam in
-  if !Flags.dump_lambda then
+  if !dump_lambda then
     Feedback.msg_debug (pp_lam lam);
   lam
 
@@ -840,10 +836,11 @@ let dynamic_int31_compilation fc args =
   if not fc then raise Not_found else
   Luint (UintDigits args)
 
+let d0 = Lint 0
+let d1 = Lint 1
+
 (* We are relying here on the tags of digits constructors *)
 let digits_from_uint i =
-  let d0 = mkConst_b0 0 in
-  let d1 = mkConst_b0 1 in
   let digits = Array.make 31 d0 in
   for k = 0 to 30 do
     if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then
diff --git a/kernel/clambda.mli b/kernel/clambda.mli
index 827eb550..8ff10b45 100644
--- a/kernel/clambda.mli
+++ b/kernel/clambda.mli
@@ -1,13 +1,14 @@
 open Names
 open Cinstr
+open Environ
 
 exception TooLargeInductive of Pp.t
 
-val lambda_of_constr : optimize:bool -> Pre_env.env -> Constr.t -> lambda
+val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda
 
 val decompose_Llam : lambda -> Name.t array * lambda
 
-val get_alias : Pre_env.env -> Constant.t -> Constant.t
+val get_alias : env -> Constant.t -> Constant.t
 
 val compile_prim : int -> Cbytecodes.instruction -> Constr.pconstant -> bool -> lambda array -> lambda
 
@@ -26,5 +27,5 @@ val dynamic_int31_compilation : bool -> lambda array -> lambda
            matching integers (in case they are in processor representation) *)
 val int31_escape_before_match : bool -> lambda -> lambda
 
-val eta_expand : (Pre_env.env -> Constr.t -> Constr.types -> Constr.t) Hook.value
-val eta_expand_hook : (Pre_env.env -> Constr.t -> Constr.types -> Constr.t) Hook.t
+(** Dump the VM lambda code after compilation (for debugging purposes) *)
+val dump_lambda : bool ref
diff --git a/kernel/constr.ml b/kernel/constr.ml
index de4e7c18..9bf74315 100644
--- a/kernel/constr.ml
+++ b/kernel/constr.ml
@@ -107,21 +107,13 @@ type t = (t, t, Sorts.t, Instance.t) kind_of_term
 type constr = t
 
 type existential = existential_key * constr array
-type rec_declaration = Name.t array * constr array * constr array
-type fixpoint = (int array * int) * rec_declaration
-  (* The array of [int]'s tells for each component of the array of
-     mutual fixpoints the number of lambdas to skip before finding the
-     recursive argument (e.g., value is 2 in "fix f (x:A) (y:=t) (z:B)
-     (v:=u) (w:I) {struct w}"), telling to skip x and z and that w is
-     the recursive argument);
-     The second component [int] tells which component of the block is
-     returned *)
-type cofixpoint = int * rec_declaration
-  (* The component [int] tells which component of the block of
-     cofixpoint is returned *)
 
 type types = constr
 
+type rec_declaration = (constr, types) prec_declaration
+type fixpoint = (constr, types) pfixpoint
+type cofixpoint = (constr, types) pcofixpoint
+
 (*********************)
 (* Term constructors *)
 (*********************)
@@ -138,8 +130,8 @@ let mkProp   = Sort Sorts.prop
 let mkSet    = Sort Sorts.set
 let mkType u = Sort (Sorts.Type u)
 let mkSort   = function
-  | Sorts.Prop Sorts.Null -> mkProp (* Easy sharing *)
-  | Sorts.Prop Sorts.Pos -> mkSet
+  | Sorts.Prop -> mkProp (* Easy sharing *)
+  | Sorts.Set -> mkSet
   | s -> Sort s
 
 (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
@@ -268,17 +260,17 @@ let isSort c = match kind c with
   | _ -> false
 
 let rec isprop c = match kind c with
-  | Sort (Sorts.Prop _) -> true
+  | Sort (Sorts.Prop | Sorts.Set) -> true
   | Cast (c,_,_) -> isprop c
   | _ -> false
 
 let rec is_Prop c = match kind c with
-  | Sort (Sorts.Prop Sorts.Null) -> true
+  | Sort Sorts.Prop -> true
   | Cast (c,_,_) -> is_Prop c
   | _ -> false
 
 let rec is_Set c = match kind c with
-  | Sort (Sorts.Prop Sorts.Pos) -> true
+  | Sort Sorts.Set -> true
   | Cast (c,_,_) -> is_Set c
   | _ -> false
 
@@ -468,16 +460,16 @@ let iter_with_binders g f n c = match kind c with
   | Prod (_,t,c) -> f n t; f (g n) c
   | Lambda (_,t,c) -> f n t; f (g n) c
   | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
-  | App (c,l) -> f n c; CArray.Fun1.iter f n l
-  | Evar (_,l) -> CArray.Fun1.iter f n l
-  | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl
+  | App (c,l) -> f n c; Array.Fun1.iter f n l
+  | Evar (_,l) -> Array.Fun1.iter f n l
+  | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl
   | Proj (p,c) -> f n c
   | Fix (_,(_,tl,bl)) ->
-      CArray.Fun1.iter f n tl;
-      CArray.Fun1.iter f (iterate g (Array.length tl) n) bl
+      Array.Fun1.iter f n tl;
+      Array.Fun1.iter f (iterate g (Array.length tl) n) bl
   | CoFix (_,(_,tl,bl)) ->
-      CArray.Fun1.iter f n tl;
-      CArray.Fun1.iter f (iterate g (Array.length tl) n) bl
+      Array.Fun1.iter f n tl;
+      Array.Fun1.iter f (iterate g (Array.length tl) n) bl
 
 (* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate
    subterms of [c] starting from [acc] and proceeding from left to
@@ -537,7 +529,7 @@ let map f c = match kind c with
       else mkLetIn (na, b', t', k')
   | App (b,l) ->
       let b' = f b in
-      let l' = Array.smartmap f l in
+      let l' = Array.Smart.map f l in
       if b'==b && l'==l then c
       else mkApp (b', l')
   | Proj (p,t) ->
@@ -545,23 +537,23 @@ let map f c = match kind c with
       if t' == t then c
       else mkProj (p, t')
   | Evar (e,l) ->
-      let l' = Array.smartmap f l in
+      let l' = Array.Smart.map f l in
       if l'==l then c
       else mkEvar (e, l')
   | Case (ci,p,b,bl) ->
       let b' = f b in
       let p' = f p in
-      let bl' = Array.smartmap f bl in
+      let bl' = Array.Smart.map f bl in
       if b'==b && p'==p && bl'==bl then c
       else mkCase (ci, p', b', bl')
   | Fix (ln,(lna,tl,bl)) ->
-      let tl' = Array.smartmap f tl in
-      let bl' = Array.smartmap f bl in
+      let tl' = Array.Smart.map f tl in
+      let bl' = Array.Smart.map f bl in
       if tl'==tl && bl'==bl then c
       else mkFix (ln,(lna,tl',bl'))
   | CoFix(ln,(lna,tl,bl)) ->
-      let tl' = Array.smartmap f tl in
-      let bl' = Array.smartmap f bl in
+      let tl' = Array.Smart.map f tl in
+      let bl' = Array.Smart.map f bl in
       if tl'==tl && bl'==bl then c
       else mkCoFix (ln,(lna,tl',bl'))
 
@@ -593,7 +585,7 @@ let fold_map f accu c = match kind c with
       else accu, mkLetIn (na, b', t', k')
   | App (b,l) ->
       let accu, b' = f accu b in
-      let accu, l' = Array.smartfoldmap f accu l in
+      let accu, l' = Array.Smart.fold_left_map f accu l in
       if b'==b && l'==l then accu, c
       else accu, mkApp (b', l')
   | Proj (p,t) ->
@@ -601,23 +593,23 @@ let fold_map f accu c = match kind c with
       if t' == t then accu, c
       else accu, mkProj (p, t')
   | Evar (e,l) ->
-      let accu, l' = Array.smartfoldmap f accu l in
+      let accu, l' = Array.Smart.fold_left_map f accu l in
       if l'==l then accu, c
       else accu, mkEvar (e, l')
   | Case (ci,p,b,bl) ->
       let accu, b' = f accu b in
       let accu, p' = f accu p in
-      let accu, bl' = Array.smartfoldmap f accu bl in
+      let accu, bl' = Array.Smart.fold_left_map f accu bl in
       if b'==b && p'==p && bl'==bl then accu, c
       else accu, mkCase (ci, p', b', bl')
   | Fix (ln,(lna,tl,bl)) ->
-      let accu, tl' = Array.smartfoldmap f accu tl in
-      let accu, bl' = Array.smartfoldmap f accu bl in
+      let accu, tl' = Array.Smart.fold_left_map f accu tl in
+      let accu, bl' = Array.Smart.fold_left_map f accu bl in
       if tl'==tl && bl'==bl then accu, c
       else accu, mkFix (ln,(lna,tl',bl'))
   | CoFix(ln,(lna,tl,bl)) ->
-      let accu, tl' = Array.smartfoldmap f accu tl in
-      let accu, bl' = Array.smartfoldmap f accu bl in
+      let accu, tl' = Array.Smart.fold_left_map f accu tl in
+      let accu, bl' = Array.Smart.fold_left_map f accu bl in
       if tl'==tl && bl'==bl then accu, c
       else accu, mkCoFix (ln,(lna,tl',bl'))
 
@@ -653,7 +645,7 @@ let map_with_binders g f l c0 = match kind c0 with
     else mkLetIn (na, b', t', c')
   | App (c, al) ->
     let c' = f l c in
-    let al' = CArray.Fun1.smartmap f l al in
+    let al' = Array.Fun1.Smart.map f l al in
     if c' == c && al' == al then c0
     else mkApp (c', al')
   | Proj (p, t) ->
@@ -661,28 +653,28 @@ let map_with_binders g f l c0 = match kind c0 with
     if t' == t then c0
     else mkProj (p, t')
   | Evar (e, al) ->
-    let al' = CArray.Fun1.smartmap f l al in
+    let al' = Array.Fun1.Smart.map f l al in
     if al' == al then c0
     else mkEvar (e, al')
   | Case (ci, p, c, bl) ->
     let p' = f l p in
     let c' = f l c in
-    let bl' = CArray.Fun1.smartmap f l bl in
+    let bl' = Array.Fun1.Smart.map f l bl in
     if p' == p && c' == c && bl' == bl then c0
     else mkCase (ci, p', c', bl')
   | Fix (ln, (lna, tl, bl)) ->
-    let tl' = CArray.Fun1.smartmap f l tl in
+    let tl' = Array.Fun1.Smart.map f l tl in
     let l' = iterate g (Array.length tl) l in
-    let bl' = CArray.Fun1.smartmap f l' bl in
+    let bl' = Array.Fun1.Smart.map f l' bl in
     if tl' == tl && bl' == bl then c0
     else mkFix (ln,(lna,tl',bl'))
   | CoFix(ln,(lna,tl,bl)) ->
-    let tl' = CArray.Fun1.smartmap f l tl in
+    let tl' = Array.Fun1.Smart.map f l tl in
     let l' = iterate g (Array.length tl) l in
-    let bl' = CArray.Fun1.smartmap f l' bl in
+    let bl' = Array.Fun1.Smart.map f l' bl in
     mkCoFix (ln,(lna,tl',bl'))
 
-type instance_compare_fn = global_reference -> int ->
+type instance_compare_fn = GlobRef.t -> int ->
   Univ.Instance.t -> Univ.Instance.t -> bool
 
 type constr_compare_fn = int -> constr -> constr -> bool
@@ -720,10 +712,10 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t
   | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2
   | Const (c1,u1), Const (c2,u2) ->
     (* The args length currently isn't used but may as well pass it. *)
-    Constant.equal c1 c2 && leq_universes (ConstRef c1) nargs u1 u2
-  | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (IndRef c1) nargs u1 u2
+    Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2
+  | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (GlobRef.IndRef c1) nargs u1 u2
   | Construct (c1,u1), Construct (c2,u2) ->
-    eq_constructor c1 c2 && leq_universes (ConstructRef c1) nargs u1 u2
+    eq_constructor c1 c2 && leq_universes (GlobRef.ConstructRef c1) nargs u1 u2
   | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
     eq 0 p1 p2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2
   | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
@@ -1217,3 +1209,10 @@ let hcons =
      Id.hcons)
 
 (* let hcons_types = hcons_constr *)
+
+type rel_declaration = (constr, types) Context.Rel.Declaration.pt
+type named_declaration = (constr, types) Context.Named.Declaration.pt
+type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt
+type rel_context = rel_declaration list
+type named_context = named_declaration list
+type compacted_context = compacted_declaration list
diff --git a/kernel/constr.mli b/kernel/constr.mli
index c1d1f988..70acf193 100644
--- a/kernel/constr.mli
+++ b/kernel/constr.mli
@@ -161,8 +161,26 @@ val mkCase : case_info * constr * constr * constr array -> constr
 
    where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
 *)
-type rec_declaration = Name.t array * types array * constr array
-type fixpoint = (int array * int) * rec_declaration
+type ('constr, 'types) prec_declaration =
+    Name.t array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+  (* The array of [int]'s tells for each component of the array of
+     mutual fixpoints the number of lambdas to skip before finding the
+     recursive argument (e.g., value is 2 in "fix f (x:A) (y:=t) (z:B)
+     (v:=u) (w:I) {struct w}"), telling to skip x and z and that w is
+     the recursive argument);
+     The second component [int] tells which component of the block is
+     returned *)
+
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+  (* The component [int] tells which component of the block of
+     cofixpoint is returned *)
+
+type rec_declaration = (constr, types) prec_declaration
+
+type fixpoint = (constr, types) pfixpoint
 val mkFix : fixpoint -> constr
 
 (** If [funnames = [|f1,.....fn|]]
@@ -176,7 +194,7 @@ val mkFix : fixpoint -> constr
      ...
      with       fn = bn.]
  *)
-type cofixpoint = int * rec_declaration
+type cofixpoint = (constr, types) pcofixpoint
 val mkCoFix : cofixpoint -> constr
 
 
@@ -185,12 +203,6 @@ val mkCoFix : cofixpoint -> constr
 (** [constr array] is an instance matching definitional [named_context] in
    the same order (i.e. last argument first) *)
 type 'constr pexistential = Evar.t * '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, 'sort, 'univs) kind_of_term =
   | Rel       of int                                  (** Gallina-variable introduced by [forall], [fun], [let-in], [fix], or [cofix]. *)
@@ -360,6 +372,15 @@ val eq_constr_nounivs : constr -> constr -> bool
 (** Total ordering compatible with [equal] *)
 val compare : constr -> constr -> int
 
+(** {6 Extension of Context with declarations on constr} *)
+
+type rel_declaration = (constr, types) Context.Rel.Declaration.pt
+type named_declaration = (constr, types) Context.Named.Declaration.pt
+type compacted_declaration = (constr, types) Context.Compacted.Declaration.pt
+type rel_context = rel_declaration list
+type named_context = named_declaration list
+type compacted_context = compacted_declaration list
+
 (** {6 Functionals working on the immediate subterm of a construction } *)
 
 (** [fold f acc c] folds [f] on the immediate subterms of [c]
@@ -422,7 +443,7 @@ val compare_head : constr_compare_fn -> constr_compare_fn
 (** Convert a global reference applied to 2 instances. The int says
    how many arguments are given (as we can only use cumulativity for
    fully applied inductives/constructors) .*)
-type instance_compare_fn = global_reference -> int ->
+type instance_compare_fn = GlobRef.t -> int ->
   Univ.Instance.t -> Univ.Instance.t -> bool
 
 (** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to
diff --git a/kernel/context.ml b/kernel/context.ml
index 4f3f649c..4a7204b7 100644
--- a/kernel/context.ml
+++ b/kernel/context.ml
@@ -43,8 +43,6 @@ struct
       | LocalAssum of Name.t * 'types            (** name, type *)
       | LocalDef of Name.t * 'constr * 'types   (** name, value, type *)
 
-    type t = (Constr.constr, Constr.types) pt
-
     (** Return the name bound by a given declaration. *)
     let get_name = function
       | LocalAssum (na,_)
@@ -151,13 +149,16 @@ struct
       | LocalAssum (na, ty) -> na, None, ty
       | LocalDef (na, v, ty) -> na, Some v, ty
 
+    let drop_body = function
+      | LocalAssum _ as d -> d
+      | LocalDef (na, v, ty) -> LocalAssum (na, ty)
+
   end
 
   (** Rel-context is represented as a list of declarations.
       Inner-most declarations are at the beginning of the list.
       Outer-most declarations are at the end of the list. *)
   type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list
-  type t = Declaration.t list
 
   (** empty rel-context *)
   let empty = []
@@ -192,7 +193,7 @@ struct
   let equal eq l = List.equal (fun c -> Declaration.equal eq c) l
 
   (** Map all terms in a given rel-context. *)
-  let map f = List.smartmap (Declaration.map_constr f)
+  let map f = List.Smart.map (Declaration.map_constr f)
 
   (** Perform a given action on every declaration in a given rel-context. *)
   let iter f = List.iter (Declaration.iter_constr f)
@@ -214,6 +215,8 @@ struct
       | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx
     in aux [] l
 
+  let drop_bodies l = List.Smart.map Declaration.drop_body l
+
   (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ]
       with n = |Δ| and with the {e local definitions} of [Γ] skipped in
       [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *)
@@ -241,8 +244,6 @@ struct
       | LocalAssum of Id.t * 'types             (** identifier, type *)
       | LocalDef of Id.t * 'constr * 'types    (** identifier, value, type *)
 
-    type t = (Constr.constr, Constr.types) pt
-
     (** Return the identifier bound by a given declaration. *)
     let get_id = function
       | LocalAssum (id,_) -> id
@@ -353,6 +354,10 @@ struct
       | id, None, ty -> LocalAssum (id, ty)
       | id, Some v, ty -> LocalDef (id, v, ty)
 
+    let drop_body = function
+      | LocalAssum _ as d -> d
+      | LocalDef (id, v, ty) -> LocalAssum (id, ty)
+
     let of_rel_decl f = function
       | Rel.Declaration.LocalAssum (na,t) ->
           LocalAssum (f na, t)
@@ -370,7 +375,6 @@ struct
       Inner-most declarations are at the beginning of the list.
       Outer-most declarations are at the end of the list. *)
   type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list
-  type t = Declaration.t list
 
   (** empty named-context *)
   let empty = []
@@ -392,7 +396,7 @@ struct
   let equal eq l = List.equal (fun c -> Declaration.equal eq c) l
 
   (** Map all terms in a given named-context. *)
-  let map f = List.smartmap (Declaration.map_constr f)
+  let map f = List.Smart.map (Declaration.map_constr f)
 
   (** Perform a given action on every declaration in a given named-context. *)
   let iter f = List.iter (Declaration.iter_constr f)
@@ -409,6 +413,8 @@ struct
   let to_vars l =
     List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty l
 
+  let drop_bodies l = List.Smart.map Declaration.drop_body l
+
   (** [instance_from_named_context Ω] builds an instance [args] such
       that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local
       definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it
@@ -429,8 +435,6 @@ module Compacted =
           | LocalAssum of Id.t list * 'types
           | LocalDef of Id.t list * 'constr * 'types
 
-        type t = (Constr.constr, Constr.types) pt
-
         let map_constr f = function
           | LocalAssum (ids, ty) as decl ->
              let ty' = f ty in
@@ -454,7 +458,6 @@ module Compacted =
       end
 
     type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list
-    type t = Declaration.t list
 
     let fold f l ~init = List.fold_right f l init
   end
diff --git a/kernel/context.mli b/kernel/context.mli
index c97db434..2b0d36cb 100644
--- a/kernel/context.mli
+++ b/kernel/context.mli
@@ -35,8 +35,6 @@ sig
     | LocalAssum of Name.t * 'types            (** name, type *)
     | LocalDef of Name.t * 'constr * 'types   (** name, value, type *)
 
-    type t = (Constr.constr, Constr.types) pt
-
     (** Return the name bound by a given declaration. *)
     val get_name : ('c, 't) pt -> Name.t
 
@@ -87,13 +85,15 @@ sig
     val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a
 
     val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't
+
+    (** Turn [LocalDef] into [LocalAssum], identity otherwise. *)
+    val drop_body : ('c, 't) pt -> ('c, 't) pt
   end
 
   (** Rel-context is represented as a list of declarations.
       Inner-most declarations are at the beginning of the list.
       Outer-most declarations are at the end of the list. *)
   type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list
-  type t = Declaration.t list
 
   (** empty rel-context *)
   val empty : ('c, 't) pt
@@ -132,6 +132,9 @@ sig
       and each {e local definition} is mapped to [false]. *)
   val to_tags : ('c, 't) pt -> bool list
 
+  (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *)
+  val drop_bodies : ('c, 't) pt -> ('c, 't) pt
+
   (** [extended_list mk n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ]
       with n = |Δ| and with the {e local definitions} of [Γ] skipped in
       [args] where [mk] is used to build the corresponding variables.
@@ -153,8 +156,6 @@ sig
       | LocalAssum of Id.t * 'types             (** identifier, type *)
       | LocalDef of Id.t * 'constr * 'types    (** identifier, value, type *)
 
-    type t = (Constr.constr, Constr.types) pt
-
     (** Return the identifier bound by a given declaration. *)
     val get_id : ('c, 't) pt -> Id.t
 
@@ -207,6 +208,9 @@ sig
     val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't
     val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt
 
+    (** Turn [LocalDef] into [LocalAssum], identity otherwise. *)
+    val drop_body : ('c, 't) pt -> ('c, 't) pt
+
     (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value.
         The function provided as the first parameter determines how to translate "names" to "ids". *)
     val of_rel_decl : (Name.t -> Id.t) -> ('c, 't) Rel.Declaration.pt -> ('c, 't) pt
@@ -220,7 +224,6 @@ sig
       Inner-most declarations are at the beginning of the list.
       Outer-most declarations are at the end of the list. *)
   type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list
-  type t = Declaration.t list
 
   (** empty named-context *)
   val empty : ('c, 't) pt
@@ -255,6 +258,9 @@ sig
   (** Return the set of all identifiers bound in a given named-context. *)
   val to_vars : ('c, 't) pt -> Id.Set.t
 
+  (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *)
+  val drop_bodies : ('c, 't) pt -> ('c, 't) pt
+
   (** [to_instance Ω] builds an instance [args] such
       that [Ω ⊢ args:Ω] where [Ω] is a named-context and with the local
       definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it
@@ -270,15 +276,12 @@ sig
       | LocalAssum of Id.t list * 'types
       | LocalDef of Id.t list * 'constr * 'types
 
-    type t = (Constr.constr, Constr.types) pt
-
     val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt
     val of_named_decl : ('c, 't) Named.Declaration.pt -> ('c, 't) pt
     val to_named_context : ('c, 't) pt -> ('c, 't) Named.pt
   end
 
   type ('constr, 'types) pt = ('constr, 'types) Declaration.pt list
-  type t = Declaration.t list
 
   val fold : (('c, 't) Declaration.pt -> 'a -> 'a) -> ('c, 't) pt -> init:'a -> 'a
 end
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 6f4541e9..657478a1 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -24,6 +24,7 @@ open Declarations
 open Univ
 
 module NamedDecl = Context.Named.Declaration
+module RelDecl = Context.Rel.Declaration
 
 (*s Cooking the constants. *)
 
@@ -126,17 +127,13 @@ let expmod_constr cache modlist c =
 	    | Not_found -> Constr.map substrec c)
 
       | Proj (p, c') ->
-          (try 
-	     let p' = share_univs (ConstRef (Projection.constant p)) Univ.Instance.empty modlist in
-	     let make c = Projection.make c (Projection.unfolded p) in
-	     match kind p' with
-	     | Const (p',_) -> mkProj (make p', substrec c')
-	     | App (f, args) -> 
-	       (match kind f with 
-	       | Const (p', _) -> mkProj (make p', substrec c')
-	       | _ -> assert false)
-	     | _ -> assert false
-	   with Not_found -> Constr.map substrec c)
+        let map cst npars =
+          let _, newpars = Mindmap.find cst (snd modlist) in
+          pop_mind cst, npars + Array.length newpars
+        in
+        let p' = try Projection.map_npars map p with Not_found -> p in
+        let c'' = substrec c' in
+        if p == p' && c' == c'' then c else mkProj (p', c'')
 
   | _ -> Constr.map substrec c
 
@@ -144,11 +141,31 @@ let expmod_constr cache modlist c =
   if is_empty_modlist modlist then c
   else substrec c
 
-let abstract_constant_type =
-   List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c)
+(** Transforms a named context into a rel context. Also returns the list of
+    variables [id1 ... idn] that need to be replaced by [Rel 1 ... Rel n] to
+    abstract a term that lived in that context. *)
+let abstract_context hyps =
+  let fold decl (ctx, subst) =
+    let id, decl = match decl with
+    | NamedDecl.LocalDef (id, b, t) ->
+      let b = Vars.subst_vars subst b in
+      let t = Vars.subst_vars subst t in
+      id, RelDecl.LocalDef (Name id, b, t)
+    | NamedDecl.LocalAssum (id, t) ->
+      let t = Vars.subst_vars subst t in
+      id, RelDecl.LocalAssum (Name id, t)
+    in
+    (decl :: ctx, id :: subst)
+  in
+  Context.Named.fold_outside fold hyps ~init:([], [])
+
+let abstract_constant_type t (hyps, subst) =
+  let t = Vars.subst_vars subst t in
+  List.fold_left (fun c d -> mkProd_wo_LetIn d c) t hyps
 
-let abstract_constant_body =
-  List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c)
+let abstract_constant_body c (hyps, subst) =
+  let c = Vars.subst_vars subst c in
+  it_mkLambda_or_LetIn c hyps
 
 type recipe = { from : constant_body; info : Opaqueproof.cooking_info }
 type inline = bool
@@ -156,10 +173,9 @@ type inline = bool
 type result = {
   cook_body : constant_def;
   cook_type : types;
-  cook_proj : projection_body option;
   cook_universes : constant_universes;
   cook_inline : inline;
-  cook_context : Context.Named.t option;
+  cook_context : Constr.named_context option;
 }
 
 let on_body ml hy f = function
@@ -178,6 +194,7 @@ let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c =
   let cache = RefTable.create 13 in
   let expmod = expmod_constr_subst cache modlist subst in
   let hyps = Context.Named.map expmod vars in
+  let hyps = abstract_context hyps in
   abstract_constant_body (expmod c) hyps
 
 let lift_univs cb subst auctx0 =
@@ -206,18 +223,19 @@ let lift_univs cb subst auctx0 =
       let auctx' = Univ.subst_univs_level_abstract_universe_context (Univ.make_instance_subst subst) auctx in
       subst, (Polymorphic_const (AUContext.union auctx0 auctx'))
 
-let cook_constant ~hcons env { from = cb; info } =
+let cook_constant ~hcons { from = cb; info } =
   let { Opaqueproof.modlist; abstract } = info in
   let cache = RefTable.create 13 in
   let abstract, usubst, abs_ctx = abstract in
   let usubst, univs = lift_univs cb usubst abs_ctx in
   let expmod = expmod_constr_subst cache modlist usubst in
-  let hyps = Context.Named.map expmod abstract in
+  let hyps0 = Context.Named.map expmod abstract in
+  let hyps = abstract_context hyps0 in
   let map c =
     let c = abstract_constant_body (expmod c) hyps in
     if hcons then Constr.hcons c else c
   in
-  let body = on_body modlist (hyps, usubst, abs_ctx)
+  let body = on_body modlist (hyps0, usubst, abs_ctx)
     map
     cb.const_body
   in
@@ -225,30 +243,11 @@ let cook_constant ~hcons env { from = cb; info } =
     Context.Named.fold_outside (fun decl hyps ->
       List.filter (fun decl' -> not (Id.equal (NamedDecl.get_id decl) (NamedDecl.get_id decl')))
 		  hyps)
-      hyps ~init:cb.const_hyps in
+      hyps0 ~init:cb.const_hyps in
   let typ = abstract_constant_type (expmod cb.const_type) hyps 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 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 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
   {
     cook_body = body;
     cook_type = typ;
-    cook_proj = Option.map projection cb.const_proj;
     cook_universes = univs;
     cook_inline = cb.const_inline_code;
     cook_context = Some const_hyps;
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index 7bd0ae56..6ebe691b 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -10,7 +10,6 @@
 
 open Constr
 open Declarations
-open Environ
 
 (** {6 Cooking the constants. } *)
 
@@ -21,13 +20,12 @@ type inline = bool
 type result = {
   cook_body : constant_def;
   cook_type : types;
-  cook_proj : projection_body option;
   cook_universes : constant_universes;
   cook_inline : inline;
-  cook_context : Context.Named.t option;
+  cook_context : Constr.named_context option;
 }
 
-val cook_constant : hcons:bool -> env -> recipe -> result
+val cook_constant : hcons:bool -> recipe -> result
 val cook_constr : Opaqueproof.cooking_info -> constr -> constr
 
 (** {6 Utility functions used in module [Discharge]. } *)
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 01294895..bb9231d0 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -20,13 +20,15 @@ open Vmvalues
 open Cemitcodes
 open Cbytecodes
 open Declarations
-open Pre_env
+open Environ
 open Cbytegen
 
 module NamedDecl = Context.Named.Declaration
 module RelDecl = Context.Rel.Declaration
 
-external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
+external eval_tcode : tcode -> atom array -> vm_global -> values array -> values = "coq_eval_tcode"
+
+type global_data = { mutable glob_len : int; mutable glob_val : values array }
 
 (*******************)
 (* Linkage du code *)
@@ -37,21 +39,28 @@ external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
 (* [global_data] contient les valeurs des constantes globales
    (axiomes,definitions), les annotations des switch et les structured
    constant *)
-external global_data : unit -> values array = "get_coq_global_data"
+let global_data = {
+  glob_len = 0;
+  glob_val = Array.make 4096 crazy_val;
+}
 
-(* [realloc_global_data n] augmente de n la taille de [global_data] *)
-external realloc_global_data : int -> unit = "realloc_coq_global_data"
+let get_global_data () = Vmvalues.vm_global global_data.glob_val
 
-let check_global_data n =
-  if n >= Array.length (global_data()) then realloc_global_data n
+let realloc_global_data n =
+  let n = min (2 * n + 0x100) Sys.max_array_length in
+  let ans = Array.make n crazy_val in
+  let src = global_data.glob_val in
+  let () = Array.blit src 0 ans 0 (Array.length src) in
+  global_data.glob_val <- ans
 
-let num_global = ref 0
+let check_global_data n =
+  if n >= Array.length global_data.glob_val then realloc_global_data n
 
 let set_global v =
-  let n = !num_global in
+  let n = global_data.glob_len in
   check_global_data n;
-  (global_data()).(n) <- v;
-  incr num_global;
+  global_data.glob_val.(n) <- v;
+  global_data.glob_len <- global_data.glob_len + 1;
   n
 
 (* table pour les structured_constant et les annotations des switchs *)
@@ -68,11 +77,15 @@ module AnnotTable = Hashtbl.Make (struct
   let hash = hash_annot_switch
 end)
 
+module ProjNameTable = Hashtbl.Make (Projection.Repr)
+
 let str_cst_tbl : int SConstTable.t = SConstTable.create 31
 
 let annot_tbl : int AnnotTable.t = AnnotTable.create 31
     (* (annot_switch * int) Hashtbl.t  *)
 
+let proj_name_tbl : int ProjNameTable.t = ProjNameTable.create 31
+
 (*************************************************************)
 (*** Mise a jour des valeurs des variables et des constantes *)
 (*************************************************************)
@@ -106,6 +119,13 @@ let slot_for_annot key =
     AnnotTable.add annot_tbl key n;
     n
 
+let slot_for_proj_name key =
+  try ProjNameTable.find proj_name_tbl key
+  with Not_found ->
+    let n =  set_global (val_of_proj_name key) in
+    ProjNameTable.add proj_name_tbl key n;
+    n
+
 let rec slot_for_getglobal env kn =
   let (cb,(_,rk)) = lookup_constant_key kn env in
   try key rk
@@ -133,23 +153,23 @@ and slot_for_fv env fv =
       | None -> v_of_id id, Id.Set.empty
       | Some c ->
           val_of_constr (env_of_id id env) c,
-          Environ.global_vars_set (Environ.env_of_pre_env env) c in
+          Environ.global_vars_set env c in
     build_lazy_val cache (v, d); v in
   let val_of_rel i = val_of_rel (nb_rel env - i) in
   let idfun _ x = x in
   match fv with
   | FVnamed id ->
-      let nv = Pre_env.lookup_named_val id env in
+      let nv = lookup_named_val id env in
       begin match force_lazy_val nv with
       | None ->
-	 env |> Pre_env.lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun
+         env |> lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun
       | Some (v, _) -> v
       end
   | FVrel i ->
-      let rv = Pre_env.lookup_rel_val i env in
+      let rv = lookup_rel_val i env in
       begin match force_lazy_val rv with
       | None ->
-        env |> Pre_env.lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel
+        env |> lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel
       | Some (v, _) -> v
       end
   | FVevar evk -> val_of_evar evk
@@ -161,10 +181,11 @@ and eval_to_patch env (buff,pl,fv) =
     | Reloc_annot a -> slot_for_annot a
     | Reloc_const sc -> slot_for_str_cst sc
     | Reloc_getglobal kn -> slot_for_getglobal env kn
+    | Reloc_proj_name p -> slot_for_proj_name p
   in
   let tc = patch buff pl slots in
   let vm_env = Array.map (slot_for_fv env) fv in
-  eval_tcode tc vm_env
+  eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env
 
 and val_of_constr env c =
   match compile ~fail_on_error:true env c with
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 19b2b8b5..72c96b0b 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.mli
@@ -12,9 +12,11 @@
 
 open Names
 open Constr
-open Pre_env
+open Environ
 
 val val_of_constr : env -> constr -> Vmvalues.values
 
 val set_opaque_const      : Constant.t -> unit
 val set_transparent_const : Constant.t -> unit
+
+val get_global_data : unit -> Vmvalues.vm_global
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index b7427d20..61fcb483 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -46,18 +46,6 @@ type inline = int option
 (** A constant can have no body (axiom/parameter), or a
     transparent body, or an opaque one *)
 
-(** Projections are a particular kind of constant: 
-    always transparent. *)
-
-type projection_body = {
-  proj_ind : MutInd.t;
-  proj_npars : int;
-  proj_arg : int;
-  proj_type : types; (* Type under params *)
-  proj_eta : constr * types; (* Eta-expanded term and type *)
-  proj_body : constr; (* For compatibility with VMs only, the match version *)
-}
-
 (* Global declarations (i.e. constants) can be either: *)
 type constant_def =
   | Undef of inline                       (** a global assumption *)
@@ -77,17 +65,17 @@ type typing_flags = {
                             points are assumed to be total. *)
   check_universes : bool; (** If [false] universe constraints are not checked *)
   conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *)
+  share_reduction : bool; (** Use by-need reduction algorithm *)
 }
 
 (* some contraints are in constant_constraints, some other may be in
  * the OpaqueDef *)
 type constant_body = {
-    const_hyps : Context.Named.t; (** New: younger hyp at top *)
+    const_hyps : Constr.named_context; (** New: younger hyp at top *)
     const_body : constant_def;
     const_type : types;
     const_body_code : Cemitcodes.to_patch_substituted option;
     const_universes : constant_universes;
-    const_proj : projection_body option;
     const_inline_code : bool;
     const_typing_flags : typing_flags; (** The typing options which
                                            were used for
@@ -112,13 +100,22 @@ v}
 *)
 
 (** Record information:
-    If the record is not primitive, then None
-    Otherwise, we get:
+    If the type is not a record, then NotRecord
+    If the type is a non-primitive record, then FakeRecord
+    If it is a primitive record, for every type in the block, we get:
     - The identifier for the binder name of the record in primitive projections.
     - The constants associated to each projection.
-    - The checked projection bodies. *)
+    - The projection types (under parameters).
+
+    The kernel does not exploit the difference between [NotRecord] and
+    [FakeRecord]. It is mostly used by extraction, and should be extruded from
+    the kernel at some point.
+*)
 
-type record_body = (Id.t * Constant.t array * projection_body array) option
+type record_info =
+| NotRecord
+| FakeRecord
+| PrimRecord of (Id.t * Label.t array * types array) array
 
 type regular_inductive_arity = {
   mind_user_arity : types;
@@ -132,7 +129,7 @@ type one_inductive_body = {
 
     mind_typename : Id.t; (** Name of the type: [Ii] *)
 
-    mind_arity_ctxt : Context.Rel.t; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
+    mind_arity_ctxt : Constr.rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
 
     mind_arity : inductive_arity; (** Arity sort and original user arity *)
 
@@ -167,7 +164,7 @@ type one_inductive_body = {
 
     mind_nb_args : int; (** number of no constant constructor *)
 
-    mind_reloc_tbl :  Cbytecodes.reloc_table;
+    mind_reloc_tbl :  Vmvalues.reloc_table;
   }
 
 type abstract_inductive_universes =
@@ -184,19 +181,19 @@ type mutual_inductive_body = {
 
     mind_packets : one_inductive_body array;  (** The component of the mutual inductive block *)
 
-    mind_record : record_body option; (** The record information *)
+    mind_record : record_info; (** The record information *)
 
     mind_finite : recursivity_kind;  (** Whether the type is inductive or coinductive *)
 
     mind_ntypes : int;  (** Number of types in the block *)
 
-    mind_hyps : Context.Named.t;  (** Section hypotheses on which the block depends *)
+    mind_hyps : Constr.named_context;  (** Section hypotheses on which the block depends *)
 
     mind_nparams : int;  (** Number of expected parameters including non-uniform ones (i.e. length of mind_params_ctxt w/o let-in) *)
 
     mind_nparams_rec : int;  (** Number of recursively uniform (i.e. ordinary) parameters *)
 
-    mind_params_ctxt : Context.Rel.t;  (** The context of parameters (includes let-in declaration) *)
+    mind_params_ctxt : Constr.rel_context;  (** The context of parameters (includes let-in declaration) *)
 
     mind_universes : abstract_inductive_universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *)
 
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
index 3652a1ce..51ec3def 100644
--- a/kernel/declareops.ml
+++ b/kernel/declareops.ml
@@ -21,6 +21,7 @@ let safe_flags oracle = {
   check_guarded = true;
   check_universes = true;
   conv_oracle = oracle;
+  share_reduction = true;
 }
 
 (** {6 Arities } *)
@@ -42,7 +43,7 @@ let map_decl_arity f g = function
 
 let hcons_template_arity ar =
   { template_param_levels = ar.template_param_levels;
-      (* List.smartmap (Option.smartmap Univ.hcons_univ_level) ar.template_param_levels; *)
+      (* List.Smart.map (Option.Smart.map Univ.hcons_univ_level) ar.template_param_levels; *)
     template_level = Univ.hcons_univ ar.template_level }
 
 (** {6 Constants } *)
@@ -70,7 +71,7 @@ let is_opaque cb = match cb.const_body with
 let subst_rel_declaration sub =
   RelDecl.map_constr (subst_mps sub)
 
-let subst_rel_context sub = List.smartmap (subst_rel_declaration sub)
+let subst_rel_context sub = List.Smart.map (subst_rel_declaration sub)
 
 let subst_const_type sub arity =
   if is_empty_subst sub then arity
@@ -83,25 +84,18 @@ let subst_const_def sub def = match def with
   | Def c -> Def (subst_constr sub c)
   | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o)
 
-let subst_const_proj sub pb =
-  { pb with proj_ind = subst_mind sub pb.proj_ind;
-    proj_type = subst_mps sub pb.proj_type;
-    proj_body = subst_const_type sub pb.proj_body }
-
 let subst_const_body sub cb =
   assert (List.is_empty cb.const_hyps); (* we're outside sections *)
   if is_empty_subst sub then cb
   else
     let body' = subst_const_def sub cb.const_body in
     let type' = subst_const_type 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
+    then cb
     else
       { const_hyps = [];
         const_body = body';
         const_type = type';
-        const_proj = proj';
         const_body_code =
           Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code;
         const_universes = cb.const_universes;
@@ -117,7 +111,7 @@ let subst_const_body sub cb =
 let hcons_rel_decl =
   RelDecl.map_name Names.Name.hcons %> RelDecl.map_value Constr.hcons %> RelDecl.map_type Constr.hcons
 
-let hcons_rel_context l = List.smartmap hcons_rel_decl l
+let hcons_rel_context l = List.Smart.map hcons_rel_decl l
 
 let hcons_const_def = function
   | Undef inl -> Undef inl
@@ -178,7 +172,7 @@ let recarg_length p j =
   let (_,cstrs) = Rtree.dest_node p in
   Array.length (snd (Rtree.dest_node cstrs.(j-1)))
 
-let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
+let subst_wf_paths sub p = Rtree.Smart.map (subst_recarg sub) p
 
 (** {7 Substitution of inductive declarations } *)
 
@@ -198,10 +192,10 @@ let subst_mind_packet sub mbp =
     mind_consnrealdecls = mbp.mind_consnrealdecls;
     mind_consnrealargs = mbp.mind_consnrealargs;
     mind_typename = mbp.mind_typename;
-    mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc;
+    mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc;
     mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
     mind_arity = subst_ind_arity sub mbp.mind_arity;
-    mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc;
+    mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc;
     mind_nrealargs = mbp.mind_nrealargs;
     mind_nrealdecls = mbp.mind_nrealdecls;
     mind_kelim = mbp.mind_kelim;
@@ -210,14 +204,20 @@ let subst_mind_packet sub mbp =
     mind_nb_args = mbp.mind_nb_args;
     mind_reloc_tbl = mbp.mind_reloc_tbl }
 
-let subst_mind_record sub (id, ps, pb as r) =
-  let ps' = Array.smartmap (subst_constant sub) ps in
-  let pb' = Array.smartmap (subst_const_proj sub) pb in
-    if ps' == ps && pb' == pb then r
-    else (id, ps', pb')
+let subst_mind_record sub r = match r with
+| NotRecord -> NotRecord
+| FakeRecord -> FakeRecord
+| PrimRecord infos ->
+  let map (id, ps, pb as info) =
+    let pb' = Array.Smart.map (subst_mps sub) pb in
+    if pb' == pb then info
+    else (id, ps, pb')
+  in
+  let infos' = Array.Smart.map map infos in
+  if infos' == infos then r else PrimRecord infos'
 
 let subst_mind_body sub mib =
-  { mind_record = Option.smartmap (Option.smartmap (subst_mind_record sub)) mib.mind_record ;
+  { mind_record = subst_mind_record sub mib.mind_record ;
     mind_finite = mib.mind_finite ;
     mind_ntypes = mib.mind_ntypes ;
     mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false);
@@ -225,7 +225,7 @@ let subst_mind_body sub mib =
     mind_nparams_rec = mib.mind_nparams_rec;
     mind_params_ctxt =
       Context.Rel.map (subst_mps sub) mib.mind_params_ctxt;
-    mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ;
+    mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ;
     mind_universes = mib.mind_universes;
     mind_private = mib.mind_private;
     mind_typing_flags = mib.mind_typing_flags;
@@ -249,6 +249,25 @@ let inductive_is_cumulative mib =
   | Polymorphic_ind ctx -> false
   | Cumulative_ind cumi -> true
 
+let inductive_make_projection ind mib ~proj_arg =
+  match mib.mind_record with
+  | NotRecord | FakeRecord -> None
+  | PrimRecord infos ->
+    Some (Names.Projection.Repr.make ind
+            ~proj_npars:mib.mind_nparams
+            ~proj_arg
+            (pi2 infos.(snd ind)).(proj_arg))
+
+let inductive_make_projections ind mib =
+  match mib.mind_record with
+  | NotRecord | FakeRecord -> None
+  | PrimRecord infos ->
+    let projs = Array.mapi (fun proj_arg lab ->
+        Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab)
+        (pi2 infos.(snd ind))
+    in
+    Some projs
+
 (** {6 Hash-consing of inductive declarations } *)
 
 let hcons_regular_ind_arity a =
@@ -263,15 +282,15 @@ let hcons_ind_arity =
 (** Substitution of inductive declarations *)
 
 let hcons_mind_packet oib =
-  let user = Array.smartmap Constr.hcons oib.mind_user_lc in
-  let nf = Array.smartmap Constr.hcons oib.mind_nf_lc in
+  let user = Array.Smart.map Constr.hcons oib.mind_user_lc in
+  let nf = Array.Smart.map Constr.hcons oib.mind_nf_lc in
   (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *)
   let nf = if Array.equal (==) user nf then user else nf in
   { oib with
     mind_typename = Names.Id.hcons oib.mind_typename;
     mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
     mind_arity = hcons_ind_arity oib.mind_arity;
-    mind_consnames = Array.smartmap Names.Id.hcons oib.mind_consnames;
+    mind_consnames = Array.Smart.map Names.Id.hcons oib.mind_consnames;
     mind_user_lc = user;
     mind_nf_lc = nf }
 
@@ -283,17 +302,10 @@ let hcons_mind_universes miu =
 
 let hcons_mind mib =
   { mib with
-    mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets;
+    mind_packets = Array.Smart.map hcons_mind_packet mib.mind_packets;
     mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
     mind_universes = hcons_mind_universes mib.mind_universes }
 
-(** {6 Stm machinery } *)
-
-let string_of_side_effect { Entries.eff } = match eff with
-  | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.Constant.to_string c ^ ")"
-  | Entries.SEscheme (cl,_) ->
-      "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.Constant.to_string c) cl) ^ ")"
-
 (** Hashconsing of modules *)
 
 let hcons_functorize hty he hself f = match f with
@@ -331,7 +343,7 @@ and hcons_structure_body sb =
     let sfb' = hcons_structure_field_body sfb in
     if l == l' && sfb == sfb' then fb else (l', sfb')
   in
-  List.smartmap map sb
+  List.Smart.map map sb
 
 and hcons_module_signature ms =
   hcons_functorize hcons_module_type hcons_structure_body hcons_module_signature ms
diff --git a/kernel/declareops.mli b/kernel/declareops.mli
index fb46112e..35490cee 100644
--- a/kernel/declareops.mli
+++ b/kernel/declareops.mli
@@ -11,7 +11,6 @@
 open Declarations
 open Mod_subst
 open Univ
-open Entries
 
 (** Operations concerning types in [Declarations] :
     [constant_body], [mutual_inductive_body], [module_body] ... *)
@@ -39,10 +38,6 @@ val constant_is_polymorphic : constant_body -> bool
 
 val is_opaque : constant_body -> bool
 
-(** Side effects *)
-
-val string_of_side_effect : side_effect -> string
-
 (** {6 Inductive types} *)
 
 val eq_recarg : recarg -> recarg -> bool
@@ -66,6 +61,11 @@ val inductive_is_polymorphic : mutual_inductive_body -> bool
 (** Is the inductive cumulative? *)
 val inductive_is_cumulative : mutual_inductive_body -> bool
 
+val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj_arg:int ->
+  Names.Projection.Repr.t option
+val inductive_make_projections : Names.inductive -> mutual_inductive_body ->
+  Names.Projection.Repr.t array option
+
 (** {6 Kernel flags} *)
 
 (** A default, safe set of flags for kernel type-checking *)
diff --git a/kernel/entries.ml b/kernel/entries.ml
index 94da00c7..94248ad2 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -49,9 +49,9 @@ type one_inductive_entry = {
   mind_entry_lc : constr list }
 
 type mutual_inductive_entry = {
-  mind_entry_record : (Id.t option) option; 
-  (** Some (Some id): primitive record with id the binder name of the record
-      in projections.
+  mind_entry_record : (Id.t array option) option;
+  (** Some (Some ids): primitive records with ids the binder name of each
+      record in their respective projections. Not used by the kernel.
       Some None: non-primitive record *)
   mind_entry_finite : Declarations.recursivity_kind;
   mind_entry_params : (Id.t * local_entry) list;
@@ -75,7 +75,7 @@ type 'a in_constant_universes_entry = 'a * constant_universes_entry
 type 'a definition_entry = {
   const_entry_body   : 'a const_entry_body;
   (* List of section variables *)
-  const_entry_secctx : Context.Named.t option;
+  const_entry_secctx : Constr.named_context option;
   (* State id on which the completion of type checking is reported *)
   const_entry_feedback : Stateid.t option;
   const_entry_type        : types option;
@@ -85,7 +85,7 @@ type 'a definition_entry = {
 
 type section_def_entry = {
   secdef_body : constr;
-  secdef_secctx : Context.Named.t option;
+  secdef_secctx : Constr.named_context option;
   secdef_feedback : Stateid.t option;
   secdef_type : types option;
 }
@@ -93,16 +93,11 @@ type section_def_entry = {
 type inline = int option (* inlining level, None for no inlining *)
 
 type parameter_entry = 
-    Context.Named.t option * types in_constant_universes_entry * inline
-
-type projection_entry = {
-  proj_entry_ind : MutInd.t;
-  proj_entry_arg : int }
+    Constr.named_context option * types in_constant_universes_entry * inline
 
 type 'a constant_entry =
   | DefinitionEntry of 'a definition_entry
   | ParameterEntry of parameter_entry
-  | ProjectionEntry of projection_entry
 
 (** {6 Modules } *)
 
@@ -125,11 +120,14 @@ type seff_env =
      Same as the constant_body's but not in an ephemeron *)
   | `Opaque of Constr.t * Univ.ContextSet.t ]
 
-type side_eff =
-  | SEsubproof of Constant.t * Declarations.constant_body * seff_env
-  | SEscheme of (inductive * Constant.t * Declarations.constant_body * seff_env) list * string
+(** Not used by the kernel. *)
+type side_effect_role =
+  | Subproof
+  | Schema of inductive * string
 
-type side_effect = {
-  from_env : Declarations.structure_body CEphemeron.key;
-  eff      : side_eff;
+type side_eff = {
+  seff_constant : Constant.t;
+  seff_body : Declarations.constant_body;
+  seff_env : seff_env;
+  seff_role : side_effect_role;
 }
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 89ba6f65..778c9a24 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -28,26 +28,208 @@ open Names
 open Constr
 open Vars
 open Declarations
-open Pre_env
 open Context.Rel.Declaration
 
+module NamedDecl = Context.Named.Declaration
+
 (* The type of environments. *)
 
-type named_context_val = Pre_env.named_context_val
+(* The key attached to each constant is used by the VM to retrieve previous *)
+(* evaluations of the constant. It is essentially an index in the symbols table *)
+(* used by the VM. *)
+type key = int CEphemeron.key option ref
+
+(** Linking information for the native compiler. *)
+
+type link_info =
+  | Linked of string
+  | LinkedInteractive of string
+  | NotLinked
+
+type constant_key = constant_body * (link_info ref * key)
+
+type mind_key = mutual_inductive_body * link_info ref
+
+type globals = {
+  env_constants : constant_key Cmap_env.t;
+  env_inductives : mind_key Mindmap_env.t;
+  env_modules : module_body MPmap.t;
+  env_modtypes : module_type_body MPmap.t;
+}
+
+type stratification = {
+  env_universes : UGraph.t;
+  env_engagement : engagement
+}
+
+type val_kind =
+    | VKvalue of (Vmvalues.values * Id.Set.t) CEphemeron.key
+    | VKnone
+
+type lazy_val = val_kind ref
+
+let force_lazy_val vk = match !vk with
+| VKnone -> None
+| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None
+
+let dummy_lazy_val () = ref VKnone
+let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key)
+
+type named_context_val = {
+  env_named_ctx : Constr.named_context;
+  env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t;
+}
+
+type rel_context_val = {
+  env_rel_ctx : Constr.rel_context;
+  env_rel_map : (Constr.rel_declaration * lazy_val) Range.t;
+}
+
+type env = {
+  env_globals       : globals;
+  env_named_context : named_context_val; (* section variables *)
+  env_rel_context   : rel_context_val;
+  env_nb_rel        : int;
+  env_stratification : stratification;
+  env_typing_flags  : typing_flags;
+  retroknowledge : Retroknowledge.retroknowledge;
+  indirect_pterms : Opaqueproof.opaquetab;
+}
+
+let empty_named_context_val = {
+  env_named_ctx = [];
+  env_named_map = Id.Map.empty;
+}
+
+let empty_rel_context_val = {
+  env_rel_ctx = [];
+  env_rel_map = Range.empty;
+}
+
+let empty_env = {
+  env_globals = {
+    env_constants = Cmap_env.empty;
+    env_inductives = Mindmap_env.empty;
+    env_modules = MPmap.empty;
+    env_modtypes = MPmap.empty};
+  env_named_context = empty_named_context_val;
+  env_rel_context = empty_rel_context_val;
+  env_nb_rel = 0;
+  env_stratification = {
+    env_universes = UGraph.initial_universes;
+    env_engagement = PredicativeSet };
+  env_typing_flags = Declareops.safe_flags Conv_oracle.empty;
+  retroknowledge = Retroknowledge.initial_retroknowledge;
+  indirect_pterms = Opaqueproof.empty_opaquetab }
+
+
+(* Rel context *)
+
+let push_rel_context_val d ctx = {
+  env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx;
+  env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map;
+}
+
+let match_rel_context_val ctx = match ctx.env_rel_ctx with
+| [] -> None
+| decl :: rem ->
+  let (_, lval) = Range.hd ctx.env_rel_map in
+  let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in
+  Some (decl, lval, ctx)
+
+let push_rel d env =
+    { env with
+      env_rel_context = push_rel_context_val d env.env_rel_context;
+      env_nb_rel = env.env_nb_rel + 1 }
+
+let lookup_rel n env =
+  try fst (Range.get env.env_rel_context.env_rel_map (n - 1))
+  with Invalid_argument _ -> raise Not_found
+
+let lookup_rel_val n env =
+  try snd (Range.get env.env_rel_context.env_rel_map (n - 1))
+  with Invalid_argument _ -> raise Not_found
+
+let rel_skipn n ctx = {
+  env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx;
+  env_rel_map = Range.skipn n ctx.env_rel_map;
+}
+
+let env_of_rel n env =
+  { env with
+    env_rel_context = rel_skipn n env.env_rel_context;
+    env_nb_rel = env.env_nb_rel - n
+  }
+
+(* Named context *)
+
+let push_named_context_val_val d rval ctxt =
+(*   assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *)
+  {
+    env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
+    env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map;
+  }
+
+let push_named_context_val d ctxt =
+  push_named_context_val_val d (ref VKnone) ctxt
+
+let match_named_context_val c = match c.env_named_ctx with
+| [] -> None
+| decl :: ctx ->
+  let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in
+  let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in
+  let cval = { env_named_ctx = ctx; env_named_map = map } in
+  Some (decl, v, cval)
+
+let map_named_val f ctxt =
+  let open Context.Named.Declaration in
+  let fold accu d =
+    let d' = map_constr f d in
+    let accu =
+      if d == d' then accu
+      else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu
+    in
+    (accu, d')
+  in
+  let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in
+  if map == ctxt.env_named_map then ctxt
+  else { env_named_ctx = ctx; env_named_map = map }
+
+let push_named d env =
+  {env with env_named_context = push_named_context_val d env.env_named_context}
 
-type env = Pre_env.env
+let lookup_named id env =
+  fst (Id.Map.find id env.env_named_context.env_named_map)
+
+let lookup_named_val id env =
+  snd(Id.Map.find id env.env_named_context.env_named_map)
+
+let lookup_named_ctxt id ctxt =
+  fst (Id.Map.find id ctxt.env_named_map)
+
+let fold_constants f env acc =
+  Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_constants acc
+
+(* Global constants *)
+
+let lookup_constant_key kn env =
+  Cmap_env.find kn env.env_globals.env_constants
+
+let lookup_constant kn env =
+  fst (Cmap_env.find kn env.env_globals.env_constants)
+
+(* Mutual Inductives *)
+let lookup_mind kn env =
+  fst (Mindmap_env.find kn env.env_globals.env_inductives)
+
+let lookup_mind_key kn env =
+  Mindmap_env.find kn env.env_globals.env_inductives
 
-let pre_env env = env
-let env_of_pre_env env = env
 let oracle env = env.env_typing_flags.conv_oracle
 let set_oracle env o =
   let env_typing_flags = { env.env_typing_flags with conv_oracle = o } in
   { env with env_typing_flags }
 
-let empty_named_context_val = empty_named_context_val
-
-let empty_env = empty_env
-
 let engagement env = env.env_stratification.env_engagement
 let typing_flags env = env.env_typing_flags
 
@@ -72,15 +254,11 @@ let empty_context env =
   | _ -> false
 
 (* Rel context *)
-let lookup_rel = lookup_rel
-
 let evaluable_rel n env =
   is_local_def (lookup_rel n env)
 
 let nb_rel env = env.env_nb_rel
 
-let push_rel = push_rel
-
 let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x
 
 let push_rec_types (lna,typarray,_) env =
@@ -105,24 +283,14 @@ let named_context_of_val c = c.env_named_ctx
 
 let ids_of_named_context_val c = Id.Map.domain c.env_named_map
 
-(* [map_named_val f ctxt] apply [f] to the body and the type of
-   each declarations.
-   *** /!\ ***   [f t] should be convertible with t *)
-let map_named_val = map_named_val
-
 let empty_named_context = Context.Named.empty
 
-let push_named = push_named
 let push_named_context = List.fold_right push_named
-let push_named_context_val = push_named_context_val
 
 let val_of_named_context ctxt =
   List.fold_right push_named_context_val ctxt empty_named_context_val
 
 
-let lookup_named = lookup_named
-let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map)
-
 let eq_named_context_val c1 c2 =
    c1 == c2 || Context.Named.equal Constr.equal (named_context_of_val c1) (named_context_of_val c2)
 
@@ -181,7 +349,10 @@ let map_universes f env =
   let s = env.env_stratification in
     { env with env_stratification =
 	 { s with env_universes = f s.env_universes } }
-				     
+
+let set_universes env u =
+  { env with env_stratification = { env.env_stratification with env_universes = u } }
+
 let add_constraints c env =
   if Univ.Constraint.is_empty c then env
   else map_universes (UGraph.merge_constraints c) env
@@ -221,8 +392,6 @@ let set_typing_flags c env = (* Unsafe *)
 
 (* Global constants *)
 
-let lookup_constant = lookup_constant
-
 let no_link_info = NotLinked
 
 let add_constant_key kn cb linkinfo env =
@@ -319,19 +488,26 @@ let polymorphic_pconstant (cst,u) env =
 let type_in_type_constant cst env =
   not (lookup_constant cst env).const_typing_flags.check_universes
 
-let lookup_projection cst env =
-  match (lookup_constant (Projection.constant cst) env).const_proj with 
-  | Some pb -> pb
-  | None -> anomaly (Pp.str "lookup_projection: constant is not a projection.")
-
-let is_projection cst env =
-  match (lookup_constant cst env).const_proj with 
-  | Some _ -> true
-  | None -> false
+let lookup_projection p env =
+  let mind,i = Projection.inductive p in
+  let mib = lookup_mind mind env in
+  (if not (Int.equal mib.mind_nparams (Projection.npars p))
+   then anomaly ~label:"lookup_projection" Pp.(str "Bad number of parameters on projection."));
+  match mib.mind_record with
+  | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection")
+  | PrimRecord infos ->
+    let _,_,typs = infos.(i) in
+    typs.(Projection.arg p)
+
+let get_projection env ind ~proj_arg =
+  let mib = lookup_mind (fst ind) env in
+  Declareops.inductive_make_projection ind mib ~proj_arg
+
+let get_projections env ind =
+  let mib = lookup_mind (fst ind) env in
+  Declareops.inductive_make_projections ind mib
 
 (* Mutual Inductives *)
-let lookup_mind = lookup_mind
-
 let polymorphic_ind (mind,i) env =
   Declareops.inductive_is_polymorphic (lookup_mind mind env)
 
@@ -351,11 +527,11 @@ let template_polymorphic_pind (ind,u) env =
   if not (Univ.Instance.is_empty u) then false
   else template_polymorphic_ind ind env
   
-let add_mind_key kn mind_key env =
+let add_mind_key kn (mind, _ as mind_key) env =
   let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in
   let new_globals =
     { env.env_globals with
-	env_inductives = new_inds } in
+        env_inductives = new_inds; } in
   { env with env_globals = new_globals }
 
 let add_mind kn mib env =
@@ -468,10 +644,6 @@ type 'types punsafe_type_judgment = {
 
 type unsafe_type_judgment = types punsafe_type_judgment
 
-(*s Compilation of global declaration *)
-
-let compile_constant_body = Cbytegen.compile_constant_body ~fail_on_error:false
-
 exception Hyp_not_found
 
 let apply_to_hyp ctxt id f =
@@ -530,121 +702,3 @@ let register env field entry =
 	in
         register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry
     | field -> register_one env field entry
-
-(* the Environ.register function syncrhonizes the proactive and reactive
-   retroknowledge. *)
-let dispatch =
-
-  (* subfunction used for static decompilation of int31 (after a vm_compute,
-     see pretyping/vnorm.ml for more information) *)
-  let constr_of_int31 =
-    let nth_digit_plus_one i n = (* calculates the nth (starting with 0)
-                                    digit of i and adds 1 to it
-                                    (nth_digit_plus_one 1 3 = 2) *)
-      if Int.equal (i land (1 lsl n)) 0 then
-        1
-      else
-        2
-    in
-      fun ind -> fun digit_ind -> fun tag ->
-	let array_of_int i =
-	  Array.init 31 (fun n -> mkConstruct
-			   (digit_ind, nth_digit_plus_one i (30-n)))
-	in
-	(* We check that no bit above 31 is set to one. This assertion used to
-	fail in the VM, and led to conversion tests failing at Qed. *)
-        assert (Int.equal (tag lsr 31) 0);
-	mkApp(mkConstruct(ind, 1), array_of_int tag)
-  in
-
-  (* subfunction which dispatches the compiling information of an
-     int31 operation which has a specific vm instruction (associates
-     it to the name of the coq definition in the reactive retroknowledge) *)
-  let int31_op n op prim kn =
-    { empty_reactive_info with
-      vm_compiling = Some (Clambda.compile_prim n op kn);
-      native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn));
-    }
-  in
-
-fun rk value field ->
-  (* subfunction which shortens the (very common) dispatch of operations *)
-  let int31_op_from_const n op prim =
-    match kind value with
-      | Const kn ->  int31_op n op prim kn
-      | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.")
-  in
-  let int31_binop_from_const op prim = int31_op_from_const 2 op prim in
-  let int31_unop_from_const op prim = int31_op_from_const 1 op prim in
-  match field with
-    | KInt31 (grp, Int31Type) ->
-        let int31bit =
-          (* invariant : the type of bits is registered, otherwise the function
-             would raise Not_found. The invariant is enforced in safe_typing.ml *)
-          match field with
-          | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits))
-          | _ -> anomaly ~label:"Environ.register"
-              (Pp.str "add_int31_decompilation_from_type called with an abnormal field.")
-        in
-        let i31bit_type =
-          match kind 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 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 Clambda.int31_escape_before_match;
-          native_before_match = Some (Nativelambda.before_match_int31 i31bit_type);
-        }
-    | KInt31 (_, Int31Constructor) ->
-        { empty_reactive_info with
-          vm_constant_static = Some Clambda.compile_structured_int31;
-          vm_constant_dynamic = Some Clambda.dynamic_int31_compilation;
-          native_constant_static = Some Nativelambda.compile_static_int31;
-          native_constant_dynamic = Some Nativelambda.compile_dynamic_int31;
-        }
-    | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31
-							  CPrimitives.Int31add
-    | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31
-							   CPrimitives.Int31addc
-    | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31
-								CPrimitives.Int31addcarryc
-    | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31
-							   CPrimitives.Int31sub
-    | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31
-							    CPrimitives.Int31subc
-    | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const
-	                                Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc
-    | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31
-							   CPrimitives.Int31mul
-    | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31
-							   CPrimitives.Int31mulc
-    | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31
-                                                           CPrimitives.Int31div21
-    | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31
-							 CPrimitives.Int31diveucl
-    | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31
-                                                         CPrimitives.Int31addmuldiv
-    | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31
-							     CPrimitives.Int31compare
-    | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31
-							  CPrimitives.Int31head0
-    | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31
-							  CPrimitives.Int31tail0
-    | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31
-							 CPrimitives.Int31lor
-    | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31
-							  CPrimitives.Int31land
-    | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31
-							  CPrimitives.Int31lxor
-    | _ -> empty_reactive_info
-
-let _ = Hook.set Retroknowledge.dispatch_hook dispatch
diff --git a/kernel/environ.mli b/kernel/environ.mli
index fdd84b25..f45b7be8 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -28,23 +28,63 @@ open Declarations
    - a set of universe constraints
    - a flag telling if Set is, can be, or cannot be set impredicative *)
 
+type lazy_val
 
+val build_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) -> unit
+val force_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) option
+val dummy_lazy_val : unit -> lazy_val
 
+(** Linking information for the native compiler *)
+type link_info =
+  | Linked of string
+  | LinkedInteractive of string
+  | NotLinked
+
+type key = int CEphemeron.key option ref
+
+type constant_key = constant_body * (link_info ref * key)
+
+type mind_key = mutual_inductive_body * link_info ref
+
+type globals
+(** globals = constants + projections + inductive types + modules + module-types *)
+
+type stratification = {
+  env_universes : UGraph.t;
+  env_engagement : engagement
+}
+
+type named_context_val = private {
+  env_named_ctx : Constr.named_context;
+  env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t;
+}
+
+type rel_context_val = private {
+  env_rel_ctx : Constr.rel_context;
+  env_rel_map : (Constr.rel_declaration * lazy_val) Range.t;
+}
+
+type env = private {
+  env_globals       : globals;
+  env_named_context : named_context_val; (* section variables *)
+  env_rel_context   : rel_context_val;
+  env_nb_rel        : int;
+  env_stratification : stratification;
+  env_typing_flags  : typing_flags;
+  retroknowledge : Retroknowledge.retroknowledge;
+  indirect_pterms : Opaqueproof.opaquetab;
+}
 
-type env
-val pre_env : env -> Pre_env.env
-val env_of_pre_env : Pre_env.env -> env
 val oracle : env -> Conv_oracle.oracle
 val set_oracle : env -> Conv_oracle.oracle -> env
 
-type named_context_val
 val eq_named_context_val : named_context_val -> named_context_val -> bool
 
 val empty_env : env
 
 val universes     : env -> UGraph.t
-val rel_context   : env -> Context.Rel.t
-val named_context : env -> Context.Named.t
+val rel_context   : env -> Constr.rel_context
+val named_context : env -> Constr.named_context
 val named_context_val : env -> named_context_val
 
 val opaque_tables : env -> Opaqueproof.opaquetab
@@ -63,24 +103,26 @@ val empty_context : env -> bool
 (** {5 Context of de Bruijn variables ([rel_context]) } *)
 
 val nb_rel           : env -> int
-val push_rel         : Context.Rel.Declaration.t -> env -> env
-val push_rel_context : Context.Rel.t -> env -> env
+val push_rel         : Constr.rel_declaration -> env -> env
+val push_rel_context : Constr.rel_context -> env -> env
 val push_rec_types   : rec_declaration -> env -> env
 
 (** Looks up in the context of local vars referred by indice ([rel_context]) 
    raises [Not_found] if the index points out of the context *)
-val lookup_rel    : int -> env -> Context.Rel.Declaration.t
+val lookup_rel    : int -> env -> Constr.rel_declaration
+val lookup_rel_val : int -> env -> lazy_val
 val evaluable_rel : int -> env -> bool
+val env_of_rel     : int -> env -> env
 
 (** {6 Recurrence on [rel_context] } *)
 
 val fold_rel_context :
-  (env -> Context.Rel.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a
+  (env -> Constr.rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
 
 (** {5 Context of variables (section variables and goal assumptions) } *)
 
-val named_context_of_val : named_context_val -> Context.Named.t
-val val_of_named_context : Context.Named.t -> named_context_val
+val named_context_of_val : named_context_val -> Constr.named_context
+val val_of_named_context : Constr.named_context -> named_context_val
 val empty_named_context_val : named_context_val
 val ids_of_named_context_val : named_context_val -> Id.Set.t
 
@@ -91,18 +133,19 @@ val ids_of_named_context_val : named_context_val -> Id.Set.t
 val map_named_val :
    (constr -> constr) -> named_context_val -> named_context_val
 
-val push_named : Context.Named.Declaration.t -> env -> env
-val push_named_context : Context.Named.t -> env -> env
+val push_named : Constr.named_declaration -> env -> env
+val push_named_context : Constr.named_context -> env -> env
 val push_named_context_val  :
-    Context.Named.Declaration.t -> named_context_val -> named_context_val
+    Constr.named_declaration -> named_context_val -> named_context_val
 
 
 
 (** Looks up in the context of local vars referred by names ([named_context]) 
    raises [Not_found] if the Id.t is not found *)
 
-val lookup_named     : variable -> env -> Context.Named.Declaration.t
-val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t
+val lookup_named     : variable -> env -> Constr.named_declaration
+val lookup_named_val : variable -> env -> lazy_val
+val lookup_named_ctxt : variable -> named_context_val -> Constr.named_declaration
 val evaluable_named  : variable -> env -> bool
 val named_type : variable -> env -> types
 val named_body : variable -> env -> constr option
@@ -110,11 +153,13 @@ val named_body : variable -> env -> constr option
 (** {6 Recurrence on [named_context]: older declarations processed first } *)
 
 val fold_named_context :
-  (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a
+  (env -> Constr.named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
+
+val set_universes : env -> UGraph.t -> env
 
 (** Recurrence on [named_context] starting from younger decl *)
 val fold_named_context_reverse :
-  ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a
+  ('a -> Constr.named_declaration -> 'a) -> init:'a -> env -> 'a
 
 (** This forgets named and rel contexts *)
 val reset_context : env -> env
@@ -125,12 +170,16 @@ val reset_with_named_context : named_context_val -> env -> env
 (** This removes the [n] last declarations from the rel context *)
 val pop_rel_context : int -> env -> env
 
+(** Useful for printing *)
+val fold_constants : (Constant.t -> constant_body -> 'a -> 'a) -> env -> 'a -> 'a
+
 (** {5 Global constants }
   {6 Add entries to global environment } *)
 
 val add_constant : Constant.t -> constant_body -> env -> env
-val add_constant_key : Constant.t -> constant_body -> Pre_env.link_info ->
+val add_constant_key : Constant.t -> constant_body -> link_info ->
   env -> env
+val lookup_constant_key :  Constant.t -> env -> constant_key
 
 (** Looks up in the context of global constant names 
    raises [Not_found] if the required path is not found *)
@@ -168,11 +217,15 @@ val constant_opt_value_in : env -> Constant.t puniverses -> constr option
 
 (** {6 Primitive projections} *)
 
-val lookup_projection    : Names.Projection.t -> env -> projection_body
-val is_projection : Constant.t -> env -> bool
+(** Checks that the number of parameters is correct. *)
+val lookup_projection : Names.Projection.t -> env -> types
+
+val get_projection : env -> inductive -> proj_arg:int -> Names.Projection.Repr.t option
+val get_projections : env -> inductive -> Names.Projection.Repr.t array option
 
 (** {5 Inductive types } *)
-val add_mind_key : MutInd.t -> Pre_env.mind_key -> env -> env
+val lookup_mind_key : MutInd.t -> env -> mind_key
+val add_mind_key : MutInd.t -> mind_key -> env -> env
 val add_mind : MutInd.t -> mutual_inductive_body -> env -> env
 
 (** Looks up in the context of global inductive names 
@@ -228,7 +281,7 @@ val vars_of_global : env -> constr -> Id.Set.t
 val really_needed : env -> Id.Set.t -> Id.Set.t
 
 (** like [really_needed] but computes a well ordered named context *)
-val keep_hyps : env -> Id.Set.t -> Context.Named.t
+val keep_hyps : env -> Id.Set.t -> Constr.named_context
 
 (** {5 Unsafe judgments. }
     We introduce here the pre-type of judgments, which is
@@ -251,20 +304,16 @@ type 'types punsafe_type_judgment = {
 
 type unsafe_type_judgment = types punsafe_type_judgment
 
-(** {6 Compilation of global declaration } *)
-
-val compile_constant_body : env -> constant_universes -> constant_def -> Cemitcodes.body_code option
-
 exception Hyp_not_found
 
 (** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
    return [tail::(f head (id,_,_) (rev tail))::head].
    the value associated to id should not change *)
 val apply_to_hyp : named_context_val -> variable ->
-  (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) ->
+  (Constr.named_context -> Constr.named_declaration -> Constr.named_context -> Constr.named_declaration) ->
     named_context_val
 
-val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
+val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declaration) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val
 
 
 
@@ -272,10 +321,11 @@ open Retroknowledge
 (** functions manipulating the retroknowledge 
     @author spiwack *)
 val retroknowledge : (retroknowledge->'a) -> env -> 'a
+[@@ocaml.deprecated "Use the record projection."]
 
 val registered : env -> field -> bool
 
 val register : env -> field -> Retroknowledge.entry -> env
 
 (** Native compiler *)
-val no_link_info : Pre_env.link_info
+val no_link_info : link_info
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index a11a0dc0..9fc3b11d 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -19,6 +19,8 @@ open Util
 (*********************)
 
 (* Explicit lifts and basic operations *)
+(* Invariant to preserve in this module: no lift contains two consecutive
+    [ELSHFT] nor two consecutive [ELLFT]. *)
 type lift =
   | ELID
   | ELSHFT of lift * int (* ELSHFT(l,n) == lift of n, then apply lift l *)
@@ -28,15 +30,15 @@ type lift =
 let el_id = ELID
 
 (* compose a relocation of magnitude n *)
-let rec el_shft_rec n = function
-  | ELSHFT(el,k) -> el_shft_rec (k+n) el
+let el_shft_rec n = function
+  | ELSHFT(el,k) -> ELSHFT(el,k+n)
   | el           -> ELSHFT(el,n)
 let el_shft n el = if Int.equal n 0 then el else el_shft_rec n el
 
 (* cross n binders *)
-let rec el_liftn_rec n = function
+let el_liftn_rec n = function
   | ELID        -> ELID
-  | ELLFT(k,el) -> el_liftn_rec (n+k) el
+  | ELLFT(k,el) -> ELLFT(n+k, el)
   | el          -> ELLFT(n, el)
 let el_liftn n el = if Int.equal n 0 then el else el_liftn_rec n el
 
@@ -132,13 +134,36 @@ let rec exp_rel lams k subs =
 
 let expand_rel k subs = exp_rel 0 k subs
 
+let rec subs_map f = function
+| ESID _ as s -> s
+| CONS (x, s) -> CONS (Array.map f x, subs_map f s)
+| SHIFT (n, s) -> SHIFT (n, subs_map f s)
+| LIFT (n, s) -> LIFT (n, subs_map f s)
+
+let rec lift_subst mk_cl s1 s2 = match s1 with
+| ELID -> subs_map (fun c -> mk_cl ELID c) s2
+| ELSHFT(s, k) -> subs_shft(k, lift_subst mk_cl s s2)
+| ELLFT (k, s) ->
+  match s2 with
+  | CONS(x,s') ->
+      CONS(CArray.Fun1.map mk_cl s1 x, lift_subst mk_cl s1 s')
+  | ESID n -> lift_subst mk_cl s (ESID (n + k))
+  | SHIFT(k',s') ->
+      if k<k'
+      then subs_shft(k, lift_subst mk_cl s (subs_shft(k'-k, s')))
+      else subs_shft(k', lift_subst mk_cl (el_liftn (k-k') s) s')
+  | LIFT(k',s') ->
+      if k<k'
+      then subs_liftn k (lift_subst mk_cl s (subs_liftn (k'-k) s'))
+      else subs_liftn k' (lift_subst mk_cl (el_liftn (k-k') s) s')
+
 let rec comp mk_cl s1 s2 =
   match (s1, s2) with
     | _, ESID _ -> s1
     | ESID _, _ -> s2
     | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2)
     | _, CONS(x,s') ->
-        CONS(CArray.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s')
+        CONS(Array.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s')
     | CONS(x,s), SHIFT(k,s') ->
         let lg = Array.length x in
         if k == lg then comp mk_cl s s'
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index b82d6fdf..475b64f4 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -56,7 +56,11 @@ val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
 (** {6 Compact representation } *)
 (** Compact representation of explicit relocations
     - [ELSHFT(l,n)] == lift of [n], then apply [lift l].
-    - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
+    - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders.
+
+    Invariant ensured by the private flag: no lift contains two consecutive
+    [ELSHFT] nor two consecutive [ELLFT].
+*)
 type lift = private
   | ELID
   | ELSHFT of lift * int
@@ -68,3 +72,10 @@ val el_liftn : int -> lift -> lift
 val el_lift : lift -> lift
 val reloc_rel : int -> lift -> int
 val is_lift_id : lift -> bool
+
+(** Lift applied to substitution: [lift_subst mk_clos el s] computes a
+    substitution equivalent to applying el then s. Argument
+    mk_clos is used when a closure has to be created, i.e. when
+    el is applied on an element of s.
+*)
+val lift_subst : (lift -> 'a -> 'b) -> lift -> 'a subs -> 'b subs
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 85be2146..14decafc 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -120,16 +120,6 @@ let mind_check_names mie =
 
 (* Typing the arities and constructor types *)
 
-(* An inductive definition is a "unit" if it has only one constructor
-   and that all arguments expected by this constructor are
-   logical, this is the case for equality, conjunction of logical properties
-*)
-let is_unit constrsinfos =
-  match constrsinfos with  (* One info = One constructor *)
-   | [level] -> is_type0m_univ level
-   | [] -> (* type without constructors *) true
-   | _ -> false
-
 let infos_and_sort env t =
   let rec aux env t max =
     let t = whd_all env t in
@@ -174,10 +164,9 @@ let infer_constructor_packet env_ar_par params lc =
   let lc'' = Array.map (fun j -> Term.it_mkProd_or_LetIn j.utj_val params) jlc in
   (* compute the max of the sorts of the products of the constructors types *)
   let levels = List.map (infos_and_sort env_ar_par) lc in
-  let isunit = is_unit levels in
   let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in
   let level = List.fold_left (fun max l -> Universe.sup max l) min levels in
-  (lc'', (isunit, level))
+  (lc'', level)
 
 (* If indices matter *)
 let cumulate_arity_large_levels env sign =
@@ -353,7 +342,7 @@ let typecheck_inductive env mie =
   (* Compute/check the sorts of the inductive types *)
 
   let inds =
-    Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,clev))  ->
+    Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,clev)  ->
       let infu = 
 	(** Inferred level, with parameters and constructors. *)
 	match inf_level with
@@ -424,7 +413,7 @@ let typecheck_inductive env mie =
 type ill_formed_ind =
   | LocalNonPos of int
   | LocalNotEnoughArgs of int
-  | LocalNotConstructor of Context.Rel.t * int
+  | LocalNotConstructor of Constr.rel_context * int
   | LocalNonPar of int * int * int
 
 exception IllFormedInd of ill_formed_ind
@@ -796,69 +785,47 @@ exception UndefinableExpansion
     build an expansion function.
     The term built is expecting to be substituted first by 
     a substitution of the form [params, x : ind params] *)
-let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
-    mind_consnrealdecls mind_consnrealargs paramslet ctx =
-  let mp, dp, l = MutInd.repr3 kn in
+let compute_projections (kn, i as ind) mib =
+  let pkt = mib.mind_packets.(i) in
+  let u = match mib.mind_universes with
+  | Monomorphic_ind _ -> Univ.Instance.empty
+  | Polymorphic_ind auctx -> Univ.make_abstract_instance auctx
+  | Cumulative_ind acumi -> Univ.make_abstract_instance (Univ.ACumulativityInfo.univ_context acumi)
+  in
+  let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in
+  let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in
+  let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in
   (** We build a substitution smashing the lets in the record parameters so
       that typechecking projections requires just a substitution and not
       matching with a parameter context. *)
-  let indty, paramsletsubst =
-    (* [ty] = [Ind inst] is typed in context [params] *)
-    let inst = Context.Rel.to_extended_vect mkRel 0 paramslet in
-    let ty = mkApp (mkIndU indu, inst) in
+  let paramsletsubst =
     (* [Ind inst] is typed in context [params-wo-let] *)
-    let inst' = rel_list 0 nparamargs in
+    let inst' = rel_list 0 mib.mind_nparams in
     (* {params-wo-let |- subst:params] *)
     let subst = subst_of_rel_context_instance paramslet inst' in
     (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *)
     let subst = (* For the record parameter: *)
       mkRel 1 :: List.map (lift 1) subst in
-      ty, subst
+    subst
   in
-  let ci = 
-    let print_info =
-      { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in
-      { ci_ind     = ind;
-	ci_npar    = nparamargs;
-	ci_cstr_ndecls = mind_consnrealdecls;
-	ci_cstr_nargs = mind_consnrealargs;
-	ci_pp_info = print_info }
-  in
-  let len = List.length ctx in
-  let x = Name x in
-  let compat_body ccl i = 
-    (* [ccl] is defined in context [params;x:indty] *)
-    (* [ccl'] is defined in context [params;x:indty;x:indty] *)
-    let ccl' = liftn 1 2 ccl in
-    let p = mkLambda (x, lift 1 indty, ccl') in
-    let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in
-    let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in
-      it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params
-  in
-  let projections decl (i, j, kns, pbs, subst, letsubst) =
+  let projections decl (i, j, labs, pbs, letsubst) =
     match decl with
     | LocalDef (na,c,t) ->
         (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)]
            to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *)
         let c = liftn 1 j c in
         (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)]
-           to [params, x:I |- c(params,proj1 x,..,projj x)] *)
-        let c1 = substl subst c in
-        (* From [params, x:I |- subst:field1,..,fieldj]
-           to [params, x:I |- subst:field1,..,fieldj+1] where [subst]
-           is represented with instance of field1 last *)
-        let subst = c1 :: subst in
-        (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)]
            to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *)
         let c2 = substl letsubst c in
         (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)]
            to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *)
         let letsubst = c2 :: letsubst in
-        (i, j+1, kns, pbs, subst, letsubst)
+        (i, j+1, labs, pbs, letsubst)
     | LocalAssum (na,t) ->
       match na with
       | Name id ->
-	let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in
+        let lab = Label.of_id id in
+        let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in
         (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)]
            to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *)
         let t = liftn 1 j t in
@@ -867,23 +834,14 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params
 	let projty = substl letsubst t in
         (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)]
            to [params, x:I |- t(proj1 x,..,projj x)] *)
-	let ty = substl subst t in
-	let term = mkProj (Projection.make kn true, mkRel 1) in
 	let fterm = mkProj (Projection.make kn false, mkRel 1) in
-	let compat = compat_body ty (j - 1) in
-	let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in
-	let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in
-	let body = { proj_ind = fst ind; proj_npars = nparamargs;
-		     proj_arg = i; proj_type = projty; proj_eta = etab, etat; 
-		     proj_body = compat } in
-	  (i + 1, j + 1, kn :: kns, body :: pbs,
-	   fterm :: subst, fterm :: letsubst)
+        (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst)
       | Anonymous -> raise UndefinableExpansion
   in
-  let (_, _, kns, pbs, subst, letsubst) =
-    List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst)
+  let (_, _, labs, pbs, letsubst) =
+    List.fold_right projections ctx (0, 1, [], [], paramsletsubst)
   in
-    Array.of_list (List.rev kns),
+    Array.of_list (List.rev labs),
     Array.of_list (List.rev pbs)
 
 let abstract_inductive_universes iu =
@@ -968,33 +926,9 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r
 	mind_reloc_tbl = rtbl;
       } in
   let packets = Array.map2 build_one_packet inds recargs in
-  let pkt = packets.(0) in
-  let isrecord = 
-    match isrecord with
-    | Some (Some rid) when pkt.mind_kelim == all_sorts
-			   && Array.length pkt.mind_consnames == 1
-			   && pkt.mind_consnrealargs.(0) > 0 ->
-      (** The elimination criterion ensures that all projections can be defined. *)
-      let u =
-        match aiu with
-        | Monomorphic_ind _ -> Univ.Instance.empty
-        | Polymorphic_ind auctx -> Univ.make_abstract_instance auctx
-        | Cumulative_ind acumi -> Univ.make_abstract_instance (Univ.ACumulativityInfo.univ_context acumi)
-      in
-      let indsp = ((kn, 0), u) in
-      let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in
-	(try 
-	   let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in
-	   let kns, projs = 
-	     compute_projections indsp pkt.mind_typename rid nparamargs paramsctxt
-	       pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields
-	   in Some (Some (rid, kns, projs))
-	 with UndefinableExpansion -> Some None)
-    | Some _ -> Some None
-    | None -> None
-  in
-    (* Build the mutual inductive *)
-    { mind_record = isrecord;
+  let mib =
+      (* Build the mutual inductive *)
+    { mind_record = NotRecord;
       mind_ntypes = ntypes;
       mind_finite = isfinite;
       mind_hyps = hyps;
@@ -1006,6 +940,27 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r
       mind_private = prv;
       mind_typing_flags = Environ.typing_flags env;
     }
+  in
+  let record_info = match isrecord with
+  | Some (Some rid) ->
+    let is_record pkt =
+      pkt.mind_kelim == all_sorts
+      && Array.length pkt.mind_consnames == 1
+      && pkt.mind_consnrealargs.(0) > 0
+    in
+    (** The elimination criterion ensures that all projections can be defined. *)
+    if Array.for_all is_record packets then
+      let map i id =
+        let labs, projs = compute_projections (kn, i) mib in
+        (id, labs, projs)
+      in
+      try PrimRecord (Array.mapi map rid)
+      with UndefinableExpansion -> FakeRecord
+    else FakeRecord
+  | Some None -> FakeRecord
+  | None -> NotRecord
+  in
+  { mib with mind_record = record_info }
 
 (************************************************************************)
 (************************************************************************)
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 5a38172c..cb09cfa8 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -42,8 +42,3 @@ val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_induct
 
 val enforce_indices_matter : unit -> unit
 val is_indices_matter : unit -> bool
-
-val compute_projections : pinductive -> Id.t -> Id.t ->
-  int -> Context.Rel.t -> int array -> int array -> 
-  Context.Rel.t -> Context.Rel.t -> 
-  (Constant.t array * projection_body array)
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 9bed598b..4d13a5fc 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -130,11 +130,6 @@ where
 Remark: Set (predicative) is encoded as Type(0)
 *)
 
-let sort_as_univ = let open Sorts in function
-| Type u -> u
-| Prop Null -> Universe.type0m
-| Prop Pos -> Universe.type0
-
 (* Template polymorphism *)
 
 (* cons_subst add the mapping [u |-> su] in subst if [u] is not *)
@@ -168,7 +163,7 @@ let make_subst env =
         (* arity is a global level which, at typing time, will be enforce *)
         (* to be greater than the level of the argument; this is probably *)
         (* a useless extra constraint *)
-        let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in
+        let s = Sorts.univ_of_sort (snd (dest_arity env (Lazy.force a))) in
           make (cons_subst u s subst) (sign, exp, args)
     | LocalAssum (na,t) :: sign, Some u::exp, [] ->
         (* No more argument here: we add the remaining universes to the *)
@@ -236,8 +231,8 @@ let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args =
 (* The max of an array of universes *)
 
 let cumulate_constructor_univ u = let open Sorts in function
-  | Prop Null -> u
-  | Prop Pos -> Universe.sup Universe.type0 u
+  | Prop -> u
+  | Set -> Universe.sup Universe.type0 u
   | Type u' -> Universe.sup u u'
 
 let max_inductive_sort =
@@ -293,8 +288,8 @@ let elim_sorts (_,mip) = mip.mind_kelim
 let is_private (mib,_) = mib.mind_private = Some true
 let is_primitive_record (mib,_) = 
   match mib.mind_record with
-  | Some (Some _) -> true
-  | _ -> false
+  | PrimRecord _ -> true
+  | NotRecord | FakeRecord -> false
 
 let build_dependent_inductive ind (_,mip) params =
   let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in
@@ -790,7 +785,7 @@ let rec subterm_specif renv stack t =
 
     | Lambda (x,a,b) ->
       let () = assert (List.is_empty l) in
-      let spec,stack' = extract_stack renv a stack in
+      let spec,stack' = extract_stack stack in
 	subterm_specif (push_var renv (x,a,spec)) stack' b
 
       (* Metas and evars are considered OK *)
@@ -803,10 +798,7 @@ let rec subterm_specif renv stack t =
          (* We take the subterm specs of the constructor of the record *)
          let wf_args = (dest_subterms wf).(0) in
          (* We extract the tree of the projected argument *)
-         let kn = Projection.constant p in
-         let cb = lookup_constant kn renv.env in
-         let pb = Option.get cb.const_proj in
-         let n = pb.proj_arg in
+         let n = Projection.arg p in
          spec_of_tree (List.nth wf_args n)
        | Dead_code -> Dead_code
        | Not_subterm -> Not_subterm)
@@ -824,7 +816,7 @@ and stack_element_specif = function
   |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h
   |SArg x -> x
 
-and extract_stack renv a = function
+and extract_stack = function
    | [] -> Lazy.from_val Not_subterm , []
    | h::t -> stack_element_specif h, t
 
@@ -855,7 +847,7 @@ let error_illegal_rec_call renv fx (arg_renv,arg) =
 let error_partial_apply renv fx =
   raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
 
-let filter_stack_domain env ci p stack =
+let filter_stack_domain env p stack =
   let absctx, ar = dest_lam_assum env p in
   (* Optimization: if the predicate is not dependent, no restriction is needed
      and we avoid building the recargs tree. *)
@@ -940,7 +932,7 @@ let check_one_fix renv recpos trees def =
             let case_spec = branches_specif renv 
 	      (lazy_subterm_specif renv [] c_0) ci in
 	    let stack' = push_stack_closures renv l stack in
-        let stack' = filter_stack_domain renv.env ci p stack' in
+        let stack' = filter_stack_domain renv.env p stack' in
               Array.iteri (fun k br' -> 
 			     let stack_br = push_stack_args case_spec.(k) stack' in
 			     check_rec_call renv stack_br br') lrest
@@ -983,7 +975,7 @@ let check_one_fix renv recpos trees def =
         | Lambda (x,a,b) ->
             let () = assert (List.is_empty l) in
 	    check_rec_call renv [] a ;
-	    let spec, stack' = extract_stack renv a stack in
+            let spec, stack' = extract_stack stack in
 	    check_rec_call (push_var renv (x,a,spec)) stack' b
 
         | Prod (x,a,b) ->
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index c7982f1f..3c1464c6 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -36,7 +36,7 @@ val lookup_mind_specif : env -> inductive -> mind_specif
 (** {6 Functions to build standard types related to inductive } *)
 val ind_subst : MutInd.t -> mutual_inductive_body -> Instance.t -> constr list
 
-val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t
+val inductive_paramdecls : mutual_inductive_body puniverses -> Constr.rel_context
 
 val instantiate_inductive_constraints :
   mutual_inductive_body -> Instance.t -> Constraint.t
@@ -87,7 +87,7 @@ val build_branches_type :
     constr list -> constr -> types array
 
 (** Return the arity of an inductive type *)
-val mind_arity : one_inductive_body -> Context.Rel.t * Sorts.family
+val mind_arity : one_inductive_body -> Constr.rel_context * Sorts.family
 
 val inductive_sort_family : one_inductive_body -> Sorts.family
 
@@ -115,8 +115,8 @@ exception SingletonInductiveBecomesProp of Id.t
 
 val max_inductive_sort : Sorts.t array -> Universe.t
 
-val instantiate_universes : env -> Context.Rel.t ->
-  template_arity -> constr Lazy.t array -> Context.Rel.t * Sorts.t
+val instantiate_universes : env -> Constr.rel_context ->
+  template_arity -> constr Lazy.t array -> Constr.rel_context * Sorts.t
 
 (** {6 Debug} *)
 
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 370185a7..a18c5d1e 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -5,32 +5,34 @@ UGraph
 Esubst
 Sorts
 Evar
-Constr
 Context
+Constr
 Vars
 Term
 Mod_subst
+Vmvalues
 Cbytecodes
 Copcodes
 Cemitcodes
 Opaqueproof
 Declarations
 Entries
-Vmvalues
 Nativevalues
 CPrimitives
 Declareops
 Retroknowledge
 Conv_oracle
-Pre_env
+Environ
+CClosure
+Reduction
 Clambda
 Nativelambda
 Cbytegen
 Nativecode
 Nativelib
-Environ
-CClosure
-Reduction
+Csymtable
+Vm
+Vconv
 Nativeconv
 Type_errors
 Modops
@@ -43,6 +45,3 @@ Subtyping
 Mod_typing
 Nativelibrary
 Safe_typing
-Vm
-Csymtable
-Vconv
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index b3d06ce7..b35b9dda 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -24,7 +24,7 @@ open Constr
    is the term into which we should inline. *)
 
 type delta_hint =
-  | Inline of int * constr option
+  | Inline of int * (Univ.AUContext.t * constr) option
   | Equiv of KerName.t
 
 (* NB: earlier constructor Prefix_equiv of ModPath.t
@@ -158,7 +158,7 @@ let find_prefix resolve mp =
 
 (** Applying a resolver to a kernel name *)
 
-exception Change_equiv_to_inline of (int * constr)
+exception Change_equiv_to_inline of (int * (Univ.AUContext.t * constr))
 
 let solve_delta_kn resolve kn =
   try
@@ -300,8 +300,9 @@ let subst_con0 sub (cst,u) =
   let knu = KerName.make mpu dir l in
   let knc = if mpu == mpc then knu else KerName.make mpc dir l in
   match search_delta_inline resolve knu knc with
-    | Some t ->
+    | Some (ctx, t) ->
       (* In case of inlining, discard the canonical part (cf #2608) *)
+      let () = assert (Int.equal (Univ.AUContext.size ctx) (Univ.Instance.length u)) in
       Constant.make1 knu, Vars.subst_instance_constr u t
     | None ->
       let knc' =
@@ -331,6 +332,12 @@ let subst_constant sub con =
   try fst (subst_con0 sub (con,Univ.Instance.empty))
   with No_subst -> con
 
+let subst_proj_repr sub p =
+  Projection.Repr.map (subst_mind sub) p
+
+let subst_proj sub p =
+  Projection.map (subst_mind sub) p
+
 (* Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
    Does the user mean "Unfold X.t" or does she mean "Unfold y"
@@ -345,11 +352,7 @@ let rec map_kn f f' c =
     match kind c with
       | Const kn -> (try snd (f' kn) with No_subst -> c)
       | Proj (p,t) -> 
-          let p' = 
-	    try
-	      Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p
-	    with No_subst -> p
-	  in
+          let p' = Projection.map f p in
 	  let t' = func t in
 	    if p' == p && t' == t then c
 	    else mkProj (p', t')
@@ -367,7 +370,7 @@ let rec map_kn f f' c =
 	  in
 	  let p' = func p in
 	  let ct' = func ct in
-	  let l' = Array.smartmap func l in
+          let l' = Array.Smart.map func l in
 	    if (ci.ci_ind==ci_ind && p'==p
 		&& l'==l && ct'==ct)then c
 	    else
@@ -396,21 +399,21 @@ let rec map_kn f f' c =
 	    else mkLetIn (na, b', t', ct')
       | App (ct,l) ->
 	  let ct' = func ct in
-	  let l' = Array.smartmap func l in
+          let l' = Array.Smart.map func l in
 	    if (ct'== ct && l'==l) then c
 	    else mkApp (ct',l')
       | Evar (e,l) ->
-	  let l' = Array.smartmap func l in
+          let l' = Array.Smart.map func l in
 	    if (l'==l) then c
 	    else mkEvar (e,l')
       | Fix (ln,(lna,tl,bl)) ->
-	  let tl' = Array.smartmap func tl in
-	  let bl' = Array.smartmap func bl in
+          let tl' = Array.Smart.map func tl in
+          let bl' = Array.Smart.map func bl in
 	    if (bl == bl'&& tl == tl') then c
 	    else mkFix (ln,(lna,tl',bl'))
       | CoFix(ln,(lna,tl,bl)) ->
-	  let tl' = Array.smartmap func tl in
-	  let bl' = Array.smartmap func bl in
+          let tl' = Array.Smart.map func tl in
+          let bl' = Array.Smart.map func bl in
 	    if (bl == bl'&& tl == tl') then c
 	    else mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
@@ -482,7 +485,7 @@ let gen_subst_delta_resolver dom subst resolver =
       | Equiv kequ ->
 	  (try Equiv (subst_kn_delta subst kequ)
 	   with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c))
-      | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t))
+      | Inline (lev,Some (ctx, t)) -> Inline (lev,Some (ctx, subst_mps subst t))
       | Inline (_,None) -> hint
     in
     Deltamap.add_kn kkey' hint' rslv
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index b14d3920..2e5211c7 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -28,7 +28,7 @@ val add_kn_delta_resolver :
   KerName.t -> KerName.t -> delta_resolver -> delta_resolver
 
 val add_inline_delta_resolver :
-  KerName.t -> (int * constr option) -> delta_resolver -> delta_resolver
+  KerName.t -> (int * (Univ.AUContext.t * constr) option) -> delta_resolver -> delta_resolver
 
 val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver
 
@@ -147,6 +147,9 @@ val subst_con_kn :
 val subst_constant :
   substitution -> Constant.t -> Constant.t
 
+val subst_proj_repr : substitution -> Projection.Repr.t -> Projection.Repr.t
+val subst_proj : substitution -> Projection.t -> Projection.t
+
 (** Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
    Does the user mean "Unfold X.t" or does she mean "Unfold y"
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 1baab7c9..d63dc057 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -120,7 +120,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv =
 	  const_body = def;
           const_universes = univs ;
 	  const_body_code = Option.map Cemitcodes.from_val
-                              (compile_constant_body env' cb.const_universes def) }
+                              (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) }
       in
       before@(lab,SFBconst(cb'))::after, c', ctx'
     else
diff --git a/kernel/modops.ml b/kernel/modops.ml
index ab187dba..98a99731 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -129,10 +129,10 @@ let destr_nofunctor = function
   |NoFunctor a -> a
   |MoreFunctor _ -> error_is_a_functor ()
 
-let rec functor_smartmap fty f0 funct = match funct with
+let rec functor_smart_map fty f0 funct = match funct with
   |MoreFunctor (mbid,ty,e) ->
     let ty' = fty ty in
-    let e' = functor_smartmap fty f0 e in
+    let e' = functor_smart_map fty f0 e in
     if ty==ty' && e==e' then funct else MoreFunctor (mbid,ty',e')
   |NoFunctor a ->
     let a' = f0 a in if a==a' then funct else NoFunctor a'
@@ -196,7 +196,7 @@ let rec subst_structure sub do_delta sign =
       let mtb' = subst_modtype sub do_delta mtb in
       if mtb==mtb' then orig else (l,SFBmodtype mtb')
   in
-  List.smartmap subst_body sign
+  List.Smart.map subst_body sign
 
 and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body =
   fun is_mod sub subst_impl do_delta mb ->
@@ -209,7 +209,7 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body ->
   in
   let ty' = subst_signature sub do_delta ty in
   let me' = subst_impl sub me in
-  let aty' = Option.smartmap (subst_expression sub id_delta) aty in
+  let aty' = Option.Smart.map (subst_expression sub id_delta) aty in
   let delta' = do_delta mb.mod_delta sub in
   if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta
   then mb
@@ -244,12 +244,12 @@ and subst_expr sub do_delta seb = match seb with
     if meb==meb' && wdb==wdb' then seb else MEwith(meb',wdb')
 
 and subst_expression sub do_delta =
-  functor_smartmap
+  functor_smart_map
     (subst_modtype sub do_delta)
     (subst_expr sub do_delta)
 
 and subst_signature sub do_delta =
-  functor_smartmap
+  functor_smart_map
     (subst_modtype sub do_delta)
     (subst_structure sub do_delta)
 
@@ -265,7 +265,7 @@ let subst_structure subst = subst_structure subst do_delta_codom
 (* spiwack: here comes the function which takes care of importing
    the retroknowledge declared in the library *)
 (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *)
-let add_retroknowledge mp =
+let add_retroknowledge =
   let perform rkaction env = match rkaction with
     | Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) ->
       Environ.register env f e
@@ -309,7 +309,7 @@ and add_module mb linkinfo env =
   let env = Environ.shallow_add_module mb env in
   match mb.mod_type with
   |NoFunctor struc ->
-    add_retroknowledge mp mb.mod_retroknowledge
+    add_retroknowledge mb.mod_retroknowledge
       (add_structure mp struc mb.mod_delta linkinfo env)
   |MoreFunctor _ -> env
 
@@ -402,7 +402,8 @@ let inline_delta_resolver env inl mp mbid mtb delta =
 	    | Undef _ | OpaqueDef _ -> l
 	    | Def body ->
 	      let constr = Mod_subst.force_constr body in
-              add_inline_delta_resolver kn (lev, Some constr) l
+              let ctx = Declareops.constant_polymorphic_context constant in
+              add_inline_delta_resolver kn (lev, Some (ctx, constr)) l
 	with Not_found ->
 	  error_no_such_label_sub (Constant.label con)
 	    (ModPath.to_string (Constant.modpath con))
@@ -594,13 +595,13 @@ and clean_field l field = match field with
     if mb==mb' then field else (lab,SFBmodule mb')
   |_ -> field
 
-and clean_structure l = List.smartmap (clean_field l)
+and clean_structure l = List.Smart.map (clean_field l)
 
 and clean_signature l =
-  functor_smartmap (clean_module_type l) (clean_structure l)
+  functor_smart_map (clean_module_type l) (clean_structure l)
 
 and clean_expression l =
-  functor_smartmap (clean_module_type l) (fun me -> me)
+  functor_smart_map (clean_module_type l) (fun me -> me)
 
 let rec collect_mbid l sign =  match sign with
   |MoreFunctor (mbid,ty,m) ->
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 1db489e6..8e7e618f 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -52,7 +52,7 @@ val add_module : module_body -> env -> env
 
 (** same as add_module, but for a module whose native code has been linked by
 the native compiler. The linking information is updated. *)
-val add_linked_module : module_body -> Pre_env.link_info -> env -> env
+val add_linked_module : module_body -> link_info -> env -> env
 
 (** same, for a module type *)
 val add_module_type : ModPath.t -> module_type_body -> env -> env
diff --git a/kernel/names.ml b/kernel/names.ml
index a3aa71f2..e1d70e81 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -17,7 +17,7 @@
    the module system, Aug 2002 *)
 (* Abstraction over the type of constant for module inlining by Claudio
    Sacerdoti, Nov 2004 *)
-(* Miscellaneous features or improvements by Hugo Herbelin, 
+(* Miscellaneous features or improvements by Hugo Herbelin,
    Élie Soubiran, ... *)
 
 open Pp
@@ -364,7 +364,6 @@ module MPmap = CMap.Make(ModPath)
 module KerName = struct
 
   type t = {
-    canary : Canary.t;
     modpath : ModPath.t;
     dirpath : DirPath.t;
     knlabel : Label.t;
@@ -372,16 +371,14 @@ module KerName = struct
     (** Lazily computed hash. If unset, it is set to negative values. *)
   }
 
-  let canary = Canary.obj
-
   type kernel_name = t
 
   let make modpath dirpath knlabel =
-    { modpath; dirpath; knlabel; refhash = -1; canary; }
+    { modpath; dirpath; knlabel; refhash = -1; }
   let repr kn = (kn.modpath, kn.dirpath, kn.knlabel)
 
   let make2 modpath knlabel =
-    { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; canary; }
+    { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; }
 
   let modpath kn = kn.modpath
   let label kn = kn.knlabel
@@ -437,7 +434,7 @@ module KerName = struct
         * (string -> string)
     let hashcons (hmod,hdir,hstr) kn =
       let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in
-      { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; }
+      { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; }
     let eq kn1 kn2 =
       kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath &&
         kn1.knlabel == kn2.knlabel
@@ -701,22 +698,6 @@ end
 module Constrmap = Map.Make(ConstructorOrdered)
 module Constrmap_env = Map.Make(ConstructorOrdered_env)
 
-type global_reference =
-  | VarRef of variable           (** A reference to the section-context. *)
-  | ConstRef of Constant.t       (** A reference to the environment. *)
-  | IndRef of inductive          (** A reference to an inductive type. *)
-  | ConstructRef of constructor  (** A reference to a constructor of an inductive type. *)
-
-(* Better to have it here that in closure, since used in grammar.cma *)
-type evaluable_global_reference =
-  | EvalVarRef of Id.t
-  | EvalConstRef of Constant.t
-
-let eq_egr e1 e2 = match e1, e2 with
-    EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2
-  | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2
-  | _, _ -> false
-
 (** {6 Hash-consing of name objects } *)
 
 module Hind = Hashcons.Make(
@@ -776,109 +757,155 @@ let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2
 (*******************************************************************)
 (** Compatibility layers *)
 
-(** Backward compatibility for [Id] *)
+type mod_bound_id = MBId.t
+let eq_constant_key = Constant.UserOrd.equal
+
+(** Compatibility layer for [ModPath] *)
+
+type module_path = ModPath.t =
+  | MPfile of DirPath.t
+  | MPbound of MBId.t
+  | MPdot of module_path * Label.t
+
+(** Compatibility layer for [Constant] *)
 
-type identifier = Id.t
+module Projection =
+struct
+  module Repr = struct
+    type t =
+      { proj_ind : inductive;
+        proj_npars : int;
+        proj_arg : int;
+        proj_name : Label.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
+    let make proj_ind ~proj_npars ~proj_arg proj_name =
+      {proj_ind;proj_npars;proj_arg;proj_name}
 
-module Idset = Id.Set
-module Idmap = Id.Map
-module Idpred = Id.Pred
+    let inductive c = c.proj_ind
 
-(** Compatibility layer for [Name] *)
+    let mind c = fst c.proj_ind
 
-let name_eq = Name.equal
+    let constant c = KerPair.change_label (mind c) c.proj_name
 
-(** Compatibility layer for [DirPath] *)
+    let label c = c.proj_name
 
-type dir_path = DirPath.t
-let dir_path_ord = DirPath.compare
-let dir_path_eq = DirPath.equal
-let make_dirpath = DirPath.make
-let repr_dirpath = DirPath.repr
-let empty_dirpath = DirPath.empty
-let is_empty_dirpath = DirPath.is_empty
-let string_of_dirpath = DirPath.to_string
-let initial_dir = DirPath.initial
+    let npars c = c.proj_npars
 
-(** Compatibility layer for [MBId] *)
+    let arg c = c.proj_arg
 
-type mod_bound_id = MBId.t
-let mod_bound_id_ord = MBId.compare
-let mod_bound_id_eq = MBId.equal
-let make_mbid = MBId.make
-let repr_mbid = MBId.repr
-let debug_string_of_mbid = MBId.debug_to_string
-let string_of_mbid = MBId.to_string
-let id_of_mbid = MBId.to_id
-
-(** Compatibility layer for [Label] *)
-
-type label = Id.t
-let mk_label = Label.make
-let string_of_label = Label.to_string
-let pr_label = Label.print
-let id_of_label = Label.to_id
-let label_of_id = Label.of_id
-let eq_label = Label.equal
+    let equal a b =
+      eq_ind a.proj_ind b.proj_ind && Int.equal a.proj_arg b.proj_arg
 
-(** Compatibility layer for [ModPath] *)
+    let hash p =
+      Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind)
 
-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
+    module SyntacticOrd = struct
+      let compare a b =
+        let c = ind_syntactic_ord a.proj_ind b.proj_ind in
+        if c == 0 then Int.compare a.proj_arg b.proj_arg
+        else c
 
-(** Compatibility layer for [Constant] *)
+      let equal a b =
+        a.proj_arg == b.proj_arg && eq_syntactic_ind a.proj_ind b.proj_ind
 
-type constant = Constant.t
+      let hash p =
+        Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind)
+    end
+    module CanOrd = struct
+      let compare a b =
+        let c = ind_ord a.proj_ind b.proj_ind in
+        if c == 0 then Int.compare a.proj_arg b.proj_arg
+        else c
 
+      let equal a b =
+        a.proj_arg == b.proj_arg && eq_ind a.proj_ind b.proj_ind
+
+      let hash p =
+        Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind)
+    end
+    module UserOrd = struct
+      let compare a b =
+        let c = ind_user_ord a.proj_ind b.proj_ind in
+        if c == 0 then Int.compare a.proj_arg b.proj_arg
+        else c
+
+      let equal a b =
+        a.proj_arg == b.proj_arg && eq_user_ind a.proj_ind b.proj_ind
+
+      let hash p =
+        Hashset.Combine.combinesmall p.proj_arg (ind_user_hash p.proj_ind)
+    end
+
+    let compare a b =
+      let c = ind_ord a.proj_ind b.proj_ind in
+      if c == 0 then Int.compare a.proj_arg b.proj_arg
+      else c
+
+    module Self_Hashcons = struct
+      type nonrec t = t
+      type u = (inductive -> inductive) * (Id.t -> Id.t)
+      let hashcons (hind,hid) p =
+        { proj_ind = hind p.proj_ind;
+          proj_npars = p.proj_npars;
+          proj_arg = p.proj_arg;
+          proj_name = hid p.proj_name }
+      let eq p p' =
+        p == p' || (p.proj_ind == p'.proj_ind && p.proj_npars == p'.proj_npars && p.proj_arg == p'.proj_arg && p.proj_name == p'.proj_name)
+      let hash = hash
+    end
+    module HashRepr = Hashcons.Make(Self_Hashcons)
+    let hcons = Hashcons.simple_hcons HashRepr.generate HashRepr.hcons (hcons_ind,Id.hcons)
+
+    let map_npars f p =
+      let ind = fst p.proj_ind in
+      let npars = p.proj_npars in
+      let ind', npars' = f ind npars in
+      if ind == ind' && npars == npars' then p
+      else {p with proj_ind = (ind',snd p.proj_ind); proj_npars = npars'}
+
+    let map f p = map_npars (fun mind n -> f mind, n) p
+
+    let to_string p = Constant.to_string (constant p)
+    let print p = Constant.print (constant p)
+  end
+
+  type t = Repr.t * bool
 
-module Projection = 
-struct 
-  type t = constant * bool
-    
   let make c b = (c, b)
 
-  let constant = fst
+  let mind (c,_) = Repr.mind c
+  let inductive (c,_) = Repr.inductive c
+  let npars (c,_) = Repr.npars c
+  let arg (c,_) = Repr.arg c
+  let constant (c,_) = Repr.constant c
+  let label (c,_) = Repr.label c
+  let repr = fst
   let unfolded = snd
   let unfold (c, b as p) = if b then p else (c, true)
-  let equal (c, b) (c', b') = Constant.equal c c' && b == b'
 
-  let hash (c, b) = (if b then 0 else 1) + Constant.hash c
+  let equal (c, b) (c', b') = Repr.equal c c' && b == b'
+
+  let hash (c, b) = (if b then 0 else 1) + Repr.hash c
 
   module SyntacticOrd = struct
     let compare (c, b) (c', b') =
-      if b = b' then Constant.SyntacticOrd.compare c c' else -1
+      if b = b' then Repr.SyntacticOrd.compare c c' else -1
     let equal (c, b as x) (c', b' as x') =
-      x == x' || b = b' && Constant.SyntacticOrd.equal c c'
-    let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c
+      x == x' || b = b' && Repr.SyntacticOrd.equal c c'
+    let hash (c, b) = (if b then 0 else 1) + Repr.SyntacticOrd.hash c
+  end
+  module CanOrd = struct
+    let compare (c, b) (c', b') =
+      if b = b' then Repr.CanOrd.compare c c' else -1
+    let equal (c, b as x) (c', b' as x') =
+      x == x' || b = b' && Repr.CanOrd.equal c c'
+    let hash (c, b) = (if b then 0 else 1) + Repr.CanOrd.hash c
   end
 
   module Self_Hashcons =
     struct
       type nonrec t = t
-      type u = Constant.t -> Constant.t
+      type u = Repr.t -> Repr.t
       let hashcons hc (c,b) = (hc c,b)
       let eq ((c,b) as x) ((c',b') as y) =
         x == y || (c == c' && b == b')
@@ -887,15 +914,19 @@ struct
 
   module HashProjection = Hashcons.Make(Self_Hashcons)
 
-  let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con
+  let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons Repr.hcons
 
   let compare (c, b) (c', b') =
-    if b == b' then Constant.CanOrd.compare c c'
+    if b == b' then Repr.compare c c'
     else if b then 1 else -1
 
   let map f (c, b as x) =
-    let c' = f c in
-      if c' == c then x else (c', b)
+    let c' = Repr.map f c in
+    if c' == c then x else (c', b)
+
+  let map_npars f (c, b as x) =
+    let c' = Repr.map_npars f c in
+    if c' == c then x else (c', b)
 
   let to_string p = Constant.to_string (constant p)
   let print p = Constant.print (constant p)
@@ -904,39 +935,39 @@ end
 
 type projection = Projection.t
 
-let constant_of_kn = Constant.make1
-let constant_of_kn_equiv = Constant.make
-let make_con = Constant.make3
-let repr_con = Constant.repr3
-let canonical_con = Constant.canonical
-let user_con = Constant.user
-let con_label = Constant.label
-let con_modpath = Constant.modpath
-let eq_constant = Constant.equal
-let eq_constant_key = Constant.UserOrd.equal
-let con_ord = Constant.CanOrd.compare
-let con_user_ord = Constant.UserOrd.compare
-let string_of_con = Constant.to_string
-let pr_con = Constant.print
-let debug_string_of_con = Constant.debug_to_string
-let debug_pr_con = Constant.debug_print
-let con_with_label = Constant.change_label
-
-(** Compatibility layer for [MutInd] *)
-
-type mutual_inductive = MutInd.t
-let mind_of_kn = MutInd.make1
-let mind_of_kn_equiv = MutInd.make
-let make_mind = MutInd.make3
-let canonical_mind = MutInd.canonical
-let user_mind = MutInd.user
-let repr_mind = MutInd.repr3
-let mind_label = MutInd.label
-let mind_modpath = MutInd.modpath
-let eq_mind = MutInd.equal
-let mind_ord = MutInd.CanOrd.compare
-let mind_user_ord = MutInd.UserOrd.compare
-let string_of_mind = MutInd.to_string
-let pr_mind = MutInd.print
-let debug_string_of_mind = MutInd.debug_to_string
-let debug_pr_mind = MutInd.debug_print
+module GlobRef = struct
+
+  type t =
+    | VarRef of variable           (** A reference to the section-context. *)
+    | ConstRef of Constant.t       (** A reference to the environment. *)
+    | IndRef of inductive          (** A reference to an inductive type. *)
+    | ConstructRef of constructor  (** A reference to a constructor of an inductive type. *)
+
+  let equal gr1 gr2 =
+    gr1 == gr2 || match gr1,gr2 with
+    | ConstRef con1, ConstRef con2 -> Constant.equal con1 con2
+    | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2
+    | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2
+    | VarRef v1, VarRef v2 -> Id.equal v1 v2
+    | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false
+
+end
+
+type global_reference = GlobRef.t
+[@@ocaml.deprecated "Alias for [GlobRef.t]"]
+
+type evaluable_global_reference =
+  | EvalVarRef of Id.t
+  | EvalConstRef of Constant.t
+
+(* Better to have it here that in closure, since used in grammar.cma *)
+let eq_egr e1 e2 = match e1, e2 with
+    EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2
+  | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2
+  | _, _ -> false
+
+(** Located identifiers and objects with syntax. *)
+
+type lident = Id.t CAst.t
+type lname = Name.t CAst.t
+type lstring = string CAst.t
diff --git a/kernel/names.mli b/kernel/names.mli
index 96e020ae..1cdf5c24 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -500,21 +500,6 @@ val constructor_user_hash : constructor -> int
 val constructor_syntactic_ord : constructor -> constructor -> int
 val constructor_syntactic_hash : constructor -> int
 
-(** {6 Global reference is a kernel side type for all references together } *)
-type global_reference =
-  | VarRef of variable           (** A reference to the section-context. *)
-  | ConstRef of Constant.t       (** A reference to the environment. *)
-  | IndRef of inductive          (** A reference to an inductive type. *)
-  | ConstructRef of constructor  (** A reference to a constructor of an inductive type. *)
-
-(** Better to have it here that in Closure, since required in grammar.cma *)
-type evaluable_global_reference =
-  | EvalVarRef of Id.t
-  | EvalConstRef of Constant.t
-
-val eq_egr : evaluable_global_reference ->  evaluable_global_reference
-  -> bool
-
 (** {6 Hash-consing } *)
 
 val hcons_con : Constant.t -> Constant.t
@@ -553,116 +538,8 @@ val eq_ind_chk : inductive -> inductive -> bool
 
 (** {6 Deprecated functions. For backward compatibility.} *)
 
-(** {5 Identifiers} *)
-
-type identifier = Id.t
-[@@ocaml.deprecated "Alias for [Id.t]"]
-
-val string_of_id : Id.t -> string
-[@@ocaml.deprecated "Same as [Id.to_string]."]
-
-val id_of_string : string -> Id.t
-[@@ocaml.deprecated "Same as [Id.of_string]."]
-
-val id_ord : Id.t -> Id.t -> int
-[@@ocaml.deprecated "Same as [Id.compare]."]
-
-val id_eq : Id.t -> Id.t -> bool
-[@@ocaml.deprecated "Same as [Id.equal]."]
-
-module Idset  : Set.S with type elt = Id.t and type t = Id.Set.t
-[@@ocaml.deprecated "Same as [Id.Set]."]
-
-module Idpred : Predicate.S with type elt = Id.t and type t = Id.Pred.t
-[@@ocaml.deprecated "Same as [Id.Pred]."]
-
-module Idmap : module type of Id.Map
-[@@ocaml.deprecated "Same as [Id.Map]."]
-
-(** {5 Directory paths} *)
-
-type dir_path = DirPath.t
-[@@ocaml.deprecated "Alias for [DirPath.t]."]
-
-val dir_path_ord : DirPath.t -> DirPath.t -> int
-[@@ocaml.deprecated "Same as [DirPath.compare]."]
-
-val dir_path_eq : DirPath.t -> DirPath.t -> bool
-[@@ocaml.deprecated "Same as [DirPath.equal]."]
-
-val make_dirpath : module_ident list -> DirPath.t
-[@@ocaml.deprecated "Same as [DirPath.make]."]
-
-val repr_dirpath : DirPath.t -> module_ident list
-[@@ocaml.deprecated "Same as [DirPath.repr]."]
-
-val empty_dirpath : DirPath.t
-[@@ocaml.deprecated "Same as [DirPath.empty]."]
-
-val is_empty_dirpath : DirPath.t -> bool
-[@@ocaml.deprecated "Same as [DirPath.is_empty]."]
-
-val string_of_dirpath : DirPath.t -> string
-[@@ocaml.deprecated "Same as [DirPath.to_string]."]
-
-val initial_dir : DirPath.t
-[@@ocaml.deprecated "Same as [DirPath.initial]."]
-
-(** {5 Labels} *)
-
-type label = Label.t
-[@@ocaml.deprecated "Same as [Label.t]."]
-(** Alias type *)
-
-val mk_label : string -> Label.t
-[@@ocaml.deprecated "Same as [Label.make]."]
-
-val string_of_label : Label.t -> string
-[@@ocaml.deprecated "Same as [Label.to_string]."]
-
-val pr_label : Label.t -> Pp.t
-[@@ocaml.deprecated "Same as [Label.print]."]
-
-val label_of_id : Id.t -> Label.t
-[@@ocaml.deprecated "Same as [Label.of_id]."]
-
-val id_of_label : Label.t -> Id.t
-[@@ocaml.deprecated "Same as [Label.to_id]."]
-
-val eq_label : Label.t -> Label.t -> bool
-[@@ocaml.deprecated "Same as [Label.equal]."]
-
-(** {5 Unique bound module names} *)
-
 type mod_bound_id = MBId.t
 [@@ocaml.deprecated "Same as [MBId.t]."]
-
-val mod_bound_id_ord : MBId.t -> MBId.t -> int
-[@@ocaml.deprecated "Same as [MBId.compare]."]
-
-val mod_bound_id_eq : MBId.t -> MBId.t -> bool
-[@@ocaml.deprecated "Same as [MBId.equal]."]
-
-val make_mbid : DirPath.t -> Id.t -> MBId.t
-[@@ocaml.deprecated "Same as [MBId.make]."]
-
-val repr_mbid : MBId.t -> int * Id.t * DirPath.t
-[@@ocaml.deprecated "Same as [MBId.repr]."]
-
-val id_of_mbid : MBId.t -> Id.t
-[@@ocaml.deprecated "Same as [MBId.to_id]."]
-
-val string_of_mbid : MBId.t -> string
-[@@ocaml.deprecated "Same as [MBId.to_string]."]
-
-val debug_string_of_mbid : MBId.t -> string
-[@@ocaml.deprecated "Same as [MBId.debug_to_string]."]
-
-(** {5 Names} *)
-
-val name_eq : Name.t -> Name.t -> bool
-[@@ocaml.deprecated "Same as [Name.equal]."]
-
 (** {5 Module paths} *)
 
 type module_path = ModPath.t =
@@ -671,64 +548,69 @@ type module_path = ModPath.t =
   | MPdot of ModPath.t * Label.t
 [@@ocaml.deprecated "Alias type"]
 
-val mp_ord : ModPath.t -> ModPath.t -> int
-[@@ocaml.deprecated "Same as [ModPath.compare]."]
-
-val mp_eq : ModPath.t -> ModPath.t -> bool
-[@@ocaml.deprecated "Same as [ModPath.equal]."]
-
-val check_bound_mp : ModPath.t -> bool
-[@@ocaml.deprecated "Same as [ModPath.is_bound]."]
-
-val string_of_mp : ModPath.t -> string
-[@@ocaml.deprecated "Same as [ModPath.to_string]."]
-
-val initial_path : ModPath.t
-[@@ocaml.deprecated "Same as [ModPath.initial]."]
-
-(** {5 Kernel names} *)
-
-type kernel_name = KerName.t
-[@@ocaml.deprecated "Alias type"]
-
-val make_kn : ModPath.t -> DirPath.t -> Label.t -> KerName.t
-[@@ocaml.deprecated "Same as [KerName.make]."]
-
-val repr_kn : KerName.t -> ModPath.t * DirPath.t * Label.t
-[@@ocaml.deprecated "Same as [KerName.repr]."]
-
-val modpath : KerName.t -> ModPath.t
-[@@ocaml.deprecated "Same as [KerName.modpath]."]
-
-val label : KerName.t -> Label.t
-[@@ocaml.deprecated "Same as [KerName.label]."]
-
-val string_of_kn : KerName.t -> string
-[@@ocaml.deprecated "Same as [KerName.to_string]."]
-
-val pr_kn : KerName.t -> Pp.t
-[@@ocaml.deprecated "Same as [KerName.print]."]
-
-val kn_ord : KerName.t -> KerName.t -> int
-[@@ocaml.deprecated "Same as [KerName.compare]."]
+module Projection : sig
+  module Repr : sig
+    type t
+
+    val make : inductive -> proj_npars:int -> proj_arg:int -> Label.t -> t
+
+    module SyntacticOrd : sig
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      val hash : t -> int
+    end
+    module CanOrd : sig
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      val hash : t -> int
+    end
+    module UserOrd : sig
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      val hash : t -> int
+    end
+
+    val constant : t -> Constant.t
+    (** Don't use this if you don't have to. *)
+
+    val inductive : t -> inductive
+    val mind : t -> MutInd.t
+    val npars : t -> int
+    val arg : t -> int
+    val label : t -> Label.t
 
-(** {5 Constant names} *)
+    val equal : t -> t -> bool
+    val hash : t -> int
+    val compare : t -> t -> int
 
-type constant = Constant.t
-[@@ocaml.deprecated "Alias type"]
+    val map : (MutInd.t -> MutInd.t) -> t -> t
+    val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t
 
-module Projection : sig
-  type t
+    val print : t -> Pp.t
+    val to_string : t -> string
+  end
+  type t (* = Repr.t * bool *)
 
-  val make : Constant.t -> bool -> t
+  val make : Repr.t -> bool -> t
+  val repr : t -> Repr.t
 
   module SyntacticOrd : sig
     val compare : t -> t -> int
     val equal : t -> t -> bool
     val hash : t -> int
   end
+  module CanOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
 
   val constant : t -> Constant.t
+  val mind : t -> MutInd.t
+  val inductive : t -> inductive
+  val npars : t -> int
+  val arg : t -> int
+  val label : t -> Label.t
   val unfolded : t -> bool
   val unfold : t -> t
 
@@ -739,7 +621,8 @@ module Projection : sig
 
   val compare : t -> t -> int
 
-  val map : (Constant.t -> Constant.t) -> t -> t
+  val map : (MutInd.t -> MutInd.t) -> t -> t
+  val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t
 
   val to_string : t -> string
   val print : t -> Pp.t
@@ -749,100 +632,34 @@ end
 type projection = Projection.t
 [@@ocaml.deprecated "Alias for [Projection.t]"]
 
-val constant_of_kn_equiv : KerName.t -> KerName.t -> Constant.t
-[@@ocaml.deprecated "Same as [Constant.make]"]
-
-val constant_of_kn : KerName.t -> Constant.t
-[@@ocaml.deprecated "Same as [Constant.make1]"]
-
-val make_con : ModPath.t -> DirPath.t -> Label.t -> Constant.t
-[@@ocaml.deprecated "Same as [Constant.make3]"]
-
-val repr_con : Constant.t -> ModPath.t * DirPath.t * Label.t
-[@@ocaml.deprecated "Same as [Constant.repr3]"]
-
-val user_con : Constant.t -> KerName.t
-[@@ocaml.deprecated "Same as [Constant.user]"]
-
-val canonical_con : Constant.t -> KerName.t
-[@@ocaml.deprecated "Same as [Constant.canonical]"]
-
-val con_modpath : Constant.t -> ModPath.t
-[@@ocaml.deprecated "Same as [Constant.modpath]"]
-
-val con_label : Constant.t -> Label.t
-[@@ocaml.deprecated "Same as [Constant.label]"]
-
-val eq_constant : Constant.t -> Constant.t -> bool
-[@@ocaml.deprecated "Same as [Constant.equal]"]
-
-val con_ord : Constant.t -> Constant.t -> int
-[@@ocaml.deprecated "Same as [Constant.CanOrd.compare]"]
-
-val con_user_ord : Constant.t -> Constant.t -> int
-[@@ocaml.deprecated "Same as [Constant.UserOrd.compare]"]
-
-val con_with_label : Constant.t -> Label.t -> Constant.t
-[@@ocaml.deprecated "Same as [Constant.change_label]"]
-
-val string_of_con : Constant.t -> string
-[@@ocaml.deprecated "Same as [Constant.to_string]"]
-
-val pr_con : Constant.t -> Pp.t
-[@@ocaml.deprecated "Same as [Constant.print]"]
-
-val debug_pr_con : Constant.t -> Pp.t
-[@@ocaml.deprecated "Same as [Constant.debug_print]"]
-
-val debug_string_of_con : Constant.t -> string
-[@@ocaml.deprecated "Same as [Constant.debug_to_string]"]
-
-(** {5 Mutual Inductive names} *)
-
-type mutual_inductive = MutInd.t
-[@@ocaml.deprecated "Alias type"]
-
-val mind_of_kn : KerName.t -> MutInd.t
-[@@ocaml.deprecated "Same as [MutInd.make1]"]
-
-val mind_of_kn_equiv : KerName.t -> KerName.t -> MutInd.t
-[@@ocaml.deprecated "Same as [MutInd.make]"]
-
-val make_mind : ModPath.t -> DirPath.t -> Label.t -> MutInd.t
-[@@ocaml.deprecated "Same as [MutInd.make3]"]
-
-val user_mind : MutInd.t -> KerName.t
-[@@ocaml.deprecated "Same as [MutInd.user]"]
-
-val canonical_mind : MutInd.t -> KerName.t
-[@@ocaml.deprecated "Same as [MutInd.canonical]"]
-
-val repr_mind : MutInd.t -> ModPath.t * DirPath.t * Label.t
-[@@ocaml.deprecated "Same as [MutInd.repr3]"]
+(** {6 Global reference is a kernel side type for all references together } *)
 
-val eq_mind : MutInd.t -> MutInd.t -> bool
-[@@ocaml.deprecated "Same as [MutInd.equal]"]
+(* XXX: Should we define GlobRefCan GlobRefUser? *)
+module GlobRef : sig
 
-val mind_ord : MutInd.t -> MutInd.t -> int
-[@@ocaml.deprecated "Same as [MutInd.CanOrd.compare]"]
+  type t =
+    | VarRef of variable           (** A reference to the section-context. *)
+    | ConstRef of Constant.t       (** A reference to the environment. *)
+    | IndRef of inductive          (** A reference to an inductive type. *)
+    | ConstructRef of constructor  (** A reference to a constructor of an inductive type. *)
 
-val mind_user_ord : MutInd.t -> MutInd.t -> int
-[@@ocaml.deprecated "Same as [MutInd.UserOrd.compare]"]
+  val equal : t -> t -> bool
 
-val mind_label : MutInd.t -> Label.t
-[@@ocaml.deprecated "Same as [MutInd.label]"]
+end
 
-val mind_modpath : MutInd.t -> ModPath.t
-[@@ocaml.deprecated "Same as [MutInd.modpath]"]
+type global_reference = GlobRef.t
+[@@ocaml.deprecated "Alias for [GlobRef.t]"]
 
-val string_of_mind : MutInd.t -> string
-[@@ocaml.deprecated "Same as [MutInd.to_string]"]
+(** Better to have it here that in Closure, since required in grammar.cma *)
+(* XXX: Move to a module *)
+type evaluable_global_reference =
+  | EvalVarRef of Id.t
+  | EvalConstRef of Constant.t
 
-val pr_mind : MutInd.t -> Pp.t
-[@@ocaml.deprecated "Same as [MutInd.print]"]
+val eq_egr : evaluable_global_reference ->  evaluable_global_reference -> bool
 
-val debug_pr_mind : MutInd.t -> Pp.t
-[@@ocaml.deprecated "Same as [MutInd.debug_print]"]
+(** Located identifiers and objects with syntax. *)
 
-val debug_string_of_mind : MutInd.t -> string
-[@@ocaml.deprecated "Same as [MutInd.debug_to_string]"]
+type lident = Id.t CAst.t
+type lname = Name.t CAst.t
+type lstring = string CAst.t
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index 123e7a6d..eed25a4c 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -16,7 +16,7 @@ open Util
 open Nativevalues
 open Nativeinstr
 open Nativelambda
-open Pre_env
+open Environ
 
 [@@@ocaml.warning "-32-37"]
 
@@ -53,7 +53,7 @@ type gname =
   | Gind of string * inductive (* prefix, inductive name *)
   | Gconstruct of string * constructor (* prefix, constructor name *)
   | Gconstant of string * Constant.t (* prefix, constant name *)
-  | Gproj of string * Constant.t (* prefix, constant name *)
+  | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *)
   | Gcase of Label.t option * int
   | Gpred of Label.t option * int
   | Gfixtype of Label.t option * int
@@ -71,8 +71,8 @@ let eq_gname gn1 gn2 =
       String.equal s1 s2 && eq_constructor c1 c2
   | Gconstant (s1, c1), Gconstant (s2, c2) ->
       String.equal s1 s2 && Constant.equal c1 c2
-  | Gproj (s1, c1), Gproj (s2, c2) ->
-    String.equal s1 s2 && Constant.equal c1 c2
+  | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) ->
+    String.equal s1 s2 && eq_ind ind1 ind2 && Int.equal i1 i2
   | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2
   | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
   | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2
@@ -112,7 +112,7 @@ let gname_hash gn = match gn with
 | Ginternal s -> combinesmall 9 (String.hash s)
 | Grel i -> combinesmall 10 (Int.hash i)
 | Gnamed id -> combinesmall 11 (Id.hash id)
-| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p))
+| Gproj (s, p, i) -> combinesmall 12 (combine (String.hash s) (combine (ind_hash p) i))
 
 let case_ctr = ref (-1)
 
@@ -156,6 +156,7 @@ type symbol =
   | SymbMeta of metavariable
   | SymbEvar of Evar.t
   | SymbLevel of Univ.Level.t
+  | SymbProj of (inductive * int)
 
 let dummy_symb = SymbValue (dummy_value ())
 
@@ -170,6 +171,7 @@ let eq_symbol sy1 sy2 =
   | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2
   | SymbEvar evk1, SymbEvar evk2 -> Evar.equal evk1 evk2
   | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2
+  | SymbProj (i1, k1), SymbProj (i2, k2) -> eq_ind i1 i2 && Int.equal k1 k2
   | _, _ -> false
 
 let hash_symbol symb =
@@ -183,6 +185,7 @@ let hash_symbol symb =
   | SymbMeta m -> combinesmall 7 m
   | SymbEvar evk -> combinesmall 8 (Evar.hash evk)
   | SymbLevel l -> combinesmall 9 (Univ.Level.hash l)
+  | SymbProj (i, k) -> combinesmall 10 (combine (ind_hash i) k)
 
 module HashedTypeSymbol = struct
   type t = symbol
@@ -245,6 +248,11 @@ let get_level tbl i =
     | SymbLevel u -> u
     | _ -> anomaly (Pp.str "get_level failed.")
 
+let get_proj tbl i =
+  match tbl.(i) with
+    | SymbProj p -> p
+    | _ -> anomaly (Pp.str "get_proj failed.")
+
 let push_symbol x =
   try HashtblSymbol.find symb_tbl x
   with Not_found ->
@@ -270,7 +278,6 @@ type primitive =
   | Mk_rel of int
   | Mk_var of Id.t
   | Mk_proj
-  | Is_accu
   | Is_int
   | Cast_accu
   | Upd_cofix
@@ -311,7 +318,6 @@ let eq_primitive p1 p2 =
   | Mk_cofix i1, Mk_cofix i2 -> Int.equal i1 i2
   | Mk_rel i1, Mk_rel i2 -> Int.equal i1 i2
   | Mk_var id1, Mk_var id2 -> Id.equal id1 id2
-  | Is_accu, Is_accu -> true
   | Cast_accu, Cast_accu -> true
   | Upd_cofix, Upd_cofix -> true
   | Force_cofix, Force_cofix -> true
@@ -337,7 +343,6 @@ let primitive_hash = function
      combinesmall 8 (Int.hash i)
   | Mk_var id ->
      combinesmall 9 (Id.hash id)
-  | Is_accu -> 10
   | Is_int -> 11
   | Cast_accu -> 12
   | Upd_cofix -> 13
@@ -388,6 +393,7 @@ type mllambda =
   | MLsetref       of string * mllambda
   | MLsequence     of mllambda * mllambda
   | MLarray        of mllambda array
+  | MLisaccu       of string * inductive * mllambda
 
 and mllam_branches = ((constructor * lname option array) list * mllambda) array
 
@@ -459,7 +465,12 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 =
   | MLarray arr1, MLarray arr2 ->
       Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2
 
-  | _, _ -> false
+  | MLisaccu (s1, ind1, ml1), MLisaccu (s2, ind2, ml2) ->
+    String.equal s1 s2 && eq_ind ind1 ind2 &&
+    eq_mllambda gn1 gn2 n env1 env2 ml1 ml2
+  | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ |
+    MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ |
+    MLsetref _ | MLsequence _ | MLarray _ | MLisaccu _), _ -> false
 
 and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 =
   let eq_def (_,args1,ml1) (_,args2,ml2) =
@@ -534,6 +545,8 @@ let rec hash_mllambda gn n env t =
       combinesmall 14 (combine hml hml')
   | MLarray arr ->
       combinesmall 15 (hash_mllambda_array gn n env 1 arr)
+  | MLisaccu (s, ind, c) ->
+      combinesmall 16 (combine (String.hash s) (combine (ind_hash ind) (hash_mllambda gn n env c)))
 
 and hash_mllambda_letrec gn n env init defs =
   let hash_def (_,args,ml) =
@@ -600,6 +613,7 @@ let fv_lam l =
     | MLsetref(_,l) -> aux l bind fv
     | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv)
     | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv
+    | MLisaccu (_, _, body) -> aux body bind fv
   in
   aux l LNset.empty LNset.empty
 
@@ -618,6 +632,14 @@ let mkMLapp f args =
     | MLapp(f,args') -> MLapp(f,Array.append args' args)
     | _ -> MLapp(f,args)
 
+let mkForceCofix prefix ind arg =
+  let name = fresh_lname Anonymous in
+  MLlet (name, arg,
+    MLif (
+      MLisaccu (prefix, ind, MLlocal name),
+      MLapp (MLprimitive Force_cofix, [|MLlocal name|]),
+      MLlocal name))
+
 let empty_params = [||]
 
 let decompose_MLlam c =
@@ -889,6 +911,10 @@ let get_level_code i =
   MLapp (MLglobal (Ginternal "get_level"),
     [|MLglobal symbols_tbl_name; MLint i|])
 
+let get_proj_code i =
+  MLapp (MLglobal (Ginternal "get_proj"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
 type rlist =
   | Rnil 
   | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' 
@@ -1049,12 +1075,11 @@ let ml_of_instance instance u =
      let tyn = fresh_lname Anonymous in
      let i = push_symbol (SymbMeta mv) in
      MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|])
-  | Levar(evk,ty,args) ->
-     let tyn = fresh_lname Anonymous in
+  | Levar(evk, args) ->
      let i = push_symbol (SymbEvar evk) in
+     (** Arguments are *not* reversed in evar instances in native compilation *)
      let args = MLarray(Array.map (ml_of_lam env l) args) in
-     MLlet(tyn, ml_of_lam env l ty,
-       MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn; args|]))
+     MLapp(MLprimitive Mk_evar, [|get_evar_code i; args|])
   | Lprod(dom,codom) ->
       let dom = ml_of_lam env l dom in
       let codom = ml_of_lam env l codom in
@@ -1074,7 +1099,7 @@ let ml_of_instance instance u =
   | Lconst (prefix, (c, u)) ->
      let args = ml_of_instance env.env_univ u in
      mkMLapp (MLglobal(Gconstant (prefix, c))) args
-  | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c))
+  | Lproj (prefix, ind, i) -> MLglobal(Gproj (prefix, ind, i))
   | Lprim _ ->
       let decl,cond,paux = extract_prim (ml_of_lam env l) t in
       compile_prim decl cond paux
@@ -1126,11 +1151,11 @@ let ml_of_instance instance u =
       let arg = ml_of_lam env l a in
       let force =
 	if annot.asw_finite then arg
-	else MLapp(MLprimitive Force_cofix, [|arg|]) in
+        else mkForceCofix annot.asw_prefix annot.asw_ind 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)) ->
+  | Lfix ((rec_pos, inds, start), (ids, tt, tb)) ->
       (* let type_f fvt = [| type fix |] 
          let norm_f1 fv f1 .. fn params1 = body1
 	 ..
@@ -1199,8 +1224,9 @@ let ml_of_instance instance u =
 	let paramsi = t_params.(i) in
 	let reci = MLlocal (paramsi.(rec_pos.(i))) in
 	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+        let (prefix, ind) = inds.(i) in
 	let body = 
-	  MLif(MLapp(MLprimitive Is_accu,[|reci|]),
+          MLif(MLisaccu (prefix, ind, reci),
 	       mkMLapp 
 		 (MLapp(MLprimitive (Mk_fix(rec_pos,i)), 
 			[|mk_type; mk_norm|]))
@@ -1362,6 +1388,7 @@ let subst s l =
       | MLsetref(s,l1) -> MLsetref(s,aux l1) 
       | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2)
       | MLarray arr -> MLarray (Array.map aux arr)
+      | MLisaccu (s, ind, l) -> MLisaccu (s, ind, aux l)
     in
     aux l
 
@@ -1459,7 +1486,7 @@ let optimize gdef l =
 	let b1 = optimize s b1 in
 	let b2 = optimize s b2 in
 	begin match t, b2 with
-	| MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs)
+        | MLisaccu (_, _, l1), MLmatch(annot, l2, _, bs)
 	    when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs)
         | _, _ -> MLif(t, b1, b2)
 	end
@@ -1471,6 +1498,7 @@ let optimize gdef l =
     | MLsetref(r,l) -> MLsetref(r, optimize s l) 
     | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2)
     | MLarray arr -> MLarray (Array.map (optimize s) arr)
+    | MLisaccu (pf, ind, l) -> MLisaccu (pf, ind, optimize s l)
   in
   optimize LNmap.empty l
 
@@ -1548,8 +1576,8 @@ let string_of_gname g =
       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)
+  | Gproj (prefix, (mind, n), i) ->
+      Format.sprintf "%sproj_%s_%i_%i" prefix (string_of_mind mind) n i
   | Gcase (l,i) ->
       Format.sprintf "case_%s_%i" (string_of_label_def l) i
   | Gpred (l,i) ->
@@ -1633,19 +1661,23 @@ let pp_mllam fmt l =
          pp_mllam fmt arr.(len-1)
        end;
        Format.fprintf fmt "|]@]"
-
+    | MLisaccu (prefix, (mind, i), c) ->
+        let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in
+        Format.fprintf fmt
+          "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n  true@\n| _ ->@\n  false@\nend@]"
+        pp_mllam c accu
 
   and pp_letrec fmt defs =
     let len = Array.length defs in
-    let pp_one_rec i (fn, argsn, body) =
+    let pp_one_rec (fn, argsn, body) =
       Format.fprintf fmt "%a%a =@\n  %a"
 	pp_lname fn 
 	pp_ldecls argsn pp_mllam body in
     Format.fprintf fmt "@[let rec ";
-    pp_one_rec 0 defs.(0);
+    pp_one_rec defs.(0);
     for i = 1 to len - 1 do
       Format.fprintf fmt "@\nand ";
-      pp_one_rec i defs.(i)
+      pp_one_rec defs.(i)
     done;
 
   and pp_blam fmt l =
@@ -1726,7 +1758,6 @@ let pp_mllam fmt l =
     | Mk_var id ->
         Format.fprintf fmt "mk_var_accu (Names.Id.of_string \"%s\")" (string_of_id id)
     | Mk_proj -> Format.fprintf fmt "mk_proj_accu"
-    | Is_accu -> Format.fprintf fmt "is_accu"
     | Is_int -> Format.fprintf fmt "is_int"
     | Cast_accu -> Format.fprintf fmt "cast_accu"
     | Upd_cofix -> Format.fprintf fmt "upd_cofix"
@@ -1833,7 +1864,7 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
   in
   let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in
   let auxdefs = List.fold_right get_named_val fv_named auxdefs in
-  let lvl = Context.Rel.length env.env_rel_context.env_rel_ctx in
+  let lvl = Context.Rel.length (rel_context env) in
   let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in
   let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in
   let aux_name = fresh_lname Anonymous in
@@ -1841,8 +1872,8 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
 
 and compile_rel env sigma univ auxdefs n =
   let open Context.Rel.Declaration in
-  let decl = Pre_env.lookup_rel n env in
-  let n = List.length env.env_rel_context.env_rel_ctx - n in
+  let decl = lookup_rel n env in
+  let n = List.length (rel_context env) - n in
   match decl with
   | LocalDef (_,t,_) ->
       let code = lambda_of_constr env sigma t in
@@ -1862,8 +1893,6 @@ and compile_named env sigma univ auxdefs id =
       Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs
 
 let compile_constant env sigma prefix ~interactive con cb =
-  match cb.const_proj with
-  | None ->
      let no_univs =
        match cb.const_universes with
        | Monomorphic_const _ -> true
@@ -1874,7 +1903,7 @@ let compile_constant env sigma prefix ~interactive con cb =
       let t = Mod_subst.force_constr t in
       let code = lambda_of_constr env sigma t in
       if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code");
-      let is_lazy = is_lazy prefix t in
+      let is_lazy = is_lazy env prefix t in
       let code = if is_lazy then mk_lazy code else code in
       let name =
         if interactive then LinkedInteractive prefix
@@ -1907,38 +1936,6 @@ let compile_constant env sigma prefix ~interactive con cb =
 	  if interactive then LinkedInteractive prefix
 	  else Linked prefix
     end
-  | Some pb ->
-      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 cf_uid = fresh_lname Anonymous in
-      let _, arity = tbl.(0) in
-      let ci_uid = fresh_lname Anonymous in
-      let cargs = Array.init arity
-        (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None)
-      in
-      let i = push_symbol (SymbConst con) in
-      let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in
-      let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in
-      let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in
-      let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in
-      let gn = Gproj ("",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), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal
-          arg|])))::
-            [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix
 
 module StringOrd = struct type t = string let compare = String.compare end
 module StringSet = Set.Make(StringOrd)
@@ -1963,12 +1960,14 @@ let is_code_loaded ~interactive name =
 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 compile_mind mb mind stack =
   let u = Declareops.inductive_polymorphic_context mb in
+  (** Generate data for every block *)
   let f i stack ob =
-    let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in
-    let j = push_symbol (SymbInd (mind,i)) in
-    let name = Gind ("", (mind, i)) in
+    let ind = (mind, i) in
+    let gtype = Gtype(ind, Array.map snd ob.mind_reloc_tbl) in
+    let j = push_symbol (SymbInd ind) in
+    let name = Gind ("", ind) in
     let accu =
       let args =
 	if Int.equal (Univ.AUContext.size u) 0 then
@@ -1982,12 +1981,43 @@ let compile_mind prefix ~interactive mb mind stack =
       Array.init nparams (fun i -> {lname = param_name; luid = i}) in
     let add_construct j acc (_,arity) = 
       let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in 
-      let c = (mind,i), (j+1) in
+      let c = ind, (j+1) in
 	  Glet(Gconstruct ("", c),
 	     mkMLlam (Array.append params args)
 	       (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc
     in
-    Array.fold_left_i add_construct (gtype::accu::stack) ob.mind_reloc_tbl
+    let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in
+    let add_proj proj_arg acc pb =
+      let tbl = ob.mind_reloc_tbl in
+      (* Building info *)
+      let ci = { ci_ind = ind; ci_npar = nparams;
+                 ci_cstr_nargs = [|0|];
+                 ci_cstr_ndecls = [||] (*FIXME*);
+                 ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in
+      let asw = { asw_ind = ind; asw_prefix = ""; asw_ci = ci;
+                  asw_reloc = tbl; asw_finite = true } in
+      let c_uid = fresh_lname Anonymous in
+      let cf_uid = fresh_lname Anonymous in
+      let _, arity = tbl.(0) in
+      let ci_uid = fresh_lname Anonymous in
+      let cargs = Array.init arity
+        (fun i -> if Int.equal i proj_arg then Some ci_uid else None)
+      in
+      let i = push_symbol (SymbProj (ind, j)) in
+      let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in
+      let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in
+      let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in
+      let code = MLlet(cf_uid, mkForceCofix "" ind (MLlocal c_uid), code) in
+      let gn = Gproj ("", ind, proj_arg) in
+      Glet (gn, mkMLlam [|c_uid|] code) :: acc
+    in
+    let projs = match mb.mind_record with
+    | NotRecord | FakeRecord -> []
+    | PrimRecord info ->
+      let _, _, pbs = info.(i) in
+      Array.fold_left_i add_proj [] pbs
+    in
+    projs @ constructors @ gtype :: accu :: stack
   in
   Array.fold_left_i f stack mb.mind_packets
 
@@ -2008,7 +2038,7 @@ let compile_mind_deps env prefix ~interactive
   then init
   else
     let comp_stack =
-      compile_mind prefix ~interactive mib mind comp_stack
+      compile_mind mib mind comp_stack
     in
     let name =
       if interactive then LinkedInteractive prefix
@@ -2033,12 +2063,9 @@ let compile_deps env sigma prefix ~interactive init t =
     then init
     else
       let comp_stack, (mind_updates, const_updates) =
-	match cb.const_proj, cb.const_body with
-        | None, Def t ->
+        match cb.const_body with
+        | Def t ->
            aux env lvl init (Mod_subst.force_constr t)
-	| Some pb, _ ->
-	   let mind = pb.proj_ind in
-	   compile_mind_deps env prefix ~interactive init mind
         | _ -> init
       in
       let code, name =
@@ -2049,8 +2076,8 @@ let compile_deps env sigma prefix ~interactive init t =
       comp_stack, (mind_updates, const_updates)
   | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind
   | Proj (p,c) ->
-    let term = mkApp (mkConst (Projection.constant p), [|c|]) in
-    aux env lvl init term
+    let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in
+    aux env lvl init c
   | Case (ci, p, c, ac) ->
       let mind = fst ci.ci_ind in
       let init = compile_mind_deps env prefix ~interactive init mind in
@@ -2082,9 +2109,9 @@ let compile_constant_field env prefix con acc cb =
     in
     gl@acc
 
-let compile_mind_field prefix mp l acc mb =
+let compile_mind_field mp l acc mb =
   let mind = MutInd.make2 mp l in
-  compile_mind prefix ~interactive:false mb mind acc
+  compile_mind mb mind acc
 
 let mk_open s = Gopen s
 
diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli
index 4b23cc5f..96efa7fa 100644
--- a/kernel/nativecode.mli
+++ b/kernel/nativecode.mli
@@ -10,7 +10,7 @@
 open Names
 open Constr
 open Declarations
-open Pre_env
+open Environ
 open Nativelambda
 
 (** This file defines the mllambda code generation phase of the native
@@ -50,6 +50,8 @@ val get_evar : symbols -> int -> Evar.t
 
 val get_level : symbols -> int -> Univ.Level.t
 
+val get_proj : symbols -> int -> inductive * int
+
 val get_symbols : unit -> symbols
 
 type code_location_update
@@ -65,7 +67,7 @@ val register_native_file : string -> unit
 val compile_constant_field : env -> string -> Constant.t ->
   global list -> constant_body -> global list
 
-val compile_mind_field : string -> ModPath.t -> Label.t ->
+val compile_mind_field : ModPath.t -> Label.t ->
   global list -> mutual_inductive_body -> global list
 
 val mk_conv_code : env -> evars -> string -> constr -> constr -> linkable_code
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
index 2a7afdca..c75dde84 100644
--- a/kernel/nativeconv.ml
+++ b/kernel/nativeconv.ml
@@ -64,7 +64,7 @@ and conv_atom env pb lvl a1 a2 cu =
     match a1, a2 with
     | Ameta (m1,_), Ameta (m2,_) ->
       if Int.equal m1 m2 then cu else raise NotConvertible
-    | Aevar (ev1,_,args1), Aevar (ev2,_,args2) ->
+    | Aevar (ev1, args1), Aevar (ev2, args2) ->
       if Evar.equal ev1 ev2 then
         Array.fold_right2 (conv_val env CONV lvl) args1 args2 cu
       else raise NotConvertible
@@ -114,8 +114,8 @@ and conv_atom env pb lvl a1 a2 cu =
        let cu = conv_val env CONV lvl d1 d2 cu in
        let v = mk_rel_accu lvl in
        conv_val env pb (lvl + 1) (d1 v) (d2 v) cu
-    | Aproj(p1,ac1), Aproj(p2,ac2) ->
-       if not (Constant.equal p1 p2) then raise NotConvertible
+    | Aproj((ind1, i1), ac1), Aproj((ind2, i2), ac2) ->
+       if not (eq_ind ind1 ind2 && Int.equal i1 i2) then raise NotConvertible
        else conv_accu env CONV lvl ac1 ac2 cu
     | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _
     | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _
@@ -141,23 +141,14 @@ let warn_no_native_compiler =
          (fun () -> strbrk "Native compiler is disabled," ++
                       strbrk " falling back to VM conversion test.")
 
-type vm_conv_gen = { vm_conv_gen : 'a. conv_pb -> (Constr.types, 'a) generic_conversion_function }
-
-let vm_conv_gen =
-  ref { vm_conv_gen = fun cv_pb env univs t1 t2 ->
-    generic_conv cv_pb ~l2r:false (fun _ -> None) full_transparent_state env univs t1 t2 }
-
-let set_vm_conv_gen f = vm_conv_gen := f
-
 let native_conv_gen pb sigma env univs t1 t2 =
   if not Coq_config.native_compiler then begin
     warn_no_native_compiler ();
-    vm_conv_gen.contents.vm_conv_gen pb env univs t1 t2
+    Vconv.vm_conv_gen pb env univs 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
+  let code, upds = mk_conv_code env sigma prefix t1 t2 in
   match compile ml_filename code ~profile:false with
   | (true, fn) ->
       begin
diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli
index b603e3bd..2111739d 100644
--- a/kernel/nativeconv.mli
+++ b/kernel/nativeconv.mli
@@ -18,7 +18,3 @@ val native_conv : conv_pb -> evars -> types kernel_conversion_function
 (** A conversion function parametrized by a universe comparator. Used outside of
     the kernel. *)
 val native_conv_gen : conv_pb -> evars -> (types, 'a) generic_conversion_function
-
-type vm_conv_gen = { vm_conv_gen : 'a. conv_pb -> (Constr.types, 'a) generic_conversion_function }
-
-val set_vm_conv_gen : vm_conv_gen -> unit
diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli
index c319be32..2d8e2ba2 100644
--- a/kernel/nativeinstr.mli
+++ b/kernel/nativeinstr.mli
@@ -25,18 +25,18 @@ and lambda =
   | Lrel          of Name.t * int 
   | Lvar          of Id.t
   | Lmeta         of metavariable * lambda (* type *)
-  | Levar         of Evar.t * lambda (* type *) * lambda array (* arguments *)
+  | Levar         of Evar.t * lambda array (* arguments *)
   | Lprod         of lambda * lambda 
   | Llam          of Name.t array * lambda  
   | Llet          of Name.t * lambda * lambda
   | Lapp          of lambda * lambda array
   | Lconst        of prefix * pconstant
-  | Lproj         of prefix * Constant.t (* prefix, projection name *)
+  | Lproj         of prefix * inductive * int (* prefix, inductive, index starting from 0 *)
   | Lprim         of prefix * Constant.t * CPrimitives.t * lambda array
   | Lcase         of annot_sw * lambda * lambda * lam_branches 
                   (* annotations, term being matched, accu, branches *)
   | Lif           of lambda * lambda * lambda
-  | Lfix          of (int array * int) * fix_decl 
+  | Lfix          of (int array * (string * inductive) array * int) * fix_decl
   | Lcofix        of int * fix_decl (* must be in eta-expanded form *)
   | Lmakeblock    of prefix * pconstructor * int * lambda array
                   (* prefix, constructor name, constructor tag, arguments *)
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
index b34eede6..122fe95d 100644
--- a/kernel/nativelambda.ml
+++ b/kernel/nativelambda.ml
@@ -12,7 +12,7 @@ open Names
 open Esubst
 open Constr
 open Declarations
-open Pre_env
+open Environ
 open Nativevalues
 open Nativeinstr
 
@@ -23,7 +23,6 @@ exception NotClosed
 
 type evars =
     { evars_val : existential -> constr option;
-      evars_typ : existential -> types;
       evars_metas : metavariable -> types }
 
 (*s Constructors *)
@@ -102,10 +101,10 @@ let rec map_lam_with_binders g f n lam =
       if body == body' && def == def' then lam else Llet(id,def',body')
   | Lapp(fct,args) ->
       let fct' = f n fct in
-      let args' = Array.smartmap (f n) args in
+      let args' = Array.Smart.map (f n) args in
       if fct == fct' && args == args' then lam else mkLapp fct' args'
   | Lprim(prefix,kn,op,args) ->
-      let args' = Array.smartmap (f n) args in
+      let args' = Array.Smart.map (f n) args in
       if args == args' then lam else Lprim(prefix,kn,op,args')
   | Lcase(annot,t,a,br) ->
       let t' = f n t in
@@ -116,7 +115,7 @@ let rec map_lam_with_binders g f n lam =
 	  if Array.is_empty ids then f n body 
 	  else f (g (Array.length ids) n) body in
 	if body == body' then b else (cn,ids,body') in
-      let br' = Array.smartmap on_b br in
+      let br' = Array.Smart.map on_b br in
       if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br')
   | Lif(t,bt,bf) ->
       let t' = f n t in
@@ -124,31 +123,30 @@ let rec map_lam_with_binders g f n lam =
       let bf' = f n bf in
       if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf')
   | Lfix(init,(ids,ltypes,lbodies)) ->
-      let ltypes' = Array.smartmap (f n) ltypes in
-      let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+      let ltypes' = Array.Smart.map (f n) ltypes in
+      let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in
       if ltypes == ltypes' && lbodies == lbodies' then lam
       else Lfix(init,(ids,ltypes',lbodies'))
   | Lcofix(init,(ids,ltypes,lbodies)) ->
-      let ltypes' = Array.smartmap (f n) ltypes in
-      let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+      let ltypes' = Array.Smart.map (f n) ltypes in
+      let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in
       if ltypes == ltypes' && lbodies == lbodies' then lam
       else Lcofix(init,(ids,ltypes',lbodies'))
   | Lmakeblock(prefix,cn,tag,args) ->
-      let args' = Array.smartmap (f n) args in
+      let args' = Array.Smart.map (f n) args in
       if args == args' then lam else Lmakeblock(prefix,cn,tag,args')
   | Luint u ->
     let u' = map_uint g f n u in
     if u == u' then lam else Luint u'
-  | Levar (evk, ty, args) ->
-    let ty' = f n ty in
-    let args' = Array.smartmap (f n) args in
-    if ty == ty' && args == args' then lam else Levar (evk, ty', args')
+  | Levar (evk, args) ->
+    let args' = Array.Smart.map (f n) args in
+    if args == args' then lam else Levar (evk, args')
 
 and map_uint g f n u =
   match u with
   | UintVal _ -> u
   | UintDigits(prefix,c,args) ->
-    let args' = Array.smartmap (f n) args in
+    let args' = Array.Smart.map (f n) args in
     if args == args' then u else UintDigits(prefix,c,args')
   | UintDecomp(prefix,c,a) ->
     let a' = f n a in
@@ -181,7 +179,7 @@ let rec lam_exsubst subst lam =
 
 let lam_subst_args subst args =
   if is_subs_id subst then args 
-  else Array.smartmap (lam_exsubst subst) args
+  else Array.Smart.map (lam_exsubst subst) args
   
 (** Simplification of lambda expression *)
       
@@ -276,7 +274,7 @@ and simplify_app substf f substa args =
   (* TODO | Lproj -> simplify if the argument is known or a known global *)
   | _ -> mkLapp (simplify substf f) (simplify_args substa args)
   
-and simplify_args subst args = Array.smartmap (simplify subst) args
+and simplify_args subst args = Array.Smart.map (simplify subst) args
 
 and reduce_lapp substf lids body substa largs =
   match lids, largs with
@@ -337,54 +335,13 @@ let rec get_alias env (kn, u as p) =
 
 (*i Global environment *)
 
-let global_env = ref empty_env 
-
-let set_global_env env = global_env := env
-
 let get_names decl = 
   let decl = Array.of_list decl in
   Array.map fst decl
 
-(* Rel Environment *)
-module Vect = 
-  struct
-    type 'a t = {
-	mutable elems : 'a array;
-	mutable size : int;
-      }
-
-    let make n a = {
-      elems = Array.make n a;
-      size = 0;
-    }
-
-    let extend v =
-      if Int.equal v.size (Array.length v.elems) then 
-	let new_size = min (2*v.size) Sys.max_array_length in
-	if new_size <= v.size then invalid_arg "Vect.extend";
-	let new_elems = Array.make new_size v.elems.(0) in
-	Array.blit v.elems 0 new_elems 0 (v.size);
-	v.elems <- new_elems
-
-    let push v a = 
-      extend v;
-      v.elems.(v.size) <- a;
-      v.size <- v.size + 1
-
-    let popn v n =
-      v.size <- max 0 (v.size - n)
-
-    let pop v = popn v 1
-	
-    let get_last v n =
-      if v.size <= n then invalid_arg "Vect.get:index out of bounds";
-      v.elems.(v.size - n - 1)
-
-  end
-
 let empty_args = [||]
 
-module Renv = 
+module Cache =
   struct
 
     module ConstrHash =
@@ -398,46 +355,20 @@ module Renv =
 
     type constructor_info = tag * int * int (* nparam nrealargs *)
 
-    type t = {
-	name_rel : Name.t Vect.t;
-	construct_tbl : constructor_info ConstrTable.t;
-
-       }
-
-
-    let make () = {
-      name_rel = Vect.make 16 Anonymous;
-      construct_tbl = ConstrTable.create 111
-    }
-
-    let push_rel env id = Vect.push env.name_rel id
-
-    let push_rels env ids = 
-      Array.iter (push_rel env) ids
-
-    let pop env = Vect.pop env.name_rel
-	    
-    let popn env n =
-      for _i = 1 to n do pop env done
-
-    let get env n =
-      Lrel (Vect.get_last env.name_rel (n-1), n)
-
-    let get_construct_info env c =
-      try ConstrTable.find env.construct_tbl c
+    let get_construct_info cache env c : constructor_info =
+      try ConstrTable.find cache c
       with Not_found -> 
 	let ((mind,j), i) = c in
-	let oib = lookup_mind mind !global_env in
+        let oib = lookup_mind mind env in
 	let oip = oib.mind_packets.(j) in
 	let tag,arity = oip.mind_reloc_tbl.(i-1) in
 	let nparams = oib.mind_nparams in
 	let r = (tag, nparams, arity) in
-	ConstrTable.add env.construct_tbl c r;
+        ConstrTable.add cache c r;
 	r
   end
 
-(* What about pattern matching ?*)
-let is_lazy prefix t =
+let is_lazy env prefix t =
   match kind t with
   | App (f,args) ->
      begin match kind f with
@@ -445,94 +376,103 @@ let is_lazy prefix t =
 	let entry = mkInd (fst c) in
 	(try
 	    let _ =
-	      Retroknowledge.get_native_before_match_info (!global_env).retroknowledge
+              Retroknowledge.get_native_before_match_info env.retroknowledge
 							  entry prefix c Llazy;
 	    in
 	    false
 	  with Not_found -> true)
      | _ -> true
      end
-  | LetIn _ -> true
+  | LetIn _ | Case _ | Proj _ -> true
   | _ -> false
 
 let evar_value sigma ev = sigma.evars_val ev
 
-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 =
+(** Extract the inductive type over which a fixpoint is decreasing *)
+let rec get_fix_struct env i t = match kind (Reduction.whd_all env t) with
+| Prod (na, dom, t) ->
+  if Int.equal i 0 then
+    let dom = Reduction.whd_all env dom in
+    let (dom, _) = decompose_appvect dom in
+    match kind dom with
+    | Ind (ind, _) -> ind
+    | _ -> assert false
+  else
+    let env = Environ.push_rel (RelDecl.LocalAssum (na, dom)) env in
+    get_fix_struct env (i - 1) t
+| _ -> assert false
+
+let rec lambda_of_constr cache env sigma c =
   match kind c with
   | Meta mv ->
      let ty = meta_type sigma mv in
-     Lmeta (mv, lambda_of_constr env sigma ty)
+     Lmeta (mv, lambda_of_constr cache env sigma ty)
 
   | Evar (evk,args as ev) ->
      (match evar_value sigma ev with
      | None ->
-        let ty = evar_type sigma ev in
-        let args = Array.map (lambda_of_constr env sigma) args in
-        Levar(evk, lambda_of_constr env sigma ty, args)
-     | Some t -> lambda_of_constr env sigma t)
+        let args = Array.map (lambda_of_constr cache env sigma) args in
+        Levar(evk, args)
+     | Some t -> lambda_of_constr cache env sigma t)
 
-  | Cast (c, _, _) -> lambda_of_constr env sigma c
+  | Cast (c, _, _) -> lambda_of_constr cache env sigma c
 
-  | Rel i -> Renv.get env i
+  | Rel i -> Lrel (RelDecl.get_name (Environ.lookup_rel i env), i)
 
   | Var id -> Lvar id
 
   | Sort s -> Lsort s
 
   | Ind (ind,u as pind) ->
-      let prefix = get_mind_prefix !global_env (fst ind) in
+      let prefix = get_mind_prefix env (fst ind) in
       Lind (prefix, pind)
 
   | Prod(id, dom, codom) ->
-      let ld = lambda_of_constr env sigma dom in
-      Renv.push_rel env id;
-      let lc = lambda_of_constr env sigma codom in
-      Renv.pop env;
+      let ld = lambda_of_constr cache env sigma dom in
+      let env = Environ.push_rel (RelDecl.LocalAssum (id, dom)) env in
+      let lc = lambda_of_constr cache env sigma codom in
       Lprod(ld,  Llam([|id|], lc))
 
   | Lambda _ ->
       let params, body = Term.decompose_lam c in
+      let fold (na, t) env = Environ.push_rel (RelDecl.LocalAssum (na, t)) env in
+      let env = List.fold_right fold params env in
+      let lb = lambda_of_constr cache env sigma body in
       let ids = get_names (List.rev params) in
-      Renv.push_rels env ids;
-      let lb = lambda_of_constr env sigma body in
-      Renv.popn env (Array.length ids);
       mkLlam ids lb
 
-  | LetIn(id, def, _, body) ->
-      let ld = lambda_of_constr env sigma def in
-      Renv.push_rel env id;
-      let lb = lambda_of_constr env sigma body in
-      Renv.pop env;
+  | LetIn(id, def, t, body) ->
+      let ld = lambda_of_constr cache env sigma def in
+      let env = Environ.push_rel (RelDecl.LocalDef (id, def, t)) env in
+      let lb = lambda_of_constr cache env sigma body in
       Llet(id, ld, lb)
 
-  | App(f, args) -> lambda_of_app env sigma f args
+  | App(f, args) -> lambda_of_app cache env sigma f args
 
-  | Const _ -> lambda_of_app env sigma c empty_args
+  | Const _ -> lambda_of_app cache env sigma c empty_args
 
-  | Construct _ ->  lambda_of_app env sigma c empty_args
+  | Construct _ ->  lambda_of_app cache env sigma c empty_args
 
   | Proj (p, c) ->
-    let kn = Projection.constant p in
-      mkLapp (Lproj (get_const_prefix !global_env kn, kn)) [|lambda_of_constr env sigma c|]
+    let ind = Projection.inductive p in
+    let prefix = get_mind_prefix env (fst ind) in
+    mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|]
 
   | Case(ci,t,a,branches) ->  
       let (mind,i as ind) = ci.ci_ind in
-      let mib = lookup_mind mind !global_env in
+      let mib = lookup_mind mind env in
       let oib = mib.mind_packets.(i) in
       let tbl = oib.mind_reloc_tbl in 
       (* Building info *)
-      let prefix = get_mind_prefix !global_env mind in
+      let prefix = get_mind_prefix env mind in
       let annot_sw = 
 	    { asw_ind = ind;
           asw_ci = ci;
@@ -541,21 +481,21 @@ let rec lambda_of_constr env sigma c =
           asw_prefix = prefix}
       in
       (* translation of the argument *)
-      let la = lambda_of_constr env sigma a in
+      let la = lambda_of_constr cache env sigma a in
       let entry = mkInd ind in
       let la =
 	try
-	  Retroknowledge.get_native_before_match_info (!global_env).retroknowledge
+          Retroknowledge.get_native_before_match_info (env).retroknowledge
 						      entry prefix (ind,1) la
 	with Not_found -> la
       in
       (* translation of the type *)
-      let lt = lambda_of_constr env sigma t in
+      let lt = lambda_of_constr cache env sigma t in
       (* translation of branches *)
       let mk_branch i b =
 	let cn = (ind,i+1) in
 	let _, arity = tbl.(i) in
-	let b = lambda_of_constr env sigma b in
+        let b = lambda_of_constr cache env sigma b in
 	if Int.equal arity 0 then (cn, empty_ids, b)
 	else 
 	  match b with
@@ -568,86 +508,90 @@ let rec lambda_of_constr env sigma c =
       let bs = Array.mapi mk_branch branches in
       Lcase(annot_sw, lt, la, bs)
 	
-  | Fix(rec_init,(names,type_bodies,rec_bodies)) ->
-      let ltypes = lambda_of_args env sigma 0 type_bodies in
-      Renv.push_rels env names;
-      let lbodies = lambda_of_args env sigma 0 rec_bodies in
-      Renv.popn env (Array.length names);
-      Lfix(rec_init, (names, ltypes, lbodies))
+  | Fix((pos, i), (names,type_bodies,rec_bodies)) ->
+      let ltypes = lambda_of_args cache env sigma 0 type_bodies in
+      let map i t =
+        let ind = get_fix_struct env i t in
+        let prefix = get_mind_prefix env (fst ind) in
+        (prefix, ind)
+      in
+      let inds = Array.map2 map pos type_bodies in
+      let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in
+      let lbodies = lambda_of_args cache env sigma 0 rec_bodies in
+      Lfix((pos, inds, i), (names, ltypes, lbodies))
 	
   | CoFix(init,(names,type_bodies,rec_bodies)) ->
-      let rec_bodies = Array.map2 (Hook.get Clambda.eta_expand !global_env) rec_bodies type_bodies in
-      let ltypes = lambda_of_args env sigma 0 type_bodies in 
-      Renv.push_rels env names;
-      let lbodies = lambda_of_args env sigma 0 rec_bodies in
-      Renv.popn env (Array.length names);
+      let rec_bodies = Array.map2 (Reduction.eta_expand env) rec_bodies type_bodies in
+      let ltypes = lambda_of_args cache env sigma 0 type_bodies in
+      let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in
+      let lbodies = lambda_of_args cache env sigma 0 rec_bodies in
       Lcofix(init, (names, ltypes, lbodies))
 
-and lambda_of_app env sigma f args =
+and lambda_of_app cache env sigma f args =
   match kind f with
   | Const (kn,u as c) ->
-      let kn,u = get_alias !global_env c in
-      let cb = lookup_constant kn !global_env in
+      let kn,u = get_alias env c in
+      let cb = lookup_constant kn env in
       (try
-          let prefix = get_const_prefix !global_env kn in
+          let prefix = get_const_prefix env kn in
 	  (* We delay the compilation of arguments to avoid an exponential behavior *)
 	  let f = Retroknowledge.get_native_compiling_info
-		    (!global_env).retroknowledge (mkConst kn) prefix in
-	  let args = lambda_of_args env sigma 0 args in
+                    (env).retroknowledge (mkConst kn) prefix in
+          let args = lambda_of_args cache env sigma 0 args in
 	  f args
       with Not_found ->
       begin match cb.const_body with
       | Def csubst -> (* TODO optimize if f is a proj and argument is known *)
           if cb.const_inline_code then
-            lambda_of_app env sigma (Mod_subst.force_constr csubst) args
+            lambda_of_app cache env sigma (Mod_subst.force_constr csubst) args
           else
-          let prefix = get_const_prefix !global_env kn in
+          let prefix = get_const_prefix env kn in
           let t =
-            if is_lazy prefix (Mod_subst.force_constr csubst) then
+            if is_lazy env prefix (Mod_subst.force_constr csubst) then
               mkLapp Lforce [|Lconst (prefix, (kn,u))|]
             else Lconst (prefix, (kn,u))
           in
-        mkLapp t (lambda_of_args env sigma 0 args)
+        mkLapp t (lambda_of_args cache env sigma 0 args)
       | OpaqueDef _ | Undef _ ->
-          let prefix = get_const_prefix !global_env kn in
-          mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args env sigma 0 args)
+          let prefix = get_const_prefix env kn in
+          mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args)
       end)
   | Construct (c,u) ->
-      let tag, nparams, arity = Renv.get_construct_info env c in
+      let tag, nparams, arity = Cache.get_construct_info cache env c in
       let expected = nparams + arity in
       let nargs = Array.length args in
-      let prefix = get_mind_prefix !global_env (fst (fst c)) in
+      let prefix = get_mind_prefix env (fst (fst c)) in
       if Int.equal nargs expected then 
       try
 	try
 	  Retroknowledge.get_native_constant_static_info
-                         (!global_env).retroknowledge
+                         (env).retroknowledge
                          f args
           with NotClosed ->
 	    assert (Int.equal nparams 0); (* should be fine for int31 *)
-	    let args = lambda_of_args env sigma nparams args in
+            let args = lambda_of_args cache env sigma nparams args in
 	    Retroknowledge.get_native_constant_dynamic_info
-                           (!global_env).retroknowledge f prefix c args
+                           (env).retroknowledge f prefix c args
         with Not_found ->
-	  let args = lambda_of_args env sigma nparams args in
-	  makeblock !global_env c u tag args
+          let args = lambda_of_args cache env sigma nparams args in
+          makeblock env c u tag args
       else
-	let args = lambda_of_args env sigma 0 args in
+        let args = lambda_of_args cache env sigma 0 args in
 	(try
 	    Retroknowledge.get_native_constant_dynamic_info
-              (!global_env).retroknowledge f prefix c args
+              (env).retroknowledge f prefix c args
 	  with Not_found ->
             mkLapp (Lconstruct (prefix, (c,u))) args)
   | _ -> 
-      let f = lambda_of_constr env sigma f in
-      let args = lambda_of_args env sigma 0 args in
+      let f = lambda_of_constr cache env sigma f in
+      let args = lambda_of_args cache env sigma 0 args in
       mkLapp f args
 	
-and lambda_of_args env sigma start args =
+and lambda_of_args cache env sigma start args =
   let nargs = Array.length args in
   if start < nargs then
     Array.init (nargs - start) 
-      (fun i -> lambda_of_constr env sigma args.(start + i))
+      (fun i -> lambda_of_constr cache env sigma args.(start + i))
   else empty_args
 
 let optimize lam =
@@ -660,11 +604,8 @@ let optimize lam =
   lam
 
 let lambda_of_constr env sigma c =
-  set_global_env env;
-  let env = Renv.make () in
-  let ids = List.rev_map RelDecl.get_name !global_env.env_rel_context.env_rel_ctx in
-  Renv.push_rels env (Array.of_list ids);
-  let lam = lambda_of_constr env sigma c in
+  let cache = Cache.ConstrTable.create 91 in
+  let lam = lambda_of_constr cache env sigma c in
 (*  if Flags.vm_draw_opt () then begin
     (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); 
     (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); 
diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli
index 9a1e19b3..7b202589 100644
--- a/kernel/nativelambda.mli
+++ b/kernel/nativelambda.mli
@@ -9,13 +9,12 @@
 (************************************************************************)
 open Names
 open Constr
-open Pre_env
+open Environ
 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
@@ -23,7 +22,7 @@ val empty_evars : evars
 val decompose_Llam : lambda -> Name.t array * lambda
 val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda
 
-val is_lazy : prefix -> constr -> bool
+val is_lazy : env -> prefix -> constr -> bool
 val mk_lazy : lambda -> lambda
 
 val get_mind_prefix : env -> MutInd.t -> string
diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml
index c69cf722..8ac3538f 100644
--- a/kernel/nativelibrary.ml
+++ b/kernel/nativelibrary.ml
@@ -10,7 +10,6 @@
 
 open Names
 open Declarations
-open Environ
 open Mod_subst
 open Modops
 open Nativecode
@@ -30,15 +29,15 @@ and translate_field prefix mp env acc (l,x) =
   | SFBconst cb ->
      let con = Constant.make3 mp DirPath.empty l in
      (if !Flags.debug then
-	let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in
+        let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in
 	Feedback.msg_debug (Pp.str msg));
-     compile_constant_field (pre_env env) prefix con acc cb
+     compile_constant_field env prefix con acc cb
   | SFBmind mb ->
      (if !Flags.debug then
 	let id = mb.mind_packets.(0).mind_typename in
 	let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in
 	Feedback.msg_debug (Pp.str msg));
-     compile_mind_field prefix mp l acc mb
+     compile_mind_field mp l acc mb
   | SFBmodule md ->
      let mp = md.mod_mp in
      (if !Flags.debug then
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
index 066dfc39..93e74af8 100644
--- a/kernel/nativevalues.ml
+++ b/kernel/nativevalues.ml
@@ -63,8 +63,8 @@ type atom =
   | Acofixe of t array * t array * int * t
   | Aprod of Name.t * t * (t -> t)
   | Ameta of metavariable * t
-  | Aevar of Evar.t * t * t array
-  | Aproj of Constant.t * accumulator
+  | Aevar of Evar.t * t array
+  | Aproj of (inductive * int) * accumulator
 
 let accumulate_tag = 0
 
@@ -117,7 +117,7 @@ let mk_ind_accu ind u =
 let mk_sort_accu s u =
   let open Sorts in
   match s with
-  | Prop _ -> mk_accu (Asort s)
+  | Prop | Set -> mk_accu (Asort s)
   | Type s ->
      let u = Univ.Instance.of_array u in
      let s = Univ.subst_instance_universe u s in
@@ -135,8 +135,8 @@ let mk_prod_accu s dom codom =
 let mk_meta_accu mv ty =
   mk_accu (Ameta (mv,ty))
 
-let mk_evar_accu ev ty args =
-  mk_accu (Aevar (ev,ty,args))
+let mk_evar_accu ev args =
+  mk_accu (Aevar (ev, args))
 
 let mk_proj_accu kn c = 
   mk_accu (Aproj (kn,c))
@@ -154,10 +154,6 @@ let args_of_accu (k:accumulator) =
   let acc = (get_accu k).acc_arg in
   (Obj.magic (Array.of_list acc) : t array)
 
-let is_accu x =
-  let o = Obj.repr x in
-  Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag
-
 let mk_fix_accu rec_pos pos types bodies =
   mk_accu (Afix(types,bodies,rec_pos, pos))
 
@@ -172,19 +168,17 @@ let upd_cofix (cofix :t) (cofix_fun : t) =
   | _ -> 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 args = args_of_accu accu in
-      let f = Array.fold_right (fun arg f -> f arg) args f in
-      let v = f (Obj.magic ()) in
-      set_atom_of_accu accu (Acofixe(typ,norm,pos,v));
-	v
-    | Acofixe(_,_,_,v) -> v 
-    | _ -> cofix
-  else cofix
+  let accu = (Obj.magic cofix : accumulator) in
+  let atom = atom_of_accu accu in
+  match atom with
+  | Acofix(typ,norm,pos,f) ->
+    let args = args_of_accu accu in
+    let f = Array.fold_right (fun arg f -> f arg) args f in
+    let v = f (Obj.magic ()) in
+    set_atom_of_accu accu (Acofixe(typ,norm,pos,v));
+      v
+  | Acofixe(_,_,_,v) -> v
+  | _ -> cofix
 
 let mk_const tag = Obj.magic tag
 
diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli
index 4a58a3c7..10689941 100644
--- a/kernel/nativevalues.mli
+++ b/kernel/nativevalues.mli
@@ -53,8 +53,8 @@ type atom =
   | Acofixe of t array * t array * int * t
   | Aprod of Name.t * t * (t -> t)
   | Ameta of metavariable * t
-  | Aevar of Evar.t * t (* type *) * t array (* arguments *)
-  | Aproj of Constant.t * accumulator
+  | Aevar of Evar.t * t array (* arguments *)
+  | Aproj of (inductive * int) * accumulator
 
 (* Constructors *)
 
@@ -70,8 +70,8 @@ val mk_prod_accu : Name.t -> t -> t -> t
 val mk_fix_accu : rec_pos  -> int -> t array -> t array -> t
 val mk_cofix_accu : int -> t array -> t array -> t
 val mk_meta_accu : metavariable -> t
-val mk_evar_accu : Evar.t -> t -> t array -> t
-val mk_proj_accu : Constant.t -> accumulator -> t
+val mk_evar_accu : Evar.t -> t array -> t
+val mk_proj_accu : (inductive * int) -> accumulator -> t
 val upd_cofix : t -> t -> unit
 val force_cofix : t -> t 
 val mk_const : tag -> t
@@ -110,9 +110,6 @@ type kind_of_value =
 
 val kind_of_value : t -> kind_of_value
 
-(* *)
-val is_accu : t -> bool
-
 val str_encode : 'a -> string
 val str_decode : string -> 'a
 
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
index a484c08e..f8b71e45 100644
--- a/kernel/opaqueproof.ml
+++ b/kernel/opaqueproof.ml
@@ -18,7 +18,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t *
 
 type cooking_info = { 
   modlist : work_list; 
-  abstract : Context.Named.t * Univ.Instance.t * Univ.AUContext.t }
+  abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t }
 type proofterm = (constr * Univ.ContextSet.t) Future.computation
 type opaque =
   | Indirect of substitution list * DirPath.t * int (* subst, lib, index *)
diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli
index b6ae80b4..5ea6da64 100644
--- a/kernel/opaqueproof.mli
+++ b/kernel/opaqueproof.mli
@@ -51,7 +51,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t *
 
 type cooking_info = { 
   modlist : work_list; 
-  abstract : Context.Named.t * Univ.Instance.t * Univ.AUContext.t }
+  abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t }
 
 (* The type has two caveats:
    1) cook_constr is defined after
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
deleted file mode 100644
index 8ebe48e2..00000000
--- a/kernel/pre_env.ml
+++ /dev/null
@@ -1,213 +0,0 @@
-(************************************************************************)
-(*         *   The Coq Proof Assistant / The Coq Development Team       *)
-(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
-(* <O___,, *       (see CREDITS file for the list of authors)           *)
-(*   \VV/  **************************************************************)
-(*    //   *    This file is distributed under the terms of the         *)
-(*         *     GNU Lesser General Public License Version 2.1          *)
-(*         *     (see LICENSE file for the text of the license)         *)
-(************************************************************************)
-
-(* Created by Benjamin Grégoire out of environ.ml for better
-   modularity in the design of the bytecode virtual evaluation
-   machine, Dec 2005 *)
-(* Bug fix by Jean-Marc Notin *)
-
-(* This file defines the type of kernel environments *)
-
-open Util
-open Names
-open Declarations
-
-module NamedDecl = Context.Named.Declaration
-
-(* The type of environments. *)
-
-(* The key attached to each constant is used by the VM to retrieve previous *)
-(* evaluations of the constant. It is essentially an index in the symbols table *)
-(* used by the VM. *)
-type key = int CEphemeron.key option ref 
-
-(** Linking information for the native compiler. *)
-
-type link_info =
-  | Linked of string
-  | LinkedInteractive of string
-  | NotLinked
-
-type constant_key = constant_body * (link_info ref * key)
-
-type mind_key = mutual_inductive_body * link_info ref
-
-type globals = {
-  env_constants : constant_key Cmap_env.t;
-  env_inductives : mind_key Mindmap_env.t;
-  env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body MPmap.t}
-
-type stratification = {
-  env_universes : UGraph.t;
-  env_engagement : engagement
-}
-
-type val_kind =
-    | VKvalue of (Vmvalues.values * Id.Set.t) CEphemeron.key
-    | VKnone
-
-type lazy_val = val_kind ref
-
-let force_lazy_val vk = match !vk with
-| VKnone -> None
-| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None
-
-let dummy_lazy_val () = ref VKnone
-let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key)
-
-type named_context_val = {
-  env_named_ctx : Context.Named.t;
-  env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
-}
-
-type rel_context_val = {
-  env_rel_ctx : Context.Rel.t;
-  env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t;
-}
-
-type env = {
-  env_globals       : globals;           (* globals = constants + inductive types + modules + module-types *)
-  env_named_context : named_context_val; (* section variables *)
-  env_rel_context   : rel_context_val;
-  env_nb_rel        : int;
-  env_stratification : stratification;
-  env_typing_flags  : typing_flags;
-  retroknowledge : Retroknowledge.retroknowledge;
-  indirect_pterms : Opaqueproof.opaquetab;
-}
-
-let empty_named_context_val = {
-  env_named_ctx = [];
-  env_named_map = Id.Map.empty;
-}
-
-let empty_rel_context_val = {
-  env_rel_ctx = [];
-  env_rel_map = Range.empty;
-}
-
-let empty_env = {
-  env_globals = {
-    env_constants = Cmap_env.empty;
-    env_inductives = Mindmap_env.empty;
-    env_modules = MPmap.empty;
-    env_modtypes = MPmap.empty};
-  env_named_context = empty_named_context_val;
-  env_rel_context = empty_rel_context_val;
-  env_nb_rel = 0;
-  env_stratification = {
-    env_universes = UGraph.initial_universes;
-    env_engagement = PredicativeSet };
-  env_typing_flags = Declareops.safe_flags Conv_oracle.empty;
-  retroknowledge = Retroknowledge.initial_retroknowledge;
-  indirect_pterms = Opaqueproof.empty_opaquetab }
-
-
-(* Rel context *)
-
-let nb_rel env = env.env_nb_rel
-
-let push_rel_context_val d ctx = {
-  env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx;
-  env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map;
-}
-
-let match_rel_context_val ctx = match ctx.env_rel_ctx with
-| [] -> None
-| decl :: rem ->
-  let (_, lval) = Range.hd ctx.env_rel_map in
-  let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in
-  Some (decl, lval, ctx)
-
-let push_rel d env =
-    { env with
-      env_rel_context = push_rel_context_val d env.env_rel_context;
-      env_nb_rel = env.env_nb_rel + 1 }
-
-let lookup_rel n env =
-  try fst (Range.get env.env_rel_context.env_rel_map (n - 1))
-  with Invalid_argument _ -> raise Not_found
-
-let lookup_rel_val n env =
-  try snd (Range.get env.env_rel_context.env_rel_map (n - 1))
-  with Invalid_argument _ -> raise Not_found
-
-let rel_skipn n ctx = {
-  env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx;
-  env_rel_map = Range.skipn n ctx.env_rel_map;
-}
-
-let env_of_rel n env =
-  { env with
-    env_rel_context = rel_skipn n env.env_rel_context;
-    env_nb_rel = env.env_nb_rel - n
-  }
-
-(* Named context *)
-
-let push_named_context_val_val d rval ctxt =
-(*   assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *)
-  {
-    env_named_ctx = Context.Named.add d ctxt.env_named_ctx;
-    env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map;
-  }
-
-let push_named_context_val d ctxt =
-  push_named_context_val_val d (ref VKnone) ctxt
-
-let match_named_context_val c = match c.env_named_ctx with
-| [] -> None
-| decl :: ctx ->
-  let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in
-  let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in
-  let cval = { env_named_ctx = ctx; env_named_map = map } in
-  Some (decl, v, cval)
-
-let map_named_val f ctxt =
-  let open Context.Named.Declaration in
-  let fold accu d =
-    let d' = map_constr f d in
-    let accu =
-      if d == d' then accu
-      else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu
-    in
-    (accu, d')
-  in
-  let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in
-  if map == ctxt.env_named_map then ctxt
-  else { env_named_ctx = ctx; env_named_map = map }
-
-let push_named d env =
-  {env with env_named_context = push_named_context_val d env.env_named_context}
-
-let lookup_named id env =
-  fst (Id.Map.find id env.env_named_context.env_named_map)
-
-let lookup_named_val id env =
-  snd(Id.Map.find id env.env_named_context.env_named_map)
-
-(* Warning all the names should be different *)
-let env_of_named id env = env
-
-(* Global constants *)
-
-let lookup_constant_key kn env =
-  Cmap_env.find kn env.env_globals.env_constants
-
-let lookup_constant kn env =
-  fst (Cmap_env.find kn env.env_globals.env_constants)
-
-(* Mutual Inductives *)
-let lookup_mind kn env =
-  fst (Mindmap_env.find kn env.env_globals.env_inductives)
-
-let lookup_mind_key kn env =
-  Mindmap_env.find kn env.env_globals.env_inductives
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
deleted file mode 100644
index b0507481..00000000
--- a/kernel/pre_env.mli
+++ /dev/null
@@ -1,108 +0,0 @@
-(************************************************************************)
-(*         *   The Coq Proof Assistant / The Coq Development Team       *)
-(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
-(* <O___,, *       (see CREDITS file for the list of authors)           *)
-(*   \VV/  **************************************************************)
-(*    //   *    This file is distributed under the terms of the         *)
-(*         *     GNU Lesser General Public License Version 2.1          *)
-(*         *     (see LICENSE file for the text of the license)         *)
-(************************************************************************)
-
-open Names
-open Constr
-open Declarations
-
-(** The type of environments. *)
-
-type link_info =
-  | Linked of string
-  | LinkedInteractive of string
-  | NotLinked
-
-type key = int CEphemeron.key option ref 
-
-type constant_key = constant_body * (link_info ref * key)
-
-type mind_key = mutual_inductive_body * link_info ref
-
-type globals = {
-  env_constants : constant_key Cmap_env.t;
-  env_inductives : mind_key Mindmap_env.t;
-  env_modules : module_body MPmap.t;
-  env_modtypes : module_type_body MPmap.t}
-
-type stratification = {
-  env_universes : UGraph.t;
-  env_engagement : engagement
-}
-
-type lazy_val
-
-val force_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) option
-val dummy_lazy_val : unit -> lazy_val
-val build_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) -> unit
-
-type named_context_val = private {
-  env_named_ctx : Context.Named.t;
-  env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t;
-}
-
-type rel_context_val = private {
-  env_rel_ctx : Context.Rel.t;
-  env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t;
-}
-
-type env = {
-    env_globals       : globals;
-    env_named_context : named_context_val;
-    env_rel_context   : rel_context_val;
-    env_nb_rel        : int;
-    env_stratification : stratification;
-    env_typing_flags  : typing_flags;
-    retroknowledge : Retroknowledge.retroknowledge;
-    indirect_pterms : Opaqueproof.opaquetab;
-}
-
-val empty_named_context_val : named_context_val
-
-val empty_env : env
-
-(** Rel context *)
-
-val empty_rel_context_val : rel_context_val
-val push_rel_context_val :
-  Context.Rel.Declaration.t -> rel_context_val -> rel_context_val
-val match_rel_context_val  :
-  rel_context_val -> (Context.Rel.Declaration.t * lazy_val * rel_context_val) option
-
-val nb_rel         : env -> int
-val push_rel       : Context.Rel.Declaration.t -> env -> env
-val lookup_rel     : int -> env -> Context.Rel.Declaration.t
-val lookup_rel_val : int -> env -> lazy_val
-val env_of_rel     : int -> env -> env
-
-(** Named context *)
-
-val push_named_context_val  :
-    Context.Named.Declaration.t -> named_context_val -> named_context_val
-val push_named_context_val_val  :
-    Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val
-val match_named_context_val  :
-  named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option
-val map_named_val :
-   (constr -> constr) -> named_context_val -> named_context_val
-
-val push_named       : Context.Named.Declaration.t -> env -> env
-val lookup_named     : Id.t -> env -> Context.Named.Declaration.t
-val lookup_named_val : Id.t -> env -> lazy_val
-val env_of_named     : Id.t -> env -> env
-
-(** Global constants *)
-
-
-val lookup_constant_key : Constant.t -> env -> constant_key
-val lookup_constant : Constant.t -> env -> constant_body
-
-(** Mutual Inductives *)
-val lookup_mind_key : MutInd.t -> env -> mind_key
-val lookup_mind : MutInd.t -> env -> mutual_inductive_body
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 2ae676bc..c701b53f 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -53,7 +53,7 @@ let compare_stack_shape stk1 stk2 =
     | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
     | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2
     | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
-    | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) ->
+    | (Zproj p1::s1, Zproj p2::s2) ->
         Int.equal bal 0 && compare_rec 0 s1 s2
     | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) ->
         Int.equal bal 0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
@@ -66,7 +66,7 @@ let compare_stack_shape stk1 stk2 =
 
 type lft_constr_stack_elt =
     Zlapp of (lift * fconstr) array
-  | Zlproj of Constant.t * lift
+  | Zlproj of Projection.Repr.t * lift
   | Zlfix of (lift * fconstr) * lft_constr_stack
   | Zlcase of case_info * lift * fconstr * fconstr array
 and lft_constr_stack = lft_constr_stack_elt list
@@ -84,7 +84,7 @@ let map_lift (l : lift) (v : fconstr array) = match v with
 | [|c0; c1|] -> [|(l, c0); (l, c1)|]
 | [|c0; c1; c2|] -> [|(l, c0); (l, c1); (l, c2)|]
 | [|c0; c1; c2; c3|] -> [|(l, c0); (l, c1); (l, c2); (l, c3)|]
-| v -> CArray.Fun1.map (fun l t -> (l, t)) l v
+| v -> Array.Fun1.map (fun l t -> (l, t)) l v
 
 let pure_stack lfts stk =
   let rec pure_rec lfts stk =
@@ -96,8 +96,8 @@ let pure_stack lfts stk =
             | (Zshift n,(l,pstk)) -> (el_shft n l, pstk)
             | (Zapp a, (l,pstk)) ->
                 (l,zlapp (map_lift l a) pstk)
-	    | (Zproj (n,m,c), (l,pstk)) ->
-		(l, Zlproj (c,l)::pstk)
+            | (Zproj p, (l,pstk)) ->
+                (l, Zlproj (p,l)::pstk)
             | (Zfix(fx,a),(l,pstk)) ->
                 let (lfx,pa) = pure_rec l a in
                 (l, Zlfix((lfx,fx),pa)::pstk)
@@ -297,7 +297,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
             | (Zlapp a1,Zlapp a2) -> 
 	       Array.fold_right2 f a1 a2 cu1
 	    | (Zlproj (c1,l1),Zlproj (c2,l2)) -> 
-	      if not (Constant.equal c1 c2) then 
+              if not (Projection.Repr.equal c1 c2) then
 		raise NotConvertible
 	      else cu1
             | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
@@ -408,7 +408,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
         | Some s2 ->
           eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv
 	| None -> 
-          if Constant.equal (Projection.constant p1) (Projection.constant p2)
+          if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2)
 	     && compare_stack_shape v1 v2 then
             let el1 = el_stack lft1 v1 in
             let el2 = el_stack lft2 v2 in
@@ -649,23 +649,19 @@ let check_leq univs u u' =
 let check_sort_cmp_universes env pb s0 s1 univs =
   let open Sorts in
   if not (type_in_type env) then
+    let check_pb u0 u1 =
+      match pb with
+      | CUMUL -> check_leq univs u0 u1
+      | CONV -> check_eq univs u0 u1
+    in
     match (s0,s1) with
-    | (Prop 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) ->
-      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) ->
-      (match pb with
-       | CUMUL -> check_leq univs u1 u2
-       | CONV -> check_eq univs u1 u2)
+    | Prop, Prop | Set, Set -> ()
+    | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible
+    | Set, Prop -> raise NotConvertible
+    | Set, Type u -> check_pb Univ.type0_univ u
+    | Type u, Prop -> raise NotConvertible
+    | Type u, Set -> check_pb u Univ.type0_univ
+    | Type u0, Type u1 -> check_pb u0 u1
 
 let checked_sort_cmp_universes env pb s0 s1 univs =
   check_sort_cmp_universes env pb s0 s1 univs; univs
@@ -697,26 +693,23 @@ let infer_leq (univs, cstrs as cuniv) u u' =
       univs, Univ.Constraint.union cstrs cstrs'
 
 let infer_cmp_universes env pb s0 s1 univs =
-  let open Sorts in
-  if type_in_type env then univs
+  if type_in_type env
+  then univs
   else
+    let open Sorts in
+    let infer_pb u0 u1 =
+      match pb with
+      | CUMUL -> infer_leq univs u0 u1
+      | CONV -> infer_eq univs u0 u1
+    in
     match (s0,s1) with
-    | (Prop 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) ->
-      (match pb with
-       | CUMUL -> infer_leq univs u1 u2
-       | CONV -> infer_eq univs u1 u2)
+    | Prop, Prop | Set, Set -> univs
+    | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs
+    | Set, Prop -> raise NotConvertible
+    | Set, Type u -> infer_pb Univ.type0_univ u
+    | Type u, Prop -> raise NotConvertible
+    | Type u, Set -> infer_pb u Univ.type0_univ
+    | Type u0, Type u1 -> infer_pb u0 u1
 
 let infer_convert_instances ~flex u u' (univs,cstrs) =
   let cstrs' =
@@ -788,24 +781,6 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta
     env univs t1 t2 = 
   infer_conv_universes CUMUL l2r evars ts env univs t1 t2
 
-(* This reference avoids always having to link C code with the kernel *)
-let vm_conv = ref (fun cv_pb env ->
-		   gen_conv cv_pb env ~evars:((fun _->None), universes env))
-
-let warn_bytecode_compiler_failed =
-  let open Pp in
-  CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler"
-         (fun () -> strbrk "Bytecode compiler failed, " ++
-                      strbrk "falling back to standard conversion")
-
-let set_vm_conv (f:conv_pb -> types kernel_conversion_function) = vm_conv := f
-let vm_conv cv_pb env t1 t2 =
-  try
-    !vm_conv cv_pb env t1 t2
-  with Not_found | Invalid_argument _ ->
-    warn_bytecode_compiler_failed ();
-    gen_conv cv_pb env t1 t2
-
 let default_conv cv_pb ?(l2r=false) env t1 t2 =
     gen_conv cv_pb env t1 t2
 
@@ -937,7 +912,6 @@ let is_arity env c =
   with NotArity -> false
 
 let eta_expand env t ty =
-  let env = env_of_pre_env env in
   let ctxt, codom = dest_prod env ty in
   let ctxt',t = dest_lam env t in
   let d = Context.Rel.nhyps ctxt - Context.Rel.nhyps ctxt' in
@@ -945,5 +919,3 @@ let eta_expand env t ty =
   let t = Term.applistc (Vars.lift d t) eta_args in
   let t = Term.it_mkLambda_or_LetIn t (List.firstn d ctxt) in
   Term.it_mkLambda_or_LetIn t ctxt'
-
-let _ = Hook.set Clambda.eta_expand_hook eta_expand
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 49384340..581e8bd8 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -87,10 +87,6 @@ val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) ->
 val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) ->
   Names.transparent_state -> (constr,'a) generic_conversion_function
 
-(** option for conversion *)
-val set_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit
-val vm_conv : conv_pb -> types kernel_conversion_function
-
 val default_conv     : conv_pb -> ?l2r:bool -> types kernel_conversion_function
 val default_conv_leq : ?l2r:bool -> types kernel_conversion_function
 
@@ -120,14 +116,14 @@ val betazeta_appvect : int -> constr -> constr array -> constr
 (***********************************************************************
   s Recognizing products and arities modulo reduction *)
 
-val dest_prod       : env -> types -> Context.Rel.t * types
-val dest_prod_assum : env -> types -> Context.Rel.t * types
-val dest_lam        : env -> types -> Context.Rel.t * constr
-val dest_lam_assum  : env -> types -> Context.Rel.t * types
+val dest_prod       : env -> types -> Constr.rel_context * types
+val dest_prod_assum : env -> types -> Constr.rel_context * types
+val dest_lam        : env -> constr -> Constr.rel_context * constr
+val dest_lam_assum  : env -> constr -> Constr.rel_context * constr
 
 exception NotArity
 
 val dest_arity : env -> types -> Term.arity (* raises NotArity if not an arity *)
 val is_arity   : env -> types -> bool
 
-val warn_bytecode_compiler_failed : ?loc:Loc.t -> unit -> unit
+val eta_expand : env -> constr -> types -> constr
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index d76b05a8..34f62def 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -25,22 +25,6 @@ open Constr
 (* aliased type for clarity purpose*)
 type entry = Constr.t
 
-(* [field]-s are the roles the kernel can learn of. *)
-type nat_field =
-  | NatType
-  | NatPlus
-  | NatTimes
-
-type n_field =
-  | NPositive
-  | NType
-  | NTwice
-  | NTwicePlusOne
-  | NPhi
-  | NPhiInv
-  | NPlus
-  | NTimes
-
 type int31_field =
   | Int31Bits
   | Int31Type
@@ -69,9 +53,6 @@ type int31_field =
   | Int31Lxor
 
 type field =
-  (* | KEq
-     | KNat of nat_field
-     | KN of n_field *)
   | KInt31 of string*int31_field
 
 
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index 0334e7a9..02d961d8 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -18,21 +18,6 @@ type entry = Constr.t
 
 (** the following types correspond to the different "things"
    the kernel can learn about.*)
-type nat_field =
-  | NatType
-  | NatPlus
-  | NatTimes
-
-type n_field =
-  | NPositive
-  | NType
-  | NTwice
-  | NTwicePlusOne
-  | NPhi
-  | NPhiInv
-  | NPlus
-  | NTimes
-
 type int31_field =
   | Int31Bits
   | Int31Type
@@ -61,13 +46,8 @@ type int31_field =
   | Int31Lxor
 
 type field =
-
-(**  | KEq
-  | KNat of nat_field
-  | KN of n_field *)
   | KInt31 of string*int31_field
 
-
 (** This type represent an atomic action of the retroknowledge. It
    is stored in the compiled libraries 
    As per now, there is only the possibility of registering things
@@ -134,7 +114,7 @@ val get_native_before_match_info : retroknowledge -> entry ->
 				   Nativeinstr.lambda -> Nativeinstr.lambda
 
 
-(** the following functions are solely used in Pre_env and Environ to implement
+(** the following functions are solely used in Environ and Safe_typing to implement
    the functions  register and unregister (and mem) of Environ *)
 val add_field : retroknowledge -> field -> entry -> retroknowledge
 val mem : retroknowledge -> field -> bool
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index de2a890f..6c87ff57 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -59,6 +59,7 @@
    etc.
 *)
 
+open CErrors
 open Util
 open Names
 open Declarations
@@ -209,13 +210,8 @@ let get_opaque_body env cbo =
         (Opaqueproof.force_proof (Environ.opaque_tables env) opaque,
          Opaqueproof.force_constraints (Environ.opaque_tables env) opaque)
 
-type private_constant = Entries.side_effect
 type private_constants = Term_typing.side_effects
 
-type private_constant_role = Term_typing.side_effect_role =
-  | Subproof
-  | Schema of inductive * string
-
 let empty_private_constants = Term_typing.empty_seff
 let add_private = Term_typing.add_seff
 let concat_private = Term_typing.concat_seff
@@ -224,44 +220,38 @@ let inline_private_constants_in_constr = Term_typing.inline_side_effects
 let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects
 let side_effects_of_private_constants = Term_typing.uniq_seff
 
+let make_eff env cst r =
+  let open Entries in
+  let cbo = Environ.lookup_constant cst env.env in
+  {
+    seff_constant = cst;
+    seff_body = cbo;
+    seff_env = get_opaque_body env.env cbo;
+    seff_role = r;
+  }
+
 let private_con_of_con env c =
-  let cbo = Environ.lookup_constant c env.env in
-  { Entries.from_env = CEphemeron.create env.revstruct;
-    Entries.eff      = Entries.SEsubproof (c,cbo,get_opaque_body env.env cbo) }
+  let open Entries in
+  let eff = [make_eff env c Subproof] in
+  add_private env.revstruct eff empty_private_constants
 
 let private_con_of_scheme ~kind env cl =
-  { Entries.from_env = CEphemeron.create env.revstruct;
-    Entries.eff      = Entries.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 open Entries in
+  let eff = List.map (fun (i, c) -> make_eff env c (Schema (i, kind))) cl in
+  add_private env.revstruct eff empty_private_constants
 
 let universes_of_private eff =
-  let open Declarations in
-  List.fold_left
-    (fun acc { Entries.eff } ->
-       match eff with
-       | Entries.SEscheme (l,s) ->
-         List.fold_left
-           (fun acc (_,_,cb,c) ->
-              let acc = match c with
-                | `Nothing -> acc
-                | `Opaque (_, ctx) -> ctx :: acc
-              in
-              match cb.const_universes with
-              | Monomorphic_const ctx ->
-                ctx :: acc
-              | Polymorphic_const _ -> acc
-           )
-           acc l
-       | Entries.SEsubproof (c, cb, e) ->
-         match cb.const_universes with
-              | Monomorphic_const ctx ->
-                ctx :: acc
-              | Polymorphic_const _ -> acc
-    )
-    [] (Term_typing.uniq_seff eff)
+  let open Entries in
+  let fold acc eff =
+    let acc = match eff.seff_env with
+    | `Nothing -> acc
+    | `Opaque (_, ctx) -> ctx :: acc
+    in
+    match eff.seff_body.const_universes with
+    | Monomorphic_const ctx -> ctx :: acc
+    | Polymorphic_const _ -> acc
+  in
+  List.fold_left fold [] (Term_typing.uniq_seff eff)
 
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
@@ -488,7 +478,7 @@ type global_declaration =
   | GlobalRecipe of Cooking.recipe
 
 type exported_private_constant = 
-  Constant.t * private_constant_role
+  Constant.t * Entries.side_effect_role
 
 let add_constant_aux no_section senv (kn, cb) =
   let l = pi3 (Constant.repr3 kn) in
@@ -896,9 +886,11 @@ let typing senv = Typeops.infer (env_of_senv senv)
 
 (** {6 Retroknowledge / native compiler } *)
 
+[@@@ocaml.warning "-3"]
 (** universal lifting, used for the "get" operations mostly *)
 let retroknowledge f senv =
   Environ.retroknowledge f (env_of_senv senv)
+[@@@ocaml.warning "+3"]
 
 let register field value by_clause senv =
   (* todo : value closed, by_clause safe, by_clause of the proper type*)
@@ -914,16 +906,12 @@ let register field value by_clause senv =
 but it is meant to become a replacement for environ.register *)
 let register_inline kn senv =
   let open Environ in
-  let open Pre_env in
   if not (evaluable_constant kn senv.env) then
     CErrors.user_err Pp.(str "Register inline: an evaluable constant is expected");
-  let env = pre_env senv.env in
-  let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in
+  let env = senv.env in
+  let cb = lookup_constant kn env in
   let cb = {cb with const_inline_code = true} in
-  let new_constants = Cmap_env.add kn (cb,r) env.env_globals.env_constants in
-  let new_globals = { env.env_globals with env_constants = new_constants } in
-  let env = { env with env_globals = new_globals } in
-  { senv with env = env_of_pre_env env }
+  let env = add_constant kn cb env in { senv with env}
 
 let add_constraints c =
   add_constraints
@@ -953,3 +941,125 @@ Would this be correct with respect to undo's and stuff ?
 let set_strategy e k l = { e with env =
    (Environ.set_oracle e.env
       (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) }
+
+(** Register retroknowledge hooks *)
+
+open Retroknowledge
+
+(* the Environ.register function synchronizes the proactive and reactive
+   retroknowledge. *)
+let dispatch =
+
+  (* subfunction used for static decompilation of int31 (after a vm_compute,
+     see pretyping/vnorm.ml for more information) *)
+  let constr_of_int31 =
+    let nth_digit_plus_one i n = (* calculates the nth (starting with 0)
+                                    digit of i and adds 1 to it
+                                    (nth_digit_plus_one 1 3 = 2) *)
+      if Int.equal (i land (1 lsl n)) 0 then
+        1
+      else
+        2
+    in
+      fun ind -> fun digit_ind -> fun tag ->
+        let array_of_int i =
+          Array.init 31 (fun n -> Constr.mkConstruct
+                           (digit_ind, nth_digit_plus_one i (30-n)))
+        in
+        (* We check that no bit above 31 is set to one. This assertion used to
+        fail in the VM, and led to conversion tests failing at Qed. *)
+        assert (Int.equal (tag lsr 31) 0);
+        Constr.mkApp(Constr.mkConstruct(ind, 1), array_of_int tag)
+  in
+
+  (* subfunction which dispatches the compiling information of an
+     int31 operation which has a specific vm instruction (associates
+     it to the name of the coq definition in the reactive retroknowledge) *)
+  let int31_op n op prim kn =
+    { empty_reactive_info with
+      vm_compiling = Some (Clambda.compile_prim n op kn);
+      native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn));
+    }
+  in
+
+fun rk value field ->
+  (* subfunction which shortens the (very common) dispatch of operations *)
+  let int31_op_from_const n op prim =
+    match Constr.kind value with
+      | Constr.Const kn ->  int31_op n op prim kn
+      | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.")
+  in
+  let int31_binop_from_const op prim = int31_op_from_const 2 op prim in
+  let int31_unop_from_const op prim = int31_op_from_const 1 op prim in
+  match field with
+    | KInt31 (grp, Int31Type) ->
+        let int31bit =
+          (* invariant : the type of bits is registered, otherwise the function
+             would raise Not_found. The invariant is enforced in safe_typing.ml *)
+          match field with
+          | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits))
+          | _ -> anomaly ~label:"Environ.register"
+              (Pp.str "add_int31_decompilation_from_type called with an abnormal field.")
+        in
+        let i31bit_type =
+          match Constr.kind int31bit with
+          | Constr.Ind (i31bit_type,_) -> i31bit_type
+          |  _ -> anomaly ~label:"Environ.register"
+              (Pp.str "Int31Bits should be an inductive type.")
+        in
+        let int31_decompilation =
+          match Constr.kind value with
+          | Constr.Ind (i31t,_) ->
+              constr_of_int31 i31t i31bit_type
+          | _ -> anomaly ~label:"Environ.register"
+              (Pp.str "should be an inductive type.")
+        in
+        { empty_reactive_info with
+          vm_decompile_const = Some int31_decompilation;
+          vm_before_match = Some Clambda.int31_escape_before_match;
+          native_before_match = Some (Nativelambda.before_match_int31 i31bit_type);
+        }
+    | KInt31 (_, Int31Constructor) ->
+        { empty_reactive_info with
+          vm_constant_static = Some Clambda.compile_structured_int31;
+          vm_constant_dynamic = Some Clambda.dynamic_int31_compilation;
+          native_constant_static = Some Nativelambda.compile_static_int31;
+          native_constant_dynamic = Some Nativelambda.compile_dynamic_int31;
+        }
+    | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31
+                                                          CPrimitives.Int31add
+    | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31
+                                                           CPrimitives.Int31addc
+    | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31
+                                                                CPrimitives.Int31addcarryc
+    | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31
+                                                           CPrimitives.Int31sub
+    | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31
+                                                            CPrimitives.Int31subc
+    | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const
+                                        Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc
+    | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31
+                                                           CPrimitives.Int31mul
+    | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31
+                                                           CPrimitives.Int31mulc
+    | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31
+                                                           CPrimitives.Int31div21
+    | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31
+                                                         CPrimitives.Int31diveucl
+    | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31
+                                                         CPrimitives.Int31addmuldiv
+    | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31
+                                                             CPrimitives.Int31compare
+    | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31
+                                                          CPrimitives.Int31head0
+    | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31
+                                                          CPrimitives.Int31tail0
+    | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31
+                                                         CPrimitives.Int31lor
+    | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31
+                                                          CPrimitives.Int31land
+    | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31
+                                                          CPrimitives.Int31lxor
+    | _ -> empty_reactive_info
+
+let _ = Hook.set Retroknowledge.dispatch_hook dispatch
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 4078a909..502e2970 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -41,29 +41,20 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment
 
 (** {6 Stm machinery } *)
 
-type private_constant
 type private_constants
 
-type private_constant_role =
-  | Subproof
-  | Schema of inductive * string
-
 val side_effects_of_private_constants :
-  private_constants -> Entries.side_effect list
+  private_constants -> Entries.side_eff list
 (** Return the list of individual side-effects in the order of their
     creation. *)
 
 val empty_private_constants : private_constants
-val add_private : private_constant -> private_constants -> private_constants
-(** Add a constant to a list of private constants. The former must be more
-    recent than all constants appearing in the latter, i.e. one should not
-    create a dependency cycle. *)
 val concat_private : private_constants -> private_constants -> private_constants
 (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in
     [e1] must be more recent than those of [e2]. *)
 
-val private_con_of_con : safe_environment -> Constant.t -> private_constant
-val private_con_of_scheme : kind:string -> safe_environment -> (inductive * Constant.t) list -> private_constant
+val private_con_of_con : safe_environment -> Constant.t -> private_constants
+val private_con_of_scheme : kind:string -> safe_environment -> (inductive * Constant.t) list -> private_constants
 
 val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output
 val inline_private_constants_in_constr :
@@ -105,7 +96,7 @@ type global_declaration =
   | GlobalRecipe of Cooking.recipe
 
 type exported_private_constant = 
-  Constant.t * private_constant_role
+  Constant.t * Entries.side_effect_role
 
 val export_private_constants : in_section:bool ->
   private_constants Entries.definition_entry ->
@@ -221,6 +212,7 @@ val delta_of_senv :
 open Retroknowledge
 
 val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a
+[@@ocaml.deprecated "Use the projection of Environ.env"]
 
 val register :
   field -> Retroknowledge.entry -> Constr.constr -> safe_transformer0
diff --git a/kernel/sorts.ml b/kernel/sorts.ml
index daeb90be..a7bb08f5 100644
--- a/kernel/sorts.ml
+++ b/kernel/sorts.ml
@@ -10,22 +10,21 @@
 
 open Univ
 
-type contents = Pos | Null
-
 type family = InProp | InSet | InType
 
 type t =
-  | Prop of contents                      (* proposition types *)
+  | Prop
+  | Set
   | Type of Universe.t
 
-let prop = Prop Null
-let set = Prop Pos
+let prop = Prop
+let set = Set
 let type1 = Type type1_univ
 
 let univ_of_sort = function
   | Type u -> u
-  | Prop Pos -> Universe.type0
-  | Prop Null -> Universe.type0m
+  | Set -> Universe.type0
+  | Prop -> Universe.type0m
 
 let sort_of_univ u =
   if is_type0m_univ u then prop
@@ -34,36 +33,34 @@ let sort_of_univ u =
 
 let compare s1 s2 =
   if s1 == s2 then 0 else
-  match s1, s2 with
-  | Prop c1, Prop c2 ->
-    begin match c1, c2 with
-    | Pos, Pos | Null, Null -> 0
-    | Pos, Null -> -1
-    | Null, Pos -> 1
-    end
-  | Type u1, Type u2 -> Universe.compare u1 u2
-  | Prop _, Type _ -> -1
-  | Type _, Prop _ -> 1
+    match s1, s2 with
+    | Prop, Prop -> 0
+    | Prop, _ -> -1
+    | Set, Prop -> 1
+    | Set, Set -> 0
+    | Set, _ -> -1
+    | Type u1, Type u2 -> Universe.compare u1 u2
+    | Type _, _ -> -1
 
 let equal s1 s2 = Int.equal (compare s1 s2) 0
 
 let is_prop = function
-  | Prop Null -> true
+  | Prop -> true
   | Type u when Universe.equal Universe.type0m u -> true
   | _ -> false
 
 let is_set = function
-  | Prop Pos -> true
+  | Set -> true
   | Type u when Universe.equal Universe.type0 u -> true
   | _ -> false
 
 let is_small = function
-  | Prop _ -> true
+  | Prop | Set -> true
   | Type u -> is_small_univ u
 
 let family = function
-  | Prop Null -> InProp
-  | Prop Pos -> InSet
+  | Prop -> InProp
+  | Set -> InSet
   | Type u when is_type0m_univ u -> InProp
   | Type u when is_type0_univ u -> InSet
   | Type _ -> InType
@@ -73,15 +70,11 @@ let family_equal = (==)
 open Hashset.Combine
 
 let hash = function
-| Prop p ->
-  let h = match p with
-  | Pos -> 0
-  | Null -> 1
-  in
-  combinesmall 1 h
-| Type u ->
- let h = Univ.Universe.hash u in
-  combinesmall 2 h
+  | Prop -> combinesmall 1 0
+  | Set -> combinesmall 1 1
+  | Type u ->
+    let h = Univ.Universe.hash u in
+    combinesmall 2 h
 
 module List = struct
   let mem = List.memq
@@ -101,7 +94,7 @@ module Hsorts =
 	    if u' == u then c else Type u'
         | s -> s
       let eq s1 s2 = match (s1,s2) with
-        | (Prop c1, Prop c2) -> c1 == c2
+        | Prop, Prop | Set, Set -> true
         | (Type u1, Type u2) -> u1 == u2
         |_ -> false
 
diff --git a/kernel/sorts.mli b/kernel/sorts.mli
index 1bbde260..cac6229b 100644
--- a/kernel/sorts.mli
+++ b/kernel/sorts.mli
@@ -10,13 +10,12 @@
 
 (** {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.t  (** Type *)
+  | Prop
+  | Set
+  | Type of Univ.Universe.t
 
 val set  : t
 val prop : t
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 2e9a33a9..74042f9e 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -194,8 +194,9 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
     else error NotEqualInductiveAliases
   end;
   (* we check that records and their field names are preserved. *)
-  check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x);
-  if mib1.mind_record <> None then begin
+  (** FIXME: this check looks nonsense *)
+  check (fun mib -> mib.mind_record <> NotRecord) (==) (fun x -> RecordFieldExpected x);
+  if mib1.mind_record <> NotRecord then begin
     let rec names_prod_letin t = match kind t with
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
@@ -223,7 +224,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
     cst
 
     
-let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = 
+let check_constant cst env l info1 cb2 spec2 subst1 subst2 =
   let error why = error_signature_mismatch l spec2 why in
   let check_conv cst poly f = check_conv_error error cst poly f in
   let check_type poly cst env t1 t2 =
@@ -291,7 +292,7 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
   let check_one_body cst (l,spec2) =
     match spec2 with
 	| SFBconst cb2 ->
-	    check_constant cst env mp1 l (get_obj mp1 map1 l)
+            check_constant cst env l (get_obj mp1 map1 l)
 	      cb2 spec2 subst1 subst2
 	| SFBmind mib2 ->
 	    check_inductive cst env mp1 l (get_obj mp1 map1 l)
diff --git a/kernel/term.ml b/kernel/term.ml
index e1affb1c..4851a9c0 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -15,219 +15,14 @@ open Names
 open Vars
 open Constr
 
-(**********************************************************************)
-(**         Redeclaration of types from module Constr                 *)
-(**********************************************************************)
-
-type contents = Sorts.contents = Pos | Null
+(* Deprecated *)
+type sorts_family = Sorts.family = InProp | InSet | InType
+[@@ocaml.deprecated "Alias for Sorts.family"]
 
 type sorts = Sorts.t =
-  | Prop of contents       (** Prop and Set *)
+  | Prop | Set
   | Type of Univ.Universe.t  (** Type *)
-
-type sorts_family = Sorts.family = InProp | InSet | InType
-
-type constr = Constr.t
-(** Alias types, for compatibility. *)
-
-type types = Constr.t
-(** Same as [constr], for documentation purposes. *)
-
-type existential_key = Evar.t
-type existential = Constr.existential
-
-type metavariable = Constr.metavariable
-
-type case_style = Constr.case_style =
-  LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
-
-type case_printing = Constr.case_printing =
-  { ind_tags : bool list; cstr_tags : bool list array; style : case_style }
-
-type case_info = Constr.case_info =
-  { ci_ind        : inductive;
-    ci_npar       : int;
-    ci_cstr_ndecls : int array;
-    ci_cstr_nargs : int array;
-    ci_pp_info    : case_printing
-  }
-
-type cast_kind = Constr.cast_kind =
-  VMcast | NATIVEcast | DEFAULTcast | REVERTcast
-
-(********************************************************************)
-(*       Constructions as implemented                               *)
-(********************************************************************)
-
-type rec_declaration = Constr.rec_declaration
-type fixpoint = Constr.fixpoint
-type cofixpoint = Constr.cofixpoint
-type 'constr pexistential = 'constr Constr.pexistential
-type ('constr, 'types) prec_declaration =
-  ('constr, 'types) Constr.prec_declaration
-type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint
-type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint
-type 'a puniverses = 'a Univ.puniverses
-
-(** Simply type aliases *)
-type pconstant = Constant.t puniverses
-type pinductive = inductive puniverses
-type pconstructor = constructor puniverses
-
-type ('constr, 'types, 'sort, 'univs) kind_of_term =
-  ('constr, 'types, 'sort, 'univs) Constr.kind_of_term =
-  | Rel       of int
-  | Var       of Id.t
-  | Meta      of metavariable
-  | Evar      of 'constr pexistential
-  | Sort      of 'sort
-  | Cast      of 'constr * cast_kind * 'types
-  | Prod      of Name.t * 'types * 'types
-  | Lambda    of Name.t * 'types * 'constr
-  | LetIn     of Name.t * 'constr * 'types * 'constr
-  | App       of 'constr * 'constr array
-  | Const     of (Constant.t * 'univs)
-  | Ind       of (inductive * 'univs)
-  | Construct of (constructor * 'univs)
-  | Case      of case_info * 'constr * 'constr * 'constr array
-  | Fix       of ('constr, 'types) pfixpoint
-  | CoFix     of ('constr, 'types) pcofixpoint
-  | Proj      of Projection.t * 'constr
-
-type values = Vmvalues.values
-
-(**********************************************************************)
-(**         Redeclaration of functions from module Constr             *)
-(**********************************************************************)
-
-let set_sort  = Sorts.set
-let prop_sort = Sorts.prop
-let type1_sort  = Sorts.type1
-let sorts_ord = Sorts.compare
-let is_prop_sort = Sorts.is_prop
-let family_of_sort = Sorts.family
-let univ_of_sort = Sorts.univ_of_sort
-let sort_of_univ = Sorts.sort_of_univ
-
-(** {6 Term constructors. } *)
-
-let mkRel = Constr.mkRel
-let mkVar = Constr.mkVar
-let mkMeta = Constr.mkMeta
-let mkEvar = Constr.mkEvar
-let mkSort = Constr.mkSort
-let mkProp = Constr.mkProp
-let mkSet  = Constr.mkSet 
-let mkType = Constr.mkType
-let mkCast = Constr.mkCast
-let mkProd = Constr.mkProd
-let mkLambda = Constr.mkLambda
-let mkLetIn = Constr.mkLetIn
-let mkApp = Constr.mkApp
-let mkConst = Constr.mkConst
-let mkProj = Constr.mkProj
-let mkInd = Constr.mkInd
-let mkConstruct = Constr.mkConstruct
-let mkConstU = Constr.mkConstU
-let mkIndU = Constr.mkIndU
-let mkConstructU = Constr.mkConstructU
-let mkConstructUi = Constr.mkConstructUi
-let mkCase = Constr.mkCase
-let mkFix = Constr.mkFix
-let mkCoFix = Constr.mkCoFix
-
-(**********************************************************************)
-(**         Aliases of functions from module Constr                   *)
-(**********************************************************************)
-
-let eq_constr = Constr.equal
-let eq_constr_univs = Constr.eq_constr_univs
-let leq_constr_univs = Constr.leq_constr_univs
-let eq_constr_nounivs = Constr.eq_constr_nounivs
-
-let kind_of_term = Constr.kind
-let compare = Constr.compare
-let constr_ord = compare
-let fold_constr = Constr.fold
-let map_puniverses = Constr.map_puniverses
-let map_constr = Constr.map
-let map_constr_with_binders = Constr.map_with_binders
-let iter_constr = Constr.iter
-let iter_constr_with_binders = Constr.iter_with_binders
-let compare_constr = Constr.compare_head
-let hash_constr = Constr.hash
-let hcons_sorts = Sorts.hcons
-let hcons_constr = Constr.hcons
-let hcons_types = Constr.hcons
-
-(**********************************************************************)
-(**         HERE BEGINS THE INTERESTING STUFF                         *)
-(**********************************************************************)
-
-(**********************************************************************)
-(*          Non primitive term destructors                            *)
-(**********************************************************************)
-
-exception DestKO = DestKO
-(* Destructs a de Bruijn index *)
-let destRel = destRel
-let destMeta = destRel
-let isMeta = isMeta
-let destVar = destVar
-let isSort = isSort
-let destSort = destSort
-let isprop = isprop
-let is_Prop = is_Prop
-let is_Set = is_Set
-let is_Type = is_Type
-let is_small = is_small
-let iskind = iskind
-let isEvar = isEvar
-let isEvar_or_Meta = isEvar_or_Meta
-let destCast = destCast
-let isCast = isCast
-let isRel = isRel
-let isRelN = isRelN
-let isVar = isVar
-let isVarId = isVarId
-let isInd = isInd
-let destProd = destProd
-let isProd = isProd
-let destLambda = destLambda
-let isLambda = isLambda
-let destLetIn = destLetIn
-let isLetIn = isLetIn
-let destApp = destApp
-let destApplication = destApp
-let isApp = isApp
-let destConst = destConst
-let isConst = isConst
-let destEvar = destEvar
-let destInd = destInd
-let destConstruct = destConstruct
-let isConstruct = isConstruct
-let destCase = destCase
-let isCase = isCase
-let isProj = isProj
-let destProj = destProj
-let destFix = destFix
-let isFix = isFix
-let destCoFix = destCoFix
-let isCoFix = isCoFix
-
-(******************************************************************)
-(* Flattening and unflattening of embedded applications and casts *)
-(******************************************************************)
-
-let decompose_app c =
-  match kind_of_term c with
-    | App (f,cl) -> (f, Array.to_list cl)
-    | _ -> (c,[])
-
-let decompose_appvect c =
-  match kind_of_term c with
-    | App (f,cl) -> (f, cl)
-    | _ -> (c,[||])
+[@@ocaml.deprecated "Alias for Sorts.t"]
 
 (****************************************************************************)
 (*              Functions for dealing with constr terms                     *)
@@ -321,7 +116,7 @@ let rec to_lambda n prod =
   if Int.equal n 0 then
     prod
   else
-    match kind_of_term prod with
+    match kind prod with
       | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd)
       | Cast (c,_,_) -> to_lambda n c
       | _   -> user_err ~hdr:"to_lambda" (mt ())
@@ -330,7 +125,7 @@ let rec to_prod n lam =
   if Int.equal n 0 then
     lam
   else
-    match kind_of_term lam with
+    match kind lam with
       | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd)
       | Cast (c,_,_) -> to_prod n c
       | _   -> user_err ~hdr:"to_prod" (mt ())
@@ -342,7 +137,7 @@ let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c)
 
 let lambda_applist c l =
   let rec app subst c l =
-    match kind_of_term c, l with
+    match kind c, l with
     | Lambda(_,_,c), arg::l -> app (arg::subst) c l
     | _, [] -> substl subst c
     | _ -> anomaly (Pp.str "Not enough lambda's.") in
@@ -355,7 +150,7 @@ let lambda_applist_assum n c l =
     if Int.equal n 0 then
       if l == [] then substl subst t
       else anomaly (Pp.str "Too many arguments.")
-    else match kind_of_term t, l with
+    else match kind t, l with
     | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l
     | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
     | _, [] -> anomaly (Pp.str "Not enough arguments.")
@@ -367,7 +162,7 @@ let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v)
 (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *)
 let prod_applist c l =
   let rec app subst c l =
-    match kind_of_term c, l with
+    match kind c, l with
     | Prod(_,_,c), arg::l -> app (arg::subst) c l
     | _, [] -> substl subst c
     | _ -> anomaly (Pp.str "Not enough prod's.") in
@@ -381,7 +176,7 @@ let prod_applist_assum n c l =
     if Int.equal n 0 then
       if l == [] then substl subst t
       else anomaly (Pp.str "Too many arguments.")
-    else match kind_of_term t, l with
+    else match kind t, l with
     | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l
     | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
     | _, [] -> anomaly (Pp.str "Not enough arguments.")
@@ -397,7 +192,7 @@ let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v)
 (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair
    ([(xn,Tn);...;(x1,T1)],T), where T is not a product *)
 let decompose_prod =
-  let rec prodec_rec l c = match kind_of_term c with
+  let rec prodec_rec l c = match kind c with
     | Prod (x,t,c) -> prodec_rec ((x,t)::l) c
     | Cast (c,_,_)   -> prodec_rec l c
     | _              -> l,c
@@ -407,7 +202,7 @@ let decompose_prod =
 (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair
    ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *)
 let decompose_lam =
-  let rec lamdec_rec l c = match kind_of_term c with
+  let rec lamdec_rec l c = match kind c with
     | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c
     | Cast (c,_,_)     -> lamdec_rec l c
     | _                -> l,c
@@ -420,7 +215,7 @@ let decompose_prod_n n =
   if n < 0 then user_err (str "decompose_prod_n: integer parameter must be positive");
   let rec prodec_rec l n c =
     if Int.equal n 0 then l,c
-    else match kind_of_term c with
+    else match kind c with
       | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)   -> prodec_rec l n c
       | _ -> user_err (str "decompose_prod_n: not enough products")
@@ -433,7 +228,7 @@ let decompose_lam_n n =
   if n < 0 then user_err (str "decompose_lam_n: integer parameter must be positive");
   let rec lamdec_rec l n c =
     if Int.equal n 0 then l,c
-    else match kind_of_term c with
+    else match kind c with
       | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)     -> lamdec_rec l n c
       | _ -> user_err (str "decompose_lam_n: not enough abstractions")
@@ -445,7 +240,7 @@ let decompose_lam_n n =
 let decompose_prod_assum =
   let open Context.Rel.Declaration in
   let rec prodec_rec l c =
-    match kind_of_term c with
+    match kind c with
     | Prod (x,t,c)    -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c
     | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c
     | Cast (c,_,_)      -> prodec_rec l c
@@ -458,7 +253,7 @@ let decompose_prod_assum =
 let decompose_lam_assum =
   let rec lamdec_rec l c =
     let open Context.Rel.Declaration in
-    match kind_of_term c with
+    match kind c with
     | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c
     | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c
     | Cast (c,_,_)      -> lamdec_rec l c
@@ -477,7 +272,7 @@ let decompose_prod_n_assum n =
     if Int.equal n 0 then l,c
     else
       let open Context.Rel.Declaration in
-      match kind_of_term c with
+      match kind c with
       | Prod (x,t,c)    -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
       | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
       | Cast (c,_,_)      -> prodec_rec l n c
@@ -498,7 +293,7 @@ let decompose_lam_n_assum n =
     if Int.equal n 0 then l,c
     else
       let open Context.Rel.Declaration in
-      match kind_of_term c with
+      match kind c with
       | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
       | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c
       | Cast (c,_,_)      -> lamdec_rec l n c
@@ -514,7 +309,7 @@ let decompose_lam_n_decls n =
     if Int.equal n 0 then l,c
     else
       let open Context.Rel.Declaration in
-      match kind_of_term c with
+      match kind c with
       | Lambda (x,t,c)  -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
       | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
       | Cast (c,_,_)      -> lamdec_rec l n c
@@ -541,12 +336,12 @@ let strip_lam_n n t = snd (decompose_lam_n n t)
    Such a term can canonically be seen as the pair of a context of types
    and of a sort *)
 
-type arity = Context.Rel.t * sorts
+type arity = Constr.rel_context * Sorts.t
 
 let destArity =
   let open Context.Rel.Declaration in
   let rec prodec_rec l c =
-    match kind_of_term c with
+    match kind c with
     | Prod (x,t,c)    -> prodec_rec (LocalAssum (x,t) :: l) c
     | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c
     | Cast (c,_,_)      -> prodec_rec l c
@@ -558,7 +353,7 @@ let destArity =
 let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign
 
 let rec isArity c =
-  match kind_of_term c with
+  match kind c with
   | Prod (_,_,c)    -> isArity c
   | LetIn (_,b,_,c) -> isArity (subst1 b c)
   | Cast (c,_,_)      -> isArity c
@@ -569,13 +364,13 @@ let rec isArity c =
 
 (* Experimental, used in Presburger contrib *)
 type ('constr, 'types) kind_of_type =
-  | SortType   of sorts
+  | SortType   of Sorts.t
   | CastType   of 'types * 'types
   | ProdType   of Name.t * 'types * 'types
   | LetInType  of Name.t * 'constr * 'types * 'types
   | AtomicType of 'constr * 'constr array
 
-let kind_of_type t = match kind_of_term t with
+let kind_of_type t = match kind t with
   | Sort s -> SortType s
   | Cast (c,_,t) -> CastType (c, t)
   | Prod (na,t,c) -> ProdType (na, t, c)
diff --git a/kernel/term.mli b/kernel/term.mli
index ee84dcb2..181d714e 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -11,166 +11,6 @@
 open Names
 open Constr
 
-(** {5 Redeclaration of types from module Constr and Sorts}
-
-    This reexports constructors of inductive types defined in module [Constr],
-    for compatibility purposes. Refer to this module for further info.
-
-*)
-
-exception DestKO
-[@@ocaml.deprecated "Alias for [Constr.DestKO]"]
-
-(** {5 Simple term case analysis. } *)
-val isRel  : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isRel]"]
-val isRelN : int -> constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isRelN]"]
-val isVar  : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isVar]"]
-val isVarId : Id.t -> constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isVarId]"]
-val isInd  : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isInd]"]
-val isEvar : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isEvar]"]
-val isMeta : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isMeta]"]
-val isEvar_or_Meta : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isEvar_or_Meta]"]
-val isSort : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isSort]"]
-val isCast : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isCast]"]
-val isApp : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isApp]"]
-val isLambda : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isLambda]"]
-val isLetIn : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isletIn]"]
-val isProd : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isProp]"]
-val isConst : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isConst]"]
-val isConstruct : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isConstruct]"]
-val isFix : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isFix]"]
-val isCoFix : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isCoFix]"]
-val isCase : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isCase]"]
-val isProj : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isProj]"]
-
-val is_Prop : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.is_Prop]"]
-val is_Set  : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.is_Set]"]
-val isprop : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.isprop]"]
-val is_Type : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.is_Type]"]
-val iskind : constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.is_kind]"]
-val is_small : Sorts.t -> bool
-[@@ocaml.deprecated "Alias for [Constr.is_small]"]
-
-
-(** {5 Term destructors } *)
-(** Destructor operations are partial functions and
-    @raise DestKO if the term has not the expected form. *)
-
-(** Destructs a de Bruijn index *)
-val destRel : constr -> int
-[@@ocaml.deprecated "Alias for [Constr.destRel]"]
-
-(** Destructs an existential variable *)
-val destMeta : constr -> metavariable
-[@@ocaml.deprecated "Alias for [Constr.destMeta]"]
-
-(** Destructs a variable *)
-val destVar : constr -> Id.t
-[@@ocaml.deprecated "Alias for [Constr.destVar]"]
-
-(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether
-   [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *)
-val destSort : constr -> Sorts.t
-[@@ocaml.deprecated "Alias for [Constr.destSort]"]
-
-(** Destructs a casted term *)
-val destCast : constr -> constr * cast_kind * constr
-[@@ocaml.deprecated "Alias for [Constr.destCast]"]
-
-(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *)
-val destProd : types -> Name.t * types * types
-[@@ocaml.deprecated "Alias for [Constr.destProd]"]
-
-(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *)
-val destLambda : constr -> Name.t * types * constr
-[@@ocaml.deprecated "Alias for [Constr.destLambda]"]
-
-(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *)
-val destLetIn : constr -> Name.t * constr * types * constr
-[@@ocaml.deprecated "Alias for [Constr.destLetIn]"]
-
-(** Destructs an application *)
-val destApp : constr -> constr * constr array
-[@@ocaml.deprecated "Alias for [Constr.destApp]"]
-
-(** Obsolete synonym of destApp *)
-val destApplication : constr -> constr * constr array
-[@@ocaml.deprecated "Alias for [Constr.destApplication]"]
-
-(** Decompose any term as an applicative term; the list of args can be empty *)
-val decompose_app : constr -> constr * constr list
-[@@ocaml.deprecated "Alias for [Constr.decompose_app]"]
-
-(** Same as [decompose_app], but returns an array. *)
-val decompose_appvect : constr -> constr * constr array
-[@@ocaml.deprecated "Alias for [Constr.decompose_appvect]"]
-
-(** Destructs a constant *)
-val destConst : constr -> Constant.t Univ.puniverses
-[@@ocaml.deprecated "Alias for [Constr.destConst]"]
-
-(** Destructs an existential variable *)
-val destEvar : constr -> existential
-[@@ocaml.deprecated "Alias for [Constr.destEvar]"]
-
-(** Destructs a (co)inductive type *)
-val destInd : constr -> inductive Univ.puniverses
-[@@ocaml.deprecated "Alias for [Constr.destInd]"]
-
-(** Destructs a constructor *)
-val destConstruct : constr -> constructor Univ.puniverses
-[@@ocaml.deprecated "Alias for [Constr.destConstruct]"]
-
-(** Destructs a [match c as x in I args return P with ... |
-Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args
-return P in t1], or [if c then t1 else t2])
-@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])]
-where [info] is pretty-printing information *)
-val destCase : constr -> case_info * constr * constr * constr array
-[@@ocaml.deprecated "Alias for [Constr.destCase]"]
-
-(** Destructs a projection *)
-val destProj : constr -> Projection.t * constr
-[@@ocaml.deprecated "Alias for [Constr.destProj]"]
-
-(** Destructs the {% $ %}i{% $ %}th function of the block
-   [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1}
-    with    f{_ 2} ctx{_ 2} = b{_ 2}
-    ...
-    with    f{_ n} ctx{_ n} = b{_ n}],
-   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
-*)
-val destFix : constr -> fixpoint
-[@@ocaml.deprecated "Alias for [Constr.destFix]"]
-
-val destCoFix : constr -> cofixpoint
-[@@ocaml.deprecated "Alias for [Constr.destCoFix]"]
-
 (** {5 Derived constructors} *)
 
 (** non-dependent product [t1 -> t2], an alias for
@@ -185,14 +25,14 @@ val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr
 val mkNamedProd : Id.t -> types -> types -> types
 
 (** Constructs either [(x:t)c] or [[x=b:t]c] *)
-val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types
-val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types
-val mkNamedProd_or_LetIn : Context.Named.Declaration.t -> types -> types
-val mkNamedProd_wo_LetIn : Context.Named.Declaration.t -> types -> types
+val mkProd_or_LetIn : Constr.rel_declaration -> types -> types
+val mkProd_wo_LetIn : Constr.rel_declaration -> types -> types
+val mkNamedProd_or_LetIn : Constr.named_declaration -> types -> types
+val mkNamedProd_wo_LetIn : Constr.named_declaration -> types -> types
 
 (** Constructs either [[x:t]c] or [[x=b:t]c] *)
-val mkLambda_or_LetIn : Context.Rel.Declaration.t -> constr -> constr
-val mkNamedLambda_or_LetIn : Context.Named.Declaration.t -> constr -> constr
+val mkLambda_or_LetIn : Constr.rel_declaration -> constr -> constr
+val mkNamedLambda_or_LetIn : Constr.named_declaration -> constr -> constr
 
 (** {5 Other term constructors. } *)
 
@@ -234,8 +74,8 @@ val to_lambda : int -> constr -> constr
    where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *)
 val to_prod : int -> constr -> constr
 
-val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr
-val it_mkProd_or_LetIn : types -> Context.Rel.t -> types
+val it_mkLambda_or_LetIn : constr -> Constr.rel_context -> constr
+val it_mkProd_or_LetIn : types -> Constr.rel_context -> types
 
 (** In [lambda_applist c args], [c] is supposed to have the form
     [λΓ.c] with [Γ] without let-in; it returns [c] with the variables
@@ -286,29 +126,29 @@ val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr
 
 (** Extract the premisses and the conclusion of a term of the form
    "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *)
-val decompose_prod_assum : types -> Context.Rel.t * types
+val decompose_prod_assum : types -> Constr.rel_context * types
 
 (** Idem with lambda's and let's *)
-val decompose_lam_assum : constr -> Context.Rel.t * constr
+val decompose_lam_assum : constr -> Constr.rel_context * constr
 
 (** Idem but extract the first [n] premisses, counting let-ins. *)
-val decompose_prod_n_assum : int -> types -> Context.Rel.t * types
+val decompose_prod_n_assum : int -> types -> Constr.rel_context * types
 
 (** Idem for lambdas, _not_ counting let-ins *)
-val decompose_lam_n_assum : int -> constr -> Context.Rel.t * constr
+val decompose_lam_n_assum : int -> constr -> Constr.rel_context * constr
 
 (** Idem, counting let-ins *)
-val decompose_lam_n_decls : int -> constr -> Context.Rel.t * constr
+val decompose_lam_n_decls : int -> constr -> Constr.rel_context * constr
 
 (** Return the premisses/parameters of a type/term (let-in included) *)
-val prod_assum : types -> Context.Rel.t
-val lam_assum : constr -> Context.Rel.t
+val prod_assum : types -> Constr.rel_context
+val lam_assum : constr -> Constr.rel_context
 
 (** Return the first n-th premisses/parameters of a type (let included and counted) *)
-val prod_n_assum : int -> types -> Context.Rel.t
+val prod_n_assum : int -> types -> Constr.rel_context
 
 (** Return the first n-th premisses/parameters of a term (let included but not counted) *)
-val lam_n_assum : int -> constr -> Context.Rel.t
+val lam_n_assum : int -> constr -> Constr.rel_context
 
 (** Remove the premisses/parameters of a type/term *)
 val strip_prod : types -> types
@@ -327,7 +167,7 @@ val strip_lam_assum : constr -> constr
     Such a term can canonically be seen as the pair of a context of types
     and of a sort *)
 
-type arity = Context.Rel.t * Sorts.t
+type arity = Constr.rel_context * Sorts.t
 
 (** Build an "arity" from its canonical form *)
 val mkArity : arity -> types
@@ -349,242 +189,11 @@ type ('constr, 'types) kind_of_type =
 
 val kind_of_type : types -> (constr, types) kind_of_type
 
-(** {5 Redeclaration of stuff from module [Sorts]} *)
-
-val set_sort  : Sorts.t
-[@@ocaml.deprecated "Alias for Sorts.set"]
-
-val prop_sort : Sorts.t
-[@@ocaml.deprecated "Alias for Sorts.prop"]
-
-val type1_sort  : Sorts.t
-[@@ocaml.deprecated "Alias for Sorts.type1"]
-
-val sorts_ord : Sorts.t -> Sorts.t -> int
-[@@ocaml.deprecated "Alias for Sorts.compare"]
-
-val is_prop_sort : Sorts.t -> bool
-[@@ocaml.deprecated "Alias for Sorts.is_prop"]
-
-val family_of_sort : Sorts.t -> Sorts.family
+(* Deprecated *)
+type sorts_family = Sorts.family = InProp | InSet | InType
 [@@ocaml.deprecated "Alias for Sorts.family"]
 
-(** {5 Redeclaration of stuff from module [Constr]}
-
-    See module [Constr] for further info. *)
-
-(** {6 Term constructors. } *)
-
-val mkRel : int -> constr
-[@@ocaml.deprecated "Alias for Constr.mkRel"]
-val mkVar : Id.t -> constr
-[@@ocaml.deprecated "Alias for Constr.mkVar"]
-val mkMeta : metavariable -> constr
-[@@ocaml.deprecated "Alias for Constr.mkMeta"]
-val mkEvar : existential -> constr
-[@@ocaml.deprecated "Alias for Constr.mkEvar"]
-val mkSort : Sorts.t -> types
-[@@ocaml.deprecated "Alias for Constr.mkSort"]
-val mkProp : types
-[@@ocaml.deprecated "Alias for Constr.mkProp"]
-val mkSet  : types
-[@@ocaml.deprecated "Alias for Constr.mkSet"]
-val mkType : Univ.Universe.t -> types
-[@@ocaml.deprecated "Alias for Constr.mkType"]
-val mkCast : constr * cast_kind * constr -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkProd : Name.t * types * types -> types
-[@@ocaml.deprecated "Alias for Constr"]
-val mkLambda : Name.t * types * constr -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkLetIn : Name.t * constr * types * constr -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkApp : constr * constr array -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkConst : Constant.t -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkProj : Projection.t * constr -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkInd : inductive -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkConstruct : constructor -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkConstU : Constant.t Univ.puniverses -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkIndU : inductive Univ.puniverses -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkConstructU : constructor Univ.puniverses -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkConstructUi : (pinductive * int) -> constr
-[@@ocaml.deprecated "Alias for Constr"]
-val mkCase : case_info * constr * constr * constr array -> constr
-[@@ocaml.deprecated "Alias for Constr.mkCase"]
-val mkFix : fixpoint -> constr
-[@@ocaml.deprecated "Alias for Constr.mkFix"]
-val mkCoFix : cofixpoint -> constr
-[@@ocaml.deprecated "Alias for Constr.mkCoFix"]
-
-(** {6 Aliases} *)
-
-val eq_constr : constr -> constr -> bool
-[@@ocaml.deprecated "Alias for Constr.equal"]
-
-(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
-   application grouping and the universe constraints in [u]. *)
-val eq_constr_univs : constr UGraph.check_function
-[@@ocaml.deprecated "Alias for Constr.eq_constr_univs"]
-
-(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
-    alpha, casts, application grouping and the universe constraints in [u]. *)
-val leq_constr_univs : constr UGraph.check_function
-[@@ocaml.deprecated "Alias for Constr.leq_constr_univs"]
-
-(** [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
-[@@ocaml.deprecated "Alias for Constr.qe_constr_nounivs"]
-
-val kind_of_term : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term
-[@@ocaml.deprecated "Alias for Constr.kind"]
-
-val compare : constr -> constr -> int
-[@@ocaml.deprecated "Alias for [Constr.compare]"]
-
-val constr_ord : constr -> constr -> int
-[@@ocaml.deprecated "Alias for [Term.compare]"]
-
-val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
-[@@ocaml.deprecated "Alias for [Constr.fold]"]
-
-val map_constr : (constr -> constr) -> constr -> constr
-[@@ocaml.deprecated "Alias for [Constr.map]"]
-
-val map_constr_with_binders :
-  ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
-[@@ocaml.deprecated "Alias for [Constr.map_with_binders]"]
-
-val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses
-[@@ocaml.deprecated "Alias for [Constr.map_puniverses]"]
-val univ_of_sort : Sorts.t -> Univ.Universe.t
-[@@ocaml.deprecated "Alias for [Sorts.univ_of_sort]"]
-val sort_of_univ : Univ.Universe.t -> Sorts.t
-[@@ocaml.deprecated "Alias for [Sorts.sort_of_univ]"]
-
-val iter_constr : (constr -> unit) -> constr -> unit
-[@@ocaml.deprecated "Alias for [Constr.iter]"]
-
-val iter_constr_with_binders :
-  ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
-[@@ocaml.deprecated "Alias for [Constr.iter_with_binders]"]
-
-val compare_constr : (int -> constr -> constr -> bool) -> int -> constr -> constr -> bool
-[@@ocaml.deprecated "Alias for [Constr.compare_head]"]
-
-type constr = Constr.constr
-[@@ocaml.deprecated "Alias for Constr.t"]
-
-(** Alias types, for compatibility. *)
-
-type types = Constr.types
-[@@ocaml.deprecated "Alias for Constr.types"]
-
-type contents = Sorts.contents = Pos | Null
-[@@ocaml.deprecated "Alias for Sorts.contents"]
-
 type sorts = Sorts.t =
-  | Prop of Sorts.contents   (** Prop and Set *)
+  | Prop | Set
   | Type of Univ.Universe.t  (** Type *)
 [@@ocaml.deprecated "Alias for Sorts.t"]
-
-type sorts_family = Sorts.family = InProp | InSet | InType
-[@@ocaml.deprecated "Alias for Sorts.family"]
-
-type 'a puniverses = 'a Univ.puniverses
-[@@ocaml.deprecated "Alias for Constr.puniverses"]
-
-(** Simply type aliases *)
-type pconstant = Constr.pconstant
-[@@ocaml.deprecated "Alias for Constr.pconstant"]
-type pinductive = Constr.pinductive
-[@@ocaml.deprecated "Alias for Constr.pinductive"]
-type pconstructor = Constr.pconstructor
-[@@ocaml.deprecated "Alias for Constr.pconstructor"]
-type existential_key = Evar.t
-[@@ocaml.deprecated "Alias for Evar.t"]
-type existential = Constr.existential
-[@@ocaml.deprecated "Alias for Constr.existential"]
-type metavariable = Constr.metavariable
-[@@ocaml.deprecated "Alias for Constr.metavariable"]
-
-type case_style = Constr.case_style =
-  LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
-[@@ocaml.deprecated "Alias for Constr.case_style"]
-
-type case_printing = Constr.case_printing =
-  { ind_tags : bool list; cstr_tags : bool list array; style : Constr.case_style }
-[@@ocaml.deprecated "Alias for Constr.case_printing"]
-
-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     : Constr.case_printing
-  }
-[@@ocaml.deprecated "Alias for Constr.case_info"]
-
-type cast_kind = Constr.cast_kind =
-  VMcast | NATIVEcast | DEFAULTcast | REVERTcast
-[@@ocaml.deprecated "Alias for Constr.cast_kind"]
-
-type rec_declaration = Constr.rec_declaration
-[@@ocaml.deprecated "Alias for Constr.rec_declaration"]
-type fixpoint = Constr.fixpoint
-[@@ocaml.deprecated "Alias for Constr.fixpoint"]
-type cofixpoint = Constr.cofixpoint
-[@@ocaml.deprecated "Alias for Constr.cofixpoint"]
-type 'constr pexistential = 'constr Constr.pexistential
-[@@ocaml.deprecated "Alias for Constr.pexistential"]
-type ('constr, 'types) prec_declaration =
-  ('constr, 'types) Constr.prec_declaration
-[@@ocaml.deprecated "Alias for Constr.prec_declaration"]
-type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint
-[@@ocaml.deprecated "Alias for Constr.pfixpoint"]
-type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint
-[@@ocaml.deprecated "Alias for Constr.pcofixpoint"]
-
-type ('constr, 'types, 'sort, 'univs) kind_of_term =
-  ('constr, 'types, 'sort, 'univs) Constr.kind_of_term =
-  | Rel       of int
-  | Var       of Id.t
-  | Meta      of Constr.metavariable
-  | Evar      of 'constr Constr.pexistential
-  | Sort      of 'sort
-  | Cast      of 'constr * 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.t * 'univs)
-  | Ind       of (inductive * 'univs)
-  | Construct of (constructor * 'univs)
-  | Case      of Constr.case_info * 'constr * 'constr * 'constr array
-  | Fix       of ('constr, 'types) Constr.pfixpoint
-  | CoFix     of ('constr, 'types) Constr.pcofixpoint
-  | Proj      of Projection.t * 'constr
-[@@ocaml.deprecated "Alias for Constr.kind_of_term"]
-
-type values = Vmvalues.values
-[@@ocaml.deprecated "Alias for Vmvalues.values"]
-
-val hash_constr : Constr.constr -> int
-[@@ocaml.deprecated "Alias for Constr.hash"]
-
-val hcons_sorts : Sorts.t -> Sorts.t
-[@@ocaml.deprecated "Alias for [Sorts.hcons]"]
-
-val hcons_constr : Constr.constr -> Constr.constr
-[@@ocaml.deprecated "Alias for [Constr.hcons]"]
-
-val hcons_types : Constr.types -> Constr.types
-[@@ocaml.deprecated "Alias for [Constr.hcons]"]
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index e621a61c..2e84f625 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -27,16 +27,10 @@ module NamedDecl = Context.Named.Declaration
 
 (* Insertion of constants and parameters in environment. *)
 
-let equal_eff e1 e2 =
-  let open Entries in
-  match e1, e2 with
-  | { eff = SEsubproof (c1,_,_) }, { eff = SEsubproof (c2,_,_) } ->
-        Names.Constant.equal c1 c2
-  | { eff = SEscheme (cl1,_) }, { eff = SEscheme (cl2,_) } ->
-        CList.for_all2eq
-          (fun (_,c1,_,_) (_,c2,_,_) -> Names.Constant.equal c1 c2)
-          cl1 cl2
-  | _ -> false
+type side_effect = {
+  from_env : Declarations.structure_body CEphemeron.key;
+  eff      : side_eff list;
+}
 
 module SideEffects :
 sig
@@ -48,17 +42,11 @@ sig
 end =
 struct
 
-let compare_seff e1 e2 = match e1, e2 with
-| SEsubproof (c1, _, _), SEsubproof (c2, _, _) -> Constant.CanOrd.compare c1 c2
-| SEscheme (cl1, _), SEscheme (cl2, _) ->
-  let cmp (_, c1, _, _) (_, c2, _, _) = Constant.CanOrd.compare c1 c2 in
-  CList.compare cmp cl1 cl2
-| SEsubproof _, SEscheme _ -> -1
-| SEscheme _, SEsubproof _ -> 1
-
 module SeffOrd = struct
 type t = side_effect
-let compare e1 e2 = compare_seff e1.eff e2.eff
+let compare e1 e2 =
+  let cmp e1 e2 = Constant.CanOrd.compare e1.seff_constant e2.seff_constant in
+  List.compare cmp e1.eff e2.eff
 end
 
 module SeffSet = Set.Make(SeffOrd)
@@ -83,10 +71,14 @@ type _ trust =
 | SideEffects : structure_body -> side_effects trust
 
 let uniq_seff_rev = SideEffects.repr
-let uniq_seff l = List.rev (SideEffects.repr l)
+let uniq_seff l =
+  let ans = List.rev (SideEffects.repr l) in
+  List.map_append (fun { eff } -> eff) ans
 
 let empty_seff = SideEffects.empty
-let add_seff = SideEffects.add
+let add_seff mb eff effs =
+  let from_env = CEphemeron.create mb in
+  SideEffects.add { eff; from_env } effs
 let concat_seff = SideEffects.concat
 
 let mk_pure_proof c = (c, Univ.ContextSet.empty), empty_seff
@@ -94,11 +86,8 @@ let mk_pure_proof c = (c, Univ.ContextSet.empty), empty_seff
 let inline_side_effects env body ctx side_eff =
   (** First step: remove the constants that are still in the environment *)
   let filter { eff = se; from_env = mb } =
-    let 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 map e = (e.seff_constant, e.seff_body, e.seff_env) in
+    let cbl = List.map map se in
     let not_exists (c,_,_) =
       try ignore(Environ.lookup_constant c env); false
       with Not_found -> true in 
@@ -114,12 +103,7 @@ let inline_side_effects env body ctx side_eff =
   if List.is_empty side_eff then (body, ctx, sigs)
   else
     (** Second step: compute the lifts and substitutions to apply *)
-    let cname c =
-      let name = Constant.to_string c in
-      let map c = if c == '.' || c == '#' then '_' else c in
-      let name = String.map map name in
-      Name (Id.of_string name)
-    in
+    let cname c = Name (Label.to_id (Constant.label c)) in
     let fold (subst, var, ctx, args) (c, cb, b) =
       let (b, opaque) = match cb.const_body, b with
       | Def b, _ -> (Mod_subst.force_constr b, false)
@@ -179,36 +163,36 @@ let rec is_nth_suffix n l suf =
   | _ :: l -> is_nth_suffix (pred n) l suf
 
 (* Given the list of signatures of side effects, checks if they match.
- * I.e. if they are ordered descendants of the current revstruct *)
+ * I.e. if they are ordered descendants of the current revstruct.
+   Returns the number of effects that can be trusted. *)
 let check_signatures curmb sl =
-  let is_direct_ancestor (sl, curmb) (mb, how_many) =
-    match curmb with
-    | None -> None, None
-    | Some curmb ->
+  let is_direct_ancestor accu (mb, how_many) =
+    match accu with
+    | None -> None
+    | Some (n, curmb) ->
         try
           let mb = CEphemeron.get mb in
-          match sl with
-          | None -> sl, None
-          | Some n ->
-              if is_nth_suffix how_many mb curmb
-              then Some (n + how_many), Some mb
-              else None, None
-        with CEphemeron.InvalidKey -> None, None in
-  let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in
-  sl
+          if is_nth_suffix how_many mb curmb
+          then Some (n + how_many, mb)
+          else None
+        with CEphemeron.InvalidKey -> None in
+  let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in
+  match sl with
+  | None -> 0
+  | Some (n, _) -> n
 
 let skip_trusted_seff sl b e =
   let rec aux sl b e acc =
     let open Context.Rel.Declaration in
-    match sl, kind b with
-    | (None|Some 0), _ -> b, e, acc
-    | Some sl, LetIn (n,c,ty,bo) ->
-       aux (Some (sl-1)) bo
+    if Int.equal sl 0 then b, e, acc
+    else match kind b with
+    | LetIn (n,c,ty,bo) ->
+       aux (sl - 1) bo
          (Environ.push_rel (LocalDef (n,c,ty)) e) (`Let(n,c,ty)::acc)
-    | Some sl, App(hd,arg) ->
+    | App(hd,arg) ->
        begin match kind hd with
        | Lambda (n,ty,bo) ->
-           aux (Some (sl-1)) bo
+           aux (sl - 1) bo
              (Environ.push_rel (LocalAssum (n,ty)) e) (`Cut(n,ty,arg)::acc)
        | _ -> assert false
        end
@@ -250,7 +234,6 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
       {
         Cooking.cook_body = Undef nl;
         cook_type = t;
-        cook_proj = None;
         cook_universes = univs;
         cook_inline = false;
         cook_context = ctx;
@@ -268,6 +251,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
       let tyj = infer_type env typ in
       let proofterm =
         Future.chain body (fun ((body,uctx),side_eff) ->
+          (* don't redeclare universes which are declared for the type *)
+          let uctx = Univ.ContextSet.diff uctx univs in
           let j, uctx = match trust with
           | Pure ->
             let env = push_context_set uctx env in
@@ -291,7 +276,6 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
       {
         Cooking.cook_body = def;
         cook_type = typ;
-        cook_proj = None;
         cook_universes = Monomorphic_const univs;
         cook_inline = c.const_entry_inline_code;
         cook_context = c.const_entry_secctx;
@@ -343,39 +327,11 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) =
       {
         Cooking.cook_body = def;
         cook_type = typ;
-        cook_proj = None;
         cook_universes = univs;
         cook_inline = c.const_entry_inline_code;
         cook_context = c.const_entry_secctx;
       }
 
-  | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} ->
-    let mib, _ = Inductive.lookup_mind_specif env (ind,0) in
-    let kn, pb = 
-      match mib.mind_record with
-      | Some (Some (id, kns, pbs)) -> 
-	if i < Array.length pbs then
-	  kns.(i), pbs.(i)
-	else assert false
-      | _ -> assert false
-    in
-    let univs =
-      match mib.mind_universes with
-      | Monomorphic_ind ctx -> Monomorphic_const ctx
-      | Polymorphic_ind auctx -> Polymorphic_const auctx
-      | Cumulative_ind acumi ->
-        Polymorphic_const (Univ.ACumulativityInfo.univ_context acumi)
-    in
-    let term, typ = pb.proj_eta in
-    {
-      Cooking.cook_body = Def (Mod_subst.from_val (Constr.hcons term));
-      cook_type = typ;
-      cook_proj = Some pb;
-      cook_universes = univs;
-      cook_inline = false;
-      cook_context = None;
-    }
-
 let record_aux env s_ty s_bo =
   let in_ty = keep_hyps env s_ty in
   let v =
@@ -408,7 +364,7 @@ let build_constant_declaration kn env result =
          str "Proof using " ++ declared_vars ++ fnl () ++
          str "to" ++ fnl () ++
          str "Proof using " ++ inferred_vars) in
-  let sort evn l =
+  let sort l =
     List.filter (fun decl ->
       let id = NamedDecl.get_id decl in
       List.exists (NamedDecl.get_id %> Names.Id.equal id) l)
@@ -441,7 +397,7 @@ let build_constant_declaration kn env result =
         [], def (* Empty section context: no need to check *)
     | Some declared ->
         (* We use the declared set and chain a check of correctness *)
-        sort env declared,
+        sort declared,
         match def with
         | Undef _ as x -> x (* nothing to check *)
         | Def cs as x ->
@@ -458,35 +414,12 @@ let build_constant_declaration kn env result =
               check declared inferred) lc) in
   let univs = result.cook_universes in
   let tps = 
-    let res =
-      match result.cook_proj with
-      | None -> compile_constant_body env univs def
-      | Some pb ->
-	(* The compilation of primitive projections is a bit tricky, because
-           they refer to themselves (the body of p looks like fun c =>
-           Proj(p,c)). We break the cycle by building an ad-hoc compilation
-           environment. A cleaner solution would be that kernel projections are
-           simply Proj(i,c) with i an int and c a constr, but we would have to
-           get rid of the compatibility layer. *)
-	let cb =
-	  { const_hyps = hyps;
-	    const_body = def;
-	    const_type = typ;
-	    const_proj = result.cook_proj;
-	    const_body_code = None;
-	    const_universes = univs;
-	    const_inline_code = result.cook_inline;
-	    const_typing_flags = Environ.typing_flags env;
-	    }
-	in
-	let env = add_constant kn cb env in
-	compile_constant_body env univs def
-    in Option.map Cemitcodes.from_val res
+    let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in
+    Option.map Cemitcodes.from_val res
   in
   { const_hyps = hyps;
     const_body = def;
     const_type = typ;
-    const_proj = result.cook_proj;
     const_body_code = tps;
     const_universes = univs;
     const_inline_code = result.cook_inline;
@@ -521,77 +454,74 @@ let constant_entry_of_side_effect cb u =
     const_entry_inline_code = cb.const_inline_code }
 ;;
 
-let turn_direct (kn,cb,u,r as orig) =
-  match cb.const_body, u with
-  | OpaqueDef _, `Opaque (b,c) ->
-      let pt = Future.from_val (b,c) in
-      kn, { cb with const_body = OpaqueDef (Opaqueproof.create pt) }, u, r
-   | _ -> orig
-;;
-
-type side_effect_role =
-  | Subproof
-  | Schema of inductive * string
+let turn_direct orig =
+  let cb = orig.seff_body in
+  if Declareops.is_opaque cb then
+    let p = match orig.seff_env with
+    | `Opaque (b, c) -> (b, c)
+    | _ -> assert false
+    in
+    let const_body = OpaqueDef (Opaqueproof.create (Future.from_val p)) in
+    let cb = { cb with const_body } in
+    { orig with seff_body = cb }
+  else orig
 
 type exported_side_effect = 
   Constant.t * constant_body * side_effect_role
 
+let export_eff eff =
+  (eff.seff_constant, eff.seff_body, eff.seff_role)
+
 let export_side_effects mb env c =
       let { const_entry_body = body } = c in
       let _, eff = Future.force body in
       let ce = { c with
         const_entry_body = Future.chain body
           (fun (b_ctx, _) -> b_ctx, ()) } in
-      let not_exists (c,_,_,_) =
-        try ignore(Environ.lookup_constant c env); false
+      let not_exists e =
+        try ignore(Environ.lookup_constant e.seff_constant env); false
         with Not_found -> true in 
       let aux (acc,sl) { eff = se; from_env = mb } =
-        let cbl = match se with
-          | SEsubproof (c,cb,b) -> [c,cb,b,Subproof]
-          | SEscheme (cl,k) ->
-              List.map (fun (i,c,cb,b) -> c,cb,b,Schema(i,k)) cl in
-        let cbl = List.filter not_exists cbl in
-        if cbl = [] then acc, sl
+        let cbl = List.filter not_exists se in
+        if List.is_empty cbl then acc, sl
         else cbl :: acc, (mb,List.length cbl) :: sl in
       let seff, signatures = List.fold_left aux ([],[]) (uniq_seff_rev eff) in
       let trusted = check_signatures mb signatures in
-      let push_seff env = function
-        | kn, cb, `Nothing, _ ->
-          begin
-            let env = Environ.add_constant kn cb env in
-            match cb.const_universes with
-            | Monomorphic_const ctx ->
-              Environ.push_context_set ~strict:true ctx env
-            | Polymorphic_const _ -> env
-          end
-        | kn, cb, `Opaque(_, ctx), _ ->
-          begin
-            let env = Environ.add_constant kn cb env in
-            match cb.const_universes with
-            | Monomorphic_const cstctx ->
-              let env = Environ.push_context_set ~strict:true cstctx env in
-              Environ.push_context_set ~strict:true ctx env
-            | Polymorphic_const _ -> env
-          end
+      let push_seff env eff =
+        let { seff_constant = kn; seff_body = cb } = eff in
+        let env = Environ.add_constant kn cb env in
+        match cb.const_universes with
+        | Polymorphic_const _ -> env
+        | Monomorphic_const ctx ->
+          let ctx = match eff.seff_env with
+          | `Nothing -> ctx
+          | `Opaque(_, ctx') -> Univ.ContextSet.union ctx' ctx
+          in
+          Environ.push_context_set ~strict:true ctx env
       in
       let rec translate_seff sl seff acc env =
-        match sl, seff with
-        | _, [] -> List.rev acc, ce
-        | (None | Some 0), cbs :: rest ->
+        match seff with
+        | [] -> List.rev acc, ce
+        | cbs :: rest ->
+          if Int.equal sl 0 then
            let env, cbs =
-             List.fold_left (fun (env,cbs) (kn, ocb, u, r) ->
+             List.fold_left (fun (env,cbs) eff ->
+              let { seff_constant = kn; seff_body = ocb; seff_env = u } = eff in
                let ce = constant_entry_of_side_effect ocb u in
                let cb = translate_constant Pure env kn ce in
-               (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,r) :: cbs)) 
+               let eff = { eff with
+                seff_body = cb;
+                seff_env = `Nothing;
+               } in
+               (push_seff env eff, export_eff eff :: cbs))
              (env,[]) cbs in
-           translate_seff sl rest (cbs @ acc) env
-        | Some sl, cbs :: rest ->
+           translate_seff 0 rest (cbs @ acc) env
+          else
            let cbs_len = List.length cbs in
            let cbs = List.map turn_direct cbs in
            let env = List.fold_left push_seff env cbs in
-           let ecbs = List.map (fun (kn,cb,u,r) ->
-             kn, cb, r) cbs in
-           translate_seff (Some (sl-cbs_len)) rest (ecbs @ acc) env
+           let ecbs = List.map export_eff cbs in
+           translate_seff (sl - cbs_len) rest (ecbs @ acc) env
      in
        translate_seff trusted seff [] env
 ;;
@@ -606,7 +536,7 @@ let translate_recipe env kn r =
       be useless. It is detected by the dirpath of the constant being empty. *)
   let (_, dir, _) = Constant.repr3 kn in
   let hcons = DirPath.is_empty dir in
-  build_constant_declaration kn env (Cooking.cook_constant ~hcons env r)
+  build_constant_declaration kn env (Cooking.cook_constant ~hcons r)
 
 let translate_local_def env id centry =
   let open Cooking in
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 6a0ff072..b05e05e4 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -38,24 +38,18 @@ val inline_entry_side_effects :
     yet type checked proof. *)
 
 val empty_seff : side_effects
-val add_seff : side_effect -> side_effects -> side_effects
+val add_seff : Declarations.structure_body -> Entries.side_eff list -> side_effects -> side_effects
 val concat_seff : side_effects -> side_effects -> side_effects
 (** [concat_seff e1 e2] adds the side-effects of [e1] to [e2], i.e. effects in
     [e1] must be more recent than those of [e2]. *)
-val uniq_seff : side_effects -> side_effect list
+val uniq_seff : side_effects -> side_eff list
 (** Return the list of individual side-effects in the order of their
     creation. *)
 
-val equal_eff : side_effect -> side_effect -> bool
-
 val translate_constant :
   'a trust -> env -> Constant.t -> 'a constant_entry ->
     constant_body
 
-type side_effect_role =
-  | Subproof
-  | Schema of inductive * string
-
 type exported_side_effect = 
   Constant.t * constant_body * side_effect_role
   
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 1c323e3e..60293fe8 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -62,6 +62,7 @@ type ('constr, 'types) ptype_error =
   | IllTypedRecBody of
       int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array
   | UnsatisfiedConstraints of Univ.Constraint.t
+  | UndeclaredUniverse of Univ.Level.t
 
 type type_error = (constr, types) ptype_error
 
@@ -125,3 +126,6 @@ let error_elim_explain kp ki =
 
 let error_unsatisfied_constraints env c =
   raise (TypeError (env, UnsatisfiedConstraints c))
+
+let error_undeclared_universe env l =
+  raise (TypeError (env, UndeclaredUniverse l))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 20bf300a..9c6ef64b 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -63,6 +63,7 @@ type ('constr, 'types) ptype_error =
   | IllTypedRecBody of
       int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array
   | UnsatisfiedConstraints of Univ.Constraint.t
+  | UndeclaredUniverse of Univ.Level.t
 
 type type_error = (constr, types) ptype_error
 
@@ -108,3 +109,5 @@ val error_ill_typed_rec_body  :
 val error_elim_explain : Sorts.family -> Sorts.family -> arity_error
 
 val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a
+
+val error_undeclared_universe : env -> Univ.Level.t -> 'a
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index be4c0e1e..25c1cbff 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -69,7 +69,7 @@ let type_of_type u =
     mkType uu
 
 let type_of_sort = function
-  | Prop c -> type1
+  | Prop | Set -> type1
   | Type u -> type_of_type u
 
 (*s Type of a de Bruijn index. *)
@@ -178,11 +178,11 @@ let type_of_apply env func funt argsv argstv =
 let sort_of_product env domsort rangsort =
   match (domsort, rangsort) with
     (* Product rule (s,Prop,Prop) *)
-    | (_,       Prop Null)  -> rangsort
+    | (_,       Prop)  -> rangsort
     (* Product rule (Prop/Set,Set,Set) *)
-    | (Prop _,  Prop Pos) -> rangsort
+    | ((Prop | Set),  Set) -> rangsort
     (* Product rule (Type,Set,?) *)
-    | (Type u1, Prop Pos) ->
+    | (Type u1, Set) ->
         if is_impredicative_set env then
           (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
           rangsort
@@ -190,9 +190,9 @@ let sort_of_product env domsort rangsort =
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
           Type (Universe.sup Universe.type0 u1)
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop Pos,  Type u2)  -> Type (Universe.sup Universe.type0 u2)
+    | (Set,  Type u2)  -> Type (Universe.sup Universe.type0 u2)
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop Null, Type _)  -> rangsort
+    | (Prop, Type _)  -> rangsort
     (* Product rule (Type_i,Type_i,Type_i) *)
     | (Type u1, Type u2) -> Type (Universe.sup u1 u2)
 
@@ -221,7 +221,7 @@ let check_cast env c ct k expected_type =
   try
     match k with
     | VMcast ->
-      vm_conv CUMUL env ct expected_type
+      Vconv.vm_conv CUMUL env ct expected_type
     | DEFAULTcast ->
       default_conv ~l2r:false CUMUL env ct expected_type
     | REVERTcast ->
@@ -296,13 +296,13 @@ let type_of_case env ci p pt c ct lf lft =
   rslty
 
 let type_of_projection env p c ct =
-  let pb = lookup_projection p env in
+  let pty = lookup_projection p env in
   let (ind,u), args =
     try find_rectype env ct
     with Not_found -> error_case_not_inductive env (make_judge c ct)
   in
-  assert(MutInd.equal pb.proj_ind (fst ind));
-  let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
+  assert(eq_ind (Projection.inductive p) ind);
+  let ty = Vars.subst_instance_constr u pty in
   substl (c :: CList.rev args) ty
       
 
@@ -431,7 +431,28 @@ and execute_recdef env (names,lar,vdef) i =
 and execute_array env = Array.map (execute env)
 
 (* Derived functions *)
+
+let universe_levels_of_constr env c =
+  let rec aux s c =
+    match kind c with
+    | Const (c, u) ->
+       LSet.fold LSet.add (Instance.levels u) s
+    | Ind ((mind,_), u) | Construct (((mind,_),_), u) ->
+       LSet.fold LSet.add (Instance.levels u) s
+    | Sort u when not (Sorts.is_small u) ->
+      let u = Sorts.univ_of_sort u in
+      LSet.fold LSet.add (Universe.levels u) s
+    | _ -> Constr.fold aux s c
+  in aux LSet.empty c
+
+let check_wellformed_universes env c =
+  let univs = universe_levels_of_constr env c in
+  try UGraph.check_declared_universes (universes env) univs
+  with UGraph.UndeclaredLevel u ->
+    error_undeclared_universe env u
+
 let infer env constr =
+  let () = check_wellformed_universes env constr in
   let t = execute env constr in
     make_judge constr t
 
@@ -449,11 +470,13 @@ let type_judgment env {uj_val=c; uj_type=t} =
   {utj_val = c; utj_type = s }
 
 let infer_type env constr =
+  let () = check_wellformed_universes env constr in
   let t = execute env constr in
   let s = check_type env constr t in
   {utj_val = constr; utj_type = s}
 
 let infer_v env cv =
+  let () = Array.iter (check_wellformed_universes env) cv in
   let jv = execute_array env cv in
     make_judgev cv jv
 
@@ -461,9 +484,11 @@ let infer_v env cv =
 
 let infer_local_decl env id = function
   | Entries.LocalDefEntry c ->
+      let () = check_wellformed_universes env c in
       let t = execute env c in
       RelDecl.LocalDef (Name id, c, t)
   | Entries.LocalAssumEntry c ->
+      let () = check_wellformed_universes env c in
       let t = execute env c in
       RelDecl.LocalAssum (Name id, check_assumption env c t)
 
@@ -481,10 +506,6 @@ let judge_of_prop = make_judge mkProp type1
 let judge_of_set = make_judge mkSet type1
 let judge_of_type u = make_judge (mkType u) (type_of_type u)
 
-let judge_of_prop_contents = function
-  | Null -> judge_of_prop
-  | Pos -> judge_of_set
-
 let judge_of_relative env k = make_judge (mkRel k) (type_of_relative env k)
 
 let judge_of_variable env x = make_judge (mkVar x) (type_of_variable env x)
@@ -528,13 +549,3 @@ let judge_of_case env ci pj cj lfj =
   let lf, lft = dest_judgev lfj in
   make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft))
              (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft)
-
-let type_of_projection_constant env (p,u) =
-  let cst = Projection.constant p in
-  let cb = lookup_constant cst env in
-  match cb.const_proj with
-  | Some pb ->
-    if Declareops.constant_is_polymorphic cb then
-      Vars.subst_instance_constr u pb.proj_type
-    else pb.proj_type
-  | None -> raise (Invalid_argument "type_of_projection: not a projection")
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 85b2cfff..57acdfe4 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -28,7 +28,7 @@ val infer_v    : env -> constr array -> unsafe_judgment array
 val infer_type : env -> types        -> unsafe_type_judgment
 
 val infer_local_decls :
-  env -> (Id.t * local_entry) list -> (env * Context.Rel.t)
+  env -> (Id.t * local_entry) list -> (env * Constr.rel_context)
 
 (** {6 Basic operations of the typing machine. } *)
 
@@ -43,7 +43,6 @@ val type1 : types
 val type_of_sort : Sorts.t -> types
 val judge_of_prop : unsafe_judgment
 val judge_of_set  : unsafe_judgment
-val judge_of_prop_contents  : Sorts.contents -> unsafe_judgment
 val judge_of_type           : Universe.t -> unsafe_judgment
 
 (** {6 Type of a bound variable. } *)
@@ -100,9 +99,7 @@ val judge_of_case : env -> case_info
   -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
     -> unsafe_judgment
 
-val type_of_projection_constant : env -> Projection.t puniverses -> types
-
 val type_of_constant_in : env -> pconstant -> types
 
 (** Check that hyps are included in env and fails with error otherwise *)
-val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Context.Named.t -> unit
+val check_hyps_inclusion : env -> ('a -> constr) -> 'a -> Constr.named_context -> unit
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
index 5d5c4831..95d71965 100644
--- a/kernel/uGraph.ml
+++ b/kernel/uGraph.ml
@@ -21,7 +21,7 @@ open Univ
 (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu
    Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *)
 
-let error_inconsistency o u v (p:explanation option) =
+let error_inconsistency o u v p =
   raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p))
 
 (* Universes are stratified by a partial ordering $\le$.
@@ -503,7 +503,7 @@ let insert_edge strict ucan vcan g =
     let () = cleanup_universes g in
     raise e
 
-let add_universe vlev strict g =
+let add_universe_gen vlev g =
   try
     let _arcv = UMap.find vlev g.entries in
       raise AlreadyDeclared
@@ -520,8 +520,19 @@ let add_universe vlev strict g =
     }
     in
     let entries = UMap.add vlev (Canonical v) g.entries in
-    let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in
-    insert_edge strict (get_set_arc g) v g
+    { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v
+
+let add_universe vlev strict g =
+  let g, v = add_universe_gen vlev g in
+  insert_edge strict (get_set_arc g) v g
+
+let add_universe_unconstrained vlev g =
+  fst (add_universe_gen vlev g)
+
+exception UndeclaredLevel of Univ.Level.t
+let check_declared_universes g us =
+  let check l = if not (UMap.mem l g.entries) then raise (UndeclaredLevel l) in
+  Univ.LSet.iter check us
 
 exception Found_explanation of explanation
 
@@ -557,8 +568,7 @@ let get_explanation strict u v g =
   else match traverse strict u with Some exp -> exp | None -> assert false
 
 let get_explanation strict u v g =
-  if !Flags.univ_print then Some (get_explanation strict u v g)
-  else None
+  Some (lazy (get_explanation strict u v g))
 
 (* To compare two nodes, we simply do a forward search.
    We implement two improvements:
@@ -697,6 +707,9 @@ let enforce_univ_lt u v g =
     error_inconsistency Lt u v (get_explanation false v u g)
 
 let empty_universes =
+  { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 }
+
+let initial_universes =
   let set_arc = Canonical {
     univ = Level.set;
     ltle = LMap.empty;
@@ -719,9 +732,6 @@ let empty_universes =
   let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in
   enforce_univ_lt Level.prop Level.set empty
 
-(* Prop = Set is forbidden here. *)
-let initial_universes = empty_universes
-
 let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries
 
 let enforce_constraint cst g =
@@ -807,18 +817,54 @@ let normalize_universes g =
     g.entries g
 
 let constraints_of_universes g =
+  let module UF = Unionfind.Make (LSet) (LMap) in
+  let uf = UF.create () in
   let constraints_of u v acc =
     match v with
     | Canonical {univ=u; ltle} ->
       UMap.fold (fun v strict acc->
         let typ = if strict then Lt else Le in
         Constraint.add (u,typ,v) acc) ltle acc
-    | Equiv v -> Constraint.add (u,Eq,v) acc
+    | Equiv v -> UF.union u v uf; acc
   in
-  UMap.fold constraints_of g.entries Constraint.empty
-
-let constraints_of_universes g =
-  constraints_of_universes (normalize_universes g)
+  let csts = UMap.fold constraints_of g.entries Constraint.empty in
+  csts, UF.partition uf
+
+(* domain g.entries = kept + removed *)
+let constraints_for ~kept g =
+  (* rmap: partial map from canonical universes to kept universes *)
+  let rmap, csts = LSet.fold (fun u (rmap,csts) ->
+      let arcu = repr g u in
+      if LSet.mem arcu.univ kept then
+        LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts
+      else
+        match LMap.find arcu.univ rmap with
+        | v -> rmap, enforce_eq_level u v csts
+        | exception Not_found -> LMap.add arcu.univ u rmap, csts)
+      kept (LMap.empty,Constraint.empty)
+  in
+  let rec add_from u csts todo = match todo with
+    | [] -> csts
+    | (v,strict)::todo ->
+      let v = repr g v in
+      (match LMap.find v.univ rmap with
+       | v ->
+         let d = if strict then Lt else Le in
+         let csts = Constraint.add (u,d,v) csts in
+         add_from u csts todo
+       | exception Not_found ->
+         (* v is not equal to any kept universe *)
+         let todo = LMap.fold (fun v' strict' todo ->
+             (v',strict || strict') :: todo)
+             v.ltle todo
+         in
+         add_from u csts todo)
+  in
+  LSet.fold (fun u csts ->
+      let arc = repr g u in
+      LMap.fold (fun v strict csts -> add_from u csts [v,strict])
+        arc.ltle csts)
+    kept csts
 
 (** [sort_universes g] builds a totally ordered universe graph.  The
     output graph should imply the input graph (and the implication
diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli
index 0f078255..752bf762 100644
--- a/kernel/uGraph.mli
+++ b/kernel/uGraph.mli
@@ -52,17 +52,34 @@ exception AlreadyDeclared
 
 val add_universe : Level.t -> bool -> t -> t
 
+(** Add a universe without (Prop,Set) <= u *)
+val add_universe_unconstrained : Level.t -> t -> t
+
+(** Check that the universe levels are declared. Otherwise
+    @raise UndeclaredLevel l for the first undeclared level found. *)
+exception UndeclaredLevel of Univ.Level.t
+
+val check_declared_universes : t -> Univ.LSet.t -> unit
+
 (** {6 Pretty-printing of universes. } *)
 
 val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t
 
 (** The empty graph of universes *)
 val empty_universes : t
-[@@ocaml.deprecated "Use UGraph.initial_universes"]
 
 val sort_universes : t -> t
 
-val constraints_of_universes : t -> Constraint.t
+(** [constraints_of_universes g] returns [csts] and [partition] where
+   [csts] are the non-Eq constraints and [partition] is the partition
+   of the universes into equivalence classes. *)
+val constraints_of_universes : t -> Constraint.t * LSet.t list
+
+(** [constraints_for ~kept g] returns the constraints about the
+   universes [kept] in [g] up to transitivity.
+
+    eg if [g] is [a <= b <= c] then [constraints_for ~kept:{a, c} g] is [a <= c]. *)
+val constraints_for : kept:LSet.t -> t -> Constraint.t
 
 val check_subtype : AUContext.t check_function
 (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 3158db52..311477da 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -456,10 +456,10 @@ struct
   let super l = 
     if is_small l then type1
     else
-      List.smartmap (fun x -> Expr.successor x) l
+      List.Smart.map (fun x -> Expr.successor x) l
 
   let addn n l =
-    List.smartmap (fun x -> Expr.addn n x) l
+    List.Smart.map (fun x -> Expr.addn n x) l
 
   let rec merge_univs l1 l2 =
     match l1, l2 with
@@ -500,7 +500,7 @@ struct
 
   let for_all = List.for_all
 
-  let smartmap = List.smartmap
+  let smart_map = List.Smart.map
 
   let map = List.map
 end
@@ -541,11 +541,11 @@ let constraint_type_ord c1 c2 = match c1, c2 with
 (* Universe inconsistency: error raised when trying to enforce a relation
    that would create a cycle in the graph of universes. *)
 
-type univ_inconsistency = constraint_type * universe * universe * explanation option
+type univ_inconsistency = constraint_type * universe * universe * explanation Lazy.t option
 
 exception UniverseInconsistency of univ_inconsistency
 
-let error_inconsistency o u v (p:explanation option) =
+let error_inconsistency o u v p =
   raise (UniverseInconsistency (o,make u,make v,p))
 
 (* Constraints and sets of constraints. *)    
@@ -848,7 +848,7 @@ struct
   let length a = Array.length a
 
   let subst_fn fn t = 
-    let t' = CArray.smartmap fn t in
+    let t' = CArray.Smart.map fn t in
       if t' == t then t else of_array t'
 
   let levels x = LSet.of_array x
@@ -885,11 +885,11 @@ let subst_instance_level s l =
   | _ -> l
 
 let subst_instance_instance s i = 
-  Array.smartmap (fun l -> subst_instance_level s l) i
+  Array.Smart.map (fun l -> subst_instance_level s l) i
 
 let subst_instance_universe s u =
   let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in
-  let u' = Universe.smartmap f u in
+  let u' = Universe.smart_map f u in
     if u == u' then u
     else Universe.sort u'
 
@@ -1095,7 +1095,7 @@ let subst_univs_level_level subst l =
 
 let subst_univs_level_universe subst u =
   let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in
-  let u' = Universe.smartmap f u in
+  let u' = Universe.smart_map f u in
     if u == u' then u
     else Universe.sort u'
 
@@ -1230,13 +1230,16 @@ let explain_universe_inconsistency prl (o,u,v,p) =
     | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" 
   in
   let reason = match p with
-    | None | Some [] -> mt()
+    | None -> mt()
     | Some p ->
-      str " because" ++ spc() ++ pr_uni v ++
+      let p = Lazy.force p in
+      if p = [] then mt ()
+      else
+        str " because" ++ spc() ++ pr_uni v ++
 	prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v)
-	p ++
+          p ++
 	(if Universe.equal (snd (List.last p)) u then mt() else
-	    (spc() ++ str "= " ++ pr_uni u)) 
+           (spc() ++ str "= " ++ pr_uni u))
   in
     str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++
       pr_rel o ++ spc() ++ pr_uni v ++ reason
diff --git a/kernel/univ.mli b/kernel/univ.mli
index aaed899b..b68bbdf3 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -205,7 +205,7 @@ val enforce_leq_level : Level.t constraint_function
   Constraint.t...
 *)
 type explanation = (constraint_type * Universe.t) list
-type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation option
+type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option
 
 exception UniverseInconsistency of univ_inconsistency
 
diff --git a/kernel/vars.mli b/kernel/vars.mli
index a0c7ba4b..fdddbdb3 100644
--- a/kernel/vars.mli
+++ b/kernel/vars.mli
@@ -70,10 +70,10 @@ type substl = constr list
    as if usable in [applist] while the substitution is
    represented the other way round, i.e. ending with either [u₁] or
    [c₁], as if usable for [substl]. *)
-val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl
+val subst_of_rel_context_instance : Constr.rel_context -> constr list -> substl
 
 (** For compatibility: returns the substitution reversed *)
-val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list
+val adjust_subst_to_rel_context : Constr.rel_context -> constr list -> constr list
 
 (** Take an index in an instance of a context and returns its index wrt to
     the full context (e.g. 2 in [x:A;y:=b;z:C] is 3, i.e. a reference to z) *)
@@ -97,13 +97,13 @@ val subst1 : constr -> constr -> constr
     accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if
     Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then
     Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *)
-val substnl_decl : substl -> int -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
+val substnl_decl : substl -> int -> Constr.rel_declaration -> Constr.rel_declaration
 
 (** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *)
-val substl_decl : substl -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
+val substl_decl : substl -> Constr.rel_declaration -> Constr.rel_declaration
 
 (** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *)
-val subst1_decl : constr -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t
+val subst1_decl : constr -> Constr.rel_declaration -> Constr.rel_declaration
 
 (** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by
     [cj] in [t]. *)
@@ -134,8 +134,8 @@ open Univ
 (** Level substitutions for polymorphism. *)
 
 val subst_univs_level_constr : universe_level_subst -> constr -> constr
-val subst_univs_level_context : Univ.universe_level_subst -> Context.Rel.t -> Context.Rel.t
+val subst_univs_level_context : Univ.universe_level_subst -> Constr.rel_context -> Constr.rel_context
 
 (** Instance substitution for polymorphism. *)
 val subst_instance_constr : Instance.t -> constr -> constr
-val subst_instance_context : Instance.t -> Context.Rel.t -> Context.Rel.t
+val subst_instance_context : Instance.t -> Constr.rel_context -> Constr.rel_context
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index 437de99e..d19bea51 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -6,9 +6,6 @@ open Vm
 open Vmvalues
 open Csymtable
 
-let val_of_constr env c =
-  val_of_constr (pre_env env) c
-
 (* Test la structure des piles *)
 
 let compare_zipper z1 z2 =
@@ -142,7 +139,7 @@ and conv_stack env k stk1 stk2 cu =
 	conv_stack env k stk1 stk2 !rcu
       else raise NotConvertible
   | Zproj p1 :: stk1, Zproj p2 :: stk2 ->
-    if Constant.equal p1 p2 then conv_stack env k stk1 stk2 cu
+    if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu
     else raise NotConvertible
   | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _
   | Zproj _ :: _, _ -> raise NotConvertible
@@ -185,8 +182,18 @@ and conv_arguments env ?from:(from=0) k args1 args2 cu =
       !rcu
     else raise NotConvertible
 
+let warn_bytecode_compiler_failed =
+  let open Pp in
+  CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler"
+         (fun () -> strbrk "Bytecode compiler failed, " ++
+                      strbrk "falling back to standard conversion")
+
 let vm_conv_gen cv_pb env univs t1 t2 =
-  try 
+  if not Coq_config.bytecode_compiler then
+    Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None)
+      full_transparent_state env univs t1 t2
+  else
+  try
     let v1 = val_of_constr env t1 in
     let v2 = val_of_constr env t2 in
     fst (conv_val env cv_pb (nb_rel env) v1 v2 univs)
@@ -204,7 +211,3 @@ let vm_conv cv_pb env t1 t2 =
   if not b then
     let univs = (univs, checked_universes) in
     let _ = vm_conv_gen cv_pb env univs t1 t2 in ()
-
-let _ = if Coq_config.bytecode_compiler then Reduction.set_vm_conv vm_conv
-let _ = if Coq_config.bytecode_compiler then
-  Nativeconv.set_vm_conv_gen { Nativeconv.vm_conv_gen = vm_conv_gen }
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index 620f6b5e..1a318489 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -9,7 +9,6 @@
 (************************************************************************)
 
 open Constr
-open Environ
 open Reduction
 
 (**********************************************************************
@@ -19,6 +18,3 @@ val vm_conv : conv_pb -> types kernel_conversion_function
 (** A conversion function parametrized by a universe comparator. Used outside of
     the kernel. *)
 val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function
-
-(** Precompute a VM value from a constr *)
-val val_of_constr : env -> constr -> Vmvalues.values
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 14aeb732..9917e94a 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -8,7 +8,6 @@
 (*         *     (see LICENSE file for the text of the license)         *)
 (************************************************************************)
 
-open Cbytecodes
 open Vmvalues
 
 external set_drawinstr : unit -> unit = "coq_set_drawinstr"
@@ -42,8 +41,11 @@ external push_vstack : vstack -> int -> unit = "coq_push_vstack"
 
 
 (* interpreteur *)
-external interprete : tcode -> values -> vm_env -> int -> values =
-  "coq_interprete_ml"
+external coq_interprete : tcode -> values -> atom array -> vm_global -> vm_env -> int -> values =
+  "coq_interprete_byte" "coq_interprete_ml"
+
+let interprete code v env k =
+  coq_interprete code v (get_atom_rel ()) (Csymtable.get_global_data ()) env k
 
 (* Functions over arguments *)
 
@@ -184,6 +186,6 @@ let apply_whd k whd =
       push_val v;
       interprete (cofix_upd_code to_up) (cofix_upd_val to_up) (cofix_upd_env to_up) 0
   | Vatom_stk(a,stk) ->
-      apply_stack (val_of_atom a) stk v 
+      apply_stack (val_of_atom a) stk v
   | Vuniv_level lvl -> assert false
 
diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml
index 0e0cb4e5..8edd49f7 100644
--- a/kernel/vmvalues.ml
+++ b/kernel/vmvalues.ml
@@ -9,8 +9,8 @@
 (************************************************************************)
 open Names
 open Sorts
-open Cbytecodes
 open Univ
+open Constr
 
 (*******************************************)
 (* Initalization of the abstract machine ***)
@@ -25,11 +25,124 @@ let _ = init_vm ()
 (* Abstract data types and utility functions **********)
 (******************************************************)
 
+(* The representation of values relies on this assertion *)
+let _ = assert (Int.equal Obj.first_non_constant_constructor_tag 0)
+
 (* Values of the abstract machine *)
 type values
+type structured_values = values
 let val_of_obj v = ((Obj.obj v):values)
 let crazy_val = (val_of_obj (Obj.repr 0))
 
+type tag = int
+
+let accu_tag = 0
+
+let type_atom_tag = 2
+let max_atom_tag = 2
+let proj_tag = 3
+let fix_app_tag = 4
+let switch_tag = 5
+let cofix_tag = 6
+let cofix_evaluated_tag = 7
+
+(** Structured constants are constants whose construction is done once. Their
+occurrences share the same value modulo kernel name substitutions (for functor
+application). Structured values have the additional property that no
+substitution will need to be performed, so their runtime value can directly be
+shared without reallocating a more structured representation. *)
+type structured_constant =
+  | Const_sort of Sorts.t
+  | Const_ind of inductive
+  | Const_b0 of tag
+  | Const_univ_level of Univ.Level.t
+  | Const_val of structured_values
+
+type reloc_table = (tag * int) array
+
+type annot_switch =
+   {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int}
+
+let rec eq_structured_values v1 v2 =
+  v1 == v2 ||
+  let o1 = Obj.repr v1 in
+  let o2 = Obj.repr v2 in
+  if Obj.is_int o1 && Obj.is_int o2 then o1 == o2
+  else
+    let t1 = Obj.tag o1 in
+    let t2 = Obj.tag o2 in
+    if Int.equal t1 t2 &&
+       Int.equal (Obj.size o1) (Obj.size o2)
+    then begin
+      assert (t1 <= Obj.last_non_constant_constructor_tag &&
+              t2 <= Obj.last_non_constant_constructor_tag);
+      let i = ref 0 in
+      while (!i < Obj.size o1 && eq_structured_values
+               (Obj.magic (Obj.field o1 !i) : structured_values)
+               (Obj.magic (Obj.field o2 !i) : structured_values)) do
+        incr i
+      done;
+      !i >= Obj.size o1
+    end
+    else false
+
+let hash_structured_values (v : structured_values) =
+  (* We may want a better hash function here *)
+  Hashtbl.hash v
+
+let eq_structured_constant c1 c2 = match c1, c2 with
+| Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2
+| Const_sort _, _ -> false
+| Const_ind i1, Const_ind i2 -> eq_ind i1 i2
+| Const_ind _, _ -> false
+| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2
+| Const_b0 _, _ -> false
+| Const_univ_level l1 , Const_univ_level l2 -> Univ.Level.equal l1 l2
+| Const_univ_level _ , _ -> false
+| Const_val v1, Const_val v2 -> eq_structured_values v1 v2
+| Const_val v1, _ -> false
+
+let hash_structured_constant c =
+  let open Hashset.Combine in
+  match c with
+  | Const_sort s -> combinesmall 1 (Sorts.hash s)
+  | Const_ind i -> combinesmall 2 (ind_hash i)
+  | Const_b0 t -> combinesmall 3 (Int.hash t)
+  | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l)
+  | Const_val v -> combinesmall 5 (hash_structured_values v)
+
+let eq_annot_switch asw1 asw2 =
+  let eq_ci ci1 ci2 =
+    eq_ind ci1.ci_ind ci2.ci_ind &&
+    Int.equal ci1.ci_npar ci2.ci_npar &&
+    CArray.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls
+  in
+  let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in
+  eq_ci asw1.ci asw2.ci &&
+  CArray.equal eq_rlc asw1.rtbl asw2.rtbl &&
+  (asw1.tailcall : bool) == asw2.tailcall
+
+let hash_annot_switch asw =
+  let open Hashset.Combine in
+  let h1 = Constr.case_info_hash asw.ci in
+  let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in
+  let h3 = if asw.tailcall then 1 else 0 in
+  combine3 h1 h2 h3
+
+let pp_sort s =
+  let open Sorts in
+  match s with
+  | Prop -> Pp.str "Prop"
+  | Set -> Pp.str "Set"
+  | Type u -> Pp.(str "Type@{" ++ Univ.pr_uni u ++ str "}")
+
+let pp_struct_const = function
+  | Const_sort s -> pp_sort s
+  | Const_ind (mind, i) -> Pp.(MutInd.print mind ++ str"#" ++ int i)
+  | Const_b0 i -> Pp.int i
+  | Const_univ_level l -> Univ.Level.pr l
+  | Const_val _ -> Pp.str "(value)"
+
 (* Abstract data *)
 type vprod
 type vfun
@@ -43,6 +156,7 @@ let fix_val v = (Obj.magic v : values)
 let cofix_upd_val v = (Obj.magic v : values)
 
 type vm_env
+type vm_global
 let fun_env v = (Obj.magic v : vm_env)
 let fix_env v = (Obj.magic v : vm_env)
 let cofix_env v = (Obj.magic v : vm_env)
@@ -51,19 +165,24 @@ type vstack = values array
 
 let fun_of_val v = (Obj.magic v : vfun)
 
+let vm_global (v : values array) = (Obj.magic v : vm_global)
+
 (*******************************************)
 (* Machine code *** ************************)
 (*******************************************)
 
 type tcode
+(** A block whose first field is a C-allocated VM bytecode, encoded as char*.
+    This is compatible with the representation of the Coq VM closures. *)
+
+type tcode_array
 
 external mkAccuCode : int -> tcode = "coq_makeaccu"
 external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode"
 
-let tcode_of_obj v = ((Obj.obj v):tcode)
-let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0)
-let fix_code v = fun_code v
-let cofix_upd_code v = fun_code v
+let fun_code v = (Obj.magic v : tcode)
+let fix_code = fun_code
+let cofix_upd_code = fun_code
 
 
 type vswitch = {
@@ -144,7 +263,7 @@ type zipper =
   | Zapp of arguments
   | Zfix of vfix*arguments  (* Possibly empty *)
   | Zswitch of vswitch
-  | Zproj of Constant.t (* name of the projection *)
+  | Zproj of Projection.Repr.t (* name of the projection *)
 
 type stack = zipper list
 
@@ -252,6 +371,7 @@ external kind_of_closure : Obj.t -> int = "coq_kind_of_closure"
 external is_accumulate : tcode -> bool = "coq_is_accumulate_code"
 external int_tcode : tcode -> int -> int = "coq_int_tcode"
 external accumulate : unit -> tcode = "accumulate_code"
+external set_bytecode_field : Obj.t -> int -> tcode -> unit = "coq_set_bytecode_field"
 let accumulate = accumulate ()
 
 let whd_val : values -> whd =
@@ -281,25 +401,26 @@ let whd_val : values -> whd =
 let obj_of_atom : atom -> Obj.t =
   fun a ->
     let res = Obj.new_block accu_tag 2 in
-    Obj.set_field res 0 (Obj.repr accumulate);
+    set_bytecode_field res 0 accumulate;
     Obj.set_field res 1 (Obj.repr a);
     res
 
 (* obj_of_str_const : structured_constant -> Obj.t *)
-let rec obj_of_str_const str =
+let obj_of_str_const str =
   match str with
   | Const_sort s -> obj_of_atom (Asort s)
   | Const_ind ind -> obj_of_atom (Aind ind)
-  | Const_proj p -> Obj.repr p
   | Const_b0 tag -> Obj.repr tag
-  | Const_bn(tag, args) ->
-      let len = Array.length args in
-      let res = Obj.new_block tag len in
-      for i = 0 to len - 1 do
-        Obj.set_field res i (obj_of_str_const args.(i))
-      done;
-      res
   | Const_univ_level l -> Obj.repr (Vuniv_level l)
+  | Const_val v -> Obj.repr v
+
+let val_of_block tag (args : structured_values array) =
+  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.repr args.(i))
+  done;
+  (Obj.magic r : structured_values)
 
 let val_of_obj o = ((Obj.obj o) : values)
 
@@ -307,6 +428,8 @@ 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 val_of_int i = (Obj.magic i : values)
+
 let atom_of_proj kn v =
   let r = Obj.new_block proj_tag 2 in
   Obj.set_field r 0 (Obj.repr kn);
@@ -348,6 +471,7 @@ let val_of_constant c = val_of_idkey (ConstKey c)
 let val_of_evar evk = val_of_idkey (EvarKey evk)
 
 external val_of_annot_switch : annot_switch -> values = "%identity"
+external val_of_proj_name : Projection.Repr.t -> values = "%identity"
 
 (*************************************************)
 (** Operations manipulating data types ***********)
@@ -367,17 +491,20 @@ external closure_arity : vfun -> int = "coq_closure_arity"
 external offset : Obj.t -> int = "coq_offset"
 external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure"
 external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure"
+external tcode_array : tcode_array -> tcode array = "coq_tcode_array"
 
 let first o = (offset_closure o (offset o))
 let first_fix (v:vfix) = (Obj.magic (first (Obj.repr v)) : vfix)
 
 let last o = (Obj.field o (Obj.size o - 1))
-let fix_types (v:vfix) = (Obj.magic (last (Obj.repr v)) : tcode array)
-let cofix_types (v:vcofix) = (Obj.magic (last (Obj.repr v)) : tcode array)
+let fix_types (v:vfix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array)
+let cofix_types (v:vcofix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array)
 
 let current_fix vf = - (offset (Obj.repr vf) / 2)
 
-let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i))
+let unsafe_fb_code fb i =
+  let off = (2 * i) * (Sys.word_size / 8) in
+  Obj.obj (Obj.add_offset (Obj.repr fb) (Int32.of_int off))
 
 let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1
 
@@ -407,13 +534,20 @@ let check_fix f1 f2 =
     else false
   else false
 
-external atom_rel : unit -> atom array = "get_coq_atom_tbl"
-external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl"
+let atom_rel : atom array ref =
+  let init i = Aid (RelKey i) in
+  ref (Array.init 40 init)
+
+let get_atom_rel () = !atom_rel
+
+let realloc_atom_rel n =
+  let n = min (2 * n + 0x100) Sys.max_array_length in
+  let init i = Aid (RelKey i) in
+  let ans = Array.init n init in
+  atom_rel := ans
 
 let relaccu_tbl =
-  let atom_rel = atom_rel() in
-  let len = Array.length atom_rel in
-  for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done;
+  let len = Array.length !atom_rel in
   ref (Array.init len mkAccuCode)
 
 let relaccu_code i =
@@ -422,9 +556,7 @@ let relaccu_code i =
   else
     begin
       realloc_atom_rel i;
-      let atom_rel = atom_rel () in
-      let nl = Array.length atom_rel in
-      for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done;
+      let nl = Array.length !atom_rel in
       relaccu_tbl :=
         Array.init nl
           (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j);
@@ -434,13 +566,12 @@ let relaccu_code i =
 let mk_fix_body k ndef fb =
   let e = Obj.dup (Obj.repr fb) in
   for i = 0 to ndef - 1 do
-    Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i)))
+    set_bytecode_field e (2 * i) (relaccu_code (k + i))
   done;
   let fix_body i =
-    let jump_grabrec c = offset_tcode c 2 in
-    let c = jump_grabrec (unsafe_fb_code fb i)  in
+    let c = offset_tcode (unsafe_fb_code fb i) 2 in
     let res = Obj.new_block Obj.closure_tag 2 in
-    Obj.set_field res 0 (Obj.repr c);
+    set_bytecode_field res 0 c;
     Obj.set_field res 1 (offset_closure e (2*i));
     ((Obj.obj res) : vfun)  in
   Array.init ndef fix_body
@@ -478,7 +609,7 @@ let mk_cofix_body apply_varray k ndef vcf =
     Obj.set_field e 0 c;
     let atom = Obj.new_block cofix_tag 1 in
     let self = Obj.new_block accu_tag 2 in
-    Obj.set_field self 0 (Obj.repr accumulate);
+    set_bytecode_field self 0 accumulate;
     Obj.set_field self 1 (Obj.repr atom);
     apply_varray (Obj.obj e) [|Obj.obj self|] in
   Array.init ndef cofix_body
@@ -500,10 +631,10 @@ let branch_arg k (tag,arity) =
   if Int.equal arity 0 then  ((Obj.magic tag):values)
   else
     let b, ofs =
-      if tag < last_variant_tag then Obj.new_block tag arity, 0
+      if tag < Obj.last_non_constant_constructor_tag then Obj.new_block tag arity, 0
       else
-        let b = Obj.new_block last_variant_tag (arity+1) in
-        Obj.set_field b 0 (Obj.repr (tag-last_variant_tag));
+        let b = Obj.new_block Obj.last_non_constant_constructor_tag (arity+1) in
+        Obj.set_field b 0 (Obj.repr (tag-Obj.last_non_constant_constructor_tag));
         b,1 in
     for i = ofs to ofs + arity - 1 do
       Obj.set_field b i (Obj.repr (val_of_rel (k+i)))
@@ -539,4 +670,4 @@ and pr_zipper z =
   | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")"
   | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")"
   | Zswitch s -> str "Zswitch(...)"
-  | Zproj c -> str "Zproj(" ++ Constant.print c ++ str ")")
+  | Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")")
diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli
index c6e342a9..ae1d416e 100644
--- a/kernel/vmvalues.mli
+++ b/kernel/vmvalues.mli
@@ -9,12 +9,14 @@
 (************************************************************************)
 
 open Names
-open Cbytecodes
+open Constr
 
 (** Values *)
 
 type values
+type structured_values
 type vm_env
+type vm_global
 type vprod
 type vfun
 type vfix
@@ -24,6 +26,38 @@ type arguments
 type vstack = values array
 type to_update
 
+type tag = int
+
+val accu_tag : tag
+
+val type_atom_tag : tag
+val max_atom_tag : tag
+val proj_tag : tag
+val fix_app_tag : tag
+val switch_tag : tag
+val cofix_tag : tag
+val cofix_evaluated_tag : tag
+
+type structured_constant =
+  | Const_sort of Sorts.t
+  | Const_ind of inductive
+  | Const_b0 of tag
+  | Const_univ_level of Univ.Level.t
+  | Const_val of structured_values
+
+val pp_struct_const : structured_constant -> Pp.t
+
+type reloc_table = (tag * int) array
+
+type annot_switch =
+   {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int}
+
+val eq_structured_constant : structured_constant -> structured_constant -> bool
+val hash_structured_constant : structured_constant -> int
+
+val eq_annot_switch : annot_switch -> annot_switch -> bool
+val hash_annot_switch : annot_switch -> int
+
 val fun_val : vfun -> values
 val fix_val : vfix -> values
 val cofix_upd_val : to_update -> values
@@ -33,6 +67,8 @@ val fix_env : vfix -> vm_env
 val cofix_env : vcofix -> vm_env
 val cofix_upd_env : to_update -> vm_env
 
+val vm_global : values array -> vm_global
+
 (** Cast a value known to be a function, unsafe in general *)
 val fun_of_val : values -> vfun
 
@@ -69,13 +105,16 @@ type atom =
   | Aind of inductive
   | Asort of Sorts.t
 
+val get_atom_rel : unit -> atom array
+(** Global table of rels *)
+
 (** Zippers *)
 
 type zipper =
   | Zapp of arguments
   | Zfix of vfix * arguments  (** might be empty *)
   | Zswitch of vswitch
-  | Zproj of Constant.t (* name of the projection *)
+  | Zproj of Projection.Repr.t (* name of the projection *)
 
 type stack = zipper list
 
@@ -102,10 +141,13 @@ val val_of_rel : int -> values
 val val_of_named : Id.t -> values
 val val_of_constant : Constant.t -> values
 val val_of_evar : Evar.t -> values
-val val_of_proj : Constant.t -> values -> values
+val val_of_proj : Projection.Repr.t -> values -> values
 val val_of_atom : atom -> values
+val val_of_int : int -> structured_values
+val val_of_block : tag -> structured_values array -> structured_values
 
 external val_of_annot_switch : annot_switch -> values = "%identity"
+external val_of_proj_name : Projection.Repr.t -> values = "%identity"
 
 (** Destructors *)
 
@@ -151,4 +193,4 @@ val bfield : vblock -> int -> values
 (** Switch *)
 
 val check_switch : vswitch -> vswitch -> bool
-val branch_arg : int -> Cbytecodes.tag * int -> values
+val branch_arg : int -> tag * int -> values